! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors assocs namespaces kernel sequences sets\r
+destructors combinators\r
+io.encodings.utf8 io.encodings.string io.binary random\r
+checksums checksums.sha2\r
+html.forms\r
http.server\r
http.server.filters\r
http.server.dispatchers\r
-furnace.sessions\r
-furnace.auth.providers ;\r
+furnace\r
+furnace.actions\r
+furnace.boilerplate\r
+furnace.auth.providers\r
+furnace.auth.providers.db ;\r
IN: furnace.auth\r
\r
SYMBOL: logged-in-user\r
M: filter-responder init-user-profile\r
responder>> init-user-profile ;\r
\r
+: have-capability? ( capability -- ? )\r
+ logged-in-user get capabilities>> member? ;\r
+\r
: profile ( -- assoc ) logged-in-user get profile>> ;\r
\r
: user-changed ( -- )\r
V{ } clone capabilities set-global\r
\r
: define-capability ( word -- ) capabilities get adjoin ;\r
+\r
+TUPLE: realm < dispatcher name users checksum ;\r
+\r
+GENERIC: login-required* ( realm -- response )\r
+\r
+GENERIC: logged-in-username ( realm -- username )\r
+\r
+: login-required ( -- * ) 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 ; 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 ( realm -- )\r
+ logged-in-username [\r
+ users get-user\r
+ [ logged-in-user set ] [ save-user-after ] bi\r
+ ] when* ;\r
+\r
+M: realm call-responder* ( path responder -- response )\r
+ dup realm set\r
+ dup init-user\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
+TUPLE: protected < filter-responder description capabilities ;\r
+\r
+: <protected> ( responder -- protected )\r
+ protected new\r
+ swap >>responder ;\r
+\r
+: check-capabilities ( responder user/f -- ? )\r
+ {\r
+ { [ dup not ] [ 2drop f ] }\r
+ { [ dup deleted>> ] [ 2drop f ] }\r
+ [ [ capabilities>> ] bi@ subset? ]\r
+ } cond ;\r
+\r
+M: protected call-responder* ( path responder -- response )\r
+ dup protected set\r
+ dup logged-in-user get check-capabilities\r
+ [ call-next-method ] [ 2drop realm get login-required* ] 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) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors quotations assocs kernel splitting\r
-base64 html.elements io combinators sequences\r
-http http.server.filters http.server.responses http.server\r
-furnace.auth.providers furnace.auth.login ;\r
+USING: accessors kernel splitting base64 namespaces\r
+http http.server.responses furnace.auth ;\r
IN: furnace.auth.basic\r
\r
-TUPLE: basic-auth < filter-responder realm provider ;\r
+TUPLE: basic-auth-realm < realm ;\r
\r
-C: <basic-auth> basic-auth\r
+C: <basic-auth-realm> basic-auth-realm\r
\r
-: authorization-ok? ( provider header -- ? )\r
- #! Given the realm and the 'Authorization' header,\r
- #! authenticate the user.\r
+: parse-basic-auth ( header -- username/f password/f )\r
dup [\r
" " split1 swap "Basic" = [\r
- base64> ":" split1 spin check-login\r
- ] [\r
- 2drop f\r
- ] if\r
- ] [\r
- 2drop f\r
- ] if ;\r
+ base64> ":" split1\r
+ ] [ drop f f ] if\r
+ ] [ drop f f ] if ;\r
\r
: <401> ( realm -- response )\r
- 401 "Unauthorized" <trivial-response>\r
- "Basic realm=\"" rot "\"" 3append\r
- "WWW-Authenticate" set-header\r
- [\r
- <html> <body>\r
- "Username or Password is invalid" write\r
- </body> </html>\r
- ] >>body ;\r
+ 401 "Invalid username or password" <trivial-response>\r
+ [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;\r
\r
-: logged-in? ( request responder -- ? )\r
- provider>> swap "authorization" header authorization-ok? ;\r
+M: basic-auth-realm login-required* ( realm -- response )\r
+ name>> <401> ;\r
\r
-M: basic-auth call-responder* ( request path responder -- response )\r
- pick over logged-in?\r
- [ call-next-method ] [ 2nip realm>> <401> ] if ;\r
+M: basic-auth-realm logged-in-username ( realm -- uid )\r
+ request get "authorization" header parse-basic-auth\r
+ dup [ over realm get check-login swap and ] [ 2drop f ] if ;\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+IN: furnace.auth.features.edit-profile.tests
+USING: tools.test furnace.auth.features.edit-profile ;
+
+\ allow-edit-profile must-infer
--- /dev/null
+! 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? ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Profile</t:title>
+
+ <t:form t:action="$login/edit-profile">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:label t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Current password:</th>
+ <td><t:password t:name="password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you don't want to change your current password, leave this field blank.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you are changing your password, enter it twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Update" />
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 1 of 4</t:title>
+
+ <p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
+
+ <t:form t:action="recover-password">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <input type="submit" value="Recover password" />
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 2 of 4</t:title>
+
+ <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 3 of 4</t:title>
+
+ <p>Choose a new password for your account.</p>
+
+ <t:form t:action="new-password">
+
+ <table>
+
+ <t:hidden t:name="username" />
+ <t:hidden t:name="ticket" />
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify password:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Set password" />
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>\r
+\r
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
+\r
+ <t:title>Recover lost password: step 4 of 4</t:title>\r
+\r
+ <p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>\r
+\r
+</t:chloe>\r
--- /dev/null
+IN: furnace.auth.features.recover-password
+USING: tools.test furnace.auth.features.recover-password ;
+
+\ allow-password-recovery must-infer
--- /dev/null
+! 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? ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New User Registration</t:title>
+
+ <t:form t:action="register">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Register" />
+ <t:validation-messages />
+
+ </p>
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+IN: furnace.auth.features.registration.tests
+USING: tools.test furnace.auth.features.registration ;
+
+\ allow-registration must-infer
--- /dev/null
+! 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? ;
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <h1><t:write-title /></h1>
-
- <t:call-next-template />
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Edit Profile</t:title>
-
- <t:form t:action="$login/edit-profile">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:label t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:field t:name="realname" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
-
- <tr>
- <th class="field-label">Current password:</th>
- <td><t:password t:name="password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>If you don't want to change your current password, leave this field blank.</td>
- </tr>
-
- <tr>
- <th class="field-label">New password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>If you are changing your password, enter it twice to ensure it is correct.</td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
- </tr>
-
- </table>
-
- <p>
- <input type="submit" value="Update" />
- <t:validation-messages />
- </p>
-
- </t:form>
-
-</t:chloe>
IN: furnace.auth.login.tests\r
USING: tools.test furnace.auth.login ;\r
\r
-\ <login> must-infer\r
-\ allow-registration must-infer\r
-\ allow-password-recovery must-infer\r
+\ <login-realm> must-infer\r
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors quotations assocs kernel splitting\r
-combinators sequences namespaces hashtables sets\r
-fry arrays threads qualified random validators words\r
-io\r
-io.sockets\r
-io.encodings.utf8\r
-io.encodings.string\r
-io.binary\r
-continuations\r
-destructors\r
-checksums\r
-checksums.sha2\r
-validators\r
+USING: kernel accessors namespaces validators urls\r
html.forms\r
-html.components\r
-html.elements\r
-urls\r
-http\r
-http.server\r
http.server.dispatchers\r
-http.server.filters\r
-http.server.responses\r
-furnace\r
furnace.auth\r
-furnace.auth.providers\r
-furnace.auth.providers.db\r
-furnace.actions\r
-furnace.asides\r
furnace.flash\r
+furnace.asides\r
+furnace.actions\r
furnace.sessions\r
-furnace.boilerplate ;\r
-QUALIFIED: smtp\r
+furnace.utilities ;\r
IN: furnace.auth.login\r
\r
-: word>string ( word -- string )\r
- [ word-vocabulary ] [ word-name ] bi ":" swap 3append ;\r
-\r
-: words>strings ( seq -- seq' )\r
- [ word>string ] map ;\r
-\r
-ERROR: no-such-word name vocab ;\r
-\r
-: string>word ( string -- word )\r
- ":" split1 swap 2dup lookup dup\r
- [ 2nip ] [ drop no-such-word ] if ;\r
-\r
-: strings>words ( seq -- seq' )\r
- [ string>word ] map ;\r
-\r
-TUPLE: login < dispatcher users checksum ;\r
-\r
-TUPLE: protected < filter-responder description capabilities ;\r
-\r
-: <protected> ( responder -- protected )\r
- protected new\r
- swap >>responder ;\r
-\r
-: users ( -- provider )\r
- login get users>> ;\r
-\r
-: encode-password ( string salt -- bytes )\r
- [ utf8 encode ] [ 4 >be ] bi* append\r
- login 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
+TUPLE: login-realm < realm ;\r
\r
-: check-login ( password username -- user/f )\r
- users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
+: set-uid ( username -- )\r
+ session get [ (>>uid) ] [ (session-changed) ] bi ;\r
\r
-! Destructor\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
-! ! ! Login\r
: successful-login ( user -- response )\r
- username>> set-uid URL" $login" end-aside ;\r
+ username>> set-uid URL" $realm" end-aside ;\r
\r
-: login-failed ( -- * )\r
- "invalid username or password" validation-error\r
- validation-failed ;\r
+: logout ( -- ) f set-uid ;\r
\r
SYMBOL: description\r
SYMBOL: capabilities\r
\r
: flashed-variables { description capabilities } ;\r
\r
+: login-failed ( -- * )\r
+ "invalid username or password" validation-error\r
+ validation-failed ;\r
+\r
: <login-action> ( -- action )\r
<page-action>\r
[\r
capabilities get words>strings "capabilities" set-value\r
] >>init\r
\r
- { login "login" } >>template\r
+ { login-realm "login" } >>template\r
\r
[\r
{\r
[ successful-login ] [ login-failed ] if*\r
] >>submit ;\r
\r
-! ! ! New user registration\r
-\r
-: user-exists ( -- * )\r
- "username taken" validation-error\r
- validation-failed ;\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
-: <register-action> ( -- action )\r
- <page-action>\r
- { login "register" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "realname" [ [ v-one-line ] v-optional ] }\r
- { "new-password" [ v-password ] }\r
- { "verify-password" [ v-password ] }\r
- { "email" [ [ v-email ] v-optional ] }\r
- { "captcha" [ v-captcha ] }\r
- } validate-params\r
-\r
- same-password-twice\r
- ] >>validate\r
-\r
- [\r
- "username" value <user>\r
- "realname" value >>realname\r
- "new-password" value >>encoded-password\r
- "email" value >>email\r
- H{ } clone >>profile\r
-\r
- users new-user [ user-exists ] unless*\r
-\r
- login get init-user-profile\r
-\r
- successful-login\r
- ] >>submit ;\r
-\r
-! ! ! Editing user profile\r
-\r
-: <edit-profile-action> ( -- action )\r
- <page-action>\r
- [\r
- logged-in-user get\r
- [ username>> "username" set-value ]\r
- [ realname>> "realname" set-value ]\r
- [ email>> "email" set-value ]\r
- tri\r
- ] >>init\r
-\r
- { login "edit-profile" } >>template\r
-\r
- [\r
- uid "username" set-value\r
-\r
- {\r
- { "realname" [ [ v-one-line ] v-optional ] }\r
- { "password" [ ] }\r
- { "new-password" [ [ v-password ] v-optional ] }\r
- { "verify-password" [ [ v-password ] v-optional ] } \r
- { "email" [ [ v-email ] v-optional ] }\r
- } validate-params\r
-\r
- { "password" "new-password" "verify-password" }\r
- [ value empty? not ] contains? [\r
- "password" value uid check-login\r
- [ "incorrect password" validation-error ] unless\r
-\r
- same-password-twice\r
- ] when\r
- ] >>validate\r
-\r
- [\r
- logged-in-user get\r
-\r
- "new-password" value dup empty?\r
- [ drop ] [ >>encoded-password ] if\r
-\r
- "realname" value >>realname\r
- "email" value >>email\r
-\r
- t >>changed?\r
-\r
- drop\r
-\r
- URL" $login" end-aside\r
- ] >>submit\r
-\r
- <protected>\r
- "edit your profile" >>description ;\r
-\r
-! ! ! Password recovery\r
-\r
-SYMBOL: lost-password-from\r
-\r
-: current-host ( -- string )\r
- request get url>> host>> host-name or ;\r
-\r
-: new-password-url ( user -- url )\r
- "recover-3"\r
- swap [\r
- [ username>> "username" set ]\r
- [ ticket>> "ticket" set ]\r
- bi\r
- ] H{ } make-assoc\r
- derive-url ;\r
-\r
-: password-email ( user -- email )\r
- smtp:<email>\r
- [ "[ " % current-host % " ] password recovery" % ] "" make >>subject\r
- lost-password-from get >>from\r
- over email>> 1array >>to\r
- [\r
- "This e-mail was sent by the application server on " % current-host % "\n" %\r
- "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %\r
- "login form, and requested a new password for the user named ``" %\r
- over username>> % "''.\n" %\r
- "\n" %\r
- "If you believe that this request was legitimate, you may click the below link in\n" %\r
- "your browser to set a new password for your account:\n" %\r
- "\n" %\r
- swap new-password-url %\r
- "\n\n" %\r
- "Love,\n" %\r
- "\n" %\r
- " FactorBot\n" %\r
- ] "" make >>body ;\r
-\r
-: send-password-email ( user -- )\r
- '[ , password-email smtp:send-email ]\r
- "E-mail send thread" spawn drop ;\r
-\r
-: <recover-action-1> ( -- action )\r
- <page-action>\r
- { login "recover-1" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "email" [ v-email ] }\r
- { "captcha" [ v-captcha ] }\r
- } validate-params\r
- ] >>validate\r
-\r
- [\r
- "email" value "username" value\r
- users issue-ticket [\r
- send-password-email\r
- ] when*\r
-\r
- URL" $login/recover-2" <redirect>\r
- ] >>submit ;\r
-\r
-: <recover-action-2> ( -- action )\r
- <page-action>\r
- { login "recover-2" } >>template ;\r
-\r
-: <recover-action-3> ( -- action )\r
- <page-action>\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "ticket" [ v-required ] }\r
- } validate-params\r
- ] >>init\r
-\r
- { login "recover-3" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "ticket" [ v-required ] }\r
- { "new-password" [ v-password ] }\r
- { "verify-password" [ v-password ] }\r
- } validate-params\r
-\r
- same-password-twice\r
- ] >>validate\r
-\r
- [\r
- "ticket" value\r
- "username" value\r
- users claim-ticket [\r
- "new-password" value >>encoded-password\r
- users update-user\r
-\r
- URL" $login/recover-4" <redirect>\r
- ] [\r
- <403>\r
- ] if*\r
- ] >>submit ;\r
-\r
-: <recover-action-4> ( -- action )\r
- <page-action>\r
- { login "recover-4" } >>template ;\r
-\r
-! ! ! Logout\r
: <logout-action> ( -- action )\r
<action>\r
- [\r
- f set-uid\r
- URL" $login" end-aside\r
- ] >>submit ;\r
+ [ logout URL" $login-realm" end-aside ] >>submit ;\r
\r
-! ! ! Authentication logic\r
-: show-login-page ( -- response )\r
+M: login-realm login-required*\r
+ drop\r
begin-aside\r
protected get description>> description set\r
protected get capabilities>> capabilities set\r
URL" $login/login" flashed-variables <flash-redirect> ;\r
\r
-: login-required ( -- * )\r
- show-login-page exit-with ;\r
-\r
-: have-capability? ( capability -- ? )\r
- logged-in-user get capabilities>> member? ;\r
-\r
-: check-capabilities ( responder user/f -- ? )\r
- dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ;\r
-\r
-M: protected call-responder* ( path responder -- response )\r
- dup protected set\r
- dup logged-in-user get check-capabilities\r
- [ call-next-method ] [ 2drop show-login-page ] if ;\r
-\r
-: init-user ( -- )\r
- uid [\r
- users get-user\r
- [ logged-in-user set ]\r
- [ save-user-after ] bi\r
- ] when* ;\r
-\r
-M: login call-responder* ( path responder -- response )\r
- dup login set\r
- init-user\r
- call-next-method ;\r
-\r
-: <login-boilerplate> ( responder -- responder' )\r
- <boilerplate>\r
- { login "boilerplate" } >>template ;\r
-\r
-: <login> ( responder -- auth )\r
- login new-dispatcher\r
- swap >>default\r
- <login-action> <login-boilerplate> "login" add-responder\r
- <logout-action> <login-boilerplate> "logout" add-responder\r
- users-in-db >>users\r
- sha-256 >>checksum ;\r
-\r
-! ! ! Configuration\r
-\r
-: allow-edit-profile ( login -- login )\r
- <edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;\r
-\r
-: allow-registration ( login -- login )\r
- <register-action> <login-boilerplate>\r
- "register" add-responder ;\r
-\r
-: allow-password-recovery ( login -- login )\r
- <recover-action-1> <login-boilerplate>\r
- "recover-password" add-responder\r
- <recover-action-2> <login-boilerplate>\r
- "recover-2" add-responder\r
- <recover-action-3> <login-boilerplate>\r
- "recover-3" add-responder\r
- <recover-action-4> <login-boilerplate>\r
- "recover-4" add-responder ;\r
-\r
-: allow-edit-profile? ( -- ? )\r
- login get responders>> "edit-profile" swap key? ;\r
-\r
-: allow-registration? ( -- ? )\r
- login get responders>> "register" swap key? ;\r
+M: login-realm logged-in-username\r
+ drop session get uid>> ;\r
\r
-: allow-password-recovery? ( -- ? )\r
- login get responders>> "recover-password" swap key? ;\r
+: <login-realm> ( responder name -- auth )\r
+ login-realm new-realm\r
+ <login-action> <auth-boilerplate> "login" add-responder\r
+ <logout-action> "logout" add-responder ;\r
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 1 of 4</t:title>
-
- <p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
-
- <t:form t:action="recover-password">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:field t:name="captcha" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
- </tr>
-
- </table>
-
- <input type="submit" value="Recover password" />
-
- </t:form>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 2 of 4</t:title>
-
- <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 3 of 4</t:title>
-
- <p>Choose a new password for your account.</p>
-
- <t:form t:action="new-password">
-
- <table>
-
- <t:hidden t:name="username" />
- <t:hidden t:name="ticket" />
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify password:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
- </tr>
-
- </table>
-
- <p>
- <input type="submit" value="Set password" />
- <t:validation-messages />
- </p>
-
- </t:form>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>\r
-\r
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
-\r
- <t:title>Recover lost password: step 4 of 4</t:title>\r
-\r
- <p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>\r
-\r
-</t:chloe>\r
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>New User Registration</t:title>
-
- <t:form t:action="register">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:field t:name="realname" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:field t:name="captcha" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
- </tr>
-
- </table>
-
- <p>
-
- <input type="submit" value="Register" />
- <t:validation-messages />
-
- </p>
-
- </t:form>
-
-</t:chloe>
IN: furnace.auth.providers.db.tests\r
USING: furnace.actions\r
+furnace.auth\r
furnace.auth.login\r
furnace.auth.providers\r
furnace.auth.providers.db tools.test\r
namespaces db db.sqlite db.tuples continuations\r
io.files accessors kernel ;\r
\r
-<action> <login>\r
- users-in-db >>users\r
-login set\r
+<action> "test" <login-realm> realm set\r
\r
[ "auth-test.db" temp-file delete-file ] ignore-errors\r
\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel accessors continuations namespaces destructors\r
-db db.pools io.pools http.server http.server.filters\r
-furnace.sessions ;\r
+db db.pools io.pools http.server http.server.filters ;\r
IN: furnace.db\r
\r
TUPLE: db-persistence < filter-responder pool ;\r
[ 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 ;
sessions set
request-session [ begin-session ] unless*
existing-session put-session-cookie ;
-
-: logout-all-sessions ( uid -- )
- session new swap >>uid delete-tuples ;
--- /dev/null
+! 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 ;
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"
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"
! 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
[
<dispatcher>
<action> <protected>
- <login>
+ "Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
[
<dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
- <login>
+ "Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
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
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 ;
! 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
furnace.auth
furnace.auth.login
furnace.boilerplate
-furnace.sessions
furnace.syndication ;
IN: webapps.blogs
[
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
"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 ( -- )
[
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
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
<wiki> "wiki" add-responder
<wee-url> "wee-url" add-responder
<user-admin> "user-admin" add-responder
- <login>
- users-in-db >>users
+ "Factor website" <login-realm>
+ "Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile
http.server
http.server.dispatchers
furnace
-furnace.sessions
furnace.boilerplate
furnace.auth
furnace.actions
: <todo> ( id -- todo )
todo new
swap >>id
- uid >>uid ;
+ logged-in-user get username>> >>uid ;
: <view-action> ( -- action )
<page-action>
furnace.auth.providers.db
furnace.auth.login
furnace.auth
-furnace.sessions
furnace.actions
+furnace.utilities
http.server
http.server.dispatchers ;
IN: webapps.user-admin
<action>
[
validate-username
-
- [ <user> select-tuple 1 >>deleted update-tuple ]
- [ logout-all-sessions ]
- bi
-
+ <user> select-tuple 1 >>deleted update-tuple
URL" $user-admin" <redirect>
] >>submit ;
projects / factor.git / commitdiff