--- /dev/null
+USING: kernel furnace.actions validators
+tools.test math math.parser multiline namespaces http
+io.streams.string http.server sequences splitting accessors ;
+IN: furnace.actions.tests
+
+<action>
+ [ "a" param "b" param [ string>number ] bi@ + ] >>display
+"action-1" set
+
+: lf>crlf "\n" split "\r\n" join ;
+
+STRING: action-request-test-1
+GET http://foo/bar?a=12&b=13 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+ action-request-test-1 lf>crlf
+ [ read-request ] with-string-reader
+ init-request
+ { } "action-1" get call-responder
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors sequences kernel assocs combinators http.server\r
+validators http hashtables namespaces fry continuations locals\r
+boxes xml.entities html.elements html.components\r
+html.templates.chloe io arrays math ;\r
+IN: furnace.actions\r
+\r
+SYMBOL: params\r
+\r
+SYMBOL: rest-param\r
+\r
+: render-validation-messages ( -- )\r
+ validation-messages get\r
+ dup empty? [ drop ] [\r
+ <ul "errors" =class ul>\r
+ [ <li> message>> escape-string write </li> ] each\r
+ </ul>\r
+ ] if ;\r
+\r
+CHLOE: validation-messages drop render-validation-messages ;\r
+\r
+TUPLE: action rest-param init display validate submit ;\r
+\r
+: new-action ( class -- action )\r
+ new\r
+ [ ] >>init\r
+ [ <400> ] >>display\r
+ [ ] >>validate\r
+ [ <400> ] >>submit ;\r
+\r
+: <action> ( -- action )\r
+ action new-action ;\r
+\r
+: handle-get ( action -- response )\r
+ blank-values\r
+ [ init>> call ]\r
+ [ display>> call ]\r
+ bi ;\r
+\r
+: validation-failed ( -- * )\r
+ request get method>> "POST" =\r
+ [ action get display>> call ] [ <400> ] if exit-with ;\r
+\r
+: handle-post ( action -- response )\r
+ init-validation\r
+ blank-values\r
+ [ validate>> call ]\r
+ [ submit>> call ] bi ;\r
+\r
+: handle-rest-param ( arg -- )\r
+ dup length 1 > action get rest-param>> not or\r
+ [ <404> exit-with ] [\r
+ action get rest-param>> associate rest-param set\r
+ ] if ;\r
+\r
+M: action call-responder* ( path action -- response )\r
+ dup action set\r
+ '[\r
+ , dup empty? [ drop ] [ handle-rest-param ] if\r
+\r
+ init-validation\r
+ ,\r
+ request get\r
+ [ request-params rest-param get assoc-union params set ]\r
+ [ method>> ] bi\r
+ {\r
+ { "GET" [ handle-get ] }\r
+ { "HEAD" [ handle-get ] }\r
+ { "POST" [ handle-post ] }\r
+ } case\r
+ ] with-exit-continuation ;\r
+\r
+: param ( name -- value )\r
+ params get at ;\r
+\r
+: check-validation ( -- )\r
+ validation-failed? [ validation-failed ] when ;\r
+\r
+: validate-params ( validators -- )\r
+ params get swap validate-values from-object\r
+ check-validation ;\r
+\r
+: validate-integer-id ( -- )\r
+ { { "id" [ v-number ] } } validate-params ;\r
+\r
+TUPLE: page-action < action template ;\r
+\r
+: <chloe-content> ( path -- response )\r
+ resolve-template-path <chloe> "text/html" <content> ;\r
+\r
+: <page-action> ( -- page )\r
+ page-action new-action\r
+ dup '[ , template>> <chloe-content> ] >>display ;\r
+\r
+TUPLE: feed-action < action feed ;\r
+\r
+: <feed-action> ( -- feed )\r
+ feed-action new-action\r
+ dup '[ , feed>> call <feed-content> ] >>display ;\r
--- /dev/null
+! Copyright (c) 2008 Slava Pestov\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors assocs namespaces kernel sequences sets\r
+http.server\r
+furnace.sessions\r
+furnace.auth.providers ;\r
+IN: furnace.auth\r
+\r
+SYMBOL: logged-in-user\r
+\r
+GENERIC: init-user-profile ( responder -- )\r
+\r
+M: object init-user-profile drop ;\r
+\r
+M: dispatcher init-user-profile\r
+ default>> init-user-profile ;\r
+\r
+M: filter-responder init-user-profile\r
+ responder>> init-user-profile ;\r
+\r
+: profile ( -- assoc ) logged-in-user get profile>> ;\r
+\r
+: user-changed ( -- )\r
+ logged-in-user get t >>changed? drop ;\r
+\r
+: uget ( key -- value )\r
+ profile at ;\r
+\r
+: uset ( value key -- )\r
+ profile set-at\r
+ user-changed ;\r
+\r
+: uchange ( quot key -- )\r
+ profile swap change-at\r
+ user-changed ; inline\r
+\r
+SYMBOL: capabilities\r
+\r
+V{ } clone capabilities set-global\r
+\r
+: define-capability ( word -- ) capabilities get adjoin ;\r
--- /dev/null
+! 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 http.server\r
+furnace.auth.providers furnace.auth.login\r
+http sequences ;\r
+IN: furnace.auth.basic\r
+\r
+TUPLE: basic-auth < filter-responder realm provider ;\r
+\r
+C: <basic-auth> basic-auth\r
+\r
+: authorization-ok? ( provider header -- ? )\r
+ #! Given the realm and the 'Authorization' header,\r
+ #! authenticate the user.\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
+\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
+\r
+: logged-in? ( request responder -- ? )\r
+ provider>> swap "authorization" header authorization-ok? ;\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
--- /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>
--- /dev/null
+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
--- /dev/null
+! 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\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
+html.components\r
+html.elements\r
+urls\r
+http\r
+http.server\r
+furnace.auth\r
+furnace.auth.providers\r
+furnace.auth.providers.db\r
+furnace.actions\r
+furnace.flows\r
+furnace.sessions\r
+furnace.boilerplate ;\r
+QUALIFIED: smtp\r
+IN: furnace.auth.login\r
+\r
+TUPLE: login < dispatcher users checksum ;\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
+\r
+: check-login ( password username -- user/f )\r
+ users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\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 "$login" end-flow ;\r
+\r
+: login-failed ( -- * )\r
+ "invalid username or password" validation-error\r
+ validation-failed ;\r
+\r
+: <login-action> ( -- action )\r
+ <page-action>\r
+ "$login/login" >>template\r
+\r
+ [\r
+ {\r
+ { "username" [ v-required ] }\r
+ { "password" [ v-required ] }\r
+ } validate-params\r
+\r
+ "password" value\r
+ "username" value check-login\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
+ "$login" end-flow\r
+ ] >>submit ;\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
+ <400>\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
+ "$login/login" end-flow\r
+ ] >>submit ;\r
+\r
+! ! ! Authentication logic\r
+\r
+TUPLE: protected < filter-responder capabilities ;\r
+\r
+C: <protected> protected\r
+\r
+: show-login-page ( -- response )\r
+ begin-flow\r
+ URL" $login/login" <redirect> ;\r
+\r
+: check-capabilities ( responder user -- ? )\r
+ [ capabilities>> ] bi@ subset? ;\r
+\r
+M: protected call-responder* ( path responder -- response )\r
+ uid dup [\r
+ users get-user 2dup check-capabilities [\r
+ [ logged-in-user set ] [ save-user-after ] bi\r
+ call-next-method\r
+ ] [\r
+ 3drop show-login-page\r
+ ] if\r
+ ] [\r
+ 3drop show-login-page\r
+ ] if ;\r
+\r
+M: login call-responder* ( path responder -- response )\r
+ dup login set\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> f <protected> <login-boilerplate>\r
+ "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
+\r
+: allow-password-recovery? ( -- ? )\r
+ login get responders>> "recover-password" swap key? ;\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Login</t:title>
+
+ <t:form t:action="login">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="password" /></td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Log in" />
+ <t:validation-messages />
+
+ </p>
+
+ </t:form>
+
+ <p>
+ <t:if code="http.server.auth.login:login-failed?">
+ <t:a t:href="register">Register</t:a>
+ </t:if>
+ |
+ <t:if code="http.server.auth.login:allow-password-recovery?">
+ <t:a t:href="recover-password">Recover Password</t:a>
+ </t:if>
+ </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 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>
--- /dev/null
+IN: furnace.auth.providers.assoc.tests\r
+USING: furnace.actions furnace.auth.providers \r
+furnace.auth.providers.assoc furnace.auth.login\r
+tools.test namespaces accessors kernel ;\r
+\r
+<action> <login>\r
+ <users-in-memory> >>users\r
+login set\r
+\r
+[ t ] [\r
+ "slava" <user>\r
+ "foobar" >>encoded-password\r
+ "slava@factorcode.org" >>email\r
+ H{ } clone >>profile\r
+ users new-user\r
+ username>> "slava" =\r
+] unit-test\r
+\r
+[ f ] [\r
+ "slava" <user>\r
+ H{ } clone >>profile\r
+ users new-user\r
+] unit-test\r
+\r
+[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
+\r
+[ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
+\r
+[ t ] [ "user" get >boolean ] unit-test\r
+\r
+[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
+\r
+[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
+\r
+[ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+IN: furnace.auth.providers.assoc\r
+USING: accessors assocs kernel furnace.auth.providers ;\r
+\r
+TUPLE: users-in-memory assoc ;\r
+\r
+: <users-in-memory> ( -- provider )\r
+ H{ } clone users-in-memory boa ;\r
+\r
+M: users-in-memory get-user ( username provider -- user/f )\r
+ assoc>> at ;\r
+\r
+M: users-in-memory update-user ( user provider -- ) 2drop ;\r
+\r
+M: users-in-memory new-user ( user provider -- user/f )\r
+ [ dup username>> ] dip assoc>>\r
+ 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;\r
--- /dev/null
+IN: furnace.auth.providers.db.tests\r
+USING: furnace.actions\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
+\r
+[ "auth-test.db" temp-file delete-file ] ignore-errors\r
+\r
+"auth-test.db" temp-file sqlite-db [\r
+\r
+ init-users-table\r
+\r
+ [ t ] [\r
+ "slava" <user>\r
+ "foobar" >>encoded-password\r
+ "slava@factorcode.org" >>email\r
+ H{ } clone >>profile\r
+ users new-user\r
+ username>> "slava" =\r
+ ] unit-test\r
+\r
+ [ f ] [\r
+ "slava" <user>\r
+ H{ } clone >>profile\r
+ users new-user\r
+ ] unit-test\r
+\r
+ [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
+\r
+ [ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
+\r
+ [ t ] [ "user" get >boolean ] unit-test\r
+\r
+ [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
+\r
+ [ ] [ "user" get users update-user ] unit-test\r
+\r
+ [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
+\r
+ [ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
+] with-db\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db db.tuples db.types accessors
+furnace.auth.providers kernel continuations
+classes.singleton ;
+IN: furnace.auth.providers.db
+
+user "USERS"
+{
+ { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
+ { "realname" "REALNAME" { VARCHAR 256 } }
+ { "password" "PASSWORD" BLOB +not-null+ }
+ { "salt" "SALT" INTEGER +not-null+ }
+ { "email" "EMAIL" { VARCHAR 256 } }
+ { "ticket" "TICKET" { VARCHAR 256 } }
+ { "capabilities" "CAPABILITIES" FACTOR-BLOB }
+ { "profile" "PROFILE" FACTOR-BLOB }
+ { "deleted" "DELETED" INTEGER +not-null+ }
+} define-persistent
+
+: init-users-table user ensure-table ;
+
+SINGLETON: users-in-db
+
+M: users-in-db get-user
+ drop <user> select-tuple ;
+
+M: users-in-db new-user
+ drop
+ [
+ user new
+ over username>> >>username
+ select-tuple [
+ drop f
+ ] [
+ dup insert-tuple
+ ] if
+ ] with-transaction ;
+
+M: users-in-db update-user
+ drop update-tuple ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: furnace.auth.providers kernel ;\r
+IN: furnace.auth.providers.null\r
+\r
+TUPLE: no-users ;\r
+\r
+: no-users T{ no-users } ;\r
+\r
+M: no-users get-user 2drop f ;\r
+\r
+M: no-users new-user 2drop f ;\r
+\r
+M: no-users update-user 2drop ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel accessors random math.parser locals\r
+sequences math ;\r
+IN: furnace.auth.providers\r
+\r
+TUPLE: user\r
+username realname\r
+password salt\r
+email ticket capabilities profile deleted changed? ;\r
+\r
+: <user> ( username -- user )\r
+ user new\r
+ swap >>username\r
+ 0 >>deleted ;\r
+\r
+GENERIC: get-user ( username provider -- user/f )\r
+\r
+GENERIC: update-user ( user provider -- )\r
+\r
+GENERIC: new-user ( user provider -- user/f )\r
+\r
+! Password recovery support\r
+\r
+:: issue-ticket ( email username provider -- user/f )\r
+ [let | user [ username provider get-user ] |\r
+ user [\r
+ user email>> length 0 > [\r
+ user email>> email = [\r
+ user\r
+ 256 random-bits >hex >>ticket\r
+ dup provider update-user\r
+ ] [ f ] if\r
+ ] [ f ] if\r
+ ] [ f ] if\r
+ ] ;\r
+\r
+:: claim-ticket ( ticket username provider -- user/f )\r
+ [let | user [ username provider get-user ] |\r
+ user [\r
+ user ticket>> ticket = [\r
+ user f >>ticket dup provider update-user\r
+ ] [ f ] if\r
+ ] [ f ] if\r
+ ] ;\r
+\r
+! For configuration\r
+\r
+: add-user ( provider user -- provider )\r
+ over new-user [ "User exists" throw ] when ;\r
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces http.server html.templates
+html.templates.chloe locals ;
+IN: furnace.boilerplate
+
+TUPLE: boilerplate < filter-responder template ;
+
+: <boilerplate> f boilerplate boa ;
+
+M:: boilerplate call-responder* ( path responder -- )
+ path responder call-next-method
+ dup content-type>> "text/html" = [
+ clone [| body |
+ [
+ body
+ responder template>> resolve-template-path <chloe>
+ with-boilerplate
+ ]
+ ] change-body
+ ] when ;
--- /dev/null
+IN: furnace.callbacks\r
+USING: furnace.actions furnace.callbacks accessors\r
+http.server http tools.test namespaces io fry sequences\r
+splitting kernel hashtables continuations ;\r
+\r
+[ 123 ] [\r
+ [\r
+ init-request\r
+\r
+ <request> "GET" >>method request set\r
+ [\r
+ exit-continuation set\r
+ { }\r
+ <action> [ [ "hello" print 123 ] show-final ] >>display\r
+ <callback-responder>\r
+ call-responder\r
+ ] callcc1\r
+ ] with-scope\r
+] unit-test\r
+\r
+[\r
+ init-request\r
+\r
+ <action> [\r
+ [\r
+ "hello" print\r
+ "text/html" <content>\r
+ ] show-page\r
+ "byebye" print\r
+ [ 123 ] show-final\r
+ ] >>display\r
+ <callback-responder> "r" set\r
+\r
+ [ 123 ] [\r
+ [\r
+ exit-continuation set\r
+ <request> "GET" >>method request set\r
+ { } "r" get call-responder\r
+ ] callcc1\r
+\r
+ body>> first\r
+\r
+ <request>\r
+ "GET" >>method\r
+ swap cont-id associate >>query\r
+ "/" >>path\r
+ request set\r
+\r
+ [\r
+ exit-continuation set\r
+ { }\r
+ "r" get call-responder\r
+ ] callcc1\r
+\r
+ ! get-post-get\r
+ <request>\r
+ "GET" >>method\r
+ swap "location" header "=" last-split1 nip cont-id associate >>query\r
+ "/" >>path\r
+ request set\r
+\r
+ [\r
+ exit-continuation set\r
+ { }\r
+ "r" get call-responder\r
+ ] callcc1\r
+ ] unit-test\r
+] with-scope\r
--- /dev/null
+! Copyright (C) 2004 Chris Double.\r
+! Copyright (C) 2006, 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: http http.server io kernel math namespaces\r
+continuations calendar sequences assocs hashtables\r
+accessors arrays alarms quotations combinators fry assocs.lib ;\r
+IN: furnace.callbacks\r
+\r
+SYMBOL: responder\r
+\r
+TUPLE: callback-responder responder callbacks ;\r
+\r
+: <callback-responder> ( responder -- responder' )\r
+ #! A continuation responder is a special type of session\r
+ #! manager. However it works entirely differently from\r
+ #! the URL and cookie session managers.\r
+ H{ } clone callback-responder boa ;\r
+\r
+TUPLE: callback cont quot expires alarm responder ;\r
+\r
+: timeout 20 minutes ;\r
+\r
+: timeout-callback ( callback -- )\r
+ [ alarm>> cancel-alarm ]\r
+ [ dup responder>> callbacks>> delete-at ]\r
+ bi ;\r
+\r
+: touch-callback ( callback -- )\r
+ dup expires>> [\r
+ dup alarm>> [ cancel-alarm ] when*\r
+ dup '[ , timeout-callback ] timeout later >>alarm\r
+ ] when drop ;\r
+\r
+: <callback> ( cont quot expires? -- callback )\r
+ f callback-responder get callback boa\r
+ dup touch-callback ;\r
+\r
+: invoke-callback ( callback -- response )\r
+ [ touch-callback ]\r
+ [ quot>> request get exit-continuation get 3array ]\r
+ [ cont>> continue-with ]\r
+ tri ;\r
+\r
+: register-callback ( cont quot expires? -- id )\r
+ <callback> callback-responder get callbacks>> set-at-unique ;\r
+\r
+: forward-to-url ( url query -- * )\r
+ #! When executed inside a 'show' call, this will force a\r
+ #! HTTP 302 to occur to instruct the browser to forward to\r
+ #! the request URL.\r
+ <temporary-redirect> exit-with ;\r
+\r
+: cont-id "factorcontid" ;\r
+\r
+: forward-to-id ( id -- * )\r
+ #! When executed inside a 'show' call, this will force a\r
+ #! HTTP 302 to occur to instruct the browser to forward to\r
+ #! the request URL.\r
+ f swap cont-id associate forward-to-url ;\r
+\r
+: restore-request ( pair -- )\r
+ first3 exit-continuation set request set call ;\r
+\r
+SYMBOL: post-refresh-get?\r
+\r
+: redirect-to-here ( -- )\r
+ #! Force a redirect to the client browser so that the browser\r
+ #! goes to the current point in the code. This forces an URL\r
+ #! change on the browser so that refreshing that URL will\r
+ #! immediately run from this code point. This prevents the\r
+ #! "this request will issue a POST" warning from the browser\r
+ #! and prevents re-running the previous POST logic. This is\r
+ #! known as the 'post-refresh-get' pattern.\r
+ post-refresh-get? get [\r
+ [\r
+ [ ] t register-callback forward-to-id\r
+ ] callcc1 restore-request\r
+ ] [\r
+ post-refresh-get? on\r
+ ] if ;\r
+\r
+SYMBOL: current-show\r
+\r
+: store-current-show ( -- )\r
+ #! Store the current continuation in the variable 'current-show'\r
+ #! so it can be returned to later by 'quot-id'. Note that it\r
+ #! recalls itself when the continuation is called to ensure that\r
+ #! it resets its value back to the most recent show call.\r
+ [ current-show set f ] callcc1\r
+ [ restore-request store-current-show ] when* ;\r
+\r
+: show-final ( quot -- * )\r
+ [ redirect-to-here store-current-show ] dip\r
+ call exit-with ; inline\r
+\r
+: resuming-callback ( responder request -- id )\r
+ cont-id query-param swap callbacks>> at ;\r
+\r
+M: callback-responder call-responder* ( path responder -- response )\r
+ '[\r
+ , ,\r
+\r
+ [ callback-responder set ]\r
+ [ request get resuming-callback ] bi\r
+\r
+ [\r
+ invoke-callback\r
+ ] [\r
+ callback-responder get responder>> call-responder\r
+ ] ?if\r
+ ] with-exit-continuation ;\r
+\r
+: show-page ( quot -- )\r
+ [ redirect-to-here store-current-show ] dip\r
+ [\r
+ [ ] t register-callback swap call exit-with\r
+ ] callcc1 restore-request ; inline\r
+\r
+: quot-id ( quot -- id )\r
+ current-show get swap t register-callback ;\r
+\r
+: quot-url ( quot -- url )\r
+ quot-id f swap cont-id associate derive-url ;\r
--- /dev/null
+IN: furnace.db.tests
+USING: tools.test furnace.db ;
+
+\ <db-persistence> must-infer
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: db db.pools io.pools http.server furnace.sessions\r
+kernel accessors continuations namespaces destructors ;\r
+IN: furnace.db\r
+\r
+TUPLE: db-persistence < filter-responder pool ;\r
+\r
+: <db-persistence> ( responder params db -- responder' )\r
+ <db-pool> db-persistence boa ;\r
+\r
+M: db-persistence call-responder*\r
+ [\r
+ pool>> [ acquire-connection ] keep\r
+ [ return-connection-later ] [ drop db set ] 2bi\r
+ ]\r
+ [ call-next-method ] bi ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces sequences arrays kernel
+assocs assocs.lib hashtables math.parser urls combinators
+html.elements http http.server furnace.sessions
+html.templates.chloe.syntax ;
+IN: furnace.flows
+
+TUPLE: flows < filter-responder ;
+
+C: <flows> flows
+
+: begin-flow* ( -- id )
+ request get
+ [ url>> ] [ post-data>> ] [ method>> ] tri 3array
+ flows sget set-at-unique
+ session-changed ;
+
+: end-flow-post ( url post-data -- response )
+ request [
+ clone
+ "POST" >>method
+ swap >>post-data
+ swap >>url
+ ] change
+ request get url>> path>> split-path
+ flows get responder>> call-responder ;
+
+: end-flow* ( url id -- response )
+ flows sget at [
+ first3 {
+ { "GET" [ drop <redirect> ] }
+ { "HEAD" [ drop <redirect> ] }
+ { "POST" [ end-flow-post ] }
+ } case
+ ] [ <redirect> ] ?if ;
+
+SYMBOL: flow-id
+
+: flow-id-key "factorflowid" ;
+
+: begin-flow ( -- )
+ begin-flow* flow-id set ;
+
+: end-flow ( default -- response )
+ flow-id get end-flow* ;
+
+M: flows call-responder*
+ dup flows set
+ flow-id-key request get request-params at flow-id set
+ call-next-method ;
+
+M: flows init-session*
+ H{ } clone flows sset
+ call-next-method ;
+
+M: flows link-attr ( tag -- )
+ drop
+ "flow" optional-attr {
+ { "none" [ flow-id off ] }
+ { "begin" [ begin-flow ] }
+ { "current" [ ] }
+ { f [ ] }
+ } case ;
+
+M: flows modify-query ( query responder -- query' )
+ drop
+ flow-id get [ flow-id-key associate assoc-union ] when* ;
+
+M: flows hidden-form-field ( responder -- )
+ drop
+ flow-id get [
+ <input
+ "hidden" =type
+ flow-id-key =name
+ =value
+ input/>
+ ] when* ;
--- /dev/null
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: furnace
+
+GENERIC: hidden-form-field ( responder -- )
+
+M: object hidden-form-field drop ;
+
+: request-params ( request -- assoc )
+ dup method>> {
+ { "GET" [ url>> query>> ] }
+ { "HEAD" [ url>> query>> ] }
+ { "POST" [ post-data>> ] }
+ } case ;
+
+: <feed-content> ( body -- response )
+ feed>xml "application/atom+xml" <content> ;
+
+: <json-content> ( obj -- response )
+ >json "application/json" <content> ;
+
+SYMBOL: exit-continuation
+
+: exit-with exit-continuation get continue-with ;
+
+: with-exit-continuation ( quot -- )
+ '[ exit-continuation set @ ] callcc1 exit-continuation off ;
+
+! Chloe tags
+: parse-query-attr ( string -- assoc )
+ dup empty?
+ [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
+
+CHLOE: atom
+ [ "title" required-attr ]
+ [ "href" required-attr ]
+ [ "query" optional-attr parse-query-attr ] tri
+ <url>
+ swap >>query
+ swap >>path
+ adjust-url
+ add-atom-feed ;
+
+CHLOE: write-atom drop write-atom-feeds ;
+
+GENERIC: link-attr ( tag responder -- )
+
+M: object link-attr 2drop ;
+
+: link-attrs ( tag -- )
+ '[ , _ link-attr ] each-responder ;
+
+: a-start-tag ( tag -- )
+ [
+ <a
+ dup link-attrs
+ dup "value" optional-attr [ value f ] [
+ [ "href" required-attr ]
+ [ "query" optional-attr parse-query-attr ]
+ bi
+ ] ?if
+ <url>
+ swap >>query
+ swap >>path
+ adjust-url =href
+ a>
+ ] with-scope ;
+
+CHLOE: a
+ [ a-start-tag ]
+ [ process-tag-children ]
+ [ drop </a> ]
+ tri ;
+
+: form-start-tag ( tag -- )
+ [
+ [
+ <form
+ "POST" =method
+ [ link-attrs ]
+ [ "action" required-attr resolve-base-path =action ]
+ [ tag-attrs non-chloe-attrs-only print-attrs ]
+ tri
+ form>
+ ] [
+ [ hidden-form-field ] each-responder
+ "for" optional-attr [ hidden render ] when*
+ ] bi
+ ] with-scope ;
+
+CHLOE: form
+ [ form-start-tag ]
+ [ process-tag-children ]
+ [ drop </form> ]
+ tri ;
+
+DEFER: process-chloe-tag
+
+STRING: button-tag-markup
+<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
+ <button type="submit"></button>
+</t:form>
+;
+
+: add-tag-attrs ( attrs tag -- )
+ tag-attrs swap update ;
+
+CHLOE: button
+ button-tag-markup string>xml delegate
+ {
+ [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
+ [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
+ [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
+ [ nip ]
+ } 2cleave process-chloe-tag ;
+
+: attr>word ( value -- word/f )
+ dup ":" split1 swap lookup
+ [ ] [ "No such word: " swap append throw ] ?if ;
+
+: attr>var ( value -- word/f )
+ attr>word dup symbol? [
+ "Must be a symbol: " swap append throw
+ ] unless ;
+
+: if-satisfied? ( tag -- ? )
+ t swap
+ {
+ [ "code" optional-attr [ attr>word execute and ] when* ]
+ [ "var" optional-attr [ attr>var get and ] when* ]
+ [ "svar" optional-attr [ attr>var sget and ] when* ]
+ [ "uvar" optional-attr [ attr>var uget and ] when* ]
+ [ "value" optional-attr [ value and ] when* ]
+ } cleave ;
+
+CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
--- /dev/null
+Doug Coleman
--- /dev/null
+IN: furnace.sessions.tests\r
+USING: tools.test http furnace.sessions\r
+furnace.actions http.server math namespaces kernel accessors\r
+prettyprint io.streams.string io.files splitting destructors\r
+sequences db db.sqlite continuations urls ;\r
+\r
+: with-session\r
+ [\r
+ [ [ save-session-after ] [ session set ] bi ] dip call\r
+ ] with-destructors ; inline\r
+\r
+TUPLE: foo ;\r
+\r
+C: <foo> foo\r
+\r
+M: foo init-session* drop 0 "x" sset ;\r
+\r
+M: foo call-responder*\r
+ 2drop\r
+ "x" [ 1+ ] schange\r
+ "x" sget number>string "text/html" <content> ;\r
+\r
+: url-responder-mock-test\r
+ [\r
+ <request>\r
+ "GET" >>method\r
+ dup url>>\r
+ "id" get session-id-key set-query-param\r
+ "/" >>path drop\r
+ init-request\r
+ { } sessions get call-responder\r
+ [ write-response-body drop ] with-string-writer\r
+ ] with-destructors ;\r
+\r
+: sessions-mock-test\r
+ [\r
+ <request>\r
+ "GET" >>method\r
+ "cookies" get >>cookies\r
+ dup url>> "/" >>path drop\r
+ init-request\r
+ { } sessions get call-responder\r
+ [ write-response-body drop ] with-string-writer\r
+ ] with-destructors ;\r
+\r
+: <exiting-action>\r
+ <action>\r
+ [ [ ] "text/plain" <content> exit-with ] >>display ;\r
+\r
+[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors\r
+\r
+"auth-test.db" temp-file sqlite-db [\r
+\r
+ <request> init-request\r
+ init-sessions-table\r
+\r
+ [ ] [\r
+ <foo> <sessions>\r
+ sessions set\r
+ ] unit-test\r
+\r
+ [\r
+ [ ] [\r
+ empty-session\r
+ 123 >>id session set\r
+ ] unit-test\r
+\r
+ [ ] [ 3 "x" sset ] unit-test\r
+\r
+ [ 9 ] [ "x" sget sq ] unit-test\r
+\r
+ [ ] [ "x" [ 1- ] schange ] unit-test\r
+\r
+ [ 4 ] [ "x" sget sq ] unit-test\r
+\r
+ [ t ] [ session get changed?>> ] unit-test\r
+ ] with-scope\r
+\r
+ [ t ] [\r
+ begin-session id>>\r
+ get-session session?\r
+ ] unit-test\r
+\r
+ [ { 5 0 } ] [\r
+ [\r
+ begin-session\r
+ dup [ 5 "a" sset ] with-session\r
+ dup [ "a" sget , ] with-session\r
+ dup [ "x" sget , ] with-session\r
+ drop\r
+ ] { } make\r
+ ] unit-test\r
+\r
+ [ 0 ] [\r
+ begin-session id>>\r
+ get-session [ "x" sget ] with-session\r
+ ] unit-test\r
+\r
+ [ { 5 0 } ] [\r
+ [\r
+ begin-session id>>\r
+ dup get-session [ 5 "a" sset ] with-session\r
+ dup get-session [ "a" sget , ] with-session\r
+ dup get-session [ "x" sget , ] with-session\r
+ drop\r
+ ] { } make\r
+ ] unit-test\r
+\r
+ [ ] [\r
+ <foo> <sessions>\r
+ sessions set\r
+ ] unit-test\r
+\r
+ [\r
+ <request>\r
+ "GET" >>method\r
+ dup url>> "/" >>path drop\r
+ request set\r
+ { "etc" } sessions get call-responder response set\r
+ [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test\r
+ response get\r
+ ] with-destructors\r
+ response set\r
+\r
+ [ ] [ response get cookies>> "cookies" set ] unit-test\r
+\r
+ [ "2" ] [ sessions-mock-test ] unit-test\r
+ [ "3" ] [ sessions-mock-test ] unit-test\r
+ [ "4" ] [ sessions-mock-test ] unit-test\r
+\r
+ [\r
+ [ ] [\r
+ <request>\r
+ "GET" >>method\r
+ dup url>>\r
+ "id" get session-id-key set-query-param\r
+ "/" >>path drop\r
+ request set\r
+\r
+ [\r
+ { } <exiting-action> <sessions>\r
+ call-responder\r
+ ] with-destructors response set\r
+ ] unit-test\r
+\r
+ [ "text/plain" ] [ response get content-type>> ] unit-test\r
+\r
+ [ f ] [ response get cookies>> empty? ] unit-test\r
+ ] with-scope\r
+] with-db\r
--- /dev/null
+! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel math.intervals math.parser namespaces
+random accessors quotations hashtables sequences continuations
+fry calendar combinators destructors alarms
+db db.tuples db.types
+http http.server html.elements html.templates.chloe ;
+IN: furnace.sessions
+
+TUPLE: session id expires uid namespace changed? ;
+
+: <session> ( id -- session )
+ session new
+ swap >>id ;
+
+session "SESSIONS"
+{
+ { "id" "ID" +random-id+ system-random-generator }
+ { "expires" "EXPIRES" TIMESTAMP +not-null+ }
+ { "uid" "UID" { VARCHAR 255 } }
+ { "namespace" "NAMESPACE" FACTOR-BLOB }
+} define-persistent
+
+: get-session ( id -- session )
+ dup [ <session> select-tuple ] when ;
+
+: init-sessions-table session ensure-table ;
+
+: start-expiring-sessions ( db seq -- )
+ '[
+ , , [
+ session new
+ -1.0/0.0 now [a,b] >>expires
+ delete-tuples
+ ] with-db
+ ] 5 minutes every drop ;
+
+GENERIC: init-session* ( responder -- )
+
+M: object init-session* drop ;
+
+M: dispatcher init-session* default>> init-session* ;
+
+M: filter-responder init-session* responder>> init-session* ;
+
+TUPLE: sessions < filter-responder timeout domain ;
+
+: <sessions> ( responder -- responder' )
+ sessions new
+ swap >>responder
+ 20 minutes >>timeout ;
+
+: (session-changed) ( session -- )
+ t >>changed? drop ;
+
+: session-changed ( -- )
+ session get (session-changed) ;
+
+: sget ( key -- value )
+ session get namespace>> at ;
+
+: sset ( value key -- )
+ session get
+ [ namespace>> set-at ] [ (session-changed) ] bi ;
+
+: schange ( key quot -- )
+ session get
+ [ 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 ;
+
+: cutoff-time ( -- time )
+ sessions get timeout>> from-now ;
+
+: touch-session ( session -- )
+ cutoff-time >>expires drop ;
+
+: empty-session ( -- session )
+ f <session>
+ H{ } clone >>namespace
+ dup touch-session ;
+
+: begin-session ( -- session )
+ empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
+
+! Destructor
+TUPLE: session-saver session ;
+
+C: <session-saver> session-saver
+
+M: session-saver dispose
+ session>> dup changed?>> [
+ [ touch-session ] [ update-tuple ] bi
+ ] [ drop ] if ;
+
+: save-session-after ( session -- )
+ <session-saver> &dispose drop ;
+
+: existing-session ( path session -- response )
+ [ session set ] [ save-session-after ] bi
+ sessions get responder>> call-responder ;
+
+: session-id-key "factorsessid" ;
+
+: cookie-session-id ( request -- id/f )
+ session-id-key get-cookie
+ dup [ value>> string>number ] when ;
+
+: post-session-id ( request -- id/f )
+ session-id-key swap post-data>> at string>number ;
+
+: request-session-id ( -- id/f )
+ request get dup method>> {
+ { "GET" [ cookie-session-id ] }
+ { "HEAD" [ cookie-session-id ] }
+ { "POST" [ post-session-id ] }
+ } case ;
+
+: request-session ( -- session/f )
+ request-session-id get-session ;
+
+: <session-cookie> ( id -- cookie )
+ session-id-key <cookie>
+ "$sessions" resolve-base-path >>path
+ sessions get timeout>> from-now >>expires
+ sessions get domain>> >>domain ;
+
+: put-session-cookie ( response -- response' )
+ session get id>> number>string <session-cookie> put-cookie ;
+
+M: sessions hidden-form-field ( responder -- )
+ drop
+ <input
+ "hidden" =type
+ session-id-key =name
+ session get id>> number>string =value
+ input/> ;
+
+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 ;
+
+M: sessions link-attr
+ drop
+ "session" optional-attr {
+ { "none" [ session off flow-id off ] }
+ { "current" [ ] }
+ { f [ ] }
+ } case ;
TUPLE: color red green blue ;
-[ ] [ 1 2 3 color boa from-tuple ] unit-test
+[ ] [ 1 2 3 color boa from-object ] unit-test
[ 1 ] [ "red" value ] unit-test
[ ] [ t "delivery" set-value ] unit-test
-[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
+[ "<input type='checkbox' name='delivery' checked='true'>Delivery</input>" ] [
[
"delivery"
<checkbox>
mirrors hashtables combinators continuations math strings
fry locals calendar calendar.format xml.entities validators
html.elements html.streams xmode.code2html farkup inspector
-lcs.diff2html ;
+lcs.diff2html urls ;
IN: html.components
SYMBOL: values
: prepare-value ( name object -- value name object )
[ [ value ] keep ] dip ; inline
-: from-assoc ( assoc -- ) values get swap update ;
-
-: from-tuple ( tuple -- ) <mirror> from-assoc ;
+: from-object ( object -- )
+ dup assoc? [ <mirror> ] unless
+ values get swap update ;
: deposit-values ( destination names -- )
[ dup value ] H{ } map>assoc update ;
: with-each-index ( seq quot -- )
'[
[
- blank-values 1+ "index" set-value @
+ values [ clone ] change
+ 1+ "index" set-value @
] with-scope
] each-index ; inline
: with-each-value ( seq quot -- )
'[ "value" set-value @ ] with-each-index ; inline
-: with-each-assoc ( seq quot -- )
- '[ from-assoc @ ] with-each-index ; inline
-
-: with-each-tuple ( seq quot -- )
- '[ from-tuple @ ] with-each-index ; inline
-
-: with-assoc-values ( assoc quot -- )
- '[ blank-values , from-assoc @ ] with-scope ; inline
+: with-each-object ( seq quot -- )
+ '[ from-object @ ] with-each-index ; inline
-: with-tuple-values ( assoc quot -- )
- '[ blank-values , from-tuple @ ] with-scope ; inline
+: with-values ( object quot -- )
+ '[ blank-values , from-object @ ] with-scope ; inline
: nest-values ( name quot -- )
swap [
] with-scope
] dip set-value ; inline
-: nest-tuple ( name quot -- )
- swap [
- [
- H{ } clone [ <mirror> values set call ] keep
- ] with-scope
- ] dip set-value ; inline
-
-: object>string ( object -- string )
- {
- { [ dup real? ] [ number>string ] }
- { [ dup timestamp? ] [ timestamp>string ] }
- { [ dup string? ] [ ] }
- { [ dup word? ] [ word-name ] }
- { [ dup not ] [ drop "" ] }
- } cond ;
-
GENERIC: render* ( value name render -- )
: render ( name renderer -- )
<input
"checkbox" =type
swap =name
- swap [ "true" =selected ] when
+ swap [ "true" =checked ] when
input>
label>> escape-string write
</input> ;
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
-sequences strings words xml.entities compiler.units effects ;
+sequences strings words xml.entities compiler.units effects
+urls math math.parser combinators calendar calendar.format ;
IN: html.elements
dup def-for-html-word-<foo
def-for-html-word-foo/> ;
+: object>string ( object -- string )
+ #! Should this be generic and in the core?
+ {
+ { [ dup real? ] [ number>string ] }
+ { [ dup timestamp? ] [ timestamp>string ] }
+ { [ dup url? ] [ url>string ] }
+ { [ dup string? ] [ ] }
+ { [ dup word? ] [ word-name ] }
+ { [ dup not ] [ drop "" ] }
+ } cond ;
+
: write-attr ( value name -- )
" " write-html
write-html
"='" write-html
- escape-quoted-string write-html
+ object>string escape-quoted-string write-html
"'" write-html ;
: attribute-effect T{ effect f { "string" } 0 } ;
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
- "media" "title" "multiple"
+ "media" "title" "multiple" "checked"
] [ define-attribute-word ] each
>>
: test-template ( name -- template )
"resource:extra/html/templates/chloe/test/"
- swap
- ".xml" 3append <chloe> ;
+ prepend <chloe> ;
[ "Hello world" ] [
[
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
[
- "test11" test-template call-template
+ "test10" test-template call-template
] run-template [ blank? not ] filter
] unit-test
+
+[ ] [ 1 "id" set-value ] unit-test
+
+[ "<a name=\"1\">Hello</a>" ] [
+ [
+ "test11" test-template call-template
+ ] run-template
+] unit-test
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
-unicode.case tuple-syntax mirrors fry math
+unicode.case tuple-syntax mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components
html.templates
-http.server
-http.server.auth
-http.server.flows
-http.server.actions
-http.server.sessions ;
+html.templates.chloe.syntax ;
IN: html.templates.chloe
! Chloe is Ed's favorite web designer
DEFER: process-template
-: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-
: chloe-attrs-only ( assoc -- assoc' )
[ drop name-url chloe-ns = ] assoc-filter ;
[ t ]
} cond nip ;
-SYMBOL: tags
-
-MEMO: chloe-name ( string -- name )
- name new
- swap >>tag
- chloe-ns >>url ;
-
-: required-attr ( tag name -- value )
- dup chloe-name rot at*
- [ nip ] [ drop " attribute is required" append throw ] if ;
-
-: optional-attr ( tag name -- value )
- chloe-name swap at ;
-
: process-tag-children ( tag -- )
[ process-template ] each ;
+CHLOE: chloe process-tag-children ;
+
: children>string ( tag -- string )
[ process-tag-children ] with-string-writer ;
-: title-tag ( tag -- )
- children>string set-title ;
+CHLOE: title children>string set-title ;
-: write-title-tag ( tag -- )
+CHLOE: write-title
drop
"head" tags get member? "title" tags get member? not and
[ <title> write-title </title> ] [ write-title ] if ;
-: style-tag ( tag -- )
+CHLOE: style
dup "include" optional-attr dup [
swap children>string empty? [
"style tag cannot have both an include attribute and a body" throw
drop children>string
] if add-style ;
-: write-style-tag ( tag -- )
+CHLOE: write-style
drop <style> write-style </style> ;
-: atom-tag ( tag -- )
- [ "title" required-attr ]
- [ "href" required-attr ]
- bi set-atom-feed ;
-
-: write-atom-tag ( tag -- )
- drop
- "head" tags get member? [
- write-atom-feed
- ] [
- atom-feed get value>> second write
- ] if ;
-
-: parse-query-attr ( string -- assoc )
- dup empty?
- [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
-
-: flow-attr ( tag -- )
- "flow" optional-attr {
- { "none" [ flow-id off ] }
- { "begin" [ begin-flow ] }
- { "current" [ ] }
- { f [ ] }
- } case ;
-
-: session-attr ( tag -- )
- "session" optional-attr {
- { "none" [ session off flow-id off ] }
- { "current" [ ] }
- { f [ ] }
- } case ;
-
-: a-start-tag ( tag -- )
- [
- <a
- dup flow-attr
- dup session-attr
- dup "value" optional-attr [ value f ] [
- [ "href" required-attr ]
- [ "query" optional-attr parse-query-attr ]
- bi
- ] ?if link>string =href
- a>
- ] with-scope ;
-
-: a-tag ( tag -- )
- [ a-start-tag ]
- [ process-tag-children ]
- [ drop </a> ]
- tri ;
-
-: form-start-tag ( tag -- )
- [
- [
- <form
- "POST" =method
- {
- [ flow-attr ]
- [ session-attr ]
- [ "action" required-attr resolve-base-path =action ]
- [ tag-attrs non-chloe-attrs-only print-attrs ]
- } cleave
- form>
- ] [
- hidden-form-field
- "for" optional-attr [ hidden render ] when*
- ] bi
- ] with-scope ;
-
-: form-tag ( tag -- )
- [ form-start-tag ]
- [ process-tag-children ]
- [ drop </form> ]
- tri ;
+CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ;
-DEFER: process-chloe-tag
-
-STRING: button-tag-markup
-<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
- <button type="submit"></button>
-</t:form>
-;
-
-: add-tag-attrs ( attrs tag -- )
- tag-attrs swap update ;
-
-: button-tag ( tag -- )
- button-tag-markup string>xml delegate
- {
- [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
- [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
- [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
- [ nip ]
- } 2cleave process-chloe-tag ;
-
-: attr>word ( value -- word/f )
- dup ":" split1 swap lookup
- [ ] [ "No such word: " swap append throw ] ?if ;
-
-: attr>var ( value -- word/f )
- attr>word dup symbol? [
- "Must be a symbol: " swap append throw
- ] unless ;
-
-: if-satisfied? ( tag -- ? )
- t swap
- {
- [ "code" optional-attr [ attr>word execute and ] when* ]
- [ "var" optional-attr [ attr>var get and ] when* ]
- [ "svar" optional-attr [ attr>var sget and ] when* ]
- [ "uvar" optional-attr [ attr>var uget and ] when* ]
- [ "value" optional-attr [ value and ] when* ]
- } cleave ;
-
-: if-tag ( tag -- )
- dup if-satisfied? [ process-tag-children ] [ drop ] if ;
-
-: even-tag ( tag -- )
- "index" value even? [ process-tag-children ] [ drop ] if ;
-
-: odd-tag ( tag -- )
- "index" value odd? [ process-tag-children ] [ drop ] if ;
-
-: (each-tag) ( tag quot -- )
- [
- [ "values" required-attr value ] keep
- '[ , process-tag-children ]
- ] dip call ; inline
-
-: each-tag ( tag -- )
- [ with-each-value ] (each-tag) ;
-
-: each-tuple-tag ( tag -- )
- [ with-each-tuple ] (each-tag) ;
-
-: each-assoc-tag ( tag -- )
- [ with-each-assoc ] (each-tag) ;
+CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
: (bind-tag) ( tag quot -- )
[
'[ , process-tag-children ]
] dip call ; inline
-: bind-tuple-tag ( tag -- )
- [ with-tuple-values ] (bind-tag) ;
+CHLOE: each [ with-each-value ] (bind-tag) ;
-: bind-assoc-tag ( tag -- )
- [ with-assoc-values ] (bind-tag) ;
+CHLOE: bind-each [ with-each-object ] (bind-tag) ;
+
+CHLOE: bind [ with-values ] (bind-tag) ;
: error-message-tag ( tag -- )
children>string render-error ;
-: validation-messages-tag ( tag -- )
- drop render-validation-messages ;
+CHLOE: comment drop ;
-: singleton-component-tag ( tag class -- )
- [ "name" required-attr ] dip render ;
+CHLOE: call-next-template drop call-next-template ;
-: attrs>slots ( tag tuple -- )
- [ attrs>> ] [ <mirror> ] bi*
- '[
- swap tag>> dup "name" =
- [ 2drop ] [ , set-at ] if
- ] assoc-each ;
+CHLOE-SINGLETON: label
+CHLOE-SINGLETON: link
+CHLOE-SINGLETON: farkup
+CHLOE-SINGLETON: inspector
+CHLOE-SINGLETON: comparison
+CHLOE-SINGLETON: html
+CHLOE-SINGLETON: hidden
-: tuple-component-tag ( tag class -- )
- [ drop "name" required-attr ]
- [ new [ attrs>slots ] keep ]
- 2bi render ;
+CHLOE-TUPLE: field
+CHLOE-TUPLE: password
+CHLOE-TUPLE: choice
+CHLOE-TUPLE: checkbox
+CHLOE-TUPLE: code
: process-chloe-tag ( tag -- )
- dup name-tag {
- { "chloe" [ process-tag-children ] }
-
- ! HTML head
- { "title" [ title-tag ] }
- { "write-title" [ write-title-tag ] }
- { "style" [ style-tag ] }
- { "write-style" [ write-style-tag ] }
- { "atom" [ atom-tag ] }
- { "write-atom" [ write-atom-tag ] }
-
- ! HTML elements
- { "a" [ a-tag ] }
- { "button" [ button-tag ] }
-
- ! Components
- { "label" [ label singleton-component-tag ] }
- { "link" [ link singleton-component-tag ] }
- { "code" [ code tuple-component-tag ] }
- { "farkup" [ farkup singleton-component-tag ] }
- { "inspector" [ inspector singleton-component-tag ] }
- { "comparison" [ comparison singleton-component-tag ] }
- { "html" [ html singleton-component-tag ] }
-
- ! Forms
- { "form" [ form-tag ] }
- { "error-message" [ error-message-tag ] }
- { "validation-messages" [ validation-messages-tag ] }
- { "hidden" [ hidden singleton-component-tag ] }
- { "field" [ field tuple-component-tag ] }
- { "password" [ password tuple-component-tag ] }
- { "textarea" [ textarea tuple-component-tag ] }
- { "choice" [ choice tuple-component-tag ] }
- { "checkbox" [ checkbox tuple-component-tag ] }
-
- ! Control flow
- { "if" [ if-tag ] }
- { "even" [ even-tag ] }
- { "odd" [ odd-tag ] }
- { "each" [ each-tag ] }
- { "each-assoc" [ each-assoc-tag ] }
- { "each-tuple" [ each-tuple-tag ] }
- { "bind-assoc" [ bind-assoc-tag ] }
- { "bind-tuple" [ bind-tuple-tag ] }
- { "comment" [ drop ] }
- { "call-next-template" [ drop call-next-template ] }
-
- [ "Unknown chloe tag: " prepend throw ]
- } case ;
+ dup name-tag tags get at
+ [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
: process-tag ( tag -- )
{
[ drop tags get pop* ]
} cleave ;
+: expand-attrs ( tag -- tag )
+ dup [ tag? ] is? [
+ clone [
+ [ "@" ?head [ value object>string ] when ] assoc-map
+ ] change-attrs
+ ] when ;
+
: process-template ( xml -- )
+ expand-attrs
{
{ [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
{ [ dup [ tag? ] is? ] [ process-tag ] }
] with-scope ;
M: chloe call-template*
- path>> utf8 <file-reader> read-xml process-chloe ;
+ path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
INSTANCE: chloe template
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: html.templates.chloe.syntax
+USING: accessors kernel sequences combinators kernel namespaces
+classes.tuple assocs splitting words arrays memoize parser
+io io.files io.encodings.utf8 io.streams.string
+unicode.case tuple-syntax mirrors fry math urls
+multiline xml xml.data xml.writer xml.utilities
+html.elements
+html.components
+html.templates ;
+
+SYMBOL: tags
+
+tags global [ H{ } clone or ] change-at
+
+: define-chloe-tag ( name quot -- ) tags get set-at ;
+
+: CHLOE:
+ scan parse-definition swap define-chloe-tag ;
+ parsing
+
+: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
+
+MEMO: chloe-name ( string -- name )
+ name new
+ swap >>tag
+ chloe-ns >>url ;
+
+: required-attr ( tag name -- value )
+ dup chloe-name rot at*
+ [ nip ] [ drop " attribute is required" append throw ] if ;
+
+: optional-attr ( tag name -- value )
+ chloe-name swap at ;
+
+: singleton-component-tag ( tag class -- )
+ [ "name" required-attr ] dip render ;
+
+: CHLOE-SINGLETON:
+ scan dup '[ , singleton-component-tag ] define-chloe-tag ;
+ parsing
+
+: attrs>slots ( tag tuple -- )
+ [ attrs>> ] [ <mirror> ] bi*
+ '[
+ swap tag>> dup "name" =
+ [ 2drop ] [ , set-at ] if
+ ] assoc-each ;
+
+: tuple-component-tag ( tag class -- )
+ [ drop "name" required-attr ]
+ [ new [ attrs>slots ] keep ]
+ 2bi render ;
+
+: CHLOE-TUPLE:
+ scan dup '[ , tuple-component-tag ] define-chloe-tag ;
+ parsing
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<table>
- <t:each-tuple t:values="people">
+ <t:bind-each t:name="people">
<tr>
<td><t:label t:name="first-name"/></td>
<td><t:label t:name="last-name"/></td>
</tr>
- </t:each-tuple>
+ </t:bind-each>
</table>
</t:chloe>
<?xml version='1.0' ?>
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <table>
- <t:each-assoc t:values="people">
- <tr>
- <td><t:label t:name="first-name"/></td>
- <td><t:label t:name="last-name"/></td>
- </tr>
- </t:each-assoc>
- </table>
-
-</t:chloe>
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><a name="@id">Hello</a></t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<ul>
- <t:each t:values="numbers">
+ <t:each t:name="numbers">
<li><t:label t:name="value"/></li>
</t:each>
</ul>
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
-arrays strings html.elements io.streams.string quotations ;
+arrays strings html.elements io.streams.string
+quotations xml.data xml.writer ;
IN: html.templates
MIXIN: template
M: callable call-template* call ;
+M: xml call-template* write-xml ;
+
M: object call-template* output-stream get stream-copy ;
ERROR: template-error template error ;
: write-style ( -- )
style get >string write ;
-SYMBOL: atom-feed
+SYMBOL: atom-feeds
-: set-atom-feed ( title url -- )
- 2array atom-feed get >box ;
+: add-atom-feed ( title url -- )
+ 2array atom-feeds get push ;
-: write-atom-feed ( -- )
- atom-feed get value>> [
+: write-atom-feeds ( -- )
+ atom-feeds get [
<link "alternate" =rel "application/atom+xml" =type
- [ first =title ] [ second =href ] bi
+ first2 [ =title ] [ =href ] bi*
link/>
- ] when* ;
+ ] each ;
SYMBOL: nested-template?
: with-boilerplate ( body template -- )
[
- title get [ <box> title set ] unless
- atom-feed get [ <box> atom-feed set ] unless
- style get [ SBUF" " clone style set ] unless
+ title [ <box> or ] change
+ style [ SBUF" " clone or ] change
+ atom-feeds [ V{ } like ] change
[
[
USING: http.client http.client.private http tools.test
-tuple-syntax namespaces ;
+tuple-syntax namespaces urls ;
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
[
TUPLE{ request
- protocol: http
+ url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" query: H{ } }
method: "GET"
- host: "www.apple.com"
- port: 80
- path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
[
TUPLE{ request
- protocol: https
+ url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" query: H{ } }
method: "GET"
- host: "www.amazon.com"
- port: 443
- path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
redirects inc
redirects get max-redirects < [
request get
- swap "location" header dup absolute-url?
- [ request-with-url ] [ request-with-path ] if
+ swap "location" header request-with-url
"GET" >>method http-request
] [
too-many-redirects
: http-request ( request -- response data )
dup request [
- dup request-addr latin1 [
+ dup url>> url-addr latin1 [
1 minutes timeouts
write-request
read-response
USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences
-assocs io.sockets db db.sqlite continuations ;
+assocs io.sockets db db.sqlite continuations urls ;
IN: http.tests
-[ "hello%20world" ] [ "hello world" url-encode ] unit-test
-[ "hello world" ] [ "hello%20world" url-decode ] unit-test
-[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
-[ f ] [ "%XX%XX%XX" url-decode ] unit-test
-[ f ] [ "%XX%XX%X" url-decode ] unit-test
-
-[ "hello world" ] [ "hello+world" url-decode ] unit-test
-[ "hello world" ] [ "hello%20world" url-decode ] unit-test
-[ " ! " ] [ "%20%21%20" url-decode ] unit-test
-[ "hello world" ] [ "hello world%" url-decode ] unit-test
-[ "hello world" ] [ "hello world%x" url-decode ] unit-test
-[ "hello%20world" ] [ "hello world" url-encode ] unit-test
-[ "%20%21%20" ] [ " ! " url-encode ] unit-test
-
-[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
-
[ "/" ] [ "http://foo.com" url>path ] unit-test
[ "/" ] [ "http://foo.com/" url>path ] unit-test
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test
-[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
-
-[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
-
-[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
-
-[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
-
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
[
TUPLE{ request
- protocol: http
- port: 80
+ url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
method: "GET"
- path: "/bar"
- query: H{ }
version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
post-data: "blah"
[
TUPLE{ request
- protocol: http
- port: 80
+ url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
method: "HEAD"
- path: "/bar"
- query: H{ }
version: "1.1"
header: H{ { "host" "www.sex.com" } }
- host: "www.sex.com"
cookies: V{ }
}
] [
] with-string-reader
] unit-test
+STRING: read-request-test-3
+GET nested HTTP/1.0
+
+;
+
+[ read-request-test-3 [ read-request ] with-string-reader ]
+[ "Bad request: URL" = ]
+must-fail-with
+
STRING: read-response-test-1
HTTP/1.1 404 not found
Content-Type: text/html; charset=UTF8
] unit-test
! Live-fire exercise
-USING: http.server http.server.static http.server.sessions
-http.server.actions http.server.auth.login http.server.db http.client
+USING: http.server http.server.static furnace.sessions
+furnace.actions furnace.auth.login furnace.db http.client
io.server io.files io io.encodings.ascii
accessors namespaces threads ;
: add-quit-action
<action>
- [ stop-server [ "Goodbye" write ] <html-content> ] >>display
+ [ stop-server "Goodbye" "text/html" <content> ] >>display
"quit" add-responder ;
: test-db "test.db" temp-file sqlite-db ;
"resource:extra/http/test" <static> >>default
"nested" add-responder
<action>
- [ "redirect-loop" f <standard-redirect> ] >>display
+ [ URL" redirect-loop" <redirect> ] >>display
"redirect-loop" add-responder
main-responder set
"http://localhost:1237/nested/foo.html" http-get =
] unit-test
-! Try with a slightly malformed request
-[ t ] [
- "localhost" 1237 <inet> ascii [
- "GET nested HTTP/1.0\r\n" write flush
- "\r\n" write flush
- read-crlf drop
- read-header
- ] with-client "location" swap at "/" head?
-] unit-test
-
[ "http://localhost:1237/redirect-loop" http-get ]
[ too-many-redirects? ] must-fail-with
[ ] [
[
<dispatcher>
- <action> [ [ "Hi" write ] <text-content> ] >>display
+ <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
<login>
<sessions>
"" add-responder
math.parser calendar calendar.format
io io.streams.string io.encodings.utf8 io.encodings.string
-io.sockets io.sockets.secure
+io.sockets io.sockets.secure io.server
unicode.case unicode.categories qualified
-html.templates ;
+urls html.templates ;
EXCLUDE: fry => , ;
IN: http
-SINGLETON: http
+: secure-protocol? ( protocol -- ? )
+ "https" = ;
-SINGLETON: https
+: url-addr ( url -- addr )
+ [ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
+ secure-protocol? [ <secure> ] when ;
-GENERIC: http-port ( protocol -- port )
-
-M: http http-port drop 80 ;
-
-M: https http-port drop 443 ;
-
-GENERIC: protocol>string ( protocol -- string )
-
-M: http protocol>string drop "http" ;
-
-M: https protocol>string drop "https" ;
-
-: string>protocol ( string -- protocol )
+: protocol-port ( protocol -- port )
{
- { "http" [ http ] }
- { "https" [ https ] }
- [ "Unknown protocol: " swap append throw ]
+ { "http" [ 80 ] }
+ { "https" [ 443 ] }
} case ;
-: absolute-url? ( url -- ? )
- [ "http://" head? ] [ "https://" head? ] bi or ;
-
-: url-quotable? ( ch -- ? )
- #! In a URL, can this character be used without
- #! URL-encoding?
- {
- { [ dup letter? ] [ t ] }
- { [ dup LETTER? ] [ t ] }
- { [ dup digit? ] [ t ] }
- { [ dup "/_-.:" member? ] [ t ] }
- [ f ]
- } cond nip ; foldable
-
-: push-utf8 ( ch -- )
- 1string utf8 encode
- [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
-
-: url-encode ( str -- str )
- [
- [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
- ] "" make ;
-
-: url-decode-hex ( index str -- )
- 2dup length 2 - >= [
- 2drop
- ] [
- [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
- ] if ;
-
-: url-decode-% ( index str -- index str )
- 2dup url-decode-hex [ 3 + ] dip ;
-
-: url-decode-+-or-other ( index str ch -- index str )
- dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
-
-: url-decode-iter ( index str -- )
- 2dup length >= [
- 2drop
- ] [
- 2dup nth dup CHAR: % = [
- drop url-decode-%
- ] [
- url-decode-+-or-other
- ] if url-decode-iter
- ] if ;
-
-: url-decode ( str -- str )
- [ 0 swap url-decode-iter ] "" make utf8 decode ;
+: ensure-port ( url -- url' )
+ dup protocol>> '[ , protocol-port or ] change-port ;
: crlf "\r\n" write ;
{
{ [ dup number? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>http-string ] }
+ { [ dup url? ] [ url>string ] }
{ [ dup string? ] [ ] }
{ [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
} cond ;
header-value>string check-header-string write crlf
] assoc-each crlf ;
-: add-query-param ( value key assoc -- )
- [
- at [
- {
- { [ dup string? ] [ swap 2array ] }
- { [ dup array? ] [ swap suffix ] }
- { [ dup not ] [ drop ] }
- } cond
- ] when*
- ] 2keep set-at ;
-
-: query>assoc ( query -- assoc )
- dup [
- "&" split H{ } clone [
- [
- [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
- add-query-param
- ] curry each
- ] keep
- ] when ;
-
-: assoc>query ( hash -- str )
- [
- {
- { [ dup number? ] [ number>string 1array ] }
- { [ dup string? ] [ 1array ] }
- { [ dup sequence? ] [ ] }
- } cond
- ] assoc-map
- [
- [
- [ url-encode ] dip
- [ url-encode "=" swap 3append , ] with each
- ] assoc-each
- ] { } make "&" join ;
-
TUPLE: cookie name value path domain expires max-age http-only ;
: <cookie> ( value name -- cookie )
[ unparse-cookie ] map concat "; " join ;
TUPLE: request
-protocol
-host
-port
method
-path
-query
+url
version
header
post-data
: <request>
request new
"1.1" >>version
- http >>protocol
+ <url>
+ "http" >>protocol
+ H{ } clone >>query
+ >>url
H{ } clone >>header
- H{ } clone >>query
V{ } clone >>cookies
"close" "connection" set-header
"Factor http.client vocabulary" "user-agent" set-header ;
-: query-param ( request key -- value )
- swap query>> at ;
-
-: set-query-param ( request value key -- request )
- pick query>> set-at ;
-
: chop-hostname ( str -- str' )
":" split1 "//" ?head drop nip
CHAR: / over index over length or tail
" " read-until [ "Bad request: method" throw ] unless
>>method ;
-: read-query ( request -- request )
- " " read-until
- [ "Bad request: query params" throw ] unless
- query>assoc >>query ;
+: check-absolute ( url -- url )
+ dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
: read-url ( request -- request )
- " ?" read-until {
- { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] }
- { CHAR: ? [ url>path >>path read-query ] }
- [ "Bad request: URL" throw ]
- } case ;
+ " " read-until [
+ dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
+ ] [ "Bad request: URL" throw ] if ;
: parse-version ( string -- version )
- "HTTP/" ?head [ "Bad version" throw ] unless
- dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
+ "HTTP/" ?head [ "Bad request: version" throw ] unless
+ dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
: read-request-version ( request -- request )
read-crlf [ CHAR: \s = ] left-trim
: read-post-data ( request -- request )
dup header>> content-length [ read >>post-data ] when* ;
-: parse-host ( string -- host port )
- "." ?tail drop ":" split1
- dup [ string>number ] when ;
-
: extract-host ( request -- request )
- dup [ "host" header parse-host ] keep protocol>> http-port or
- [ >>host ] [ >>port ] bi* ;
+ [ ] [ url>> ] [ "host" header parse-host ] tri
+ [ >>host ] [ >>port ] bi*
+ ensure-port
+ drop ;
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
+: detect-protocol ( request -- request )
+ dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
+
: read-request ( -- request )
<request>
read-method
read-request-version
read-request-header
read-post-data
+ detect-protocol
extract-host
extract-post-data-type
parse-post-data
: write-method ( request -- request )
dup method>> write bl ;
-: (link>string) ( url query -- url' )
- [ url-encode ] [ assoc>query ] bi*
- dup empty? [ drop ] [ "?" swap 3append ] if ;
-
-: write-url ( request -- )
- [ path>> ] [ query>> ] bi (link>string) write ;
-
: write-request-url ( request -- request )
- dup write-url bl ;
+ dup url>> relative-url url>string write bl ;
: write-version ( request -- request )
"HTTP/" write dup request-version write crlf ;
"application/x-www-form-urlencoded" >>post-data-type
] if ;
-GENERIC: protocol-addr ( request protocol -- addr )
-
-M: object protocol-addr
- drop [ host>> ] [ port>> ] bi <inet> ;
-
-M: https protocol-addr
- call-next-method <secure> ;
-
-: request-addr ( request -- addr )
- dup protocol>> protocol-addr ;
-
-: request-host ( request -- string )
- [ host>> ] [ port>> ] bi dup http http-port =
+: url-host ( url -- string )
+ [ host>> ] [ port>> ] bi dup "http" protocol-port =
[ drop ] [ ":" swap number>string 3append ] if ;
: write-request-header ( request -- request )
dup header>> >hashtable
- over host>> [ over request-host "host" pick set-at ] when
+ over url>> host>> [ over url>> url-host "host" pick set-at ] when
over post-data>> [ length "content-length" pick set-at ] when*
over post-data-type>> [ "content-type" pick set-at ] when*
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
flush
drop ;
-: request-with-path ( request path -- request )
- [ "/" prepend ] [ "/" ] if*
- "?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ;
-
: request-with-url ( request url -- request )
- ":" split1
- [ string>protocol >>protocol ]
- [
- "//" ?head [ "Invalid URL" throw ] unless
- "/" split1
- [
- parse-host [ >>host ] [ >>port ] bi*
- dup protocol>> http-port '[ , or ] change-port
- ]
- [ request-with-path ]
- bi*
- ] bi* ;
-
-: request-url ( request -- url )
- [
- [
- dup host>> [
- [ protocol>> protocol>string write "://" write ]
- [ host>> url-encode write ":" write ]
- [ [ port>> ] [ protocol>> http-port or ] bi number>string write ]
- tri
- ] [ drop ] if
- ]
- [ path>> "/" head? [ "/" write ] unless ]
- [ write-url ]
- tri
- ] with-string-writer ;
+ '[ , >url derive-url ensure-port ] change-url ;
GENERIC: write-response ( response -- )
+++ /dev/null
-USING: kernel http.server.actions validators
-tools.test math math.parser multiline namespaces http
-io.streams.string http.server sequences splitting accessors ;
-IN: http.server.actions.tests
-
-<action>
- [ "a" param "b" param [ string>number ] bi@ + ] >>display
-"action-1" set
-
-: lf>crlf "\n" split "\r\n" join ;
-
-STRING: action-request-test-1
-GET http://foo/bar?a=12&b=13 HTTP/1.1
-
-blah
-;
-
-[ 25 ] [
- init-request
- action-request-test-1 lf>crlf
- [ read-request ] with-string-reader
- request set
- { } "action-1" get call-responder
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors sequences kernel assocs combinators http.server\r
-validators http hashtables namespaces fry continuations locals\r
-boxes xml.entities html.elements html.components io arrays math ;\r
-IN: http.server.actions\r
-\r
-SYMBOL: params\r
-\r
-SYMBOL: rest-param\r
-\r
-: render-validation-messages ( -- )\r
- validation-messages get\r
- dup empty? [ drop ] [\r
- <ul "errors" =class ul>\r
- [ <li> message>> escape-string write </li> ] each\r
- </ul>\r
- ] if ;\r
-\r
-TUPLE: action rest-param init display validate submit ;\r
-\r
-: new-action ( class -- action )\r
- new\r
- [ ] >>init\r
- [ <400> ] >>display\r
- [ ] >>validate\r
- [ <400> ] >>submit ;\r
-\r
-: <action> ( -- action )\r
- action new-action ;\r
-\r
-: handle-get ( action -- response )\r
- blank-values\r
- [ init>> call ]\r
- [ display>> call ]\r
- bi ;\r
-\r
-: validation-failed ( -- * )\r
- request get method>> "POST" =\r
- [ action get display>> call ] [ <400> ] if exit-with ;\r
-\r
-: handle-post ( action -- response )\r
- init-validation\r
- blank-values\r
- [ validate>> call ]\r
- [ submit>> call ] bi ;\r
-\r
-: handle-rest-param ( arg -- )\r
- dup length 1 > action get rest-param>> not or\r
- [ <404> exit-with ] [\r
- action get rest-param>> associate rest-param set\r
- ] if ;\r
-\r
-M: action call-responder* ( path action -- response )\r
- dup action set\r
- '[\r
- , dup empty? [ drop ] [ handle-rest-param ] if\r
-\r
- init-validation\r
- ,\r
- request get\r
- [ request-params rest-param get assoc-union params set ]\r
- [ method>> ] bi\r
- {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case\r
- ] with-exit-continuation ;\r
-\r
-: param ( name -- value )\r
- params get at ;\r
-\r
-: check-validation ( -- )\r
- validation-failed? [ validation-failed ] when ;\r
-\r
-: validate-params ( validators -- )\r
- params get swap validate-values from-assoc\r
- check-validation ;\r
-\r
-: validate-integer-id ( -- )\r
- { { "id" [ v-number ] } } validate-params ;\r
-\r
-TUPLE: page-action < action template ;\r
-\r
-: <page-action> ( -- page )\r
- page-action new-action\r
- dup '[ , template>> <html-content> ] >>display ;\r
-\r
-TUPLE: feed-action < action feed ;\r
-\r
-: <feed-action> ( -- feed )\r
- feed-action new\r
- dup '[ , feed>> call <feed-content> ] >>display ;\r
+++ /dev/null
-! Copyright (c) 2008 Slava Pestov\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs namespaces kernel sequences sets\r
-http.server\r
-http.server.sessions\r
-http.server.auth.providers ;\r
-IN: http.server.auth\r
-\r
-SYMBOL: logged-in-user\r
-\r
-GENERIC: init-user-profile ( responder -- )\r
-\r
-M: object init-user-profile drop ;\r
-\r
-M: dispatcher init-user-profile\r
- default>> init-user-profile ;\r
-\r
-M: filter-responder init-user-profile\r
- responder>> init-user-profile ;\r
-\r
-: profile ( -- assoc ) logged-in-user get profile>> ;\r
-\r
-: user-changed ( -- )\r
- logged-in-user get t >>changed? drop ;\r
-\r
-: uget ( key -- value )\r
- profile at ;\r
-\r
-: uset ( value key -- )\r
- profile set-at\r
- user-changed ;\r
-\r
-: uchange ( quot key -- )\r
- profile swap change-at\r
- user-changed ; inline\r
-\r
-SYMBOL: capabilities\r
-\r
-V{ } clone capabilities set-global\r
-\r
-: define-capability ( word -- ) capabilities get adjoin ;\r
+++ /dev/null
-! 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 http.server\r
-http.server.auth.providers http.server.auth.login\r
-http sequences ;\r
-IN: http.server.auth.basic\r
-\r
-TUPLE: basic-auth < filter-responder realm provider ;\r
-\r
-C: <basic-auth> basic-auth\r
-\r
-: authorization-ok? ( provider header -- ? )\r
- #! Given the realm and the 'Authorization' header,\r
- #! authenticate the user.\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
-\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
-\r
-: logged-in? ( request responder -- ? )\r
- provider>> swap "authorization" header authorization-ok? ;\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
+++ /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>
+++ /dev/null
-IN: http.server.auth.login.tests\r
-USING: tools.test http.server.auth.login ;\r
-\r
-\ <login> must-infer\r
-\ allow-registration must-infer\r
-\ allow-password-recovery must-infer\r
+++ /dev/null
-! 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\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
-html.components\r
-html.elements\r
-html.templates\r
-html.templates.chloe\r
-http\r
-http.server\r
-http.server.auth\r
-http.server.auth.providers\r
-http.server.auth.providers.db\r
-http.server.actions\r
-http.server.flows\r
-http.server.sessions\r
-http.server.boilerplate ;\r
-QUALIFIED: smtp\r
-IN: http.server.auth.login\r
-\r
-TUPLE: login < dispatcher users checksum ;\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
-\r
-: check-login ( password username -- user/f )\r
- users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\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-template ( name -- template )\r
- "resource:extra/http/server/auth/login/" swap ".xml"\r
- 3append <chloe> ;\r
-\r
-! ! ! Login\r
-: successful-login ( user -- response )\r
- username>> set-uid "$login" end-flow ;\r
-\r
-: login-failed ( -- * )\r
- "invalid username or password" validation-error\r
- validation-failed ;\r
-\r
-: <login-action> ( -- action )\r
- <action>\r
- [ "login" login-template <html-content> ] >>display\r
-\r
- [\r
- {\r
- { "username" [ v-required ] }\r
- { "password" [ v-required ] }\r
- } validate-params\r
-\r
- "password" value\r
- "username" value check-login\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
- "register" login-template >>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
- <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
- [ "edit-profile" login-template <html-content> ] >>display\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
- "$login" end-flow\r
- ] >>submit ;\r
-\r
-! ! ! Password recovery\r
-\r
-SYMBOL: lost-password-from\r
-\r
-: current-host ( -- string )\r
- request get host>> host-name or ;\r
-\r
-: new-password-url ( user -- url )\r
- "new-password"\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
- <action>\r
- [ "recover-1" login-template <html-content> ] >>display\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
- "recover-2" login-template <html-content>\r
- ] >>submit ;\r
-\r
-: <recover-action-3> ( -- action )\r
- <action>\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "ticket" [ v-required ] }\r
- } validate-params\r
- ] >>init\r
-\r
- [ "recover-3" login-template <html-content> ] >>display\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
- "recover-4" login-template <html-content>\r
- ] [\r
- <400>\r
- ] if*\r
- ] >>submit ;\r
-\r
-! ! ! Logout\r
-: <logout-action> ( -- action )\r
- <action>\r
- [\r
- f set-uid\r
- "$login/login" end-flow\r
- ] >>submit ;\r
-\r
-! ! ! Authentication logic\r
-\r
-TUPLE: protected < filter-responder capabilities ;\r
-\r
-C: <protected> protected\r
-\r
-: show-login-page ( -- response )\r
- begin-flow\r
- "$login/login" f <standard-redirect> ;\r
-\r
-: check-capabilities ( responder user -- ? )\r
- [ capabilities>> ] bi@ subset? ;\r
-\r
-M: protected call-responder* ( path responder -- response )\r
- uid dup [\r
- users get-user 2dup check-capabilities [\r
- [ logged-in-user set ] [ save-user-after ] bi\r
- call-next-method\r
- ] [\r
- 3drop show-login-page\r
- ] if\r
- ] [\r
- 3drop show-login-page\r
- ] if ;\r
-\r
-M: login call-responder* ( path responder -- response )\r
- dup login set\r
- call-next-method ;\r
-\r
-: <login-boilerplate> ( responder -- responder' )\r
- <boilerplate>\r
- "boilerplate" login-template >>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> f <protected> <login-boilerplate>\r
- "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-3> <login-boilerplate>\r
- "new-password" 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
-\r
-: allow-password-recovery? ( -- ? )\r
- login get responders>> "recover-password" swap key? ;\r
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Login</t:title>
-
- <t:form t:action="login">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:password t:name="password" /></td>
- </tr>
-
- </table>
-
- <p>
-
- <input type="submit" value="Log in" />
- <t:validation-messages />
-
- </p>
-
- </t:form>
-
- <p>
- <t:if code="http.server.auth.login:login-failed?">
- <t:a t:href="register">Register</t:a>
- </t:if>
- |
- <t:if code="http.server.auth.login:allow-password-recovery?">
- <t:a t:href="recover-password">Recover Password</t:a>
- </t:if>
- </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 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>
+++ /dev/null
-IN: http.server.auth.providers.assoc.tests\r
-USING: http.server.actions http.server.auth.providers \r
-http.server.auth.providers.assoc http.server.auth.login\r
-tools.test namespaces accessors kernel ;\r
-\r
-<action> <login>\r
- <users-in-memory> >>users\r
-login set\r
-\r
-[ t ] [\r
- "slava" <user>\r
- "foobar" >>encoded-password\r
- "slava@factorcode.org" >>email\r
- H{ } clone >>profile\r
- users new-user\r
- username>> "slava" =\r
-] unit-test\r
-\r
-[ f ] [\r
- "slava" <user>\r
- H{ } clone >>profile\r
- users new-user\r
-] unit-test\r
-\r
-[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
-[ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
-\r
-[ t ] [ "user" get >boolean ] unit-test\r
-\r
-[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
-\r
-[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
-[ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-IN: http.server.auth.providers.assoc\r
-USING: accessors assocs kernel\r
-http.server.auth.providers ;\r
-\r
-TUPLE: users-in-memory assoc ;\r
-\r
-: <users-in-memory> ( -- provider )\r
- H{ } clone users-in-memory boa ;\r
-\r
-M: users-in-memory get-user ( username provider -- user/f )\r
- assoc>> at ;\r
-\r
-M: users-in-memory update-user ( user provider -- ) 2drop ;\r
-\r
-M: users-in-memory new-user ( user provider -- user/f )\r
- [ dup username>> ] dip assoc>>\r
- 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;\r
+++ /dev/null
-IN: http.server.auth.providers.db.tests\r
-USING: http.server.actions\r
-http.server.auth.login\r
-http.server.auth.providers\r
-http.server.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
-\r
-[ "auth-test.db" temp-file delete-file ] ignore-errors\r
-\r
-"auth-test.db" temp-file sqlite-db [\r
-\r
- init-users-table\r
-\r
- [ t ] [\r
- "slava" <user>\r
- "foobar" >>encoded-password\r
- "slava@factorcode.org" >>email\r
- H{ } clone >>profile\r
- users new-user\r
- username>> "slava" =\r
- ] unit-test\r
-\r
- [ f ] [\r
- "slava" <user>\r
- H{ } clone >>profile\r
- users new-user\r
- ] unit-test\r
-\r
- [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
- [ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
-\r
- [ t ] [ "user" get >boolean ] unit-test\r
-\r
- [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
-\r
- [ ] [ "user" get users update-user ] unit-test\r
-\r
- [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
- [ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
-] with-db\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: db db.tuples db.types accessors
-http.server.auth.providers kernel continuations
-classes.singleton ;
-IN: http.server.auth.providers.db
-
-user "USERS"
-{
- { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
- { "realname" "REALNAME" { VARCHAR 256 } }
- { "password" "PASSWORD" BLOB +not-null+ }
- { "salt" "SALT" INTEGER +not-null+ }
- { "email" "EMAIL" { VARCHAR 256 } }
- { "ticket" "TICKET" { VARCHAR 256 } }
- { "capabilities" "CAPABILITIES" FACTOR-BLOB }
- { "profile" "PROFILE" FACTOR-BLOB }
- { "deleted" "DELETED" INTEGER +not-null+ }
-} define-persistent
-
-: init-users-table user ensure-table ;
-
-SINGLETON: users-in-db
-
-M: users-in-db get-user
- drop <user> select-tuple ;
-
-M: users-in-db new-user
- drop
- [
- user new
- over username>> >>username
- select-tuple [
- drop f
- ] [
- dup insert-tuple
- ] if
- ] with-transaction ;
-
-M: users-in-db update-user
- drop update-tuple ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: http.server.auth.providers kernel ;\r
-IN: http.server.auth.providers.null\r
-\r
-TUPLE: no-users ;\r
-\r
-: no-users T{ no-users } ;\r
-\r
-M: no-users get-user 2drop f ;\r
-\r
-M: no-users new-user 2drop f ;\r
-\r
-M: no-users update-user 2drop ;\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel accessors random math.parser locals\r
-sequences math ;\r
-IN: http.server.auth.providers\r
-\r
-TUPLE: user\r
-username realname\r
-password salt\r
-email ticket capabilities profile deleted changed? ;\r
-\r
-: <user> ( username -- user )\r
- user new\r
- swap >>username\r
- 0 >>deleted ;\r
-\r
-GENERIC: get-user ( username provider -- user/f )\r
-\r
-GENERIC: update-user ( user provider -- )\r
-\r
-GENERIC: new-user ( user provider -- user/f )\r
-\r
-! Password recovery support\r
-\r
-:: issue-ticket ( email username provider -- user/f )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user email>> length 0 > [\r
- user email>> email = [\r
- user\r
- 256 random-bits >hex >>ticket\r
- dup provider update-user\r
- ] [ f ] if\r
- ] [ f ] if\r
- ] [ f ] if\r
- ] ;\r
-\r
-:: claim-ticket ( ticket username provider -- user/f )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user ticket>> ticket = [\r
- user f >>ticket dup provider update-user\r
- ] [ f ] if\r
- ] [ f ] if\r
- ] ;\r
-\r
-! For configuration\r
-\r
-: add-user ( provider user -- provider )\r
- over new-user [ "User exists" throw ] when ;\r
+++ /dev/null
-! Copyright (c) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces http.server html.templates
-locals ;
-IN: http.server.boilerplate
-
-TUPLE: boilerplate < filter-responder template ;
-
-: <boilerplate> f boilerplate boa ;
-
-M:: boilerplate call-responder* ( path responder -- )
- path responder call-next-method
- dup content-type>> "text/html" = [
- clone [| body |
- [ body responder template>> with-boilerplate ]
- ] change-body
- ] when ;
+++ /dev/null
-IN: http.server.callbacks\r
-USING: http.server.actions http.server.callbacks accessors\r
-http.server http tools.test namespaces io fry sequences\r
-splitting kernel hashtables continuations ;\r
-\r
-[ 123 ] [\r
- [\r
- init-request\r
-\r
- <request> "GET" >>method request set\r
- [\r
- exit-continuation set\r
- { }\r
- <action> [ [ "hello" print 123 ] show-final ] >>display\r
- <callback-responder>\r
- call-responder\r
- ] callcc1\r
- ] with-scope\r
-] unit-test\r
-\r
-[\r
- init-request\r
-\r
- <action> [\r
- [\r
- "hello" print\r
- '[ , write ] <html-content>\r
- ] show-page\r
- "byebye" print\r
- [ 123 ] show-final\r
- ] >>display\r
- <callback-responder> "r" set\r
-\r
- [ 123 ] [\r
- [\r
- exit-continuation set\r
- <request> "GET" >>method request set\r
- { } "r" get call-responder\r
- ] callcc1\r
-\r
- body>> first\r
-\r
- <request>\r
- "GET" >>method\r
- swap cont-id associate >>query\r
- "/" >>path\r
- request set\r
-\r
- [\r
- exit-continuation set\r
- { }\r
- "r" get call-responder\r
- ] callcc1\r
-\r
- ! get-post-get\r
- <request>\r
- "GET" >>method\r
- swap "location" header "=" last-split1 nip cont-id associate >>query\r
- "/" >>path\r
- request set\r
-\r
- [\r
- exit-continuation set\r
- { }\r
- "r" get call-responder\r
- ] callcc1\r
- ] unit-test\r
-] with-scope\r
+++ /dev/null
-! Copyright (C) 2004 Chris Double.\r
-! Copyright (C) 2006, 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: http http.server io kernel math namespaces\r
-continuations calendar sequences assocs hashtables\r
-accessors arrays alarms quotations combinators fry assocs.lib ;\r
-IN: http.server.callbacks\r
-\r
-SYMBOL: responder\r
-\r
-TUPLE: callback-responder responder callbacks ;\r
-\r
-: <callback-responder> ( responder -- responder' )\r
- #! A continuation responder is a special type of session\r
- #! manager. However it works entirely differently from\r
- #! the URL and cookie session managers.\r
- H{ } clone callback-responder boa ;\r
-\r
-TUPLE: callback cont quot expires alarm responder ;\r
-\r
-: timeout 20 minutes ;\r
-\r
-: timeout-callback ( callback -- )\r
- [ alarm>> cancel-alarm ]\r
- [ dup responder>> callbacks>> delete-at ]\r
- bi ;\r
-\r
-: touch-callback ( callback -- )\r
- dup expires>> [\r
- dup alarm>> [ cancel-alarm ] when*\r
- dup '[ , timeout-callback ] timeout later >>alarm\r
- ] when drop ;\r
-\r
-: <callback> ( cont quot expires? -- callback )\r
- f callback-responder get callback boa\r
- dup touch-callback ;\r
-\r
-: invoke-callback ( callback -- response )\r
- [ touch-callback ]\r
- [ quot>> request get exit-continuation get 3array ]\r
- [ cont>> continue-with ]\r
- tri ;\r
-\r
-: register-callback ( cont quot expires? -- id )\r
- <callback> callback-responder get callbacks>> set-at-unique ;\r
-\r
-: forward-to-url ( url query -- * )\r
- #! When executed inside a 'show' call, this will force a\r
- #! HTTP 302 to occur to instruct the browser to forward to\r
- #! the request URL.\r
- <temporary-redirect> exit-with ;\r
-\r
-: cont-id "factorcontid" ;\r
-\r
-: forward-to-id ( id -- * )\r
- #! When executed inside a 'show' call, this will force a\r
- #! HTTP 302 to occur to instruct the browser to forward to\r
- #! the request URL.\r
- f swap cont-id associate forward-to-url ;\r
-\r
-: restore-request ( pair -- )\r
- first3 exit-continuation set request set call ;\r
-\r
-SYMBOL: post-refresh-get?\r
-\r
-: redirect-to-here ( -- )\r
- #! Force a redirect to the client browser so that the browser\r
- #! goes to the current point in the code. This forces an URL\r
- #! change on the browser so that refreshing that URL will\r
- #! immediately run from this code point. This prevents the\r
- #! "this request will issue a POST" warning from the browser\r
- #! and prevents re-running the previous POST logic. This is\r
- #! known as the 'post-refresh-get' pattern.\r
- post-refresh-get? get [\r
- [\r
- [ ] t register-callback forward-to-id\r
- ] callcc1 restore-request\r
- ] [\r
- post-refresh-get? on\r
- ] if ;\r
-\r
-SYMBOL: current-show\r
-\r
-: store-current-show ( -- )\r
- #! Store the current continuation in the variable 'current-show'\r
- #! so it can be returned to later by 'quot-id'. Note that it\r
- #! recalls itself when the continuation is called to ensure that\r
- #! it resets its value back to the most recent show call.\r
- [ current-show set f ] callcc1\r
- [ restore-request store-current-show ] when* ;\r
-\r
-: show-final ( quot -- * )\r
- [ redirect-to-here store-current-show ] dip\r
- call exit-with ; inline\r
-\r
-: resuming-callback ( responder request -- id )\r
- cont-id query-param swap callbacks>> at ;\r
-\r
-M: callback-responder call-responder* ( path responder -- response )\r
- '[\r
- , ,\r
-\r
- [ callback-responder set ]\r
- [ request get resuming-callback ] bi\r
-\r
- [\r
- invoke-callback\r
- ] [\r
- callback-responder get responder>> call-responder\r
- ] ?if\r
- ] with-exit-continuation ;\r
-\r
-: show-page ( quot -- )\r
- [ redirect-to-here store-current-show ] dip\r
- [\r
- [ ] t register-callback swap call exit-with\r
- ] callcc1 restore-request ; inline\r
-\r
-: quot-id ( quot -- id )\r
- current-show get swap t register-callback ;\r
-\r
-: quot-url ( quot -- url )\r
- quot-id f swap cont-id associate derive-url ;\r
"HTTP/" request get version>> append "SERVER_PROTOCOL" set\r
"Factor" "SERVER_SOFTWARE" set\r
\r
- dup "PATH_TRANSLATED" set\r
- "SCRIPT_FILENAME" set\r
+ [ "PATH_TRANSLATED" set ] [ "SCRIPT_FILENAME" set ] bi\r
\r
- request get path>> "SCRIPT_NAME" set\r
+ request get url>> path>> "SCRIPT_NAME" set\r
\r
- request get host>> "SERVER_NAME" set\r
- request get port>> number>string "SERVER_PORT" set\r
+ request get url>> host>> "SERVER_NAME" set\r
+ request get url>> port>> number>string "SERVER_PORT" set\r
"" "PATH_INFO" set\r
"" "REMOTE_HOST" set\r
"" "REMOTE_ADDR" set\r
+++ /dev/null
-IN: http.server.db.tests
-USING: tools.test http.server.db ;
-
-\ <db-persistence> must-infer
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: db db.pools io.pools http.server http.server.sessions\r
-kernel accessors continuations namespaces destructors ;\r
-IN: http.server.db\r
-\r
-TUPLE: db-persistence < filter-responder pool ;\r
-\r
-: <db-persistence> ( responder params db -- responder' )\r
- <db-pool> db-persistence boa ;\r
-\r
-M: db-persistence call-responder*\r
- [\r
- pool>> [ acquire-connection ] keep\r
- [ return-connection-later ] [ drop db set ] 2bi\r
- ]\r
- [ call-next-method ] bi ;\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces sequences arrays kernel
-assocs assocs.lib hashtables math.parser
-html.elements http http.server http.server.sessions ;
-IN: http.server.flows
-
-TUPLE: flows < filter-responder ;
-
-C: <flows> flows
-
-: begin-flow* ( -- id )
- request get
- [ path>> ] [ request-params ] [ method>> ] tri 3array
- flows sget set-at-unique
- session-changed ;
-
-: end-flow-post ( path params -- response )
- request [
- clone
- "POST" >>method
- swap >>post-data
- swap >>path
- ] change
- request get path>> split-path
- flows get responder>> call-responder ;
-
-: end-flow* ( default id -- response )
- flows sget at
- [ first3 "POST" = [ end-flow-post ] [ <standard-redirect> ] if ]
- [ f <standard-redirect> ] ?if ;
-
-SYMBOL: flow-id
-
-: flow-id-key "factorflowid" ;
-
-: begin-flow ( -- )
- begin-flow* flow-id set ;
-
-: end-flow ( default -- response )
- flow-id get end-flow* ;
-
-: add-flow-id ( query -- query' )
- flow-id get [ flow-id-key associate assoc-union ] when* ;
-
-: flow-form-field ( -- )
- flow-id get [
- <input
- "hidden" =type
- flow-id-key =name
- =value
- input/>
- ] when* ;
-
-M: flows call-responder*
- dup flows set
- [ add-flow-id ] add-link-hook
- [ flow-form-field ] add-form-hook
- flow-id-key request get request-params at flow-id set
- call-next-method ;
-
-M: flows init-session*
- H{ } clone flows sset
- call-next-method ;
USING: http.server tools.test kernel namespaces accessors
-io http math sequences assocs arrays classes words ;
+io http math sequences assocs arrays classes words urls ;
IN: http.server.tests
\ find-responder must-infer
[
<request>
- http >>protocol
- "www.apple.com" >>host
- "/xxx/bar" >>path
- { { "a" "b" } } >>query
+ <url>
+ "http" >>protocol
+ "www.apple.com" >>host
+ "/xxx/bar" >>path
+ { { "a" "b" } } >>query
+ >>url
request set
[ ] link-hook set
- [ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test
- [ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test
- [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test
- [ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test
- [ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test
- [ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test
- [ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test
- [ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test
+ [ "http://www.apple.com:80/xxx/bar" ] [
+ <url> adjust-url url>string
+ ] unit-test
+
+ [ "http://www.apple.com:80/xxx/baz" ] [
+ <url> "baz" >>path adjust-url url>string
+ ] unit-test
+
+ [ "http://www.apple.com:80/xxx/baz?c=d" ] [
+ <url> "baz" >>path { { "c" "d" } } >>query adjust-url url>string
+ ] unit-test
+
+ [ "http://www.apple.com:80/xxx/bar?c=d" ] [
+ <url> { { "c" "d" } } >>query adjust-url url>string
+ ] unit-test
+
+ [ "http://www.apple.com:80/flip" ] [
+ <url> "/flip" >>path adjust-url url>string
+ ] unit-test
+
+ [ "http://www.apple.com:80/flip?c=d" ] [
+ <url> "/flip" >>path { { "c" "d" } } >>query adjust-url url>string
+ ] unit-test
+
+ [ "http://www.jedit.org:80/" ] [
+ "http://www.jedit.org" >url adjust-url url>string
+ ] unit-test
+
+ [ "http://www.jedit.org:80/?a=b" ] [
+ "http://www.jedit.org" >url { { "a" "b" } } >>query adjust-url url>string
+ ] unit-test
] with-scope
TUPLE: mock-responder path ;
M: mock-responder call-responder*
nip
path>> on
- [ ] <text-content> ;
+ [ ] "text/plain" <content> ;
: check-dispatch ( tag path -- ? )
H{ } clone base-paths set
M: path-check-responder call-responder*
drop
- >array <text-content> ;
+ >array "text/plain" <content> ;
[ { "c" } ] [
H{ } clone base-paths set
M: base-path-check-responder call-responder*
2drop
"$funny-dispatcher" resolve-base-path
- <text-content> ;
+ "text/plain" <content> ;
[ ] [
<dispatcher>
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
threads sequences prettyprint io.server logging calendar http
-html.streams html.elements accessors math.parser
-combinators.lib tools.vocabs debugger continuations random
-combinators destructors io.encodings.8-bit fry classes words
-math rss json.writer ;
+html.streams html.components html.elements html.templates
+accessors math.parser combinators.lib tools.vocabs debugger
+continuations random combinators destructors io.streams.string
+io.encodings.8-bit fry classes words math urls
+arrays vocabs.loader ;
IN: http.server
! path is a sequence of path component strings
-
GENERIC: call-responder* ( path responder -- response )
-: request-params ( request -- assoc )
- dup method>> {
- { "GET" [ query>> ] }
- { "HEAD" [ query>> ] }
- { "POST" [ post-data>> ] }
- } case ;
-
: <content> ( body content-type -- response )
<response>
200 >>code
swap >>content-type
swap >>body ;
-: <text-content> ( body -- response )
- "text/plain" <content> ;
-
-: <html-content> ( body -- response )
- "text/html" <content> ;
-
-: <xml-content> ( body -- response )
- "text/xml" <content> ;
-
-: <feed-content> ( feed -- response )
- '[ , feed>xml ] "text/xml" <content> ;
-
-: <json-content> ( obj -- response )
- '[ , >json ] "application/json" <content> ;
-
TUPLE: trivial-responder response ;
C: <trivial-responder> trivial-responder
</html> ;
: <trivial-response> ( code message -- response )
- 2dup '[ , , trivial-response-body ] <html-content>
+ 2dup [ trivial-response-body ] with-string-writer
+ "text/html" <content>
swap >>message
swap >>code ;
[ <404> ] <trivial-responder> 404-responder set-global
-SYMBOL: base-paths
+SYMBOL: responder-nesting
: invert-slice ( slice -- slice' )
dup slice? [
drop { }
] if ;
-: add-base-path ( path dispatcher -- )
- [ invert-slice ] [ class word-name ] bi*
- base-paths get set-at ;
+: vocab-path ( vocab -- path )
+ dup vocab-dir vocab-append-path ;
+
+: vocab-path-of ( dispatcher -- path )
+ class word-vocabulary vocab-path ;
+
+: add-responder-path ( path dispatcher -- )
+ [ [ invert-slice ] [ [ vocab-path-of ] keep ] bi* 3array ]
+ [ nip class word-name ] 2bi
+ responder-nesting get set-at ;
: call-responder ( path responder -- response )
- [ add-base-path ] [ call-responder* ] 2bi ;
+ [ add-responder-path ] [ call-responder* ] 2bi ;
-SYMBOL: link-hook
+: nested-responders ( -- seq )
+ responder-nesting get assocs:values [ third ] map ;
-: add-link-hook ( quot -- )
- link-hook [ compose ] change ; inline
+: each-responder ( quot -- )
+ nested-responders swap each ; inline
-: modify-query ( query -- query )
- link-hook get call ;
+: responder-path ( string -- pair )
+ dup responder-nesting get at
+ [ ] [ "No such responder: " swap append throw ] ?if ;
: base-path ( string -- path )
- dup base-paths get at
- [ ] [ "No such responder: " swap append throw ] ?if ;
+ responder-path first ;
-: resolve-base-path ( string -- string' )
- "$" ?head [
+: template-path ( string -- path )
+ responder-path second ;
+
+: resolve-responder-path ( string quot -- string' )
+ [ "$" ?head ] dip '[
[
- "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
+ "/" split1 [ @ [ "/" % % ] each "/" % ] dip %
] "" make
- ] when ;
-
-: link>string ( url query -- url' )
- [ resolve-base-path ] [ modify-query ] bi* (link>string) ;
-
-: write-link ( url query -- )
- link>string write ;
+ ] when ; inline
-SYMBOL: form-hook
-
-: add-form-hook ( quot -- )
- form-hook [ compose ] change ;
-
-: hidden-form-field ( -- )
- form-hook get call ;
+: resolve-base-path ( string -- string' )
+ [ base-path ] resolve-responder-path ;
-: absolute-redirect ( to query -- url )
- #! Same host.
- request get clone
- swap [ >>query ] when*
- swap url-encode >>path
- [ modify-query ] change-query
- request-url ;
+: resolve-template-path ( string -- string' )
+ [ template-path ] resolve-responder-path ;
-: replace-last-component ( path with -- path' )
- [ "/" last-split1 drop "/" ] dip 3append ;
+GENERIC: modify-query ( query responder -- query' )
-: relative-redirect ( to query -- url )
- request get clone
- swap [ >>query ] when*
- swap [ '[ , replace-last-component ] change-path ] when*
- [ modify-query ] change-query
- request-url ;
+M: object modify-query drop ;
-: derive-url ( to query -- url )
- {
- { [ over "http://" head? ] [ link>string ] }
- { [ over "/" head? ] [ absolute-redirect ] }
- { [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] }
- [ relative-redirect ]
- } cond ;
+: adjust-url ( url -- url' )
+ clone
+ [ dup [ modify-query ] each-responder ] change-query
+ [ resolve-base-path ] change-path
+ request get url>>
+ clone
+ f >>query
+ swap derive-url ensure-port ;
-: <redirect> ( to query code message -- response )
- <trivial-response> -rot derive-url "location" set-header ;
+: <custom-redirect> ( url code message -- response )
+ <trivial-response>
+ swap dup url? [ adjust-url ] when
+ "location" set-header ;
-\ <redirect> DEBUG add-input-logging
+\ <custom-redirect> DEBUG add-input-logging
: <permanent-redirect> ( to query -- response )
- 301 "Moved Permanently" <redirect> ;
+ 301 "Moved Permanently" <custom-redirect> ;
: <temporary-redirect> ( to query -- response )
- 307 "Temporary Redirect" <redirect> ;
+ 307 "Temporary Redirect" <custom-redirect> ;
-: <standard-redirect> ( to query -- response )
- request get method>> "POST" =
- [ <permanent-redirect> ] [ <temporary-redirect> ] if ;
+: <redirect> ( to query -- response )
+ request get method>> {
+ { "GET" [ <temporary-redirect> ] }
+ { "HEAD" [ <temporary-redirect> ] }
+ { "POST" [ <permanent-redirect> ] }
+ } case ;
TUPLE: dispatcher default responders ;
404-responder get H{ } clone vhost-dispatcher boa ;
: find-vhost ( dispatcher -- responder )
- request get host>> over responders>> at*
+ request get url>> host>> over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
LOG: httpd-hit NOTICE
: log-request ( request -- )
- { method>> host>> path>> } map-exec-with httpd-hit ;
-
-SYMBOL: exit-continuation
-
-: exit-with exit-continuation get continue-with ;
-
-: with-exit-continuation ( quot -- )
- '[ exit-continuation set @ ] callcc1 exit-continuation off ;
+ [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ;
: split-path ( string -- path )
"/" split harvest ;
-: init-request ( -- )
- H{ } clone base-paths set
+: init-request ( request -- )
+ request set
+ H{ } clone responder-nesting set
[ ] link-hook set
[ ] form-hook set ;
+: dispatch-request ( request -- response )
+ url>> path>> split-path main-responder get call-responder ;
+
: do-request ( request -- response )
[
- init-request
- [ request set ]
+ [ init-request ]
[ log-request ]
- [ path>> split-path main-responder get call-responder ] tri
- [ <404> ] unless*
- ] [
- [ \ do-request log-error ]
- [ <500> ]
- bi
- ] recover ;
+ [ dispatch-request ] tri
+ ]
+ [ [ \ do-request log-error ] [ <500> ] bi ]
+ recover ;
: ?refresh-all ( -- )
development-mode get-global
+++ /dev/null
-Doug Coleman
+++ /dev/null
-IN: http.server.sessions.tests\r
-USING: tools.test http http.server.sessions\r
-http.server.actions http.server math namespaces kernel accessors\r
-prettyprint io.streams.string io.files splitting destructors\r
-sequences db db.sqlite continuations ;\r
-\r
-: with-session\r
- [\r
- [ [ save-session-after ] [ session set ] bi ] dip call\r
- ] with-destructors ; inline\r
-\r
-TUPLE: foo ;\r
-\r
-C: <foo> foo\r
-\r
-M: foo init-session* drop 0 "x" sset ;\r
-\r
-M: foo call-responder*\r
- 2drop\r
- "x" [ 1+ ] schange\r
- [ "x" sget pprint ] <html-content> ;\r
-\r
-: url-responder-mock-test\r
- [\r
- <request>\r
- "GET" >>method\r
- "id" get session-id-key set-query-param\r
- "/" >>path\r
- request set\r
- { } sessions get call-responder\r
- [ write-response-body drop ] with-string-writer\r
- ] with-destructors ;\r
-\r
-: sessions-mock-test\r
- [\r
- <request>\r
- "GET" >>method\r
- "cookies" get >>cookies\r
- "/" >>path\r
- request set\r
- { } sessions get call-responder\r
- [ write-response-body drop ] with-string-writer\r
- ] with-destructors ;\r
-\r
-: <exiting-action>\r
- <action>\r
- [ [ ] <text-content> exit-with ] >>display ;\r
-\r
-[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors\r
-\r
-"auth-test.db" temp-file sqlite-db [\r
-\r
- init-request\r
- init-sessions-table\r
-\r
- [ ] [\r
- <foo> <sessions>\r
- sessions set\r
- ] unit-test\r
-\r
- [\r
- [ ] [\r
- empty-session\r
- 123 >>id session set\r
- ] unit-test\r
-\r
- [ ] [ 3 "x" sset ] unit-test\r
-\r
- [ 9 ] [ "x" sget sq ] unit-test\r
-\r
- [ ] [ "x" [ 1- ] schange ] unit-test\r
-\r
- [ 4 ] [ "x" sget sq ] unit-test\r
-\r
- [ t ] [ session get changed?>> ] unit-test\r
- ] with-scope\r
-\r
- [ t ] [\r
- begin-session id>>\r
- get-session session?\r
- ] unit-test\r
-\r
- [ { 5 0 } ] [\r
- [\r
- begin-session\r
- dup [ 5 "a" sset ] with-session\r
- dup [ "a" sget , ] with-session\r
- dup [ "x" sget , ] with-session\r
- drop\r
- ] { } make\r
- ] unit-test\r
-\r
- [ 0 ] [\r
- begin-session id>>\r
- get-session [ "x" sget ] with-session\r
- ] unit-test\r
-\r
- [ { 5 0 } ] [\r
- [\r
- begin-session id>>\r
- dup get-session [ 5 "a" sset ] with-session\r
- dup get-session [ "a" sget , ] with-session\r
- dup get-session [ "x" sget , ] with-session\r
- drop\r
- ] { } make\r
- ] unit-test\r
-\r
- [ ] [\r
- <foo> <sessions>\r
- sessions set\r
- ] unit-test\r
-\r
- [\r
- <request>\r
- "GET" >>method\r
- "/" >>path\r
- request set\r
- { "etc" } sessions get call-responder response set\r
- [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test\r
- response get\r
- ] with-destructors\r
- response set\r
-\r
- [ ] [ response get cookies>> "cookies" set ] unit-test\r
-\r
- [ "2" ] [ sessions-mock-test ] unit-test\r
- [ "3" ] [ sessions-mock-test ] unit-test\r
- [ "4" ] [ sessions-mock-test ] unit-test\r
-\r
- [\r
- [ ] [\r
- <request>\r
- "GET" >>method\r
- "id" get session-id-key set-query-param\r
- "/" >>path\r
- request set\r
-\r
- [\r
- { } <exiting-action> <sessions>\r
- call-responder\r
- ] with-destructors response set\r
- ] unit-test\r
-\r
- [ "text/plain" ] [ response get content-type>> ] unit-test\r
-\r
- [ f ] [ response get cookies>> empty? ] unit-test\r
- ] with-scope\r
-] with-db\r
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel math.intervals math.parser namespaces
-random accessors quotations hashtables sequences continuations
-fry calendar combinators destructors alarms
-db db.tuples db.types
-http http.server html.elements ;
-IN: http.server.sessions
-
-TUPLE: session id expires uid namespace changed? ;
-
-: <session> ( id -- session )
- session new
- swap >>id ;
-
-session "SESSIONS"
-{
- { "id" "ID" +random-id+ system-random-generator }
- { "expires" "EXPIRES" TIMESTAMP +not-null+ }
- { "uid" "UID" { VARCHAR 255 } }
- { "namespace" "NAMESPACE" FACTOR-BLOB }
-} define-persistent
-
-: get-session ( id -- session )
- dup [ <session> select-tuple ] when ;
-
-: init-sessions-table session ensure-table ;
-
-: start-expiring-sessions ( db seq -- )
- '[
- , , [
- session new
- -1.0/0.0 now [a,b] >>expires
- delete-tuples
- ] with-db
- ] 5 minutes every drop ;
-
-GENERIC: init-session* ( responder -- )
-
-M: object init-session* drop ;
-
-M: dispatcher init-session* default>> init-session* ;
-
-M: filter-responder init-session* responder>> init-session* ;
-
-TUPLE: sessions < filter-responder timeout domain ;
-
-: <sessions> ( responder -- responder' )
- sessions new
- swap >>responder
- 20 minutes >>timeout ;
-
-: (session-changed) ( session -- )
- t >>changed? drop ;
-
-: session-changed ( -- )
- session get (session-changed) ;
-
-: sget ( key -- value )
- session get namespace>> at ;
-
-: sset ( value key -- )
- session get
- [ namespace>> set-at ] [ (session-changed) ] bi ;
-
-: schange ( key quot -- )
- session get
- [ 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 ;
-
-: cutoff-time ( -- time )
- sessions get timeout>> from-now ;
-
-: touch-session ( session -- )
- cutoff-time >>expires drop ;
-
-: empty-session ( -- session )
- f <session>
- H{ } clone >>namespace
- dup touch-session ;
-
-: begin-session ( -- session )
- empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
-
-! Destructor
-TUPLE: session-saver session ;
-
-C: <session-saver> session-saver
-
-M: session-saver dispose
- session>> dup changed?>> [
- [ touch-session ] [ update-tuple ] bi
- ] [ drop ] if ;
-
-: save-session-after ( session -- )
- <session-saver> &dispose drop ;
-
-: existing-session ( path session -- response )
- [ session set ] [ save-session-after ] bi
- sessions get responder>> call-responder ;
-
-: session-id-key "factorsessid" ;
-
-: cookie-session-id ( request -- id/f )
- session-id-key get-cookie
- dup [ value>> string>number ] when ;
-
-: post-session-id ( request -- id/f )
- session-id-key swap post-data>> at string>number ;
-
-: request-session-id ( -- id/f )
- request get dup method>> {
- { "GET" [ cookie-session-id ] }
- { "HEAD" [ cookie-session-id ] }
- { "POST" [ post-session-id ] }
- } case ;
-
-: request-session ( -- session/f )
- request-session-id get-session ;
-
-: <session-cookie> ( id -- cookie )
- session-id-key <cookie>
- "$sessions" resolve-base-path >>path
- sessions get timeout>> from-now >>expires
- sessions get domain>> >>domain ;
-
-: put-session-cookie ( response -- response' )
- session get id>> number>string <session-cookie> put-cookie ;
-
-: session-form-field ( -- )
- <input
- "hidden" =type
- session-id-key =name
- session get id>> number>string =value
- input/> ;
-
-M: sessions call-responder* ( path responder -- response )
- [ session-form-field ] add-form-hook
- sessions set
- request-session [ begin-session ] unless*
- existing-session put-session-cookie ;
-
-: logout-all-sessions ( uid -- )
- session new swap >>uid delete-tuples ;
math.parser http http.server namespaces parser sequences strings\r
assocs hashtables debugger http.mime sorting html.elements\r
html.templates.fhtml logging calendar.format accessors\r
-io.encodings.binary fry xml.entities destructors ;\r
+io.encodings.binary fry xml.entities destructors urls ;\r
IN: http.server.static\r
\r
! special maps mime types to quots with effect ( path -- )\r
\r
: list-directory ( directory -- response )\r
file-responder get allow-listings>> [\r
- '[ , directory. ] <html-content>\r
+ '[ , directory. ] "text/html" <content>\r
] [\r
drop <403>\r
] if ;\r
find-index [ serve-file ] [ list-directory ] ?if\r
] [\r
drop\r
- request get path>> "/" append f <standard-redirect>\r
+ request get url>> clone [ "/" append ] change-path <redirect>\r
] if ;\r
\r
: serve-object ( filename -- response )\r
\r
! file responder integration\r
: enable-fhtml ( responder -- responder )\r
- [ <fhtml> <html-content> ]\r
+ [ <fhtml> "text/html" <content> ]\r
"application/x-factor-server-page"\r
pick special>> set-at ;\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays namespaces sequences continuations
-destructors io.sockets ;
+destructors io.sockets alien alien.syntax ;
IN: io.pools
-TUPLE: pool connections disposed ;
+TUPLE: pool connections disposed expired ;
+
+: check-pool ( pool -- )
+ dup check-disposed
+ dup expired>> expired? [
+ ALIEN: 31337 >>expired
+ connections>> [ delete-all ] [ dispose-each ] bi
+ ] [ drop ] if ;
: <pool> ( class -- pool )
- new V{ } clone >>connections ; inline
+ new V{ } clone
+ >>connections
+ dup check-pool ; inline
M: pool dispose* connections>> dispose-each ;
TUPLE: return-connection conn pool ;
: return-connection ( conn pool -- )
- dup check-disposed connections>> push ;
+ dup check-pool connections>> push ;
GENERIC: make-connection ( pool -- conn )
: new-connection ( pool -- )
- [ make-connection ] keep return-connection ;
+ dup check-pool [ make-connection ] keep return-connection ;
: acquire-connection ( pool -- conn )
- dup check-disposed
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ;
</tr> ;
: htmlize-diff ( diff -- )
- <table "comparison" =class table>
+ <table "100%" =width "comparison" =class table>
<tr> <th> "Old" write </th> <th> "New" write </th> </tr>
[ diff-line ] each
</table> ;
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities io.files io
http.client namespaces xml.generator hashtables
- calendar.format accessors continuations ;
+ calendar.format accessors continuations urls ;
IN: rss
: any-tag-named ( tag names -- tag-inside )
: entry, ( entry -- )
"entry" [
- dup entry-title "title" { { "type" "html" } } simple-tag*,
- "link" over entry-link "href" associate contained*,
- dup entry-pub-date timestamp>rfc3339 "published" simple-tag,
- entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
+ dup title>> "title" { { "type" "html" } } simple-tag*,
+ "link" over link>> dup url? [ url>string ] when "href" associate contained*,
+ dup pub-date>> timestamp>rfc3339 "published" simple-tag,
+ description>> [ "content" { { "type" "html" } } simple-tag*, ] when*
] tag, ;
: feed>xml ( feed -- xml )
"feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
- dup feed-title "title" simple-tag,
- "link" over feed-link "href" associate contained*,
- feed-entries [ entry, ] each
+ dup title>> "title" simple-tag,
+ "link" over link>> dup url? [ url>string ] when "href" associate contained*,
+ entries>> [ entry, ] each
] make-xml* ;
-
-: write-feed ( feed -- )
- feed>xml write-xml ;
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ;
+USING: accessors assocs db db.sqlite db.postgresql http http.server furnace.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ;
IN: tangle
GENERIC: render* ( content templater -- output )
[ [ db>> ] [ seq>> ] bi ] dip with-db ;
: node-response ( id -- response )
- load-node [ node-content <text-content> ] [ <404> ] if* ;
+ load-node [ node-content "text/plain" <content> ] [ <404> ] if* ;
: display-node ( params -- response )
[
: submit-node ( params -- response )
[
"node_content" swap at* [
- create-node id>> number>string <text-content>
+ create-node id>> number>string "text/plain" <content>
] [
drop <400>
] if
C: <path-responder> path-responder
M: path-responder call-responder* ( path responder -- response )
- drop path>file [ node-content <text-content> ] [ <404> ] if* ;
+ drop path>file [ node-content "text/plain" <content> ] [ <404> ] if* ;
TUPLE: tangle-dispatcher < dispatcher tangle ;
}
"a/relative/path"
}
+ {
+ TUPLE{ url
+ path: "bar"
+ query: H{ { "a" "b" } }
+ }
+ "bar?a=b"
+ }
} ;
urls [
- [ 1array ] [ [ string>url ] curry ] bi* unit-test
+ [ 1array ] [ [ >url ] curry ] bi* unit-test
] assoc-each
urls [
derive-url
] unit-test
+
+[ "a" ] [
+ <url> "a" "b" set-query-param "b" query-param
+] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel unicode.categories combinators sequences splitting
-fry namespaces assocs arrays strings mirrors
-io.encodings.string io.encodings.utf8
-math math.parser accessors namespaces.lib ;
+fry namespaces assocs arrays strings io.encodings.string
+io.encodings.utf8 math math.parser accessors mirrors parser
+prettyprint.backend hashtables ;
IN: urls
: url-quotable? ( ch -- ? )
TUPLE: url protocol host port path query anchor ;
+: <url> ( -- url ) url new ;
+
: query-param ( request key -- value )
swap query>> at ;
: set-query-param ( request value key -- request )
- pick query>> set-at ;
+ '[ , , _ ?set-at ] change-query ;
: parse-host ( string -- host port )
":" split1 [ url-decode ] [
] when
] bi* ;
-: parse-host-part ( protocol rest -- string' )
- [ "protocol" set ] [
+: parse-host-part ( url protocol rest -- url string' )
+ [ >>protocol ] [
"//" ?head [ "Invalid URL" throw ] unless
"/" split1 [
- parse-host [ "host" set ] [ "port" set ] bi*
+ parse-host [ >>host ] [ >>port ] bi*
] [ "/" prepend ] bi*
] bi* ;
-: string>url ( string -- url )
- [
- ":" split1 [ parse-host-part ] when*
- "#" split1 [
- "?" split1 [ query>assoc "query" set ] when*
- url-decode "path" set
- ] [
- url-decode "anchor" set
- ] bi*
- ] url make-object ;
+GENERIC: >url ( obj -- url )
+
+M: url >url ;
-: unparse-host-part ( protocol -- )
+M: string >url
+ <url> swap
+ ":" split1 [ parse-host-part ] when*
+ "#" split1 [
+ "?" split1
+ [ url-decode >>path ]
+ [ [ query>assoc >>query ] when* ] bi*
+ ]
+ [ url-decode >>anchor ] bi* ;
+
+: unparse-host-part ( url protocol -- )
%
"://" %
- "host" get url-encode %
- "port" get [ ":" % # ] when*
- "path" get "/" head? [ "Invalid URL" throw ] unless ;
+ [ host>> url-encode % ]
+ [ port>> [ ":" % # ] when* ]
+ [ path>> "/" head? [ "/" % ] unless ]
+ tri ;
: url>string ( url -- string )
[
- <mirror> [
- "protocol" get [ unparse-host-part ] when*
- "path" get url-encode %
- "query" get [ "?" % assoc>query % ] when*
- "anchor" get [ "#" % url-encode % ] when*
- ] bind
+ {
+ [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
+ [ path>> url-encode % ]
+ [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
+ [ anchor>> [ "#" % url-encode % ] when* ]
+ } cleave
] "" make ;
: url-append-path ( path1 path2 -- path )
: relative-url ( url -- url' )
clone f >>protocol f >>host f >>port ;
+
+: URL" lexer get skip-blank parse-string >url parsed ; parsing
+
+M: url pprint* dup url>string "URL\" " "\"" pprint-string ;
-USING: math kernel accessors html.components
-http.server http.server.actions
-http.server.sessions html.templates.chloe fry ;
+USING: math kernel accessors html.components http.server
+furnace.actions furnace.sessions html.templates.chloe
+fry urls ;
IN: webapps.counter
SYMBOL: count
: <counter-action> ( quot -- action )
<action>
- swap '[ count , schange "" f <standard-redirect> ] >>submit ;
-
-: counter-template ( -- template )
- "resource:extra/webapps/counter/counter.xml" <chloe> ;
+ swap '[
+ count , schange
+ URL" $counter-app" <redirect>
+ ] >>submit ;
: <display-action> ( -- action )
<page-action>
[ count sget "counter" set-value ] >>init
- counter-template >>template ;
+ "$counter-app/counter" >>template ;
: <counter-app> ( -- responder )
counter-app new-dispatcher
io.server
namespaces db db.sqlite smtp
http.server
-http.server.db
-http.server.flows
-http.server.sessions
-http.server.auth.login
-http.server.auth.providers.db
-http.server.boilerplate
-html.templates.chloe
+furnace.db
+furnace.flows
+furnace.sessions
+furnace.auth.login
+furnace.auth.providers.db
+furnace.boilerplate
webapps.pastebin
webapps.planet
webapps.todo
: test-db "resource:test.db" sqlite-db ;
-: factor-template ( path -- template )
- "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
-
: init-factor-db ( -- )
test-db [
init-users-table
init-revisions-table
] with-db ;
+TUPLE: factor-website < dispatcher ;
+
: <factor-website> ( -- responder )
- <dispatcher>
+ factor-website new-dispatcher
<todo-list> "todo" add-responder
<pastebin> "pastebin" add-responder
<planet-factor> "planet" add-responder
allow-password-recovery
allow-edit-profile
<boilerplate>
- "page" factor-template >>template
+ "$factor-website/page" >>template
<flows>
<sessions>
test-db <db-persistence> ;
<t:style t:include="resource:extra/webapps/factor-website/page.css" />
<t:write-style />
+
+ <t:write-atom />
</head>
<body>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="Paste - Atom" t:href="$pastebin/paste.atom" t:query="id" />
+ <t:atom t:title="This paste" t:href="$pastebin/paste.atom" t:query="id" />
<t:title>Paste: <t:label t:name="summary" /></t:title>
<tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table>
- <pre class="description"><t:code t:name="contents" t:mode="modes" /></pre>
+ <pre class="description"><t:code t:name="contents" t:mode="mode" /></pre>
<t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
- |
- <t:a t:href="$pastebin/annotate" t:query="id">Annotate</t:a>
- <t:each-tuple t:values="annotations">
+ <t:bind-each t:name="annotations">
- <h2>Annotation: <t:label t:name="summary" /></h2>
+ <a name="@id"><h2>Annotation: <t:label t:name="summary" /></h2></a>
<table>
<tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
<t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
- </t:each-tuple>
+ </t:bind-each>
- <t:bind-assoc t:name="new-annotation">
+ <t:bind t:name="new-annotation">
<h2>New Annotation</h2>
<input type="SUBMIT" value="Done" />
</t:form>
- </t:bind-assoc>
+ </t:bind>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:title="Pastebin" t:href="$pastebin/list.atom" />
+
<t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
<div class="navbar">
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
hashtables sequences.lib db.types db.tuples db combinators
-calendar calendar.format math.parser rss xml.writer
+calendar calendar.format math.parser rss urls xml.writer
xmode.catalog validators html.components html.templates.chloe
http.server
-http.server.actions
-http.server.auth
-http.server.auth.login
-http.server.boilerplate ;
+furnace.actions
+furnace.auth
+furnace.auth.login
+furnace.boilerplate ;
IN: webapps.pastebin
! ! !
: paste ( id -- paste )
<paste> select-tuple fetch-annotations ;
-: <id-redirect> ( id next -- response )
- swap "id" associate <standard-redirect> ;
-
! ! !
! LINKS, ETC
! ! !
: pastebin-link ( -- url )
- "$pastebin/list" f link>string ;
+ URL" $pastebin/list" ;
GENERIC: entity-link ( entity -- url )
+: paste-link ( id -- url )
+ <url>
+ "$pastebin/paste" >>path
+ swap "id" set-query-param ;
+
M: paste entity-link
- id>> "id" associate "$pastebin/paste" swap link>string ;
+ id>> paste-link ;
-M: annotation entity-link
- [ parent>> "parent" associate "$pastebin/paste" swap link>string ]
- [ id>> number>string "#" prepend ] bi
- append ;
+: annotation-link ( parent id -- url )
+ <url>
+ "$pastebin/paste" >>path
+ swap number>string >>anchor
+ swap "id" set-query-param ;
-: pastebin-template ( name -- template )
- "resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
+M: annotation entity-link
+ [ parent>> ] [ id>> ] bi annotation-link ;
! ! !
! PASTE LIST
: <pastebin-action> ( -- action )
<page-action>
[ pastes "pastes" set-value ] >>init
- "pastebin" pastebin-template >>template ;
+ "$pastebin/pastebin" >>template ;
: pastebin-feed-entries ( seq -- entries )
<reversed> 20 short head [
swap
[ summary>> >>title ]
[ date>> >>pub-date ]
- [ entity-link >>link ]
+ [ entity-link adjust-url >>link ]
tri
] map ;
<page-action>
[
validate-integer-id
- "id" value paste from-tuple
+ "id" value paste from-object
"id" value
"new-annotation" [
] nest-values
] >>init
- "paste" pastebin-template >>template ;
+ "$pastebin/paste" >>template ;
: paste-feed-entries ( paste -- entries )
fetch-annotations annotations>> pastebin-feed-entries ;
: paste-feed ( paste -- feed )
feed new
swap
- [ "Paste #" swap id>> number>string append >>title ]
- [ entity-link >>link ]
+ [ "Paste " swap id>> number>string append >>title ]
+ [ entity-link adjust-url >>link ]
[ paste-feed-entries >>entries ]
tri ;
: <paste-feed-action> ( -- action )
<feed-action>
[ validate-integer-id ] >>init
- [ "id" value paste annotations>> paste-feed ] >>feed ;
+ [ "id" value paste paste-feed ] >>feed ;
: validate-entity ( -- )
{
mode-names "modes" set-value
] >>init
- "new-paste" pastebin-template >>template
+ "$pastebin/new-paste" >>template
[
validate-entity
f <paste>
[ deposit-entity-slots ]
[ insert-tuple ]
- [ id>> "$pastebin/paste" <id-redirect> ]
+ [ id>> paste-link <redirect> ]
tri
] >>submit ;
[
"id" value <paste> delete-tuples
"id" value f <annotation> delete-tuples
- "$pastebin/list" f <permanent-redirect>
+ URL" $pastebin/list" <redirect>
] >>submit ;
! ! !
! ! !
: <new-annotation-action> ( -- action )
- <page-action>
+ <action>
[
{ { "id" [ v-integer ] } } validate-params
- "id" value "$pastebin/paste" <id-redirect>
+ "id" value paste-link <redirect>
] >>display
[
"id" value f <annotation>
[ deposit-entity-slots ]
[ insert-tuple ]
- [
- ! Add anchor here
- parent>> "$pastebin/paste" <id-redirect>
- ]
+ [ entity-link <redirect> ]
tri
] >>submit ;
[
f "id" value <annotation> select-tuple
[ delete-tuples ]
- [ parent>> "$pastebin/paste" <id-redirect> ]
+ [ parent>> paste-link <redirect> ]
bi
] >>submit ;
<new-annotation-action> "new-annotation" add-responder
<delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
<boilerplate>
- "pastebin-common" pastebin-template >>template ;
+ "$pastebin/pastebin-common" >>template ;
: init-pastes-table \ paste ensure-table ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="Pastebin - Atom" t:href="$pastebin/list.atom" />
-
<t:title>Pastebin</t:title>
<table width="100%">
<th align="left" width="100">Paste by:</th>
<th align="left" width="200">Date:</th>
- <t:each-tuple t:values="pastes">
+ <t:bind-each t:name="pastes">
<tr>
<td><t:a t:href="$pastebin/paste" t:query="id"><t:label t:name="summary" /></t:a></td>
<td><t:label t:name="author" /></td>
<td><t:label t:name="date" /></td>
</tr>
- </t:each-tuple>
+ </t:bind-each>
</table>
</t:chloe>
<t:title>Planet Factor Administration</t:title>
<ul>
- <t:each-tuple t:values="blogroll">
+ <t:bind-each t:name="blogroll">
<li>
<t:a t:href="$planet-factor/admin/edit-blog" t:query="id">
<t:label t:name="name" />
</t:a>
</li>
- </t:each-tuple>
+ </t:bind-each>
</ul>
<p>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:each-tuple t:values="postings">
+ <t:bind-each t:name="postings">
<p class="news">
<strong><t:view t:component="title" /></strong> <br/>
<t:a value="link" t:session="none" class="more">Read More...</t:a>
</p>
- </t:each-tuple>
+ </t:bind-each>
</t:chloe>
USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db fry locals hashtables
-html.components html.templates.chloe
-rss xml.writer
+html.components
+rss urls xml.writer
validators
http.server
-http.server.actions
-http.server.boilerplate
-http.server.auth.login
-http.server.auth ;
+furnace.actions
+furnace.boilerplate
+furnace.auth.login
+furnace.auth ;
IN: webapps.planet
-: planet-template ( name -- template )
- "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
-
TUPLE: blog id name www-url feed-url ;
M: blog link-title name>> ;
: <edit-blogroll-action> ( -- action )
<page-action>
[ blogroll "blogroll" set-value ] >>init
- "admin" planet-template >>template ;
+ "$planet-factor/admin" >>template ;
: <planet-action> ( -- action )
<page-action>
postings "postings" set-value
] >>init
- "planet" planet-template >>template ;
+ "$planet-factor/planet" >>template ;
: planet-feed ( -- feed )
feed new
<action>
[
update-cached-postings
- "" f <permanent-redirect>
+ URL" $planet-factor/admin" <redirect>
] >>submit ;
: <delete-blog-action> ( -- action )
[
"id" value <blog> delete-tuples
- "$planet-factor/admin" f <standard-redirect>
+ URL" $planet-factor/admin" <redirect>
] >>submit ;
: validate-blog ( -- )
{ "feed-url" [ v-url ] }
} validate-params ;
-: <id-redirect> ( id next -- response )
- swap "id" associate <standard-redirect> ;
-
: deposit-blog-slots ( blog -- )
{ "name" "www-url" "feed-url" } deposit-slots ;
: <new-blog-action> ( -- action )
<page-action>
- "new-blog" planet-template >>template
+ "$planet-factor/new-blog" >>template
[ validate-blog ] >>validate
f <blog>
[ deposit-blog-slots ]
[ insert-tuple ]
- [ id>> "$planet-factor/admin/edit-blog" <id-redirect> ]
+ [
+ <url>
+ "$planet-factor/admin/edit-blog" >>path
+ swap id>> "id" set-query-param
+ <redirect>
+ ]
tri
] >>submit ;
<page-action>
[
validate-integer-id
- "id" value <blog> select-tuple from-tuple
+ "id" value <blog> select-tuple from-object
] >>init
- "edit-blog" planet-template >>template
+ "$planet-factor/edit-blog" >>template
[
validate-integer-id
f <blog>
[ deposit-blog-slots ]
[ update-tuple ]
- [ id>> "$planet-factor/admin" <id-redirect> ]
+ [
+ <url>
+ "$planet-factor/admin" >>path
+ swap id>> "id" set-query-param
+ <redirect>
+ ]
tri
] >>submit ;
<feed-action> "feed.xml" add-responder
<planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
<boilerplate>
- "planet-common" planet-template >>template ;
+ "$planet-factor/planet-common" >>template ;
: start-update-task ( db params -- )
'[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;
<tr>
<td>
- <t:each-tuple t:values="postings">
+ <t:bind-each t:name="postings">
<h2 class="posting-title">
<t:a t:value="link" t:session="none"><t:label t:name="title" /></t:a>
<t:a t:value="link" t:session="none"><t:label t:name="pub-date" /></t:a>
</p>
- </t:each-tuple>
+ </t:bind-each>
</td>
<h2>Blogroll</h2>
<ul>
- <t:each t:values="blogroll">
+ <t:each t:name="blogroll">
<li>
<t:link t:name="value"/>
</li>
<input type="SUBMIT" value="Done" />
</t:form>
- <t:if t:value="id">
-
- <t:a t:href="$todo-list/view" t:query="id">View</t:a>
- |
- <t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
-
- </t:if>
+ <t:a t:href="$todo-list/view" t:query="id">View</t:a>
+ |
+ <t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New Item</t:title>
+
+ <t:form t:action="$todo-list/new">
+ <table>
+ <tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:field t:name="priority" /></td></tr>
+ <tr><th class="field-label big-field-label">Description:</th><td><t:textarea t:name="description" t:rows="20" t:cols="60" /></td></tr>
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+ </t:form>
+
+</t:chloe>
<th>Edit</th>
</tr>
- <t:each-tuple t:values="items">
+ <t:bind-each t:name="items">
<tr>
<td>
</td>
</tr>
- </t:each-tuple>
+ </t:bind-each>
</table>
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces
-db db.types db.tuples validators hashtables
+db db.types db.tuples validators hashtables urls
html.components
html.templates.chloe
-http.server.sessions
-http.server.boilerplate
-http.server.auth
-http.server.actions
-http.server.db
-http.server.auth.login
+furnace.sessions
+furnace.boilerplate
+furnace.auth
+furnace.actions
+furnace.db
+furnace.auth.login
http.server ;
IN: webapps.todo
swap >>id
uid >>uid ;
-: todo-template ( name -- template )
- "resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
-
: <view-action> ( -- action )
<page-action>
[
validate-integer-id
- "id" value <todo> select-tuple from-tuple
+ "id" value <todo> select-tuple from-object
] >>init
- "view-todo" todo-template >>template ;
-
-: <id-redirect> ( id next -- response )
- swap "id" associate <standard-redirect> ;
+ "$todo-list/view-todo" >>template ;
: validate-todo ( -- )
{
<page-action>
[ 0 "priority" set-value ] >>init
- "edit-todo" todo-template >>template
+ "$todo-list/new-todo" >>template
[ validate-todo ] >>validate
[
f <todo>
- dup { "summary" "description" } deposit-slots
+ dup { "summary" "priority" "description" } deposit-slots
[ insert-tuple ]
- [ id>> "$todo-list/view" <id-redirect> ]
+ [
+ <url>
+ "$todo-list/view" >>path
+ swap id>> "id" set-query-param
+ <redirect>
+ ]
bi
] >>submit ;
<page-action>
[
validate-integer-id
- "id" value <todo> select-tuple from-tuple
+ "id" value <todo> select-tuple from-object
] >>init
- "edit-todo" todo-template >>template
+ "$todo-list/edit-todo" >>template
[
validate-integer-id
f <todo>
dup { "id" "summary" "priority" "description" } deposit-slots
[ update-tuple ]
- [ id>> "$todo-list/view" <id-redirect> ]
+ [
+ <url>
+ "$todo-list/view" >>path
+ swap id>> "id" set-query-param
+ <redirect>
+ ]
bi
] >>submit ;
[
"id" get <todo> delete-tuples
- "$todo-list/list" f <standard-redirect>
+ URL" $todo-list/list" <redirect>
] >>submit ;
: <list-action> ( -- action )
<page-action>
[ f <todo> select-tuples "items" set-value ] >>init
- "todo-list" todo-template >>template ;
+ "$todo-list/todo-list" >>template ;
TUPLE: todo-list < dispatcher ;
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<boilerplate>
- "todo" todo-template >>template
+ "$todo-list/todo" >>template
f <protected> ;
<div class="navbar">
<t:a t:href="$todo-list/list">List Items</t:a>
- | <t:a t:href="$todo-list/edit">Add Item</t:a>
+ | <t:a t:href="$todo-list/new">Add Item</t:a>
<t:if t:code="http.server.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
<tr>
<th class="field-label big-field-label">Capabilities:</th>
- <td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
+ <td>
+ <t:each t:name="capabilities">
+ <t:checkbox t:name="@value" t:label="@value" /><br/>
+ </t:each>
+ </td>
</tr>
<tr>
<tr>
<th class="field-label big-field-label">Capabilities:</th>
- <td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
+ <td>
+ <t:each t:name="capabilities">
+ <li><t:checkbox t:name="@value" t:label="@value" /><br/>
+ </t:each>
+ </td>
</tr>
</table>
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators words
-assocs db.tuples arrays splitting strings validators
+assocs db.tuples arrays splitting strings validators urls
html.elements
html.components
-html.templates.chloe
-http.server.boilerplate
-http.server.auth.providers
-http.server.auth.providers.db
-http.server.auth.login
-http.server.auth
-http.server.sessions
-http.server.actions
+furnace.boilerplate
+furnace.auth.providers
+furnace.auth.providers.db
+furnace.auth.login
+furnace.auth
+furnace.sessions
+furnace.actions
http.server ;
IN: webapps.user-admin
-: admin-template ( name -- template )
- "resource:extra/webapps/user-admin/" swap ".xml" 3append <chloe> ;
+: word>string ( word -- string )
+ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
: words>strings ( seq -- seq' )
- [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
+ [ word>string ] map ;
+
+: string>word ( string -- word )
+ ":" split1 swap lookup ;
: strings>words ( seq -- seq' )
- [ ":" split1 swap lookup ] map ;
+ [ string>word ] map ;
: <user-list-action> ( -- action )
<page-action>
[ f <user> select-tuples "users" set-value ] >>init
- "user-list" admin-template >>template ;
+ "$user-admin/user-list" >>template ;
+
+: init-capabilities ( -- )
+ capabilities get words>strings "capabilities" set-value ;
+
+: selected-capabilities ( -- seq )
+ "capabilities" value
+ [ param empty? not ] filter
+ [ string>word ] map ;
: <new-user-action> ( -- action )
<page-action>
[
- "username" param <user> from-tuple
- capabilities get words>strings "all-capabilities" set-value
+ "username" param <user> from-object
+ init-capabilities
] >>init
- "new-user" admin-template >>template
+ "$user-admin/new-user" >>template
[
- capabilities get words>strings "all-capabilities" set-value
+ init-capabilities
{
{ "username" [ v-username ] }
"email" value >>email
"new-password" value >>encoded-password
H{ } clone >>profile
+ selected-capabilities >>capabilities
insert-tuple
- "$user-admin" f <standard-redirect>
+ URL" $user-admin" <redirect>
] >>submit ;
: validate-username ( -- )
validate-username
"username" value <user> select-tuple
- [ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi
+ [ from-object ]
+ [ capabilities>> [ "true" swap word>string set-value ] each ] bi
- capabilities get words>strings "all-capabilities" set-value
+ capabilities get words>strings "capabilities" set-value
] >>init
- "edit-user" admin-template >>template
+ "$user-admin/edit-user" >>template
[
- capabilities get words>strings "all-capabilities" set-value
+ init-capabilities
{
{ "username" [ v-username ] }
{ "new-password" [ [ v-password ] v-optional ] }
{ "verify-password" [ [ v-password ] v-optional ] }
{ "email" [ [ v-email ] v-optional ] }
- { "capabilities" [ ] }
} validate-params
"new-password" "verify-password"
"username" value <user> select-tuple
"realname" value >>realname
"email" value >>email
+ selected-capabilities >>capabilities
"new-password" value empty? [
"new-password" value >>encoded-password
] unless
- "capabilities" value {
- { [ dup string? ] [ 1array ] }
- { [ dup array? ] [ ] }
- } cond strings>words >>capabilities
-
update-tuple
- "$user-admin" f <standard-redirect>
+ URL" $user-admin" <redirect>
] >>submit ;
: <delete-user-action> ( -- action )
[ logout-all-sessions ]
bi
- "$user-admin" f <standard-redirect>
+ URL" $user-admin" <redirect>
] >>submit ;
TUPLE: user-admin < dispatcher ;
<edit-user-action> "edit" add-responder
<delete-user-action> "delete" add-responder
<boilerplate>
- "user-admin" admin-template >>template
+ "$user-admin/user-admin" >>template
{ can-administer-users? } <protected> ;
: make-admin ( username -- )
<ul>
- <t:each-tuple t:values="users">
+ <t:bind-each t:name="users">
<li>
<t:a t:href="$user-admin/edit" t:query="username">
<t:label t:name="username" />
</t:a>
</li>
- </t:each-tuple>
+ </t:bind-each>
</ul>
<t:title>All Articles</t:title>
<ul>
- <t:each-tuple t:values="articles">
+ <t:bind-each t:name="articles">
<li>
<t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
</li>
- </t:each-tuple>
+ </t:bind-each>
</ul>
</t:chloe>
<t:title>Recent Changes</t:title>
<ul>
- <t:each-tuple t:values="changes">
+ <t:bind-each t:name="changes">
<li>
<t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
on
by
<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
</li>
- </t:each-tuple>
+ </t:bind-each>
</ul>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:bind-tuple t:name="old">
+ <t:bind t:name="old">
<t:title>Diff: <t:label t:name="title" /></t:title>
- </t:bind-tuple>
+ </t:bind>
<table>
<tr>
<th class="field-label">Old revision:</th>
- <t:bind-tuple t:name="old">
+ <t:bind t:name="old">
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
- </t:bind-tuple>
+ </t:bind>
</tr>
<tr>
<th class="field-label">New revision:</th>
- <t:bind-tuple t:name="old">
+ <t:bind t:name="old">
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
- </t:bind-tuple>
+ </t:bind>
</tr>
</table>
<t:comparison t:name="diff" />
- <t:bind-tuple t:name="old">
+ <t:bind t:name="old">
<div class="navbar">
<t:a t:href="$wiki/view" t:query="title">Latest</t:a>
| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
</div>
- </t:bind-tuple>
+ </t:bind>
</t:chloe>
<t:title>Revisions of <t:label t:name="title" /></t:title>
- <ul>
- <t:each-tuple t:values="revisions">
- <li>
- <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
- by
- <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
- </li>
- </t:each-tuple>
- </ul>
+ <div class="revisions">
+ <table>
+ <tr>
+ <th>Revision</th>
+ <th>Author</th>
+ <th>Rollback</th>
+ </tr>
+
+ <t:bind-each t:name="revisions">
+ <tr>
+ <td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td>
+ <td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td>
+ <td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
+ </tr>
+ </t:bind-each>
+ </table>
+ </div>
<h2>View Differences</h2>
<td>
<select name="old-id">
- <t:each-tuple t:values="revisions">
+ <t:bind-each t:name="revisions">
<option> <t:label t:name="id" /> </option>
- </t:each-tuple>
+ </t:bind-each>
</select>
</td>
</tr>
<td>
<select name="new-id">
- <t:each-tuple t:values="revisions">
+ <t:bind-each t:name="revisions">
<option> <t:label t:name="id" /> </option>
- </t:each-tuple>
+ </t:bind-each>
</select>
</td>
</tr>
<input type="submit" value="View" />
</form>
+ <br/>
+
+ <div class="navbar">
+ <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
+ | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
+ | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+ | <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
+ </div>
+
</t:chloe>
<t:title>Edits by <t:label t:name="author" /></t:title>
<ul>
- <t:each-tuple t:values="user-edits">
+ <t:bind-each t:name="user-edits">
<li>
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
on
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
</li>
- </t:each-tuple>
+ </t:bind-each>
</ul>
</t:chloe>
-.comparison table, {
- border-color: #666;
- border-style: solid;
-}
-
.comparison th {
border-width: 1px;
border-color: #666;
}
.comparison table {
+ border-color: #666;
+ border-style: solid;
border-width: 1px;
border-spacing: 0;
border-collapse: collapse;
}
-
.insert {
background-color: #9f9;
}
.delete {
background-color: #f99;
}
+
+.revisions table, .revisions td, .revisions th {
+ border-color: #666;
+ border-style: solid;
+}
+
+.revisions table {
+ border-width: 0 0 1px 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+.revisions td, .revisions th {
+ margin: 0;
+ padding: 4px;
+ border-width: 1px 1px 0 0;
+}
+
USING: accessors kernel hashtables calendar
namespaces splitting sequences sorting math.order
html.components
-html.templates.chloe
http.server
-http.server.actions
-http.server.auth
-http.server.auth.login
-http.server.boilerplate
+furnace.actions
+furnace.auth
+furnace.auth.login
+furnace.boilerplate
validators
-db.types db.tuples lcs farkup ;
+db.types db.tuples lcs farkup urls ;
IN: webapps.wiki
TUPLE: article title revision ;
: init-revisions-table revision ensure-table ;
-: wiki-template ( name -- template )
- "resource:extra/webapps/wiki/" swap ".xml" 3append <chloe> ;
-
-: <title-redirect> ( title next -- response )
- swap "title" associate <standard-redirect> ;
-
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;
: <main-article-action> ( -- action )
<action>
- [ "Front Page" "$wiki/view" <title-redirect> ] >>display ;
+ [
+ <url>
+ "$wiki/view" >>path
+ "Front Page" "title" set-query-param
+ <redirect>
+ ] >>display ;
: <view-article-action> ( -- action )
<action>
[
"title" value dup <article> select-tuple [
- revision>> <revision> select-tuple from-tuple
- "view" wiki-template <html-content>
+ revision>> <revision> select-tuple from-object
+ "$wiki/view" <chloe-content>
] [
- "$wiki/edit" <title-redirect>
+ <url>
+ "$wiki/edit" >>path
+ swap "title" set-query-param
+ <redirect>
] ?if
] >>display ;
[
{ { "id" [ v-integer ] } } validate-params
"id" value <revision>
- select-tuple from-tuple
+ select-tuple from-object
] >>init
- "view" wiki-template >>template ;
+ "$wiki/view" >>template ;
: add-revision ( revision -- )
[ insert-tuple ]
[
validate-title
"title" value <article> select-tuple [
- revision>> <revision> select-tuple from-tuple
+ revision>> <revision> select-tuple from-object
] when*
] >>init
- "edit" wiki-template >>template
+ "$wiki/edit" >>template
[
validate-title
logged-in-user get username>> >>author
"content" value >>content
[ add-revision ]
- [ title>> "$wiki/view" <title-redirect> ] bi
+ [
+ <url>
+ "$wiki/view" >>path
+ swap title>> "title" set-query-param
+ <redirect>
+ ] bi
] >>submit ;
: <list-revisions-action> ( -- action )
"revisions" set-value
] >>init
- "revisions" wiki-template >>template ;
+ "$wiki/revisions" >>template ;
+
+: <rollback-action> ( -- action )
+ <action>
+ [
+ { { "id" [ v-integer ] } } validate-params
+ ] >>validate
+
+ [
+ "id" value <revision> select-tuple clone f >>id
+ [ add-revision ]
+ [
+ <url>
+ "$wiki/view" >>path
+ swap title>> "title" set-query-param
+ <redirect>
+ ] bi
+ ] >>submit ;
: <list-changes-action> ( -- action )
<page-action>
"changes" set-value
] >>init
- "changes" wiki-template >>template ;
+ "$wiki/changes" >>template ;
: <delete-action> ( -- action )
<action>
[
"title" value <article> delete-tuples
f <revision> "title" value >>title delete-tuples
- "" f <standard-redirect>
+ URL" $wiki" <redirect>
] >>submit ;
: <diff-action> ( -- action )
2bi
] >>init
- "diff" wiki-template >>template ;
+ "$wiki/diff" >>template ;
: <list-articles-action> ( -- action )
<page-action>
"articles" set-value
] >>init
- "articles" wiki-template >>template ;
+ "$wiki/articles" >>template ;
: <user-edits-action> ( -- action )
<page-action>
select-tuples "user-edits" set-value
] >>init
- "user-edits" wiki-template >>template ;
+ "$wiki/user-edits" >>template ;
TUPLE: wiki < dispatcher ;
<view-article-action> "view" add-responder
<view-revision-action> "revision" add-responder
<list-revisions-action> "revisions" add-responder
+ <rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder
<diff-action> "diff" add-responder
<list-articles-action> "articles" add-responder
<edit-article-action> { } <protected> "edit" add-responder
<delete-action> { } <protected> "delete" add-responder
<boilerplate>
- "wiki-common" wiki-template >>template ;
+ "$wiki/wiki-common" >>template ;
USING: xmode.tokens xmode.marker xmode.catalog kernel
html.elements io io.files sequences words io.encodings.utf8
-namespaces xml.entities ;
+namespaces xml.entities accessors ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- )
[
- dup token-str swap token-id [
+ [ str>> ] [ id>> ] bi [
<span word-name =class span> escape-string write </span>
] [
- write
+ escape-string write
] if*
] each ;
, utf8 [\r
, file-name input-stream get htmlize-stream\r
] with-file-reader\r
- ] <html-content>\r
+ ] "text/html" <content>\r
] <file-responder> ;\r
projects / factor.git / commitdiff