! 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
+USING: accessors sequences kernel assocs combinators\r
validators http hashtables namespaces fry continuations locals\r
-boxes xml.entities html.elements html.components\r
-html.templates.chloe io arrays math ;\r
+io arrays math boxes\r
+xml.entities\r
+http.server\r
+http.server.responses\r
+furnace\r
+html.elements\r
+html.components\r
+html.templates.chloe\r
+html.templates.chloe.syntax ;\r
IN: furnace.actions\r
\r
SYMBOL: params\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
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors assocs namespaces kernel sequences sets\r
http.server\r
+http.server.filters\r
+http.server.dispatchers\r
furnace.sessions\r
furnace.auth.providers ;\r
IN: furnace.auth\r
urls\r
http\r
http.server\r
+http.server.dispatchers\r
+http.server.filters\r
+http.server.responses\r
+furnace\r
furnace.auth\r
furnace.auth.providers\r
furnace.auth.providers.db\r
\r
! ! ! Login\r
: successful-login ( user -- response )\r
- username>> set-uid "$login" end-flow ;\r
+ username>> set-uid URL" $login" end-flow ;\r
\r
: login-failed ( -- * )\r
"invalid username or password" validation-error\r
\r
: <login-action> ( -- action )\r
<page-action>\r
- "$login/login" >>template\r
+ { login "login" } >>template\r
\r
[\r
{\r
\r
: <register-action> ( -- action )\r
<page-action>\r
- "$login/register" >>template\r
+ { login "register" } >>template\r
\r
[\r
{\r
tri\r
] >>init\r
\r
- "$login/edit-profile" >>template\r
+ { login "edit-profile" } >>template\r
\r
[\r
uid "username" set-value\r
\r
drop\r
\r
- "$login" end-flow\r
+ URL" $login" end-flow\r
] >>submit ;\r
\r
! ! ! Password recovery\r
\r
: <recover-action-1> ( -- action )\r
<page-action>\r
- "$login/recover-1" >>template\r
+ { login "recover-1" } >>template\r
\r
[\r
{\r
\r
: <recover-action-2> ( -- action )\r
<page-action>\r
- "$login/recover-2" >>template ;\r
+ { login "recover-2" } >>template ;\r
\r
: <recover-action-3> ( -- action )\r
<page-action>\r
} validate-params\r
] >>init\r
\r
- "$login/recover-3" >>template\r
+ { login "recover-3" } >>template\r
\r
[\r
{\r
\r
URL" $login/recover-4" <redirect>\r
] [\r
- <400>\r
+ <403>\r
] if*\r
] >>submit ;\r
\r
: <recover-action-4> ( -- action )\r
<page-action>\r
- "$login/recover-4" >>template ;\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
+ URL" $login" end-flow\r
] >>submit ;\r
\r
! ! ! Authentication logic\r
\r
: <login-boilerplate> ( responder -- responder' )\r
<boilerplate>\r
- "$login/boilerplate" >>template ;\r
+ { login "boilerplate" } >>template ;\r
\r
: <login> ( responder -- auth )\r
login new-dispatcher\r
</t:form>
<p>
- <t:if code="http.server.auth.login:login-failed?">
+ <t:if t:code="furnace.auth.login:allow-registration?">
<t:a t:href="register">Register</t:a>
</t:if>
|
- <t:if code="http.server.auth.login:allow-password-recovery?">
+ <t:if t:code="furnace.auth.login:allow-password-recovery?">
<t:a t:href="recover-password">Recover Password</t:a>
</t:if>
</p>
! 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 ;
+USING: accessors kernel namespaces
+html.templates html.templates.chloe
+locals
+http.server
+http.server.filters
+furnace ;
IN: furnace.boilerplate
TUPLE: boilerplate < filter-responder template ;
+++ /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
! 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
+USING: kernel accessors continuations namespaces destructors\r
+db db.pools io.pools http.server http.server.filters\r
+furnace.sessions ;\r
IN: furnace.db\r
\r
TUPLE: db-persistence < filter-responder pool ;\r
! 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 ;
+furnace http http.server http.server.filters furnace.sessions
+html.elements html.templates.chloe.syntax ;
IN: furnace.flows
TUPLE: flows < filter-responder ;
--- /dev/null
+IN: furnace.tests
+USING: http.server.dispatchers http.server.responses
+http.server furnace tools.test kernel namespaces accessors ;
+TUPLE: funny-dispatcher < dispatcher ;
+
+: <funny-dispatcher> funny-dispatcher new-dispatcher ;
+
+TUPLE: base-path-check-responder ;
+
+C: <base-path-check-responder> base-path-check-responder
+
+M: base-path-check-responder call-responder*
+ 2drop
+ "$funny-dispatcher" resolve-base-path
+ "text/plain" <content> ;
+
+[ ] [
+ <dispatcher>
+ <dispatcher>
+ <funny-dispatcher>
+ <base-path-check-responder> "c" add-responder
+ "b" add-responder
+ "a" add-responder
+ main-responder set
+] unit-test
+
+[ "/a/b/" ] [
+ V{ } responder-nesting set
+ "a/b/c" split-path main-responder get call-responder body>>
+] unit-test
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel combinators assocs
+continuations namespaces sequences splitting words
+vocabs.loader classes
+fry urls multiline
+xml
+xml.data
+xml.writer
+xml.utilities
+html.components
+html.elements
+html.templates
+html.templates.chloe
+html.templates.chloe.syntax
+http
+http.server
+http.server.redirection
+http.server.responses
+qualified ;
+QUALIFIED-WITH: assocs a
IN: furnace
+: nested-responders ( -- seq )
+ responder-nesting get a:values ;
+
+: each-responder ( quot -- )
+ nested-responders swap each ; inline
+
+: base-path ( string -- pair )
+ dup responder-nesting get
+ [ second class word-name = ] with find nip
+ [ first ] [ "No such responder: " swap append throw ] ?if ;
+
+: resolve-base-path ( string -- string' )
+ "$" ?head [
+ [
+ "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
+ ] "" make
+ ] when ;
+
+: vocab-path ( vocab -- path )
+ dup vocab-dir vocab-append-path ;
+
+: resolve-template-path ( pair -- path )
+ [
+ first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi*
+ ] "" make ;
+
+GENERIC: modify-query ( query responder -- query' )
+
+M: object modify-query drop ;
+
+: adjust-url ( url -- url' )
+ clone
+ [ [ modify-query ] each-responder ] change-query
+ [ resolve-base-path ] change-path
+ relative-to-request ;
+
+: <redirect> ( url -- response )
+ adjust-url request get method>> {
+ { "GET" [ <temporary-redirect> ] }
+ { "HEAD" [ <temporary-redirect> ] }
+ { "POST" [ <permanent-redirect> ] }
+ } case ;
+
GENERIC: hidden-form-field ( responder -- )
M: object hidden-form-field drop ;
{ "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 ;
<url>
swap >>query
swap >>path
- adjust-url
+ adjust-url relative-to-request
add-atom-feed ;
CHLOE: write-atom drop write-atom-feeds ;
<url>
swap >>query
swap >>path
- adjust-url =href
+ adjust-url relative-to-request =href
a>
] with-scope ;
[ 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>
] 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 ;
+ "code" required-attr attr>word execute ;
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: json.writer http.server.responses ;
+IN: furnace.json
+
+: <json-content> ( body -- response )
+ >json "application/json" <content> ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel fry
+rss http.server.responses furnace.actions ;
+IN: furnace.rss
+
+: <feed-content> ( body -- response )
+ feed>xml "application/atom+xml" <content> ;
+
+TUPLE: feed-action < action feed ;
+
+: <feed-action> ( -- feed )
+ feed-action new-action
+ dup '[ , feed>> call <feed-content> ] >>display ;
IN: furnace.sessions.tests\r
USING: tools.test http furnace.sessions\r
-furnace.actions http.server math namespaces kernel accessors\r
+furnace.actions http.server http.server.responses\r
+math namespaces kernel accessors\r
prettyprint io.streams.string io.files splitting destructors\r
-sequences db db.sqlite continuations urls ;\r
+sequences db db.sqlite continuations urls math.parser\r
+furnace ;\r
\r
: with-session\r
[\r
random accessors quotations hashtables sequences continuations
fry calendar combinators destructors alarms
db db.tuples db.types
-http http.server html.elements html.templates.chloe ;
+http http.server http.server.dispatchers http.server.filters
+html.elements furnace ;
IN: furnace.sessions
TUPLE: session id expires uid namespace changed? ;
: 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 ;
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
<head> <title> swap write </title> </head>
<body> call </body>
- </html> ;
+ </html> ; inline
: render-error ( message -- )
<span "error" =class span> escape-string write </span> ;
[
[
"test2" test-template call-template
- ] "test3" test-template with-boilerplate
+ ] [ "test3" test-template ] with-boilerplate
] run-template
] unit-test
] run-template
] unit-test
-SYMBOL: test6-aux?
-
-[ "True" ] [
- [
- test6-aux? on
- "test6" test-template call-template
- ] run-template
-] unit-test
-
-SYMBOL: test7-aux?
-
-[ "" ] [
- [
- test7-aux? off
- "test7" test-template call-template
- ] run-template
-] unit-test
-
[ ] [ blank-values ] unit-test
[ ] [ "A label" "label" set-value ] unit-test
[ "<ul><li>1</li><li>2</li><li>3</li></ul>" ] [
[
- "test9" test-template call-template
+ "test7" test-template call-template
] run-template [ blank? not ] filter
] unit-test
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
[
- "test10" test-template call-template
+ "test8" test-template call-template
] run-template [ blank? not ] filter
] unit-test
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
[
- "test10" test-template call-template
+ "test9" test-template call-template
] run-template [ blank? not ] filter
] unit-test
[ "<a name=\"1\">Hello</a>" ] [
[
- "test11" test-template call-template
+ "test10" test-template call-template
] run-template
] unit-test
IN: html.templates.chloe
! Chloe is Ed's favorite web designer
+SYMBOL: tag-stack
TUPLE: chloe path ;
CHLOE: write-title
drop
- "head" tags get member? "title" tags get member? not and
+ "head" tag-stack get member?
+ "title" tag-stack get member? not and
[ <title> write-title </title> ] [ write-title ] if ;
CHLOE: style
CHLOE-SINGLETON: hidden
CHLOE-TUPLE: field
+CHLOE-TUPLE: textarea
CHLOE-TUPLE: password
CHLOE-TUPLE: choice
CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
: process-chloe-tag ( tag -- )
- dup name-tag tags get at
+ dup name-tag dup tags get at
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
: process-tag ( tag -- )
{
- [ name-tag >lower tags get push ]
+ [ name-tag >lower tag-stack get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
- [ drop tags get pop* ]
+ [ drop tag-stack get pop* ]
} cleave ;
: expand-attrs ( tag -- tag )
: process-chloe ( xml -- )
[
- V{ } clone tags set
+ V{ } clone tag-stack set
nested-template? get [
process-template
tags global [ H{ } clone or ] change-at
-: define-chloe-tag ( name quot -- ) tags get set-at ;
+: define-chloe-tag ( name quot -- ) swap tags get set-at ;
: CHLOE:
- scan parse-definition swap define-chloe-tag ;
- parsing
+ scan parse-definition define-chloe-tag ; parsing
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
[ "name" required-attr ] dip render ;
: CHLOE-SINGLETON:
- scan dup '[ , singleton-component-tag ] define-chloe-tag ;
+ scan-word
+ [ word-name ] [ '[ , singleton-component-tag ] ] bi
+ define-chloe-tag ;
parsing
: attrs>slots ( tag tuple -- )
2bi render ;
: CHLOE-TUPLE:
- scan dup '[ , tuple-component-tag ] define-chloe-tag ;
+ scan-word
+ [ word-name ] [ '[ , tuple-component-tag ] ] bi
+ define-chloe-tag ;
parsing
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:if t:var="html.templates.chloe.tests:test6-aux?">
- True
- </t:if>
+ <t:label t:name="label" />
+
+ <t:link t:name="link" />
+
+ <t:code t:name="code" mode="mode" />
+
+ <t:farkup t:name="farkup" />
+
+ <t:inspector t:name="inspector" />
+
+ <t:html t:name="html" />
+
+ <t:field t:name="field" t:size="13" />
+
+ <t:password t:name="password" t:size="10" />
+
+ <t:textarea t:name="textarea" t:rows="5" t:cols="10" />
+
+ <t:choice t:name="choice" t:choices="choices" />
+
+ <t:checkbox t:name="checkbox">Checkbox</t:checkbox>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:if t:var="html.templates.chloe.tests:test7-aux?">
- True
- </t:if>
+ <ul>
+ <t:each t:name="numbers">
+ <li><t:label t:name="value"/></li>
+ </t:each>
+ </ul>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:label t:name="label" />
-
- <t:link t:name="link" />
-
- <t:code t:name="code" mode="mode" />
-
- <t:farkup t:name="farkup" />
-
- <t:inspector t:name="inspector" />
-
- <t:html t:name="html" />
-
- <t:field t:name="field" t:size="13" />
-
- <t:password t:name="password" t:size="10" />
-
- <t:textarea t:name="textarea" t:rows="5" t:cols="10" />
-
- <t:choice t:name="choice" t:choices="choices" />
-
- <t:checkbox t:name="checkbox">Checkbox</t:checkbox>
+ <table>
+ <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:bind-each>
+ </table>
</t:chloe>
<?xml version='1.0' ?>
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <ul>
- <t:each t:name="numbers">
- <li><t:label t:name="value"/></li>
- </t:each>
- </ul>
-
-</t:chloe>
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><a name="@id">Hello</a></t:chloe>
[
TUPLE{ request
- url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" query: H{ } }
+ url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" }
method: "GET"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
}
] [
- [
- "http://www.apple.com/index.html"
- <get-request>
- ] with-scope
+ "http://www.apple.com/index.html"
+ <get-request>
] unit-test
[
TUPLE{ request
- url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" query: H{ } }
+ url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" }
method: "GET"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
}
] [
- [
- "https://www.amazon.com/index.html"
- <get-request>
- ] with-scope
+ "https://www.amazon.com/index.html"
+ <get-request>
] unit-test
io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors math.order
io.encodings.8-bit io.encodings.binary io.streams.duplex
-fry debugger inspector ascii ;
+fry debugger inspector ascii urls ;
IN: http.client
: max-redirects 10 ;
SYMBOL: redirects
+: redirect-url ( request url -- request )
+ '[ , >url derive-url ensure-port ] change-url ;
+
: do-redirect ( response data -- response data )
over code>> 300 399 between? [
drop
redirects inc
redirects get max-redirects < [
request get
- swap "location" header request-with-url
+ swap "location" header redirect-url
"GET" >>method http-request
] [
too-many-redirects
: <get-request> ( url -- request )
<request>
- swap request-with-url
- "GET" >>method ;
+ "GET" >>method
+ swap >url ensure-port >>url ;
: http-get* ( url -- response data )
<get-request> http-request ;
: <post-request> ( content-type content url -- request )
<request>
"POST" >>method
- swap request-with-url
+ swap >url ensure-port >>url
swap >>post-data
swap >>post-data-type ;
assocs io.sockets db db.sqlite continuations urls ;
IN: http.tests
-[ "/" ] [ "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
-
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
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 ;
+accessors namespaces threads
+http.server.responses http.server.redirection
+http.server.dispatchers ;
: add-quit-action
<action>
"resource:extra/http/test" <static> >>default
"nested" add-responder
<action>
- [ URL" redirect-loop" <redirect> ] >>display
+ [ URL" redirect-loop" <temporary-redirect> ] >>display
"redirect-loop" add-responder
main-responder set
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format
-io io.streams.string io.encodings.utf8 io.encodings.string
-io.sockets io.sockets.secure io.server
+io io.server io.sockets.secure
unicode.case unicode.categories qualified
IN: http
-: secure-protocol? ( protocol -- ? )
- "https" = ;
-
-: url-addr ( url -- addr )
- [ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
- secure-protocol? [ <secure> ] when ;
-
-: protocol-port ( protocol -- port )
- {
- { "http" [ 80 ] }
- { "https" [ 443 ] }
- } case ;
-
-: ensure-port ( url -- url' )
- dup protocol>> '[ , protocol-port or ] change-port ;
-
: crlf "\r\n" write ;
: add-header ( value key assoc -- )
"close" "connection" set-header
"Factor http.client vocabulary" "user-agent" set-header ;
-: chop-hostname ( str -- str' )
- ":" split1 "//" ?head drop nip
- CHAR: / over index over length or tail
- dup empty? [ drop "/" ] when ;
-
-: url>path ( url -- path )
- #! Technically, only proxies are meant to support hostnames
- #! in HTTP requests, but IE sends these sometimes so we
- #! just chop the hostname part.
- url-decode
- dup { "http://" "https://" } [ head? ] with contains?
- [ chop-hostname ] when ;
-
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
>>method ;
flush
drop ;
-: request-with-url ( request url -- request )
- '[ , >url derive-url ensure-port ] change-url ;
-
GENERIC: write-response ( response -- )
GENERIC: write-full-response ( request response -- )
: <raw-response> ( -- response )
raw-response new
- "1.1" >>version ;
+ "1.1" >>version ;
M: raw-response write-response ( respose -- )
write-response-version
--- /dev/null
+USING: http.server http.server.dispatchers http.server.responses
+tools.test kernel namespaces accessors io http math sequences
+assocs arrays classes words urls ;
+IN: http.server.dispatchers.tests
+
+\ find-responder must-infer
+\ http-error. must-infer
+
+TUPLE: mock-responder path ;
+
+C: <mock-responder> mock-responder
+
+M: mock-responder call-responder*
+ nip
+ path>> on
+ [ ] "text/plain" <content> ;
+
+: check-dispatch ( tag path -- ? )
+ V{ } clone responder-nesting set
+ over off
+ split-path
+ main-responder get call-responder
+ write-response get ;
+
+[
+ <dispatcher>
+ "foo" <mock-responder> "foo" add-responder
+ "bar" <mock-responder> "bar" add-responder
+ <dispatcher>
+ "123" <mock-responder> "123" add-responder
+ "default" <mock-responder> >>default
+ "baz" add-responder
+ main-responder set
+
+ [ "foo" ] [
+ { "foo" } main-responder get find-responder path>> nip
+ ] unit-test
+
+ [ "bar" ] [
+ { "bar" } main-responder get find-responder path>> nip
+ ] unit-test
+
+ [ t ] [ "foo" "foo" check-dispatch ] unit-test
+ [ f ] [ "foo" "bar" check-dispatch ] unit-test
+ [ t ] [ "bar" "bar" check-dispatch ] unit-test
+ [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
+ [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test
+ [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
+ [ t ] [ "123" "baz/123" check-dispatch ] unit-test
+ [ t ] [ "123" "baz///123" check-dispatch ] unit-test
+
+] with-scope
+
+[
+ <dispatcher>
+ "default" <mock-responder> >>default
+ main-responder set
+
+ [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
+] with-scope
+
+! Make sure path for default responder isn't chopped
+TUPLE: path-check-responder ;
+
+C: <path-check-responder> path-check-responder
+
+M: path-check-responder call-responder*
+ drop
+ >array "text/plain" <content> ;
+
+[ { "c" } ] [
+ V{ } clone responder-nesting set
+
+ { "b" "c" }
+ <dispatcher>
+ <dispatcher>
+ <path-check-responder> >>default
+ "b" add-responder
+ call-responder
+ body>>
+] unit-test
+
+! Test that "" dispatcher works with default>>
+[ ] [
+ <dispatcher>
+ "" <mock-responder> "" add-responder
+ "bar" <mock-responder> "bar" add-responder
+ "baz" <mock-responder> >>default
+ main-responder set
+
+ [ t ] [ "" "" check-dispatch ] unit-test
+ [ f ] [ "" "quux" check-dispatch ] unit-test
+ [ t ] [ "baz" "quux" check-dispatch ] unit-test
+ [ f ] [ "foo" "bar" check-dispatch ] unit-test
+ [ t ] [ "bar" "bar" check-dispatch ] unit-test
+ [ t ] [ "baz" "xxx" check-dispatch ] unit-test
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces sequences assocs accessors
+http http.server http.server.responses ;
+IN: http.server.dispatchers
+
+TUPLE: dispatcher default responders ;
+
+: new-dispatcher ( class -- dispatcher )
+ new
+ <404> <trivial-responder> >>default
+ H{ } clone >>responders ; inline
+
+: <dispatcher> ( -- dispatcher )
+ dispatcher new-dispatcher ;
+
+: find-responder ( path dispatcher -- path responder )
+ over empty? [
+ "" over responders>> at*
+ [ nip ] [ drop default>> ] if
+ ] [
+ over first over responders>> at*
+ [ [ drop rest-slice ] dip ] [ drop default>> ] if
+ ] if ;
+
+M: dispatcher call-responder* ( path dispatcher -- response )
+ find-responder call-responder ;
+
+TUPLE: vhost-dispatcher default responders ;
+
+: <vhost-dispatcher> ( -- dispatcher )
+ vhost-dispatcher new-dispatcher ;
+
+: find-vhost ( dispatcher -- responder )
+ request get url>> host>> over responders>> at*
+ [ nip ] [ drop default>> ] if ;
+
+M: vhost-dispatcher call-responder* ( path dispatcher -- response )
+ find-vhost call-responder ;
+
+: add-responder ( dispatcher responder path -- dispatcher )
+ pick responders>> set-at ;
+
+: add-main-responder ( dispatcher responder path -- dispatcher )
+ [ add-responder drop ]
+ [ drop "" add-responder drop ]
+ [ 2drop ] 3tri ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.server accessors ;
+IN: http.server.filters
+
+TUPLE: filter-responder responder ;
+
+M: filter-responder call-responder*
+ responder>> call-responder ;
--- /dev/null
+IN: http.server.redirection.tests
+USING: http http.server.redirection urls accessors
+namespaces tools.test ;
+
+\ relative-to-request must-infer
+
+[
+ <request>
+ <url>
+ "http" >>protocol
+ "www.apple.com" >>host
+ "/xxx/bar" >>path
+ { { "a" "b" } } >>query
+ >>url
+ request set
+
+ [ "http://www.apple.com:80/xxx/bar" ] [
+ <url> relative-to-request url>string
+ ] unit-test
+
+ [ "http://www.apple.com:80/xxx/baz" ] [
+ <url> "baz" >>path relative-to-request url>string
+ ] unit-test
+
+ [ "http://www.apple.com:80/xxx/baz?c=d" ] [
+ <url> "baz" >>path { { "c" "d" } } >>query relative-to-request url>string
+ ] unit-test
+
+ [ "http://www.apple.com:80/xxx/bar?c=d" ] [
+ <url> { { "c" "d" } } >>query relative-to-request url>string
+ ] unit-test
+
+ [ "http://www.apple.com:80/flip" ] [
+ <url> "/flip" >>path relative-to-request url>string
+ ] unit-test
+
+ [ "http://www.apple.com:80/flip?c=d" ] [
+ <url> "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string
+ ] unit-test
+
+ [ "http://www.jedit.org:80/" ] [
+ "http://www.jedit.org" >url relative-to-request url>string
+ ] unit-test
+
+ [ "http://www.jedit.org:80/?a=b" ] [
+ "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string
+ ] unit-test
+] with-scope
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators namespaces
+logging urls http http.server http.server.responses ;
+IN: http.server.redirection
+
+: relative-to-request ( url -- url' )
+ request get url>>
+ clone
+ f >>query
+ swap derive-url ensure-port ;
+
+: <custom-redirect> ( url code message -- response )
+ <trivial-response>
+ swap dup url? [ relative-to-request ] when
+ "location" set-header ;
+
+\ <custom-redirect> DEBUG add-input-logging
+
+: <permanent-redirect> ( url -- response )
+ 301 "Moved Permanently" <custom-redirect> ;
+
+: <temporary-redirect> ( url -- response )
+ 307 "Temporary Redirect" <custom-redirect> ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: html.elements math.parser http accessors kernel
+io io.streams.string ;
+IN: http.server.responses
+
+: <content> ( body content-type -- response )
+ <response>
+ 200 >>code
+ "Document follows" >>message
+ swap >>content-type
+ swap >>body ;
+
+: trivial-response-body ( code message -- )
+ <html>
+ <body>
+ <h1> [ number>string write bl ] [ write ] bi* </h1>
+ </body>
+ </html> ;
+
+: <trivial-response> ( code message -- response )
+ 2dup [ trivial-response-body ] with-string-writer
+ "text/html" <content>
+ swap >>message
+ swap >>code ;
+
+: <304> ( -- response )
+ 304 "Not modified" <trivial-response> ;
+
+: <403> ( -- response )
+ 403 "Forbidden" <trivial-response> ;
+
+: <400> ( -- response )
+ 400 "Bad request" <trivial-response> ;
+
+: <404> ( -- response )
+ 404 "Not found" <trivial-response> ;
! Copyright (C) 2003, 2008 Slava Pestov.
! 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.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 ;
+USING: kernel accessors sequences arrays namespaces splitting
+vocabs.loader http http.server.responses logging calendar
+destructors html.elements html.streams io.server
+io.encodings.8-bit io.timeouts io assocs debugger continuations
+fry tools.vocabs math ;
IN: http.server
+SYMBOL: responder-nesting
+
+SYMBOL: main-responder
+
+SYMBOL: development-mode
+
! path is a sequence of path component strings
GENERIC: call-responder* ( path responder -- response )
-: <content> ( body content-type -- response )
- <response>
- 200 >>code
- "Document follows" >>message
- swap >>content-type
- swap >>body ;
-
TUPLE: trivial-responder response ;
C: <trivial-responder> trivial-responder
-M: trivial-responder call-responder* nip response>> call ;
+M: trivial-responder call-responder* nip response>> clone ;
-: trivial-response-body ( code message -- )
- <html>
- <body>
- <h1> [ number>string write bl ] [ write ] bi* </h1>
- </body>
- </html> ;
-
-: <trivial-response> ( code message -- response )
- 2dup [ trivial-response-body ] with-string-writer
- "text/html" <content>
- swap >>message
- swap >>code ;
-
-: <400> ( -- response )
- 400 "Bad request" <trivial-response> ;
-
-: <404> ( -- response )
- 404 "Not Found" <trivial-response> ;
-
-SYMBOL: 404-responder
-
-[ <404> ] <trivial-responder> 404-responder set-global
-
-SYMBOL: responder-nesting
+main-responder global [ <404> <trivial-responder> get-global or ] change-at
: invert-slice ( slice -- slice' )
- dup slice? [
- [ seq>> ] [ from>> ] bi head-slice
- ] [
- drop { }
- ] if ;
-
-: vocab-path ( vocab -- path )
- dup vocab-dir vocab-append-path ;
-
-: vocab-path-of ( dispatcher -- path )
- class word-vocabulary vocab-path ;
+ dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
-: add-responder-path ( path dispatcher -- )
- [ [ invert-slice ] [ [ vocab-path-of ] keep ] bi* 3array ]
- [ nip class word-name ] 2bi
- responder-nesting get set-at ;
+: add-responder-nesting ( path responder -- )
+ [ invert-slice ] dip 2array responder-nesting get push ;
: call-responder ( path responder -- response )
- [ add-responder-path ] [ call-responder* ] 2bi ;
-
-: nested-responders ( -- seq )
- responder-nesting get assocs:values [ third ] map ;
-
-: each-responder ( quot -- )
- nested-responders swap each ; inline
-
-: responder-path ( string -- pair )
- dup responder-nesting get at
- [ ] [ "No such responder: " swap append throw ] ?if ;
-
-: base-path ( string -- path )
- responder-path first ;
-
-: template-path ( string -- path )
- responder-path second ;
-
-: resolve-responder-path ( string quot -- string' )
- [ "$" ?head ] dip '[
- [
- "/" split1 [ @ [ "/" % % ] each "/" % ] dip %
- ] "" make
- ] when ; inline
-
-: resolve-base-path ( string -- string' )
- [ base-path ] resolve-responder-path ;
-
-: resolve-template-path ( string -- string' )
- [ template-path ] resolve-responder-path ;
-
-GENERIC: modify-query ( query responder -- query' )
-
-M: object modify-query drop ;
-
-: 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 ;
-
-: <custom-redirect> ( url code message -- response )
- <trivial-response>
- swap dup url? [ adjust-url ] when
- "location" set-header ;
-
-\ <custom-redirect> DEBUG add-input-logging
-
-: <permanent-redirect> ( to query -- response )
- 301 "Moved Permanently" <custom-redirect> ;
-
-: <temporary-redirect> ( to query -- response )
- 307 "Temporary Redirect" <custom-redirect> ;
-
-: <redirect> ( to query -- response )
- request get method>> {
- { "GET" [ <temporary-redirect> ] }
- { "HEAD" [ <temporary-redirect> ] }
- { "POST" [ <permanent-redirect> ] }
- } case ;
-
-TUPLE: dispatcher default responders ;
-
-: new-dispatcher ( class -- dispatcher )
- new
- 404-responder get >>default
- H{ } clone >>responders ; inline
-
-: <dispatcher> ( -- dispatcher )
- dispatcher new-dispatcher ;
-
-: find-responder ( path dispatcher -- path responder )
- over empty? [
- "" over responders>> at*
- [ nip ] [ drop default>> ] if
- ] [
- over first over responders>> at*
- [ [ drop rest-slice ] dip ] [ drop default>> ] if
- ] if ;
-
-M: dispatcher call-responder* ( path dispatcher -- response )
- find-responder call-responder ;
-
-TUPLE: vhost-dispatcher default responders ;
-
-: <vhost-dispatcher> ( -- dispatcher )
- 404-responder get H{ } clone vhost-dispatcher boa ;
-
-: find-vhost ( dispatcher -- responder )
- request get url>> host>> over responders>> at*
- [ nip ] [ drop default>> ] if ;
-
-M: vhost-dispatcher call-responder* ( path dispatcher -- response )
- find-vhost call-responder ;
-
-: add-responder ( dispatcher responder path -- dispatcher )
- pick responders>> set-at ;
-
-: add-main-responder ( dispatcher responder path -- dispatcher )
- [ add-responder drop ]
- [ drop "" add-responder drop ]
- [ 2drop ] 3tri ;
-
-TUPLE: filter-responder responder ;
-
-M: filter-responder call-responder*
- responder>> call-responder ;
-
-SYMBOL: main-responder
-
-main-responder global
-[ drop 404-responder get-global ] cache
-drop
-
-SYMBOL: development-mode
+ [ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- )
"Internal server error" [
- development-mode get [
- [ print-error nl :c ] with-html-stream
- ] [
- 500 "Internal server error"
- trivial-response-body
- ] if
+ [ print-error nl :c ] with-html-stream
] simple-page ;
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
- swap '[ , http-error. ] >>body ;
+ development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
dup write-response
request get method>> "HEAD" =
- [ drop ] [
- '[
- , write-response-body
- ] [
- http-error.
- ] recover
- ] if ;
+ [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ;
LOG: httpd-hit NOTICE
: init-request ( request -- )
request set
- H{ } clone responder-nesting set
- [ ] link-hook set
- [ ] form-hook set ;
+ V{ } clone responder-nesting set ;
: dispatch-request ( request -- response )
url>> path>> split-path main-responder get call-responder ;
[ init-request ]
[ log-request ]
[ dispatch-request ] tri
- ]
- [ [ \ do-request log-error ] [ <500> ] bi ]
- recover ;
+ ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
: ?refresh-all ( -- )
development-mode get-global
: httpd ( port -- )
dup integer? [ internet-server ] when
- "http.server" latin1
- [ handle-client ] with-server ;
+ "http.server" latin1 [ handle-client ] with-server ;
: httpd-main ( -- )
8888 httpd ;
! Copyright (C) 2004, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: calendar io io.files kernel math math.order\r
-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 urls ;\r
+math.parser namespaces parser sequences strings\r
+assocs hashtables debugger mime-types sorting logging\r
+calendar.format accessors\r
+io.encodings.binary fry xml.entities destructors urls\r
+html.elements html.templates.fhtml\r
+http\r
+http.server\r
+http.server.responses\r
+http.server.redirection ;\r
IN: http.server.static\r
\r
! special maps mime types to quots with effect ( path -- )\r
2drop t\r
] if ;\r
\r
-: <304> ( -- response )\r
- 304 "Not modified" <trivial-response> ;\r
-\r
-: <403> ( -- response )\r
- 403 "Forbidden" <trivial-response> ;\r
-\r
: <file-responder> ( root hook -- responder )\r
file-responder new\r
swap >>hook\r
find-index [ serve-file ] [ list-directory ] ?if\r
] [\r
drop\r
- request get url>> clone [ "/" append ] change-path <redirect>\r
+ request get url>> clone [ "/" append ] change-path <permanent-redirect>\r
] if ;\r
\r
: serve-object ( filename -- response )\r
: <url> ( -- url ) url new ;
-: query-param ( request key -- value )
+: query-param ( url key -- value )
swap query>> at ;
-: set-query-param ( request value key -- request )
+: set-query-param ( url value key -- url )
'[ , , _ ?set-at ] change-query ;
: parse-host ( string -- host port )
: <display-action> ( -- action )
<page-action>
[ count sget "counter" set-value ] >>init
- "$counter-app/counter" >>template ;
+ { counter-app "counter" } >>template ;
: <counter-app> ( -- responder )
counter-app new-dispatcher
io.server
namespaces db db.sqlite smtp
http.server
+http.server.dispatchers
furnace.db
furnace.flows
furnace.sessions
allow-password-recovery
allow-edit-profile
<boilerplate>
- "$factor-website/page" >>template
+ { factor-website "page" } >>template
<flows>
<sessions>
test-db <db-persistence> ;
<t:a t:href="$pastebin/list">Pastes</t:a>
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
- <t:if t:code="http.server.sessions:uid">
+ <t:if t:code="furnace.sessions:uid">
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ <t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
USING: namespaces assocs sorting sequences kernel accessors
hashtables sequences.lib db.types db.tuples db combinators
calendar calendar.format math.parser rss urls xml.writer
-xmode.catalog validators html.components html.templates.chloe
+xmode.catalog validators
+html.components
+html.templates.chloe
http.server
+http.server.dispatchers
+http.server.redirection
+furnace
furnace.actions
furnace.auth
furnace.auth.login
-furnace.boilerplate ;
+furnace.boilerplate
+furnace.rss ;
IN: webapps.pastebin
+TUPLE: pastebin < dispatcher ;
+
! ! !
! DOMAIN MODEL
! ! !
: <pastebin-action> ( -- action )
<page-action>
[ pastes "pastes" set-value ] >>init
- "$pastebin/pastebin" >>template ;
+ { pastebin "pastebin" } >>template ;
: pastebin-feed-entries ( seq -- entries )
<reversed> 20 short head [
swap
[ summary>> >>title ]
[ date>> >>pub-date ]
- [ entity-link adjust-url >>link ]
+ [ entity-link adjust-url relative-to-request >>link ]
tri
] map ;
] nest-values
] >>init
- "$pastebin/paste" >>template ;
+ { pastebin "paste" } >>template ;
: paste-feed-entries ( paste -- entries )
fetch-annotations annotations>> pastebin-feed-entries ;
feed new
swap
[ "Paste " swap id>> number>string append >>title ]
- [ entity-link adjust-url >>link ]
+ [ entity-link adjust-url relative-to-request >>link ]
[ paste-feed-entries >>entries ]
tri ;
mode-names "modes" set-value
] >>init
- "$pastebin/new-paste" >>template
+ { pastebin "new-paste" } >>template
+
+ [ mode-names "modes" set-value ] >>validate
[
validate-entity
bi
] >>submit ;
-TUPLE: pastebin < dispatcher ;
-
SYMBOL: can-delete-pastes?
can-delete-pastes? define-capability
<new-annotation-action> "new-annotation" add-responder
<delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
<boilerplate>
- "$pastebin/pastebin-common" >>template ;
+ { pastebin "pastebin-common" } >>template ;
: init-pastes-table \ paste ensure-table ;
<p class="news">
<strong><t:view t:component="title" /></strong> <br/>
- <t:a value="link" t:session="none" class="more">Read More...</t:a>
+ <t:a value="link" class="more">Read More...</t:a>
</p>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2 class="posting-title">
- <t:a t:value="link" t:session="none"><t:view t:component="title" /></t:a>
+ <t:a t:value="link"><t:view t:component="title" /></t:a>
</h2>
<p class="posting-body">
</p>
<p class="posting-date">
- <t:a t:value="link" t:session="none"><t:view t:component="pub-date" /></t:a>
+ <t:a t:value="link"><t:view t:component="pub-date" /></t:a>
</p>
</t:chloe>
<p class="news">
<strong><t:view t:component="title" /></strong> <br/>
- <t:a value="link" t:session="none" class="more">Read More...</t:a>
+ <t:a value="link" class="more">Read More...</t:a>
</p>
</t:bind-each>
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet-factor/admin">Admin</t:a>
- <t:if t:code="http.server.sessions:uid">
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ <t:if t:code="furnace.sessions:uid">
+ <t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
rss urls xml.writer
validators
http.server
+http.server.dispatchers
+furnace
furnace.actions
furnace.boilerplate
furnace.auth.login
-furnace.auth ;
+furnace.auth
+furnace.rss ;
IN: webapps.planet
+TUPLE: planet-factor < dispatcher ;
+
+TUPLE: planet-factor-admin < dispatcher ;
+
TUPLE: blog id name www-url feed-url ;
M: blog link-title name>> ;
: <edit-blogroll-action> ( -- action )
<page-action>
[ blogroll "blogroll" set-value ] >>init
- "$planet-factor/admin" >>template ;
+ { planet-factor "admin" } >>template ;
: <planet-action> ( -- action )
<page-action>
postings "postings" set-value
] >>init
- "$planet-factor/planet" >>template ;
+ { planet-factor "planet" } >>template ;
: planet-feed ( -- feed )
feed new
: <new-blog-action> ( -- action )
<page-action>
- "$planet-factor/new-blog" >>template
+ { planet-factor "new-blog" } >>template
[ validate-blog ] >>validate
"id" value <blog> select-tuple from-object
] >>init
- "$planet-factor/edit-blog" >>template
+ { planet-factor "edit-blog" } >>template
[
validate-integer-id
tri
] >>submit ;
-TUPLE: planet-factor-admin < dispatcher ;
-
: <planet-factor-admin> ( -- responder )
planet-factor-admin new-dispatcher
<edit-blogroll-action> "blogroll" add-main-responder
can-administer-planet-factor? define-capability
-TUPLE: planet-factor < dispatcher ;
-
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
<planet-action> "list" add-main-responder
<feed-action> "feed.xml" add-responder
<planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
<boilerplate>
- "$planet-factor/planet-common" >>template ;
+ { planet-factor "planet-common" } >>template ;
: start-update-task ( db params -- )
'[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;
<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:label t:name="title" /></t:a>
</h2>
<p class="posting-body">
</p>
<p class="posting-date">
- <t:a t:value="link" t:session="none"><t:label t:name="pub-date" /></t:a>
+ <t:a t:value="link"><t:label t:name="pub-date" /></t:a>
</p>
</t:bind-each>
db db.types db.tuples validators hashtables urls
html.components
html.templates.chloe
+http.server
+http.server.dispatchers
+furnace
furnace.sessions
furnace.boilerplate
furnace.auth
furnace.actions
furnace.db
-furnace.auth.login
-http.server ;
+furnace.auth.login ;
IN: webapps.todo
+TUPLE: todo-list < dispatcher ;
+
TUPLE: todo uid id priority summary description ;
todo "TODO"
"id" value <todo> select-tuple from-object
] >>init
- "$todo-list/view-todo" >>template ;
+ { todo-list "view-todo" } >>template ;
: validate-todo ( -- )
{
<page-action>
[ 0 "priority" set-value ] >>init
- "$todo-list/new-todo" >>template
+ { todo-list "new-todo" } >>template
[ validate-todo ] >>validate
"id" value <todo> select-tuple from-object
] >>init
- "$todo-list/edit-todo" >>template
+ { todo-list "edit-todo" } >>template
[
validate-integer-id
: <list-action> ( -- action )
<page-action>
[ f <todo> select-tuples "items" set-value ] >>init
- "$todo-list/todo-list" >>template ;
-
-TUPLE: todo-list < dispatcher ;
+ { todo-list "todo-list" } >>template ;
: <todo-list> ( -- responder )
todo-list new-dispatcher
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<boilerplate>
- "$todo-list/todo" >>template
+ { todo-list "todo" } >>template
f <protected> ;
<t:a t:href="$todo-list/list">List Items</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:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
assocs db.tuples arrays splitting strings validators urls
html.elements
html.components
+furnace
furnace.boilerplate
furnace.auth.providers
furnace.auth.providers.db
furnace.auth
furnace.sessions
furnace.actions
-http.server ;
+http.server
+http.server.dispatchers ;
IN: webapps.user-admin
+TUPLE: user-admin < dispatcher ;
+
: word>string ( word -- string )
[ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
: <user-list-action> ( -- action )
<page-action>
[ f <user> select-tuples "users" set-value ] >>init
- "$user-admin/user-list" >>template ;
+ { user-admin "user-list" } >>template ;
: init-capabilities ( -- )
capabilities get words>strings "capabilities" set-value ;
init-capabilities
] >>init
- "$user-admin/new-user" >>template
+ { user-admin "new-user" } >>template
[
init-capabilities
capabilities get words>strings "capabilities" set-value
] >>init
- "$user-admin/edit-user" >>template
+ { user-admin "edit-user" } >>template
[
init-capabilities
URL" $user-admin" <redirect>
] >>submit ;
-TUPLE: user-admin < dispatcher ;
-
SYMBOL: can-administer-users?
can-administer-users? define-capability
<edit-user-action> "edit" add-responder
<delete-user-action> "delete" add-responder
<boilerplate>
- "$user-admin/user-admin" >>template
+ { user-admin "user-admin" } >>template
{ can-administer-users? } <protected> ;
: make-admin ( username -- )
<t:a t:href="$user-admin">List Users</t:a>
| <t:a t:href="$user-admin/new">Add User</t:a>
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ <t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
| <t:a t:href="$wiki/articles">All Articles</t:a>
| <t:a t:href="$wiki/changes">Recent Changes</t:a>
- <t:if t:code="http.server.sessions:uid">
+ <t:if t:code="furnace.sessions:uid">
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ <t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
namespaces splitting sequences sorting math.order
html.components
http.server
+http.server.dispatchers
+furnace
furnace.actions
furnace.auth
furnace.auth.login
db.types db.tuples lcs farkup urls ;
IN: webapps.wiki
+TUPLE: wiki < dispatcher ;
+
TUPLE: article title revision ;
article "ARTICLES" {
[
"title" value dup <article> select-tuple [
revision>> <revision> select-tuple from-object
- "$wiki/view" <chloe-content>
+ { wiki "view" } <chloe-content>
] [
<url>
"$wiki/edit" >>path
select-tuple from-object
] >>init
- "$wiki/view" >>template ;
+ { wiki "view" } >>template ;
: add-revision ( revision -- )
[ insert-tuple ]
] when*
] >>init
- "$wiki/edit" >>template
+ { wiki "edit" } >>template
[
validate-title
"revisions" set-value
] >>init
- "$wiki/revisions" >>template ;
+ { wiki "revisions" } >>template ;
: <rollback-action> ( -- action )
<action>
"changes" set-value
] >>init
- "$wiki/changes" >>template ;
+ { wiki "changes" } >>template ;
: <delete-action> ( -- action )
<action>
2bi
] >>init
- "$wiki/diff" >>template ;
+ { wiki "diff" } >>template ;
: <list-articles-action> ( -- action )
<page-action>
"articles" set-value
] >>init
- "$wiki/articles" >>template ;
+ { wiki "articles" } >>template ;
: <user-edits-action> ( -- action )
<page-action>
select-tuples "user-edits" set-value
] >>init
- "$wiki/user-edits" >>template ;
-
-TUPLE: wiki < dispatcher ;
+ { wiki "user-edits" } >>template ;
: <wiki> ( -- dispatcher )
wiki new-dispatcher
<edit-article-action> { } <protected> "edit" add-responder
<delete-action> { } <protected> "delete" add-responder
<boilerplate>
- "$wiki/wiki-common" >>template ;
+ { wiki "wiki-common" } >>template ;
--- /dev/null
+USING: furnace furnace.actions furnace.callbacks accessors\r
+http http.server http.server.responses tools.test\r
+namespaces io fry sequences\r
+splitting kernel hashtables continuations ;\r
+IN: furnace.callbacks.tests\r
+\r
+[ 123 ] [\r
+ [\r
+ <request> "GET" >>method init-request\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
+ <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
+ <request> init-request\r
+\r
+ [\r
+ exit-continuation set\r
+ <request> "GET" >>method init-request\r
+ { } "r" get call-responder\r
+ ] callcc1\r
+\r
+ body>> first\r
+\r
+ <request>\r
+ "GET" >>method\r
+ dup url>> rot cont-id associate >>query drop\r
+ dup url>> "/" >>path drop\r
+ init-request\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
+ dup url>> rot "location" header query>> >>query drop\r
+ dup url>> "/" >>path drop\r
+ init-request\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\r
+http.server.redirection furnace assocs.lib urls ;\r
+IN: furnace.callbacks\r
+\r
+SYMBOL: responder\r
+\r
+TUPLE: callback-responder responder callbacks ;\r
+\r
+: <callback-responder> ( responder -- responder' )\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 -- * )\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
+ <url>\r
+ swap cont-id set-query-param 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
+ url>> 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
projects / factor.git / commitdiff