From 39d8bec7ef41228902ec00e829aa0505ff269528 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Jun 2008 03:34:17 -0500 Subject: [PATCH] Refactoring furnace.auth --- extra/furnace/auth/auth.factor | 100 ++++- extra/furnace/auth/basic/basic.factor | 44 +- .../furnace/auth/{login => }/boilerplate.xml | 0 .../edit-profile/edit-profile-tests.factor | 4 + .../features/edit-profile/edit-profile.factor | 67 ++++ .../edit-profile}/edit-profile.xml | 0 .../recover-password}/recover-1.xml | 0 .../recover-password}/recover-2.xml | 0 .../recover-password}/recover-3.xml | 0 .../recover-password}/recover-4.xml | 0 .../recover-password-tests.factor | 4 + .../recover-password/recover-password.factor | 123 ++++++ .../registration}/register.xml | 0 .../registration/registration-tests.factor | 4 + .../features/registration/registration.factor | 43 ++ extra/furnace/auth/login/login-tests.factor | 4 +- extra/furnace/auth/login/login.factor | 379 ++---------------- .../furnace/auth/providers/db/db-tests.factor | 5 +- extra/furnace/db/db.factor | 3 +- extra/furnace/sessions/sessions.factor | 9 - extra/furnace/utilities/utilities.factor | 19 + extra/http/client/client-tests.factor | 4 +- extra/http/http-tests.factor | 6 +- extra/http/http.factor | 3 +- extra/webapps/blogs/blogs.factor | 14 +- .../factor-website/factor-website.factor | 11 +- extra/webapps/todo/todo.factor | 3 +- extra/webapps/user-admin/user-admin.factor | 8 +- 28 files changed, 426 insertions(+), 431 deletions(-) rename extra/furnace/auth/{login => }/boilerplate.xml (100%) create mode 100644 extra/furnace/auth/features/edit-profile/edit-profile-tests.factor create mode 100644 extra/furnace/auth/features/edit-profile/edit-profile.factor rename extra/furnace/auth/{login => features/edit-profile}/edit-profile.xml (100%) rename extra/furnace/auth/{login => features/recover-password}/recover-1.xml (100%) rename extra/furnace/auth/{login => features/recover-password}/recover-2.xml (100%) rename extra/furnace/auth/{login => features/recover-password}/recover-3.xml (100%) rename extra/furnace/auth/{login => features/recover-password}/recover-4.xml (100%) create mode 100644 extra/furnace/auth/features/recover-password/recover-password-tests.factor create mode 100644 extra/furnace/auth/features/recover-password/recover-password.factor rename extra/furnace/auth/{login => features/registration}/register.xml (100%) create mode 100644 extra/furnace/auth/features/registration/registration-tests.factor create mode 100644 extra/furnace/auth/features/registration/registration.factor create mode 100644 extra/furnace/utilities/utilities.factor diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index f78cea3835..d10ba48ce5 100755 --- a/extra/furnace/auth/auth.factor +++ b/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.auth.providers ; +furnace +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 + +M: user-saver dispose + user>> dup changed?>> [ users update-user ] [ drop ] if ; + +: save-user-after ( user -- ) + &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 ; + +: ( 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 ; + +: ( responder -- responder' ) + { 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 ; diff --git a/extra/furnace/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor index c8d542c219..ae9cbb82c1 100755 --- a/extra/furnace/auth/basic/basic.factor +++ b/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 -base64 html.elements io combinators sequences -http http.server.filters http.server.responses http.server -furnace.auth.providers furnace.auth.login ; +USING: accessors kernel splitting base64 namespaces +http http.server.responses furnace.auth ; IN: furnace.auth.basic -TUPLE: basic-auth < filter-responder realm provider ; +TUPLE: basic-auth-realm < realm ; -C: basic-auth +C: basic-auth-realm -: authorization-ok? ( provider header -- ? ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. +: parse-basic-auth ( header -- username/f password/f ) dup [ " " split1 swap "Basic" = [ - base64> ":" split1 spin check-login - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; + base64> ":" split1 + ] [ drop f f ] if + ] [ drop f f ] if ; : <401> ( realm -- response ) - 401 "Unauthorized" - "Basic realm=\"" rot "\"" 3append - "WWW-Authenticate" set-header - [ - - "Username or Password is invalid" write - - ] >>body ; + 401 "Invalid username or password" + [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ; -: logged-in? ( request responder -- ? ) - provider>> swap "authorization" header authorization-ok? ; +M: basic-auth-realm login-required* ( realm -- response ) + name>> <401> ; -M: basic-auth call-responder* ( request path responder -- response ) - pick over logged-in? - [ call-next-method ] [ 2nip realm>> <401> ] if ; +M: basic-auth-realm logged-in-username ( realm -- uid ) + request get "authorization" header parse-basic-auth + dup [ over realm get check-login swap and ] [ 2drop f ] if ; diff --git a/extra/furnace/auth/login/boilerplate.xml b/extra/furnace/auth/boilerplate.xml similarity index 100% rename from extra/furnace/auth/login/boilerplate.xml rename to extra/furnace/auth/boilerplate.xml diff --git a/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor b/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor new file mode 100644 index 0000000000..d0fdf22c27 --- /dev/null +++ b/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 diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.factor b/extra/furnace/auth/features/edit-profile/edit-profile.factor new file mode 100644 index 0000000000..4edb4ac364 --- /dev/null +++ b/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 + +: ( -- 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 + + + "edit your profile" >>description ; + +: allow-edit-profile ( login -- login ) + "edit-profile" add-responder ; + +: allow-edit-profile? ( -- ? ) + realm get get responders>> "edit-profile" swap key? ; diff --git a/extra/furnace/auth/login/edit-profile.xml b/extra/furnace/auth/features/edit-profile/edit-profile.xml similarity index 100% rename from extra/furnace/auth/login/edit-profile.xml rename to extra/furnace/auth/features/edit-profile/edit-profile.xml diff --git a/extra/furnace/auth/login/recover-1.xml b/extra/furnace/auth/features/recover-password/recover-1.xml similarity index 100% rename from extra/furnace/auth/login/recover-1.xml rename to extra/furnace/auth/features/recover-password/recover-1.xml diff --git a/extra/furnace/auth/login/recover-2.xml b/extra/furnace/auth/features/recover-password/recover-2.xml similarity index 100% rename from extra/furnace/auth/login/recover-2.xml rename to extra/furnace/auth/features/recover-password/recover-2.xml diff --git a/extra/furnace/auth/login/recover-3.xml b/extra/furnace/auth/features/recover-password/recover-3.xml similarity index 100% rename from extra/furnace/auth/login/recover-3.xml rename to extra/furnace/auth/features/recover-password/recover-3.xml diff --git a/extra/furnace/auth/login/recover-4.xml b/extra/furnace/auth/features/recover-password/recover-4.xml similarity index 100% rename from extra/furnace/auth/login/recover-4.xml rename to extra/furnace/auth/features/recover-password/recover-4.xml diff --git a/extra/furnace/auth/features/recover-password/recover-password-tests.factor b/extra/furnace/auth/features/recover-password/recover-password-tests.factor new file mode 100644 index 0000000000..b589c52624 --- /dev/null +++ b/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 diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor new file mode 100644 index 0000000000..1e8d163e99 --- /dev/null +++ b/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 ) + + [ "[ " % 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 ; + +: ( -- 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" + ] >>submit ; + +: ( -- action ) + + { realm "recover-2" } >>template ; + +: ( -- 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" + ] [ + <403> + ] if* + ] >>submit ; + +: ( -- action ) + + { realm "recover-4" } >>template ; + +: allow-password-recovery ( login -- login ) + + "recover-password" add-responder + + "recover-2" add-responder + + "recover-3" add-responder + + "recover-4" add-responder ; + +: allow-password-recovery? ( -- ? ) + realm get responders>> "recover-password" swap key? ; diff --git a/extra/furnace/auth/login/register.xml b/extra/furnace/auth/features/registration/register.xml similarity index 100% rename from extra/furnace/auth/login/register.xml rename to extra/furnace/auth/features/registration/register.xml diff --git a/extra/furnace/auth/features/registration/registration-tests.factor b/extra/furnace/auth/features/registration/registration-tests.factor new file mode 100644 index 0000000000..e770f35586 --- /dev/null +++ b/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 diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor new file mode 100644 index 0000000000..3deead4869 --- /dev/null +++ b/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 + +: ( -- 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 + "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" + ] >>submit ; + +: allow-registration ( login -- login ) + "register" add-responder ; + +: allow-registration? ( -- ? ) + realm get responders>> "register" swap key? ; diff --git a/extra/furnace/auth/login/login-tests.factor b/extra/furnace/auth/login/login-tests.factor index 5095ebdb85..64f7bd3b96 100755 --- a/extra/furnace/auth/login/login-tests.factor +++ b/extra/furnace/auth/login/login-tests.factor @@ -1,6 +1,4 @@ IN: furnace.auth.login.tests USING: tools.test furnace.auth.login ; -\ must-infer -\ allow-registration must-infer -\ allow-password-recovery must-infer +\ must-infer diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 80005c452a..1f81c488cc 100755 --- a/extra/furnace/auth/login/login.factor +++ b/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 -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 +USING: kernel accessors namespaces validators urls 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 ; -QUALIFIED: smtp +furnace.utilities ; IN: furnace.auth.login -: word>string ( word -- string ) - [ word-vocabulary ] [ word-name ] bi ":" swap 3append ; +TUPLE: login-realm < realm ; -: words>strings ( seq -- seq' ) - [ word>string ] map ; +: set-uid ( username -- ) + 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 ; - -: ( 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 - -M: user-saver dispose - user>> dup changed?>> [ users update-user ] [ drop ] if ; - -: save-user-after ( user -- ) - &dispose drop ; - -! ! ! Login : successful-login ( user -- response ) - username>> set-uid URL" $login" end-aside ; + username>> set-uid URL" $realm" end-aside ; -: login-failed ( -- * ) - "invalid username or password" validation-error - validation-failed ; +: logout ( -- ) f set-uid ; SYMBOL: description SYMBOL: capabilities : flashed-variables { description capabilities } ; +: login-failed ( -- * ) + "invalid username or password" validation-error + validation-failed ; + : ( -- 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 ; - -: ( -- 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 - "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 - -: ( -- 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 - - - "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: - [ "[ " % 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 ; - -: ( -- 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" - ] >>submit ; - -: ( -- action ) - - { login "recover-2" } >>template ; - -: ( -- 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" - ] [ - <403> - ] if* - ] >>submit ; - -: ( -- action ) - - { login "recover-4" } >>template ; - -! ! ! Logout : ( -- action ) - [ - f set-uid - URL" $login" end-aside - ] >>submit ; + [ logout URL" $login-realm" end-aside ] >>submit ; -! ! ! Authentication logic -: show-login-page ( -- response ) +M: login-realm login-required* + drop begin-aside protected get description>> description set protected get capabilities>> capabilities set URL" $login/login" flashed-variables ; -: login-required ( -- * ) - show-login-page exit-with ; +M: login-realm logged-in-username + drop session get uid>> ; -: have-capability? ( capability -- ? ) - logged-in-user get capabilities>> member? ; - -: check-capabilities ( responder user/f -- ? ) - 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 ; - -: ( responder -- responder' ) - - { login "boilerplate" } >>template ; - -: ( responder -- auth ) - login new-dispatcher - swap >>default - "login" add-responder - "logout" add-responder - users-in-db >>users - sha-256 >>checksum ; - -! ! ! Configuration - -: allow-edit-profile ( login -- login ) - "edit-profile" add-responder ; - -: allow-registration ( login -- login ) - - "register" add-responder ; - -: allow-password-recovery ( login -- login ) - - "recover-password" add-responder - - "recover-2" add-responder - - "recover-3" add-responder - - "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? ; +: ( responder name -- auth ) + login-realm new-realm + "login" add-responder + "logout" add-responder ; diff --git a/extra/furnace/auth/providers/db/db-tests.factor b/extra/furnace/auth/providers/db/db-tests.factor index e5914c7ab3..fac5c23e4a 100755 --- a/extra/furnace/auth/providers/db/db-tests.factor +++ b/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 ; - - users-in-db >>users -login set + "test" realm set [ "auth-test.db" temp-file delete-file ] ignore-errors diff --git a/extra/furnace/db/db.factor b/extra/furnace/db/db.factor index 8487b4b3fc..b4a4386015 100755 --- a/extra/furnace/db/db.factor +++ b/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 -furnace.sessions ; +db db.pools io.pools http.server http.server.filters ; IN: furnace.db TUPLE: db-persistence < filter-responder pool ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 4be7403e39..fe8053fc9c 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/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 ; diff --git a/extra/furnace/utilities/utilities.factor b/extra/furnace/utilities/utilities.factor new file mode 100644 index 0000000000..20c05d459f --- /dev/null +++ b/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 ; diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index daf4ad88d3..28a605174a 100755 --- a/extra/http/client/client-tests.factor +++ b/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" diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index d092e5008f..73d26aa327 100755 --- a/extra/http/http-tests.factor +++ b/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 [ [ - + "Test" "" add-responder add-quit-action @@ -206,7 +206,7 @@ test-db [ [ [ [ "Hi" write ] "text/plain" ] >>display - + "Test" "" add-responder add-quit-action diff --git a/extra/http/http.factor b/extra/http/http.factor index 25bf20429d..d2a0b0f922 100755 --- a/extra/http/http.factor +++ b/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 ; diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 760951eec6..aa1aa5edc7 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/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 dup { "title" "content" } to-object - uid >>author + logged-in-user get username>> >>author now >>date [ insert-tuple ] [ entity-url ] 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 "content" value >>content - uid >>author + logged-in-user get username>> >>author now >>date [ insert-tuple ] [ entity-url ] bi ] >>submit diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 04fc0487b8..c0bd856d5d 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/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" add-responder "wee-url" add-responder "user-admin" add-responder - - users-in-db >>users + "Factor website" + "Factor website" >>name allow-registration allow-password-recovery allow-edit-profile diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index dba10184f4..4b1b59e80f 100755 --- a/extra/webapps/todo/todo.factor +++ b/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" : ( id -- todo ) todo new swap >>id - uid >>uid ; + logged-in-user get username>> >>uid ; : ( -- action ) diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 5859d616ee..8c7b1b21c9 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/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 ; [ validate-username - - [ select-tuple 1 >>deleted update-tuple ] - [ logout-all-sessions ] - bi - + select-tuple 1 >>deleted update-tuple URL" $user-admin" ] >>submit ;