Refactoring furnace.auth

extra/furnace/auth/auth.factor

@@ -1,11 +1,18 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs namespaces kernel sequences sets
+destructors combinators
+io.encodings.utf8 io.encodings.string io.binary random
+checksums checksums.sha2
+html.forms
 http.server
 http.server.filters
 http.server.dispatchers
-furnace.sessions
+furnace
-furnace.auth.providers ;
+furnace.actions
+furnace.boilerplate
+furnace.auth.providers
+furnace.auth.providers.db ;
 IN: furnace.auth
 
 SYMBOL: logged-in-user
@@ -20,6 +27,9 @@ M: dispatcher init-user-profile
 M: filter-responder init-user-profile
     responder>> init-user-profile ;
 
+: have-capability? ( capability -- ? )
+    logged-in-user get capabilities>> member? ;
+
 : profile ( -- assoc ) logged-in-user get profile>> ;
 
 : user-changed ( -- )
@@ -41,3 +51,89 @@ SYMBOL: capabilities
 V{ } clone capabilities set-global
 
 : define-capability ( word -- ) capabilities get adjoin ;
+
+TUPLE: realm < dispatcher name users checksum ;
+
+GENERIC: login-required* ( realm -- response )
+
+GENERIC: logged-in-username ( realm -- username )
+
+: login-required ( -- * ) 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 ; 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 ( realm -- )
+    logged-in-username [
+        users get-user
+        [ logged-in-user set ] [ save-user-after ] bi
+    ] when* ;
+
+M: realm call-responder* ( path responder -- response )
+    dup realm set
+    dup init-user
+    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 ;
+
+TUPLE: protected < filter-responder description capabilities ;
+
+: <protected> ( responder -- protected )
+    protected new
+        swap >>responder ;
+
+: check-capabilities ( responder user/f -- ? )
+    {
+        { [ dup not ] [ 2drop f ] }
+        { [ dup deleted>> ] [ 2drop f ] }
+        [ [ capabilities>> ] bi@ subset? ]
+    } cond ;
+
+M: protected call-responder* ( path responder -- response )
+    dup protected set
+    dup logged-in-user get check-capabilities
+    [ call-next-method ] [ 2drop 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 ;

extra/furnace/auth/basic/basic.factor

@@ -1,41 +1,27 @@
 ! Copyright (c) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors quotations assocs kernel splitting
+USING: accessors kernel splitting base64 namespaces
-base64 html.elements io combinators sequences
+http http.server.responses furnace.auth ;
-http http.server.filters http.server.responses http.server
-furnace.auth.providers furnace.auth.login ;
 IN: furnace.auth.basic
 
-TUPLE: basic-auth < filter-responder realm provider ;
+TUPLE: basic-auth-realm < realm ;
 
-C: <basic-auth> basic-auth
+C: <basic-auth-realm> basic-auth-realm
 
-: authorization-ok? ( provider header -- ? )
+: parse-basic-auth ( header -- username/f password/f )
-    #! Given the realm and the 'Authorization' header,
-    #! authenticate the user.
     dup [
         " " split1 swap "Basic" = [
-            base64> ":" split1 spin check-login
+            base64> ":" split1
-        ] [
+        ] [ drop f f ] if
-            2drop f
+    ] [ drop f f ] if ;
-        ] if
-    ] [
-        2drop f
-    ] if ;
 
 : <401> ( realm -- response )
-    401 "Unauthorized" <trivial-response>
+    401 "Invalid username or password" <trivial-response>
-    "Basic realm=\"" rot "\"" 3append
+    [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;
-    "WWW-Authenticate" set-header
-    [
-        <html> <body>
-            "Username or Password is invalid" write
-        </body> </html>
-    ] >>body ;
 
-: logged-in? ( request responder -- ? )
+M: basic-auth-realm login-required* ( realm -- response )
-    provider>> swap "authorization" header authorization-ok? ;
+    name>> <401> ;
 
-M: basic-auth call-responder* ( request path responder -- response )
+M: basic-auth-realm logged-in-username ( realm -- uid )
-    pick over logged-in?
+    request get "authorization" header parse-basic-auth
-    [ call-next-method ] [ 2nip realm>> <401> ] if ;
+    dup [ over realm get check-login swap and ] [ 2drop f ] if ;

extra/furnace/auth/features/edit-profile/edit-profile-tests.factor

@@ -0,0 +1,4 @@
+IN: furnace.auth.features.edit-profile.tests
+USING: tools.test furnace.auth.features.edit-profile ;
+
+\ allow-edit-profile must-infer

extra/furnace/auth/features/edit-profile/edit-profile.factor

@@ -0,0 +1,67 @@
+! Copyright (c) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences assocs
+validators urls
+html.forms
+http.server.dispatchers
+furnace.auth
+furnace.asides
+furnace.actions ;
+IN: furnace.auth.features.edit-profile
+
+: <edit-profile-action> ( -- action )
+    <page-action>
+        [
+            logged-in-user get
+            [ username>> "username" set-value ]
+            [ realname>> "realname" set-value ]
+            [ email>> "email" set-value ]
+            tri
+        ] >>init
+
+        { realm "features/edit-profile/edit-profile" } >>template
+
+        [
+            logged-in-user get username>> "username" set-value
+
+            {
+                { "realname" [ [ v-one-line ] v-optional ] }
+                { "password" [ ] }
+                { "new-password" [ [ v-password ] v-optional ] }
+                { "verify-password" [ [ v-password ] v-optional ] } 
+                { "email" [ [ v-email ] v-optional ] }
+            } validate-params
+
+            { "password" "new-password" "verify-password" }
+            [ value empty? not ] contains? [
+                "password" value logged-in-user get username>> check-login
+                [ "incorrect password" validation-error ] unless
+
+                same-password-twice
+            ] when
+        ] >>validate
+
+        [
+            logged-in-user get
+
+            "new-password" value dup empty?
+            [ drop ] [ >>encoded-password ] if
+
+            "realname" value >>realname
+            "email" value >>email
+
+            t >>changed?
+
+            drop
+
+            URL" $login" end-aside
+        ] >>submit
+
+    <protected>
+        "edit your profile" >>description ;
+
+: allow-edit-profile ( login -- login )
+    <edit-profile-action> <auth-boilerplate> "edit-profile" add-responder ;
+
+: allow-edit-profile? ( -- ? )
+    realm get get responders>> "edit-profile" swap key? ;

extra/furnace/auth/features/recover-password/recover-password-tests.factor

@@ -0,0 +1,4 @@
+IN: furnace.auth.features.recover-password
+USING: tools.test furnace.auth.features.recover-password ;
+
+\ allow-password-recovery must-infer

extra/furnace/auth/features/recover-password/recover-password.factor

@@ -0,0 +1,123 @@
+! Copyright (c) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces accessors kernel assocs arrays io.sockets threads
+fry urls smtp validators html.forms
+http http.server.responses http.server.dispatchers
+furnace furnace.actions furnace.auth furnace.auth.providers ;
+IN: furnace.auth.features.recover-password
+
+SYMBOL: lost-password-from
+
+: current-host ( -- string )
+    request get url>> host>> host-name or ;
+
+: new-password-url ( user -- url )
+    "recover-3"
+    swap [
+        [ username>> "username" set ]
+        [ ticket>> "ticket" set ]
+        bi
+    ] H{ } make-assoc
+    derive-url ;
+
+: password-email ( user -- email )
+    <email>
+        [ "[ " % current-host % " ] password recovery" % ] "" make >>subject
+        lost-password-from get >>from
+        over email>> 1array >>to
+        [
+            "This e-mail was sent by the application server on " % current-host % "\n" %
+            "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
+            "login form, and requested a new password for the user named ``" %
+            over username>> % "''.\n" %
+            "\n" %
+            "If you believe that this request was legitimate, you may click the below link in\n" %
+            "your browser to set a new password for your account:\n" %
+            "\n" %
+            swap new-password-url %
+            "\n\n" %
+            "Love,\n" %
+            "\n" %
+            "  FactorBot\n" %
+        ] "" make >>body ;
+
+: send-password-email ( user -- )
+    '[ , password-email send-email ]
+    "E-mail send thread" spawn drop ;
+
+: <recover-action-1> ( -- action )
+    <page-action>
+        { realm "recover-1" } >>template
+
+        [
+            {
+                { "username" [ v-username ] }
+                { "email" [ v-email ] }
+                { "captcha" [ v-captcha ] }
+            } validate-params
+        ] >>validate
+
+        [
+            "email" value "username" value
+            users issue-ticket [
+                send-password-email
+            ] when*
+
+            URL" $login/recover-2" <redirect>
+        ] >>submit ;
+
+: <recover-action-2> ( -- action )
+    <page-action>
+        { realm "recover-2" } >>template ;
+
+: <recover-action-3> ( -- action )
+    <page-action>
+        [
+            {
+                { "username" [ v-username ] }
+                { "ticket" [ v-required ] }
+            } validate-params
+        ] >>init
+
+        { realm "recover-3" } >>template
+
+        [
+            {
+                { "username" [ v-username ] }
+                { "ticket" [ v-required ] }
+                { "new-password" [ v-password ] }
+                { "verify-password" [ v-password ] }
+            } validate-params
+
+            same-password-twice
+        ] >>validate
+
+        [
+            "ticket" value
+            "username" value
+            users claim-ticket [
+                "new-password" value >>encoded-password
+                users update-user
+
+                URL" $login/recover-4" <redirect>
+            ] [
+                <403>
+            ] if*
+        ] >>submit ;
+
+: <recover-action-4> ( -- action )
+    <page-action>
+        { realm "recover-4" } >>template ;
+
+: allow-password-recovery ( login -- login )
+    <recover-action-1> <auth-boilerplate>
+        "recover-password" add-responder
+    <recover-action-2> <auth-boilerplate>
+        "recover-2" add-responder
+    <recover-action-3> <auth-boilerplate>
+        "recover-3" add-responder
+    <recover-action-4> <auth-boilerplate>
+        "recover-4" add-responder ;
+
+: allow-password-recovery? ( -- ? )
+    realm get responders>> "recover-password" swap key? ;

extra/furnace/auth/features/registration/registration-tests.factor

@@ -0,0 +1,4 @@
+IN: furnace.auth.features.registration.tests
+USING: tools.test furnace.auth.features.registration ;
+
+\ allow-registration must-infer

extra/furnace/auth/features/registration/registration.factor

@@ -0,0 +1,43 @@
+! Copyright (c) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel namespaces validators html.forms urls
+http.server.dispatchers
+furnace furnace.auth furnace.auth.providers furnace.actions ;
+IN: furnace.auth.features.registration
+
+: <register-action> ( -- action )
+    <page-action>
+        { realm "register" } >>template
+
+        [
+            {
+                { "username" [ v-username ] }
+                { "realname" [ [ v-one-line ] v-optional ] }
+                { "new-password" [ v-password ] }
+                { "verify-password" [ v-password ] }
+                { "email" [ [ v-email ] v-optional ] }
+                { "captcha" [ v-captcha ] }
+            } validate-params
+
+            same-password-twice
+        ] >>validate
+
+        [
+            "username" value <user>
+                "realname" value >>realname
+                "new-password" value >>encoded-password
+                "email" value >>email
+                H{ } clone >>profile
+
+            users new-user [ user-exists ] unless*
+
+            realm get init-user-profile
+
+            URL" $realm" <redirect>
+        ] >>submit ;
+
+: allow-registration ( login -- login )
+    <register-action> <auth-boilerplate> "register" add-responder ;
+
+: allow-registration? ( -- ? )
+    realm get responders>> "register" swap key? ;

extra/furnace/auth/login/login-tests.factor

@@ -1,6 +1,4 @@
 IN: furnace.auth.login.tests
 USING: tools.test furnace.auth.login ;
 
-\ <login> must-infer
+\ <login-realm> must-infer
-\ allow-registration must-infer
-\ allow-password-recovery must-infer

extra/furnace/auth/login/login.factor

@@ -1,103 +1,35 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors quotations assocs kernel splitting
+USING: kernel accessors namespaces validators urls
-combinators sequences namespaces hashtables sets
-fry arrays threads qualified random validators words
-io
-io.sockets
-io.encodings.utf8
-io.encodings.string
-io.binary
-continuations
-destructors
-checksums
-checksums.sha2
-validators
 html.forms
-html.components
-html.elements
-urls
-http
-http.server
 http.server.dispatchers
-http.server.filters
-http.server.responses
-furnace
 furnace.auth
-furnace.auth.providers
-furnace.auth.providers.db
-furnace.actions
-furnace.asides
 furnace.flash
+furnace.asides
+furnace.actions
 furnace.sessions
-furnace.boilerplate ;
+furnace.utilities ;
-QUALIFIED: smtp
 IN: furnace.auth.login
 
-: word>string ( word -- string )
+TUPLE: login-realm < realm ;
-    [ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
 
-: words>strings ( seq -- seq' )
+: set-uid ( username -- )
-    [ word>string ] map ;
+    session get [ (>>uid) ] [ (session-changed) ] bi ;
 
-ERROR: no-such-word name vocab ;
-
-: string>word ( string -- word )
-    ":" split1 swap 2dup lookup dup
-    [ 2nip ] [ drop no-such-word ] if ;
-
-: strings>words ( seq -- seq' )
-    [ string>word ] map ;
-
-TUPLE: login < dispatcher users checksum ;
-
-TUPLE: protected < filter-responder description capabilities ;
-
-: <protected> ( responder -- protected )
-    protected new
-        swap >>responder ;
-
-: users ( -- provider )
-    login get users>> ;
-
-: encode-password ( string salt -- bytes )
-    [ utf8 encode ] [ 4 >be ] bi* append
-    login 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 ;
-
-! Destructor
-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 ;
-
-! ! ! Login
 : successful-login ( user -- response )
-    username>> set-uid URL" $login" end-aside ;
+    username>> set-uid URL" $realm" end-aside ;
 
-: login-failed ( -- * )
+: logout ( -- ) f set-uid ;
-    "invalid username or password" validation-error
-    validation-failed ;
 
 SYMBOL: description
 SYMBOL: capabilities
 
 : flashed-variables { description capabilities } ;
 
+: login-failed ( -- * )
+    "invalid username or password" validation-error
+    validation-failed ;
+
 : <login-action> ( -- action )
     <page-action>
         [
@@ -106,7 +38,7 @@ SYMBOL: capabilities
             capabilities get words>strings "capabilities" set-value
         ] >>init
 
-        { login "login" } >>template
+        { login-realm "login" } >>template
 
         [
             {
@@ -119,286 +51,21 @@ SYMBOL: capabilities
             [ successful-login ] [ login-failed ] if*
         ] >>submit ;
 
-! ! ! New user registration
-
-: user-exists ( -- * )
-    "username taken" validation-error
-    validation-failed ;
-
-: password-mismatch ( -- * )
-    "passwords do not match" validation-error
-    validation-failed ;
-
-: same-password-twice ( -- )
-    "new-password" value "verify-password" value =
-    [ password-mismatch ] unless ;
-
-: <register-action> ( -- action )
-    <page-action>
-        { login "register" } >>template
-
-        [
-            {
-                { "username" [ v-username ] }
-                { "realname" [ [ v-one-line ] v-optional ] }
-                { "new-password" [ v-password ] }
-                { "verify-password" [ v-password ] }
-                { "email" [ [ v-email ] v-optional ] }
-                { "captcha" [ v-captcha ] }
-            } validate-params
-
-            same-password-twice
-        ] >>validate
-
-        [
-            "username" value <user>
-                "realname" value >>realname
-                "new-password" value >>encoded-password
-                "email" value >>email
-                H{ } clone >>profile
-
-            users new-user [ user-exists ] unless*
-
-            login get init-user-profile
-
-            successful-login
-        ] >>submit ;
-
-! ! ! Editing user profile
-
-: <edit-profile-action> ( -- action )
-    <page-action>
-        [
-            logged-in-user get
-            [ username>> "username" set-value ]
-            [ realname>> "realname" set-value ]
-            [ email>> "email" set-value ]
-            tri
-        ] >>init
-
-        { login "edit-profile" } >>template
-
-        [
-            uid "username" set-value
-
-            {
-                { "realname" [ [ v-one-line ] v-optional ] }
-                { "password" [ ] }
-                { "new-password" [ [ v-password ] v-optional ] }
-                { "verify-password" [ [ v-password ] v-optional ] } 
-                { "email" [ [ v-email ] v-optional ] }
-            } validate-params
-
-            { "password" "new-password" "verify-password" }
-            [ value empty? not ] contains? [
-                "password" value uid check-login
-                [ "incorrect password" validation-error ] unless
-
-                same-password-twice
-            ] when
-        ] >>validate
-
-        [
-            logged-in-user get
-
-            "new-password" value dup empty?
-            [ drop ] [ >>encoded-password ] if
-
-            "realname" value >>realname
-            "email" value >>email
-
-            t >>changed?
-
-            drop
-
-            URL" $login" end-aside
-        ] >>submit
-
-    <protected>
-        "edit your profile" >>description ;
-
-! ! ! Password recovery
-
-SYMBOL: lost-password-from
-
-: current-host ( -- string )
-    request get url>> host>> host-name or ;
-
-: new-password-url ( user -- url )
-    "recover-3"
-    swap [
-        [ username>> "username" set ]
-        [ ticket>> "ticket" set ]
-        bi
-    ] H{ } make-assoc
-    derive-url ;
-
-: password-email ( user -- email )
-    smtp:<email>
-        [ "[ " % current-host % " ] password recovery" % ] "" make >>subject
-        lost-password-from get >>from
-        over email>> 1array >>to
-        [
-            "This e-mail was sent by the application server on " % current-host % "\n" %
-            "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
-            "login form, and requested a new password for the user named ``" %
-            over username>> % "''.\n" %
-            "\n" %
-            "If you believe that this request was legitimate, you may click the below link in\n" %
-            "your browser to set a new password for your account:\n" %
-            "\n" %
-            swap new-password-url %
-            "\n\n" %
-            "Love,\n" %
-            "\n" %
-            "  FactorBot\n" %
-        ] "" make >>body ;
-
-: send-password-email ( user -- )
-    '[ , password-email smtp:send-email ]
-    "E-mail send thread" spawn drop ;
-
-: <recover-action-1> ( -- action )
-    <page-action>
-        { login "recover-1" } >>template
-
-        [
-            {
-                { "username" [ v-username ] }
-                { "email" [ v-email ] }
-                { "captcha" [ v-captcha ] }
-            } validate-params
-        ] >>validate
-
-        [
-            "email" value "username" value
-            users issue-ticket [
-                send-password-email
-            ] when*
-
-            URL" $login/recover-2" <redirect>
-        ] >>submit ;
-
-: <recover-action-2> ( -- action )
-    <page-action>
-        { login "recover-2" } >>template ;
-
-: <recover-action-3> ( -- action )
-    <page-action>
-        [
-            {
-                { "username" [ v-username ] }
-                { "ticket" [ v-required ] }
-            } validate-params
-        ] >>init
-
-        { login "recover-3" } >>template
-
-        [
-            {
-                { "username" [ v-username ] }
-                { "ticket" [ v-required ] }
-                { "new-password" [ v-password ] }
-                { "verify-password" [ v-password ] }
-            } validate-params
-
-            same-password-twice
-        ] >>validate
-
-        [
-            "ticket" value
-            "username" value
-            users claim-ticket [
-                "new-password" value >>encoded-password
-                users update-user
-
-                URL" $login/recover-4" <redirect>
-            ] [
-                <403>
-            ] if*
-        ] >>submit ;
-
-: <recover-action-4> ( -- action )
-    <page-action>
-        { login "recover-4" } >>template ;
-
-! ! ! Logout
 : <logout-action> ( -- action )
     <action>
-        [
+        [ logout URL" $login-realm" end-aside ] >>submit ;
-            f set-uid
-            URL" $login" end-aside
-        ] >>submit ;
 
-! ! ! Authentication logic
+M: login-realm login-required*
-: show-login-page ( -- response )
+    drop
     begin-aside
     protected get description>> description set
     protected get capabilities>> capabilities set
     URL" $login/login" flashed-variables <flash-redirect> ;
 
-: login-required ( -- * )
+M: login-realm logged-in-username
-    show-login-page exit-with ;
+    drop session get uid>> ;
 
-: have-capability? ( capability -- ? )
+: <login-realm> ( responder name -- auth )
-    logged-in-user get capabilities>> member? ;
+    login-realm new-realm
-
+        <login-action> <auth-boilerplate> "login" add-responder
-: check-capabilities ( responder user/f -- ? )
+        <logout-action> "logout" add-responder ;
-    dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ;
-
-M: protected call-responder* ( path responder -- response )
-    dup protected set
-    dup logged-in-user get check-capabilities
-    [ call-next-method ] [ 2drop show-login-page ] if ;
-
-: init-user ( -- )
-    uid [
-        users get-user
-        [ logged-in-user set ]
-        [ save-user-after ] bi
-    ] when* ;
-
-M: login call-responder* ( path responder -- response )
-    dup login set
-    init-user
-    call-next-method ;
-
-: <login-boilerplate> ( responder -- responder' )
-    <boilerplate>
-        { login "boilerplate" } >>template ;
-
-: <login> ( responder -- auth )
-    login new-dispatcher
-        swap >>default
-        <login-action> <login-boilerplate> "login" add-responder
-        <logout-action> <login-boilerplate> "logout" add-responder
-        users-in-db >>users
-        sha-256 >>checksum ;
-
-! ! ! Configuration
-
-: allow-edit-profile ( login -- login )
-    <edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;
-
-: allow-registration ( login -- login )
-    <register-action> <login-boilerplate>
-        "register" add-responder ;
-
-: allow-password-recovery ( login -- login )
-    <recover-action-1> <login-boilerplate>
-        "recover-password" add-responder
-    <recover-action-2> <login-boilerplate>
-        "recover-2" add-responder
-    <recover-action-3> <login-boilerplate>
-        "recover-3" add-responder
-    <recover-action-4> <login-boilerplate>
-        "recover-4" add-responder ;
-
-: allow-edit-profile? ( -- ? )
-    login get responders>> "edit-profile" swap key? ;
-
-: allow-registration? ( -- ? )
-    login get responders>> "register" swap key? ;
-
-: allow-password-recovery? ( -- ? )
-    login get responders>> "recover-password" swap key? ;

extra/furnace/auth/providers/db/db-tests.factor

@@ -1,14 +1,13 @@
 IN: furnace.auth.providers.db.tests
 USING: furnace.actions
+furnace.auth
 furnace.auth.login
 furnace.auth.providers
 furnace.auth.providers.db tools.test
 namespaces db db.sqlite db.tuples continuations
 io.files accessors kernel ;
 
-<action> <login>
+<action> "test" <login-realm> realm set
-    users-in-db >>users
-login set
 
 [ "auth-test.db" temp-file delete-file ] ignore-errors
 

extra/furnace/db/db.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors continuations namespaces destructors
-db db.pools io.pools http.server http.server.filters
+db db.pools io.pools http.server http.server.filters ;
-furnace.sessions ;
 IN: furnace.db
 
 TUPLE: db-persistence < filter-responder pool ;

extra/furnace/sessions/sessions.factor

@@ -57,12 +57,6 @@ TUPLE: sessions < server-state-manager domain verify? ;
     [ namespace>> swap change-at ] keep
     (session-changed) ; inline
 
-: uid ( -- uid )
-    session get uid>> ;
-
-: set-uid ( uid -- )
-    session get [ (>>uid) ] [ (session-changed) ] bi ;
-
 : init-session ( session -- )
     session [ sessions get init-session* ] with-variable ;
 
@@ -147,6 +141,3 @@ M: sessions call-responder* ( path responder -- response )
     sessions set
     request-session [ begin-session ] unless*
     existing-session put-session-cookie ;
-
-: logout-all-sessions ( uid -- )
-    session new swap >>uid delete-tuples ;

extra/furnace/utilities/utilities.factor

@@ -0,0 +1,19 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel sequences splitting ;
+IN: furnace.utilities
+
+: word>string ( word -- string )
+    [ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
+
+: words>strings ( seq -- seq' )
+    [ word>string ] map ;
+
+ERROR: no-such-word name vocab ;
+
+: string>word ( string -- word )
+    ":" split1 swap 2dup lookup dup
+    [ 2nip ] [ drop no-such-word ] if ;
+
+: strings>words ( seq -- seq' )
+    [ string>word ] map ;

extra/http/client/client-tests.factor

@@ -14,7 +14,7 @@ tuple-syntax namespaces urls ;
         method: "GET"
         version: "1.1"
         cookies: V{ }
-        header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
+        header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
     }
 ] [
     "http://www.apple.com/index.html"
@@ -27,7 +27,7 @@ tuple-syntax namespaces urls ;
         method: "GET"
         version: "1.1"
         cookies: V{ }
-        header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
+        header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
     }
 ] [
     "https://www.amazon.com/index.html"

extra/http/http-tests.factor

@@ -122,7 +122,7 @@ read-response-test-1' 1array [
 
 ! Live-fire exercise
 USING: http.server http.server.static furnace.sessions furnace.alloy
-furnace.actions furnace.auth.login furnace.db http.client
+furnace.actions furnace.auth furnace.auth.login furnace.db http.client
 io.server io.files io io.encodings.ascii
 accessors namespaces threads
 http.server.responses http.server.redirection
@@ -176,7 +176,7 @@ test-db [
     [
         <dispatcher>
             <action> <protected>
-            <login>
+            "Test" <login-realm>
             <sessions>
             "" add-responder
             add-quit-action
@@ -206,7 +206,7 @@ test-db [
     [
         <dispatcher>
             <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
-            <login>
+            "Test" <login-realm>
             <sessions>
             "" add-responder
             add-quit-action

extra/http/http.factor

@@ -147,7 +147,7 @@ cookies ;
         H{ } clone >>header
         V{ } clone >>cookies
         "close" "connection" set-header
-        "Factor http.client vocabulary" "user-agent" set-header ;
+        "Factor http.client" "user-agent" set-header ;
 
 : read-method ( request -- request )
     " " read-until [ "Bad request: method" throw ] unless
@@ -296,6 +296,7 @@ body ;
         H{ } clone >>header
         "close" "connection" set-header
         now timestamp>http-string "date" set-header
+        "Factor http.server" "server" set-header
         latin1 >>content-charset
         V{ } clone >>cookies ;
 

extra/webapps/blogs/blogs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sorting math.order math.parser
-urls validators db db.types db.tuples calendar present
+urls validators db db.types db.tuples calendar present namespaces
 html.forms
 html.components
 http.server.dispatchers
@@ -10,7 +10,6 @@ furnace.actions
 furnace.auth
 furnace.auth.login
 furnace.boilerplate
-furnace.sessions
 furnace.syndication ;
 IN: webapps.blogs
 
@@ -160,13 +159,13 @@ M: comment entity-url
 
         [
             validate-post
-            uid "author" set-value
+            logged-in-user get username>> "author" set-value
         ] >>validate
 
         [
             f <post>
                 dup { "title" "content" } to-object
-                uid >>author
+                logged-in-user get username>> >>author
                 now >>date
             [ insert-tuple ] [ entity-url <redirect> ] bi
         ] >>submit
@@ -177,7 +176,8 @@ M: comment entity-url
         "make a new blog post" >>description ;
 
 : authorize-author ( author -- )
-    uid = can-administer-blogs? have-capability? or
+    logged-in-user get username>> =
+    can-administer-blogs? have-capability? or
     [ login-required ] unless ;
 
 : do-post-action ( -- )
@@ -253,13 +253,13 @@ M: comment entity-url
 
         [
             validate-comment
-            uid "author" set-value
+            logged-in-user get username>> "author" set-value
         ] >>validate
 
         [
             "parent" value f <comment>
                 "content" value >>content
-                uid >>author
+                logged-in-user get username>> >>author
                 now >>date
             [ insert-tuple ] [ entity-url <redirect> ] bi
         ] >>submit

extra/webapps/factor-website/factor-website.factor

@@ -7,12 +7,11 @@ logging.insomniac
 http.server
 http.server.dispatchers
 furnace.alloy
-furnace.db
-furnace.asides
-furnace.flash
-furnace.sessions
 furnace.auth.login
 furnace.auth.providers.db
+furnace.auth.features.edit-profile
+furnace.auth.features.recover-password
+furnace.auth.features.registration
 furnace.boilerplate
 webapps.blogs
 webapps.pastebin
@@ -50,8 +49,8 @@ TUPLE: factor-website < dispatcher ;
         <wiki> "wiki" add-responder
         <wee-url> "wee-url" add-responder
         <user-admin> "user-admin" add-responder
-    <login>
+    "Factor website" <login-realm>
-        users-in-db >>users
+        "Factor website" >>name
         allow-registration
         allow-password-recovery
         allow-edit-profile

extra/webapps/todo/todo.factor

@@ -8,7 +8,6 @@ html.templates.chloe
 http.server
 http.server.dispatchers
 furnace
-furnace.sessions
 furnace.boilerplate
 furnace.auth
 furnace.actions
@@ -32,7 +31,7 @@ todo "TODO"
 : <todo> ( id -- todo )
     todo new
         swap >>id
-        uid >>uid ;
+        logged-in-user get username>> >>uid ;
 
 : <view-action> ( -- action )
     <page-action>

extra/webapps/user-admin/user-admin.factor

@@ -11,8 +11,8 @@ furnace.auth.providers
 furnace.auth.providers.db
 furnace.auth.login
 furnace.auth
-furnace.sessions
 furnace.actions
+furnace.utilities
 http.server
 http.server.dispatchers ;
 IN: webapps.user-admin
@@ -138,11 +138,7 @@ TUPLE: user-admin < dispatcher ;
     <action>
         [
             validate-username
-
+            <user> select-tuple 1 >>deleted update-tuple
-            [ <user> select-tuple 1 >>deleted update-tuple ]
-            [ logout-all-sessions ]
-            bi
-
             URL" $user-admin" <redirect>
         ] >>submit ;