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