CouchDB auth provider (furnace.auth.providers.couchdb)
Alex Drummond
John Benediktsson
parent
2b87eaa1b5
commit
93fa3c1670
|
|
@ -121,6 +121,7 @@ $nl
|
||||||
"furnace.auth.providers.null"
|
"furnace.auth.providers.null"
|
||||||
"furnace.auth.providers.assoc"
|
"furnace.auth.providers.assoc"
|
||||||
"furnace.auth.providers.db"
|
"furnace.auth.providers.db"
|
||||||
|
"furnace.auth.providers.couchdb"
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "furnace.auth.features" "Optional authentication features"
|
ARTICLE: "furnace.auth.features" "Optional authentication features"
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,40 @@
|
||||||
|
USING: help.syntax help.markup help.vocabs furnace.auth.providers ;
|
||||||
|
IN: furnace.auth.providers.couchdb
|
||||||
|
|
||||||
|
HELP: couchdb-auth-provider
|
||||||
|
{
|
||||||
|
$class-description "Implements the furnace authentication protocol for CouchDB."
|
||||||
|
{ $table
|
||||||
|
{ { $slot "base-url" } { "The base URL for the CouchDB database, e.g. http://foo.org:5984/mydatabase" } }
|
||||||
|
{ { $slot "username-view" } { "A URL for a view which emits usernames as keys and user documents as values, "
|
||||||
|
"i.e. something like emit(doc.username, doc). The URL should be relative"
|
||||||
|
" to base-url (e.g. \"_design/my_views/_view/by_username\")."
|
||||||
|
" The view is not defined automatically by the library." } }
|
||||||
|
{ { $slot "prefix" } { "In order to ensure the uniqueness of user IDs and email addresses,"
|
||||||
|
" the library creates documents in the database with ids corresponding to these values. "
|
||||||
|
"These ids "
|
||||||
|
"are prefixed by the string given as the value for this slot. Ideally, you should guarantee that no other "
|
||||||
|
"documents in the database can have ids with this prefix. However, "
|
||||||
|
"the worst that can happen is for someone to falsely be told that a username "
|
||||||
|
"is taken when it is in fact free." } }
|
||||||
|
{ { $slot "field-map" } { "An assoc taking " { $link user } " slot names to CouchDB document "
|
||||||
|
"field names. It is not usually necessary to set this slot - it is useful only if "
|
||||||
|
"you do not wish to use the default field names." } }
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
|
ARTICLE: "furnace.auth.providers.couchdb" "CouchDB Authentication Provider"
|
||||||
|
{ $nl } "The " { $vocab-link "furnace.auth.providers.couchdb" } " vocabulary implements an authentication provider "
|
||||||
|
"which looks up authentication requests in a CouchDB. It is necessary to create a view "
|
||||||
|
"associating usernames with user documents before using this vocabulary; see documentation "
|
||||||
|
"for " { $link couchdb-auth-provider } "."
|
||||||
|
{ $nl }
|
||||||
|
"Although this implementation guarantees that users with duplicate IDs/emails"
|
||||||
|
" cannot be created in a single CouchDB database, it provides so such guarentee if you are clustering "
|
||||||
|
"multiple DBs. In this case, you are responsible for ensuring the uniqueness of users across "
|
||||||
|
"databases."
|
||||||
|
{ $nl }
|
||||||
|
"Password hashes are base64 encoded."
|
||||||
|
;
|
||||||
|
|
||||||
|
ABOUT: "furnace.auth.providers.couchdb"
|
||||||
|
|
@ -0,0 +1,228 @@
|
||||||
|
USING: accessors assocs couchdb furnace.auth.providers
|
||||||
|
json.writer kernel mirrors sequences urls urls.encoding
|
||||||
|
arrays furnace.auth byte-arrays combinators.short-circuit
|
||||||
|
strings continuations combinators base64 make
|
||||||
|
locals namespaces ;
|
||||||
|
IN: furnace.auth.providers.couchdb
|
||||||
|
|
||||||
|
! !!! Implement the authentication protocol for CouchDB.
|
||||||
|
! !!!
|
||||||
|
! !!! 'user' tuples are copied verbatim into the DB as objects.
|
||||||
|
! !!! Special 'reservation' records are inserted into the DB to
|
||||||
|
! !!! reserve usernames and email addresses. These reservation records
|
||||||
|
! !!! all have ids with the prefix given to couchdb-auth-provider.
|
||||||
|
! !!! A reservation in the email domain for the email address "foo@bar.com"
|
||||||
|
! !!! would have id "PREFIXemail!foo%40bar.com". Both the domain name
|
||||||
|
! !!! and the value are url-encoded, to ensure that the use of '!' as
|
||||||
|
! !!! a separator guarantees a unique ID for any given (domain,value)
|
||||||
|
! !!! pairing.
|
||||||
|
! !!!
|
||||||
|
! !!! It would be nice to use CouchDB attachments to avoid junking the
|
||||||
|
! !!! global namespace like this. However, attachments in CouchDB
|
||||||
|
! !!! inherit their revision ids from their parent document, which would
|
||||||
|
! !!! make various operations on users unnecessairly non-independent
|
||||||
|
! !!! of each other.
|
||||||
|
! !!!
|
||||||
|
! !!! On the basic technique used here, see:
|
||||||
|
! !!!
|
||||||
|
! !!! http://kfalck.net/2009/06/29/enforcing-unique-usernames-on-couchdb
|
||||||
|
! !!!
|
||||||
|
|
||||||
|
! Many of the words below assume that this symbol is bound to an
|
||||||
|
! appropriate instance.
|
||||||
|
TUPLE: couchdb-auth-provider
|
||||||
|
base-url
|
||||||
|
{ username-view string }
|
||||||
|
{ prefix string initial: "user_reservation_" }
|
||||||
|
{ field-map assoc initial: { } } ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
! >json does weird things for mirrors, so we copy the mirror into
|
||||||
|
! a real hashtable before serializing it.
|
||||||
|
: hash-mirror ( obj -- hash )
|
||||||
|
make-mirror H{ } assoc-like ;
|
||||||
|
|
||||||
|
: is-couchdb-conflict-error? ( error -- ? )
|
||||||
|
{ [ couchdb-error? ] [ data>> "error" swap at "conflict" = ] } 1&& ;
|
||||||
|
: is-couchdb-not-found-error? ( error -- ? )
|
||||||
|
{ [ couchdb-error? ] [ data>> "error" swap at "not_found" = ] } 1&& ;
|
||||||
|
|
||||||
|
: get-url ( url -- url' )
|
||||||
|
couchdb-auth-provider get
|
||||||
|
base-url>> >url swap >url derive-url ;
|
||||||
|
|
||||||
|
: reservation-id ( value name -- id )
|
||||||
|
couchdb-auth-provider get
|
||||||
|
prefix>> [ % url-encode-full % "!" % url-encode-full % ] "" make ;
|
||||||
|
|
||||||
|
: (reserve) ( value name -- id/f )
|
||||||
|
reservation-id
|
||||||
|
get-url
|
||||||
|
[
|
||||||
|
H{ } clone >json swap couch-put
|
||||||
|
] [
|
||||||
|
nip dup is-couchdb-conflict-error? [ drop f ] [ rethrow ] if
|
||||||
|
] recover ;
|
||||||
|
|
||||||
|
! Don't reserve false values (e.g. if the email field is f, don't reserve f,
|
||||||
|
! or the first user who registers without an email address will block all
|
||||||
|
! others who wish to do so).
|
||||||
|
: reserve ( value name -- id/f )
|
||||||
|
over [ (reserve) ] [ 2drop t ] if ;
|
||||||
|
|
||||||
|
: unreserve ( couch-rval -- )
|
||||||
|
[ "id" swap at get-url ]
|
||||||
|
[ "rev" swap at "rev" set-query-param ]
|
||||||
|
bi
|
||||||
|
couch-delete drop ;
|
||||||
|
|
||||||
|
: unreserve-from-id ( id -- )
|
||||||
|
[
|
||||||
|
get-url dup couch-get
|
||||||
|
"_rev" swap at "rev" set-query-param
|
||||||
|
couch-delete drop
|
||||||
|
] [
|
||||||
|
dup is-couchdb-not-found-error? [ 2drop ] [ rethrow ] if
|
||||||
|
] recover ;
|
||||||
|
|
||||||
|
:: (reserve-multiple) ( hash keys made -- ? )
|
||||||
|
keys empty? [ t ] [
|
||||||
|
keys first hash at keys first reserve [
|
||||||
|
made push
|
||||||
|
hash keys rest-slice made (reserve-multiple)
|
||||||
|
] [
|
||||||
|
! Delete reservations that were already successfully made.
|
||||||
|
made [ unreserve ] each
|
||||||
|
f
|
||||||
|
] if*
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
! Try to reserve all of the given name/value pairs; if not all reservations
|
||||||
|
! can be made, delete those that were made.
|
||||||
|
: reserve-multiple ( hash -- ? )
|
||||||
|
dup keys V{ } clone (reserve-multiple) ;
|
||||||
|
|
||||||
|
: change-at* ( key assoc quot -- assoc )
|
||||||
|
over [ change-at ] dip ; inline
|
||||||
|
|
||||||
|
! Should be given a view URL.
|
||||||
|
: ((get-user)) ( couchdb-url -- user/f )
|
||||||
|
couch-get
|
||||||
|
"rows" swap at dup empty? [ drop f ] [ first "value" swap at ] if ;
|
||||||
|
|
||||||
|
: (get-user) ( username -- user/f )
|
||||||
|
couchdb-auth-provider get
|
||||||
|
username-view>> get-url
|
||||||
|
swap >json "key" set-query-param
|
||||||
|
((get-user)) ;
|
||||||
|
|
||||||
|
: strip-hash ( hash1 -- hash2 )
|
||||||
|
[ drop first CHAR: _ = not ] assoc-filter ;
|
||||||
|
|
||||||
|
: at-or-k ( key hash -- newkey )
|
||||||
|
dupd at [ nip ] when* ;
|
||||||
|
: value-at-or-k ( key hash -- newkey )
|
||||||
|
dupd value-at [ nip ] when* ;
|
||||||
|
|
||||||
|
: map-fields-forward ( assoc field-map -- assoc )
|
||||||
|
[ swapd at-or-k swap ] curry assoc-map ;
|
||||||
|
|
||||||
|
: map-fields-backward ( assoc field-map -- assoc )
|
||||||
|
[ swapd value-at-or-k swap ] curry assoc-map ;
|
||||||
|
|
||||||
|
: user-hash>user ( hash -- user )
|
||||||
|
couchdb-auth-provider get field-map>> map-fields-backward
|
||||||
|
[ "password" swap [ base64> >byte-array ] change-at ]
|
||||||
|
[
|
||||||
|
strip-hash
|
||||||
|
user new dup [ make-mirror swap assoc-union! drop ] dip
|
||||||
|
f >>changed?
|
||||||
|
]
|
||||||
|
bi ;
|
||||||
|
|
||||||
|
: user>user-hash ( user -- hash )
|
||||||
|
hash-mirror
|
||||||
|
[ [ "password" ] dip [ >base64 >string ] change-at ] keep
|
||||||
|
couchdb-auth-provider get field-map>> map-fields-forward ;
|
||||||
|
|
||||||
|
! Used when the user is guaranteed to exist if the logic of the Factor
|
||||||
|
! code is correct (e.g. when update-user is called).
|
||||||
|
! In the unlikely event that the user does not exist, an error is thrown.
|
||||||
|
: (get-user)/throw-on-no-user ( username -- user/f )
|
||||||
|
(get-user) [ ] [ "User not found" throw ] if* ;
|
||||||
|
|
||||||
|
: (new-user) ( user -- user/f )
|
||||||
|
dup
|
||||||
|
[
|
||||||
|
[ username>> "username" set ]
|
||||||
|
[ email>> "email" set ]
|
||||||
|
bi
|
||||||
|
] H{ } make-assoc
|
||||||
|
reserve-multiple
|
||||||
|
[
|
||||||
|
user>user-hash >json
|
||||||
|
"" get-url
|
||||||
|
couch-post
|
||||||
|
] [
|
||||||
|
drop f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: unify-users ( old new -- new )
|
||||||
|
swap
|
||||||
|
[ "_rev" swap at "_rev" rot set-at ]
|
||||||
|
[ "_id" swap at "_id" rot set-at ]
|
||||||
|
[ swap assoc-union ]
|
||||||
|
2tri ;
|
||||||
|
|
||||||
|
! If the user has changed username or email address,
|
||||||
|
! we should let other registrants use the old ones,
|
||||||
|
! and make sure that the new ones are reserved.
|
||||||
|
! (This word is called by the 'update-user' method.)
|
||||||
|
: check-update ( old new -- ? )
|
||||||
|
[
|
||||||
|
2dup [ "email" swap at ] bi@ = not [
|
||||||
|
[ "email" swap at ] bi@
|
||||||
|
[ drop "email" reservation-id unreserve-from-id ]
|
||||||
|
[ nip "email" reserve ]
|
||||||
|
2bi
|
||||||
|
] [ 2drop t ] if
|
||||||
|
] [
|
||||||
|
2dup [ "username" swap at ] bi@ = not [
|
||||||
|
[ "username" swap at ] bi@
|
||||||
|
[ drop "username" reservation-id unreserve-from-id ]
|
||||||
|
[ nip "username" reserve ]
|
||||||
|
2bi
|
||||||
|
] [ 2drop t ] if
|
||||||
|
] 2bi and ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: <couchdb-auth-provider> ( base-url username-view -- couchdb-auth-provider )
|
||||||
|
couchdb-auth-provider new swap >>username-view swap >>base-url ;
|
||||||
|
|
||||||
|
M: couchdb-auth-provider get-user ( username provider -- user/f )
|
||||||
|
[
|
||||||
|
couchdb-auth-provider set
|
||||||
|
(get-user) [ user-hash>user ] [ f ] if*
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
M: couchdb-auth-provider new-user ( user provider -- user/f )
|
||||||
|
[
|
||||||
|
couchdb-auth-provider set
|
||||||
|
dup (new-user) [
|
||||||
|
username>> couchdb-auth-provider get get-user
|
||||||
|
] [ drop f ] if
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
M: couchdb-auth-provider update-user ( user provider -- )
|
||||||
|
[
|
||||||
|
couchdb-auth-provider set
|
||||||
|
[ username>> (get-user)/throw-on-no-user dup ]
|
||||||
|
[ drop "_id" swap at get-url ]
|
||||||
|
[ user>user-hash swapd
|
||||||
|
2dup check-update drop
|
||||||
|
unify-users >json swap couch-put drop
|
||||||
|
]
|
||||||
|
tri
|
||||||
|
] with-scope ;
|
||||||
Loading…
Reference in New Issue