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

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