-! Copyright (c) 2008, 2010 Slava Pestov\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs namespaces kernel sequences sets\r
-destructors combinators fry logging io.encodings.utf8\r
-io.encodings.string io.binary io.sockets.secure random checksums\r
-checksums.sha urls\r
-html.forms\r
-http.server\r
-http.server.filters\r
-http.server.dispatchers\r
-furnace.actions\r
-furnace.utilities\r
-furnace.redirection\r
-furnace.boilerplate\r
-furnace.auth.providers\r
-furnace.auth.providers.db ;\r
-FROM: assocs => change-at ;\r
-FROM: namespaces => set ;\r
-IN: furnace.auth\r
-\r
-SYMBOL: logged-in-user\r
-\r
-: logged-in? ( -- ? )\r
- logged-in-user get >boolean ;\r
-\r
-: username ( -- string/f )\r
- logged-in-user get dup [ username>> ] when ;\r
-\r
-GENERIC: init-user-profile ( responder -- )\r
-\r
-M: object init-user-profile drop ;\r
-\r
-M: dispatcher init-user-profile\r
- default>> init-user-profile ;\r
-\r
-M: filter-responder init-user-profile\r
- responder>> init-user-profile ;\r
-\r
-: current-profile ( -- assoc ) logged-in-user get profile>> ;\r
-\r
-: user-changed ( -- )\r
- logged-in-user get t >>changed? drop ;\r
-\r
-: uget ( key -- value )\r
- current-profile at ;\r
-\r
-: uset ( value key -- )\r
- current-profile set-at\r
- user-changed ;\r
-\r
-: uchange ( quot key -- )\r
- current-profile swap change-at\r
- user-changed ; inline\r
-\r
-SYMBOL: capabilities\r
-\r
-V{ } clone capabilities set-global\r
-\r
-: define-capability ( word -- ) capabilities get adjoin ;\r
-\r
-TUPLE: realm < dispatcher name users checksum secure ;\r
-\r
-GENERIC: login-required* ( description capabilities realm -- response )\r
-\r
-GENERIC: user-registered ( user realm -- response )\r
-\r
-M: object user-registered 2drop URL" $realm" <redirect> ;\r
-\r
-GENERIC: init-realm ( realm -- )\r
-\r
-GENERIC: logged-in-username ( realm -- username )\r
-\r
-: login-required ( description capabilities -- * )\r
- realm get login-required* exit-with ;\r
-\r
-: new-realm ( responder name class -- realm )\r
- new-dispatcher\r
- swap >>name\r
- swap >>default\r
- users-in-db >>users\r
- sha-256 >>checksum\r
- ssl-supported? >>secure ; inline\r
-\r
-: users ( -- provider )\r
- realm get users>> ;\r
-\r
-TUPLE: user-saver user ;\r
-\r
-C: <user-saver> user-saver\r
-\r
-M: user-saver dispose\r
- user>> dup changed?>> [ users update-user ] [ drop ] if ;\r
-\r
-: save-user-after ( user -- )\r
- <user-saver> &dispose drop ;\r
-\r
-: init-user ( user -- )\r
- [ [ logged-in-user set ] [ save-user-after ] bi ] when* ;\r
-\r
-\ init-user DEBUG add-input-logging\r
-\r
-M: realm call-responder* ( path responder -- response )\r
- dup realm set\r
- logged-in? [\r
- dup init-realm\r
- dup logged-in-username\r
- dup [ users get-user ] when\r
- init-user\r
- ] unless\r
- call-next-method ;\r
-\r
-: encode-password ( string salt -- bytes )\r
- [ utf8 encode ] [ 4 >be ] bi* append\r
- realm get checksum>> checksum-bytes ;\r
-\r
-: >>encoded-password ( user string -- user )\r
- 32 random-bits [ encode-password ] keep\r
- [ >>password ] [ >>salt ] bi* ; inline\r
-\r
-: valid-login? ( password user -- ? )\r
- [ salt>> encode-password ] [ password>> ] bi = ;\r
-\r
-: check-login ( password username -- user/f )\r
- users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
-\r
-: if-secure-realm ( quot -- )\r
- realm get secure>> [ if-secure ] [ call ] if ; inline\r
-\r
-TUPLE: secure-realm-only < filter-responder ;\r
-\r
-C: <secure-realm-only> secure-realm-only\r
-\r
-M: secure-realm-only call-responder*\r
- '[ _ _ call-next-method ] if-secure-realm ;\r
-\r
-TUPLE: protected < filter-responder description capabilities ;\r
-\r
-: <protected> ( responder -- protected )\r
- protected new\r
- swap >>responder ;\r
-\r
-: have-capabilities? ( capabilities -- ? )\r
- realm get secure>> secure-connection? not and [ drop f ] [\r
- logged-in-user get {\r
- { [ dup not ] [ 2drop f ] }\r
- { [ dup deleted>> 1 = ] [ 2drop f ] }\r
- [ capabilities>> subset? ]\r
- } cond\r
- ] if ;\r
-\r
-M: protected call-responder* ( path responder -- response )\r
- dup protected set\r
- dup capabilities>> have-capabilities?\r
- [ call-next-method ] [\r
- [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*\r
- realm get login-required*\r
- ] if ;\r
-\r
-: <auth-boilerplate> ( responder -- responder' )\r
- <boilerplate> { realm "boilerplate" } >>template ;\r
-\r
-: password-mismatch ( -- * )\r
- "passwords do not match" validation-error\r
- validation-failed ;\r
-\r
-: same-password-twice ( -- )\r
- "new-password" value "verify-password" value =\r
- [ password-mismatch ] unless ;\r
-\r
-: user-exists ( -- * )\r
- "username taken" validation-error\r
- validation-failed ;\r
+! Copyright (c) 2008, 2010 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs namespaces kernel sequences sets
+destructors combinators fry logging io.encodings.utf8
+io.encodings.string io.binary io.sockets.secure random checksums
+checksums.sha urls
+html.forms
+http.server
+http.server.filters
+http.server.dispatchers
+furnace.actions
+furnace.utilities
+furnace.redirection
+furnace.boilerplate
+furnace.auth.providers
+furnace.auth.providers.db ;
+FROM: assocs => change-at ;
+FROM: namespaces => set ;
+IN: furnace.auth
+
+SYMBOL: logged-in-user
+
+: logged-in? ( -- ? )
+ logged-in-user get >boolean ;
+
+: username ( -- string/f )
+ logged-in-user get dup [ username>> ] when ;
+
+GENERIC: init-user-profile ( responder -- )
+
+M: object init-user-profile drop ;
+
+M: dispatcher init-user-profile
+ default>> init-user-profile ;
+
+M: filter-responder init-user-profile
+ responder>> init-user-profile ;
+
+: current-profile ( -- assoc ) logged-in-user get profile>> ;
+
+: user-changed ( -- )
+ logged-in-user get t >>changed? drop ;
+
+: uget ( key -- value )
+ current-profile at ;
+
+: uset ( value key -- )
+ current-profile set-at
+ user-changed ;
+
+: uchange ( quot key -- )
+ current-profile swap change-at
+ user-changed ; inline
+
+SYMBOL: capabilities
+
+V{ } clone capabilities set-global
+
+: define-capability ( word -- ) capabilities get adjoin ;
+
+TUPLE: realm < dispatcher name users checksum secure ;
+
+GENERIC: login-required* ( description capabilities realm -- response )
+
+GENERIC: user-registered ( user realm -- response )
+
+M: object user-registered 2drop URL" $realm" <redirect> ;
+
+GENERIC: init-realm ( realm -- )
+
+GENERIC: logged-in-username ( realm -- username )
+
+: login-required ( description capabilities -- * )
+ realm get login-required* exit-with ;
+
+: new-realm ( responder name class -- realm )
+ new-dispatcher
+ swap >>name
+ swap >>default
+ users-in-db >>users
+ sha-256 >>checksum
+ ssl-supported? >>secure ; inline
+
+: users ( -- provider )
+ realm get users>> ;
+
+TUPLE: user-saver user ;
+
+C: <user-saver> user-saver
+
+M: user-saver dispose
+ user>> dup changed?>> [ users update-user ] [ drop ] if ;
+
+: save-user-after ( user -- )
+ <user-saver> &dispose drop ;
+
+: init-user ( user -- )
+ [ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
+
+\ init-user DEBUG add-input-logging
+
+M: realm call-responder* ( path responder -- response )
+ dup realm set
+ logged-in? [
+ dup init-realm
+ dup logged-in-username
+ dup [ users get-user ] when
+ init-user
+ ] unless
+ call-next-method ;
+
+: encode-password ( string salt -- bytes )
+ [ utf8 encode ] [ 4 >be ] bi* append
+ realm get checksum>> checksum-bytes ;
+
+: >>encoded-password ( user string -- user )
+ 32 random-bits [ encode-password ] keep
+ [ >>password ] [ >>salt ] bi* ; inline
+
+: valid-login? ( password user -- ? )
+ [ salt>> encode-password ] [ password>> ] bi = ;
+
+: check-login ( password username -- user/f )
+ users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
+
+: if-secure-realm ( quot -- )
+ realm get secure>> [ if-secure ] [ call ] if ; inline
+
+TUPLE: secure-realm-only < filter-responder ;
+
+C: <secure-realm-only> secure-realm-only
+
+M: secure-realm-only call-responder*
+ '[ _ _ call-next-method ] if-secure-realm ;
+
+TUPLE: protected < filter-responder description capabilities ;
+
+: <protected> ( responder -- protected )
+ protected new
+ swap >>responder ;
+
+: have-capabilities? ( capabilities -- ? )
+ realm get secure>> secure-connection? not and [ drop f ] [
+ logged-in-user get {
+ { [ dup not ] [ 2drop f ] }
+ { [ dup deleted>> 1 = ] [ 2drop f ] }
+ [ capabilities>> subset? ]
+ } cond
+ ] if ;
+
+M: protected call-responder* ( path responder -- response )
+ dup protected set
+ dup capabilities>> have-capabilities?
+ [ call-next-method ] [
+ [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
+ realm get login-required*
+ ] if ;
+
+: <auth-boilerplate> ( responder -- responder' )
+ <boilerplate> { realm "boilerplate" } >>template ;
+
+: password-mismatch ( -- * )
+ "passwords do not match" validation-error
+ validation-failed ;
+
+: same-password-twice ( -- )
+ "new-password" value "verify-password" value =
+ [ password-mismatch ] unless ;
+
+: user-exists ( -- * )
+ "username taken" validation-error
+ validation-failed ;
projects / factor.git / blobdiff