basis/furnace/auth/providers/couchdb/couchdb.factor

   1 USING: accessors assocs couchdb furnace.auth.providers
   2 json.writer kernel mirrors sequences urls urls.encoding
   3 arrays furnace.auth byte-arrays combinators.short-circuit
   4 strings continuations combinators base64 make
   5 locals namespaces ;
   6 IN: furnace.auth.providers.couchdb
   7
   8 ! !!! Implement the authentication protocol for CouchDB.
   9 ! !!!
  10 ! !!! 'user' tuples are copied verbatim into the DB as objects.
  11 ! !!! Special 'reservation' records are inserted into the DB to
  12 ! !!! reserve usernames and email addresses. These reservation records
  13 ! !!! all have ids with the prefix given to couchdb-auth-provider.
  14 ! !!! A reservation in the email domain for the email address "foo@bar.com"
  15 ! !!! would have id "PREFIXemail!foo%40bar.com". Both the domain name
  16 ! !!! and the value are url-encoded, to ensure that the use of '!' as
  17 ! !!! a separator guarantees a unique ID for any given (domain,value)
  18 ! !!! pairing.
  19 ! !!!
  20 ! !!! It would be nice to use CouchDB attachments to avoid junking the
  21 ! !!! global namespace like this. However, attachments in CouchDB
  22 ! !!! inherit their revision ids from their parent document, which would
  23 ! !!! make various operations on users unnecessairly non-independent
  24 ! !!! of each other.
  25 ! !!!
  26 ! !!! On the basic technique used here, see:
  27 ! !!!
  28 ! !!! http://kfalck.net/2009/06/29/enforcing-unique-usernames-on-couchdb
  29 ! !!!
  30
  31 ! Many of the words below assume that this symbol is bound to an
  32 ! appropriate instance.
  33 TUPLE: couchdb-auth-provider
  34     base-url
  35     { username-view string }
  36     { prefix string initial: "user_reservation_" }
  37     { field-map assoc initial: { } } ;
  38
  39 <PRIVATE
  40
  41 ! >json does weird things for mirrors, so we copy the mirror into
  42 ! a real hashtable before serializing it.
  43 : hash-mirror ( obj -- hash )
  44     make-mirror H{ } assoc-like ;
  45
  46 : is-couchdb-conflict-error? ( error -- ? )
  47     { [ couchdb-error? ] [ data>> "error" of "conflict" = ] } 1&& ;
  48 : is-couchdb-not-found-error? ( error -- ? )
  49     { [ couchdb-error? ] [ data>> "error" of "not_found" = ] } 1&& ;
  50
  51 : get-url ( url -- url' )
  52     couchdb-auth-provider get
  53     base-url>> >url swap >url derive-url ;
  54
  55 : reservation-id ( value name -- id )
  56     couchdb-auth-provider get
  57     prefix>> [ % url-encode-full % "!" % url-encode-full % ] "" make ;
  58
  59 : (reserve) ( value name -- id/f )
  60     reservation-id
  61     get-url
  62     [
  63         H{ } clone >json swap couch-put
  64     ] [
  65         nip dup is-couchdb-conflict-error? [ drop f ] [ rethrow ] if
  66     ] recover ;
  67
  68 ! Don't reserve false values (e.g. if the email field is f, don't reserve f,
  69 ! or the first user who registers without an email address will block all
  70 ! others who wish to do so).
  71 : reserve ( value name -- id/f )
  72     over [ (reserve) ] [ 2drop t ] if ;
  73
  74 : unreserve ( couch-rval -- )
  75     [ "id" of get-url ]
  76     [ "rev" of "rev" set-query-param ]
  77     bi
  78     couch-delete drop ;
  79
  80 : unreserve-from-id ( id -- )
  81     [
  82         get-url dup couch-get
  83         "_rev" of "rev" set-query-param
  84         couch-delete drop
  85     ] [
  86         dup is-couchdb-not-found-error? [ 2drop ] [ rethrow ] if
  87     ] recover ;
  88
  89 :: (reserve-multiple) ( hash keys made -- ? )
  90     keys empty? [ t ] [
  91         keys first hash at keys first reserve [
  92             made push
  93             hash keys rest-slice made (reserve-multiple)
  94         ] [
  95             ! Delete reservations that were already successfully made.
  96             made [ unreserve ] each
  97             f
  98         ] if*
  99     ] if ;
 100
 101 ! Try to reserve all of the given name/value pairs; if not all reservations
 102 ! can be made, delete those that were made.
 103 : reserve-multiple ( hash -- ? )
 104     dup keys V{ } clone (reserve-multiple) ;
 105
 106 : change-at* ( key assoc quot -- assoc )
 107     over [ change-at ] dip ; inline
 108
 109 ! Should be given a view URL.
 110 : url>user ( couchdb-url -- user/f )
 111     couch-get
 112     "rows" of dup empty? [ drop f ] [ first "value" of ] if ;
 113
 114 : (get-user) ( username -- user/f )
 115     couchdb-auth-provider get
 116     username-view>> get-url
 117     swap >json "key" set-query-param
 118     url>user ;
 119
 120 : strip-hash ( hash1 -- hash2 )
 121     [ drop first CHAR: _ = ] assoc-reject ;
 122
 123 : at-or-k ( key hash -- newkey )
 124     dupd at [ nip ] when* ;
 125 : value-at-or-k ( key hash -- newkey )
 126     dupd value-at [ nip ] when* ;
 127
 128 : map-fields-forward ( assoc field-map -- assoc )
 129     [ swapd at-or-k swap ] curry assoc-map ;
 130
 131 : map-fields-backward ( assoc field-map -- assoc )
 132     [ swapd value-at-or-k swap ] curry assoc-map ;
 133
 134 : user-hash>user ( hash -- user )
 135     couchdb-auth-provider get field-map>> map-fields-backward
 136     [ "password" swap [ base64> >byte-array ] change-at ]
 137     [
 138         strip-hash
 139         user new dup [ make-mirror swap assoc-union! drop ] dip
 140         f >>changed?
 141     ]
 142     bi ;
 143
 144 : user>user-hash ( user -- hash )
 145      hash-mirror
 146      [ [ "password" ] dip [ >base64 >string ] change-at ] keep
 147      couchdb-auth-provider get field-map>> map-fields-forward ;
 148
 149 ! Used when the user is guaranteed to exist if the logic of the Factor
 150 ! code is correct (e.g. when update-user is called).
 151 ! In the unlikely event that the user does not exist, an error is thrown.
 152 : (get-user)/throw-on-no-user ( username -- user/f )
 153     (get-user) [ ] [ "User not found" throw ] if* ;
 154
 155 : (new-user) ( user -- user/f )
 156     dup
 157     [
 158         [ username>> "username" ,, ]
 159         [ email>> "email" ,, ]
 160         bi
 161     ] H{ } make
 162     reserve-multiple
 163     [
 164         user>user-hash
 165         "" get-url
 166         couch-post
 167     ] [
 168         drop f
 169     ] if ;
 170
 171 : unify-users ( old new -- new )
 172     swap
 173     [ "_rev" of "_rev" rot set-at ]
 174     [ "_id" of "_id" rot set-at ]
 175     [ swap assoc-union ]
 176     2tri ;
 177
 178 ! If the user has changed username or email address,
 179 ! we should let other registrants use the old ones,
 180 ! and make sure that the new ones are reserved.
 181 ! (This word is called by the 'update-user' method.)
 182 : check-update ( old new -- ? )
 183     [
 184         2dup [ "email" of ] same? not [
 185             [ "email" of ] bi@
 186             [ drop "email" reservation-id unreserve-from-id ]
 187             [ nip "email" reserve ]
 188             2bi
 189         ] [ 2drop t ] if
 190     ] [
 191         2dup [ "username" of ] same? not [
 192             [ "username" of ] bi@
 193             [ drop "username" reservation-id unreserve-from-id ]
 194             [ nip "username" reserve ]
 195             2bi
 196         ] [ 2drop t ] if
 197     ] 2bi and ;
 198
 199 PRIVATE>
 200
 201 : <couchdb-auth-provider> ( base-url username-view -- couchdb-auth-provider )
 202     couchdb-auth-provider new swap >>username-view swap >>base-url ;
 203
 204 M: couchdb-auth-provider get-user ( username provider -- user/f )
 205     couchdb-auth-provider [
 206         (get-user) [ user-hash>user ] [ f ] if*
 207     ] with-variable ;
 208
 209 M: couchdb-auth-provider new-user ( user provider -- user/f )
 210     couchdb-auth-provider [
 211         dup (new-user) [
 212             username>> couchdb-auth-provider get get-user
 213         ] [ drop f ] if
 214     ] with-variable ;
 215
 216 M: couchdb-auth-provider update-user ( user provider -- )
 217     couchdb-auth-provider [
 218         [ username>> (get-user)/throw-on-no-user dup ]
 219         [ drop "_id" of get-url ]
 220         [ user>user-hash swapd
 221           2dup check-update drop
 222           unify-users swap couch-put drop
 223         ]
 224         tri
 225     ] with-variable ;