Big web framework refactoring
Slava Pestov
parent
81d417f265
commit
9bd38767ab
|
|
@ -1,9 +1,16 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors sequences kernel assocs combinators http.server
|
||||
USING: accessors sequences kernel assocs combinators
|
||||
validators http hashtables namespaces fry continuations locals
|
||||
boxes xml.entities html.elements html.components
|
||||
html.templates.chloe io arrays math ;
|
||||
io arrays math boxes
|
||||
xml.entities
|
||||
http.server
|
||||
http.server.responses
|
||||
furnace
|
||||
html.elements
|
||||
html.components
|
||||
html.templates.chloe
|
||||
html.templates.chloe.syntax ;
|
||||
IN: furnace.actions
|
||||
|
||||
SYMBOL: params
|
||||
|
|
@ -92,9 +99,3 @@ TUPLE: page-action < action template ;
|
|||
: <page-action> ( -- page )
|
||||
page-action new-action
|
||||
dup '[ , template>> <chloe-content> ] >>display ;
|
||||
|
||||
TUPLE: feed-action < action feed ;
|
||||
|
||||
: <feed-action> ( -- feed )
|
||||
feed-action new-action
|
||||
dup '[ , feed>> call <feed-content> ] >>display ;
|
||||
|
|
|
|||
|
|
@ -2,6 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs namespaces kernel sequences sets
|
||||
http.server
|
||||
http.server.filters
|
||||
http.server.dispatchers
|
||||
furnace.sessions
|
||||
furnace.auth.providers ;
|
||||
IN: furnace.auth
|
||||
|
|
|
|||
|
|
@ -18,6 +18,10 @@ html.elements
|
|||
urls
|
||||
http
|
||||
http.server
|
||||
http.server.dispatchers
|
||||
http.server.filters
|
||||
http.server.responses
|
||||
furnace
|
||||
furnace.auth
|
||||
furnace.auth.providers
|
||||
furnace.auth.providers.db
|
||||
|
|
@ -60,7 +64,7 @@ M: user-saver dispose
|
|||
|
||||
! ! ! Login
|
||||
: successful-login ( user -- response )
|
||||
username>> set-uid "$login" end-flow ;
|
||||
username>> set-uid URL" $login" end-flow ;
|
||||
|
||||
: login-failed ( -- * )
|
||||
"invalid username or password" validation-error
|
||||
|
|
@ -68,7 +72,7 @@ M: user-saver dispose
|
|||
|
||||
: <login-action> ( -- action )
|
||||
<page-action>
|
||||
"$login/login" >>template
|
||||
{ login "login" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
|
|
@ -97,7 +101,7 @@ M: user-saver dispose
|
|||
|
||||
: <register-action> ( -- action )
|
||||
<page-action>
|
||||
"$login/register" >>template
|
||||
{ login "register" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
|
|
@ -138,7 +142,7 @@ M: user-saver dispose
|
|||
tri
|
||||
] >>init
|
||||
|
||||
"$login/edit-profile" >>template
|
||||
{ login "edit-profile" } >>template
|
||||
|
||||
[
|
||||
uid "username" set-value
|
||||
|
|
@ -173,7 +177,7 @@ M: user-saver dispose
|
|||
|
||||
drop
|
||||
|
||||
"$login" end-flow
|
||||
URL" $login" end-flow
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Password recovery
|
||||
|
|
@ -219,7 +223,7 @@ SYMBOL: lost-password-from
|
|||
|
||||
: <recover-action-1> ( -- action )
|
||||
<page-action>
|
||||
"$login/recover-1" >>template
|
||||
{ login "recover-1" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
|
|
@ -240,7 +244,7 @@ SYMBOL: lost-password-from
|
|||
|
||||
: <recover-action-2> ( -- action )
|
||||
<page-action>
|
||||
"$login/recover-2" >>template ;
|
||||
{ login "recover-2" } >>template ;
|
||||
|
||||
: <recover-action-3> ( -- action )
|
||||
<page-action>
|
||||
|
|
@ -251,7 +255,7 @@ SYMBOL: lost-password-from
|
|||
} validate-params
|
||||
] >>init
|
||||
|
||||
"$login/recover-3" >>template
|
||||
{ login "recover-3" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
|
|
@ -273,20 +277,20 @@ SYMBOL: lost-password-from
|
|||
|
||||
URL" $login/recover-4" <redirect>
|
||||
] [
|
||||
<400>
|
||||
<403>
|
||||
] if*
|
||||
] >>submit ;
|
||||
|
||||
: <recover-action-4> ( -- action )
|
||||
<page-action>
|
||||
"$login/recover-4" >>template ;
|
||||
{ login "recover-4" } >>template ;
|
||||
|
||||
! ! ! Logout
|
||||
: <logout-action> ( -- action )
|
||||
<action>
|
||||
[
|
||||
f set-uid
|
||||
"$login/login" end-flow
|
||||
URL" $login" end-flow
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Authentication logic
|
||||
|
|
@ -320,7 +324,7 @@ M: login call-responder* ( path responder -- response )
|
|||
|
||||
: <login-boilerplate> ( responder -- responder' )
|
||||
<boilerplate>
|
||||
"$login/boilerplate" >>template ;
|
||||
{ login "boilerplate" } >>template ;
|
||||
|
||||
: <login> ( responder -- auth )
|
||||
login new-dispatcher
|
||||
|
|
|
|||
|
|
@ -30,11 +30,11 @@
|
|||
</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>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,11 @@
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: db db.pools io.pools http.server furnace.sessions
|
||||
kernel accessors continuations namespaces destructors ;
|
||||
USING: kernel accessors continuations namespaces destructors
|
||||
db db.pools io.pools http.server http.server.filters
|
||||
furnace.sessions ;
|
||||
IN: furnace.db
|
||||
|
||||
TUPLE: db-persistence < filter-responder pool ;
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,30 @@
|
|||
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
|
||||
|
|
@ -1,7 +1,69 @@
|
|||
! 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 ;
|
||||
|
|
@ -13,12 +75,6 @@ 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 ;
|
||||
|
|
@ -38,7 +94,7 @@ CHLOE: atom
|
|||
<url>
|
||||
swap >>query
|
||||
swap >>path
|
||||
adjust-url
|
||||
adjust-url relative-to-request
|
||||
add-atom-feed ;
|
||||
|
||||
CHLOE: write-atom drop write-atom-feeds ;
|
||||
|
|
@ -62,7 +118,7 @@ M: object link-attr 2drop ;
|
|||
<url>
|
||||
swap >>query
|
||||
swap >>path
|
||||
adjust-url =href
|
||||
adjust-url relative-to-request =href
|
||||
a>
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -94,8 +150,6 @@ CHLOE: form
|
|||
[ 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>
|
||||
|
|
@ -124,13 +178,6 @@ CHLOE: 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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
! 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> ;
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! 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 ;
|
||||
|
|
@ -1,8 +1,10 @@
|
|||
IN: furnace.sessions.tests
|
||||
USING: tools.test http furnace.sessions
|
||||
furnace.actions http.server math namespaces kernel accessors
|
||||
furnace.actions http.server http.server.responses
|
||||
math namespaces kernel accessors
|
||||
prettyprint io.streams.string io.files splitting destructors
|
||||
sequences db db.sqlite continuations urls ;
|
||||
sequences db db.sqlite continuations urls math.parser
|
||||
furnace ;
|
||||
|
||||
: with-session
|
||||
[
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ 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 ;
|
||||
http http.server http.server.dispatchers http.server.filters
|
||||
html.elements furnace ;
|
||||
IN: furnace.sessions
|
||||
|
||||
TUPLE: session id expires uid namespace changed? ;
|
||||
|
|
@ -151,11 +152,3 @@ M: sessions call-responder* ( path responder -- response )
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -190,7 +190,7 @@ SYMBOL: html
|
|||
<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> ;
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ IN: html.templates.chloe.tests
|
|||
[
|
||||
[
|
||||
"test2" test-template call-template
|
||||
] "test3" test-template with-boilerplate
|
||||
] [ "test3" test-template ] with-boilerplate
|
||||
] run-template
|
||||
] unit-test
|
||||
|
||||
|
|
@ -69,24 +69,6 @@ IN: html.templates.chloe.tests
|
|||
] 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
|
||||
|
|
@ -127,7 +109,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
|
|||
|
||||
[ "<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
|
||||
|
||||
|
|
@ -142,7 +124,7 @@ TUPLE: person first-name last-name ;
|
|||
|
||||
[ "<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
|
||||
|
||||
|
|
@ -155,7 +137,7 @@ TUPLE: person first-name last-name ;
|
|||
|
||||
[ "<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
|
||||
|
||||
|
|
@ -163,6 +145,6 @@ TUPLE: person first-name last-name ;
|
|||
|
||||
[ "<a name=\"1\">Hello</a>" ] [
|
||||
[
|
||||
"test11" test-template call-template
|
||||
"test10" test-template call-template
|
||||
] run-template
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ html.templates.chloe.syntax ;
|
|||
IN: html.templates.chloe
|
||||
|
||||
! Chloe is Ed's favorite web designer
|
||||
SYMBOL: tag-stack
|
||||
|
||||
TUPLE: chloe path ;
|
||||
|
||||
|
|
@ -44,7 +45,8 @@ CHLOE: title children>string set-title ;
|
|||
|
||||
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
|
||||
|
|
@ -92,22 +94,23 @@ CHLOE-SINGLETON: html
|
|||
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 )
|
||||
|
|
@ -127,7 +130,7 @@ CHLOE-TUPLE: code
|
|||
|
||||
: process-chloe ( xml -- )
|
||||
[
|
||||
V{ } clone tags set
|
||||
V{ } clone tag-stack set
|
||||
|
||||
nested-template? get [
|
||||
process-template
|
||||
|
|
|
|||
|
|
@ -14,11 +14,10 @@ SYMBOL: tags
|
|||
|
||||
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
|
||||
|
||||
|
|
@ -38,7 +37,9 @@ MEMO: chloe-name ( string -- name )
|
|||
[ "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 -- )
|
||||
|
|
@ -54,5 +55,7 @@ MEMO: chloe-name ( string -- name )
|
|||
2bi render ;
|
||||
|
||||
: CHLOE-TUPLE:
|
||||
scan dup '[ , tuple-component-tag ] define-chloe-tag ;
|
||||
scan-word
|
||||
[ word-name ] [ '[ , tuple-component-tag ] ] bi
|
||||
define-chloe-tag ;
|
||||
parsing
|
||||
|
|
|
|||
|
|
@ -2,8 +2,26 @@
|
|||
|
||||
<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>
|
||||
|
|
|
|||
|
|
@ -2,8 +2,10 @@
|
|||
|
||||
<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>
|
||||
|
|
|
|||
|
|
@ -2,26 +2,13 @@
|
|||
|
||||
<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>
|
||||
|
|
|
|||
|
|
@ -1,11 +1,3 @@
|
|||
<?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>
|
||||
|
|
|
|||
|
|
@ -10,30 +10,26 @@ tuple-syntax namespaces urls ;
|
|||
|
||||
[
|
||||
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
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: assocs http kernel math math.parser namespaces sequences
|
|||
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 ;
|
||||
|
|
@ -21,13 +21,16 @@ DEFER: http-request
|
|||
|
||||
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
|
||||
|
|
@ -61,8 +64,8 @@ PRIVATE>
|
|||
|
||||
: <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 ;
|
||||
|
|
@ -100,7 +103,7 @@ M: download-failed error.
|
|||
: <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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,11 +3,6 @@ io.streams.string kernel arrays splitting sequences
|
|||
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
|
||||
|
|
@ -126,7 +121,9 @@ read-response-test-1' 1array [
|
|||
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>
|
||||
|
|
@ -149,7 +146,7 @@ test-db [
|
|||
"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
|
||||
|
||||
|
|
|
|||
|
|
@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger
|
|||
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
|
||||
|
||||
|
|
@ -17,22 +16,6 @@ EXCLUDE: fry => , ;
|
|||
|
||||
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 -- )
|
||||
|
|
@ -167,19 +150,6 @@ cookies ;
|
|||
"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 ;
|
||||
|
|
@ -299,9 +269,6 @@ SYMBOL: max-post-request
|
|||
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 -- )
|
||||
|
|
@ -406,7 +373,7 @@ body ;
|
|||
|
||||
: <raw-response> ( -- response )
|
||||
raw-response new
|
||||
"1.1" >>version ;
|
||||
"1.1" >>version ;
|
||||
|
||||
M: raw-response write-response ( respose -- )
|
||||
write-response-version
|
||||
|
|
|
|||
|
|
@ -0,0 +1,97 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
! 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> ;
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
! 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> ;
|
||||
|
|
@ -1,217 +1,51 @@
|
|||
! 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 ;
|
||||
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 ;
|
||||
|
||||
: 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
|
||||
|
||||
|
|
@ -223,9 +57,7 @@ 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 ;
|
||||
|
|
@ -235,9 +67,7 @@ LOG: httpd-hit NOTICE
|
|||
[ 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
|
||||
|
|
@ -254,8 +84,7 @@ LOG: httpd-hit NOTICE
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,15 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: calendar io io.files kernel math math.order
|
||||
math.parser http http.server namespaces parser sequences strings
|
||||
assocs hashtables debugger http.mime sorting html.elements
|
||||
html.templates.fhtml logging calendar.format accessors
|
||||
io.encodings.binary fry xml.entities destructors urls ;
|
||||
math.parser namespaces parser sequences strings
|
||||
assocs hashtables debugger mime-types sorting logging
|
||||
calendar.format accessors
|
||||
io.encodings.binary fry xml.entities destructors urls
|
||||
html.elements html.templates.fhtml
|
||||
http
|
||||
http.server
|
||||
http.server.responses
|
||||
http.server.redirection ;
|
||||
IN: http.server.static
|
||||
|
||||
! special maps mime types to quots with effect ( path -- )
|
||||
|
|
@ -17,12 +22,6 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
2drop t
|
||||
] if ;
|
||||
|
||||
: <304> ( -- response )
|
||||
304 "Not modified" <trivial-response> ;
|
||||
|
||||
: <403> ( -- response )
|
||||
403 "Forbidden" <trivial-response> ;
|
||||
|
||||
: <file-responder> ( root hook -- responder )
|
||||
file-responder new
|
||||
swap >>hook
|
||||
|
|
@ -85,7 +84,7 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
find-index [ serve-file ] [ list-directory ] ?if
|
||||
] [
|
||||
drop
|
||||
request get url>> clone [ "/" append ] change-path <redirect>
|
||||
request get url>> clone [ "/" append ] change-path <permanent-redirect>
|
||||
] if ;
|
||||
|
||||
: serve-object ( filename -- response )
|
||||
|
|
|
|||
|
|
@ -94,10 +94,10 @@ TUPLE: url protocol username password host port path query anchor ;
|
|||
|
||||
: <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 )
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ M: counter-app init-session* drop 0 count sset ;
|
|||
: <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
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ USING: accessors kernel sequences assocs io.files io.sockets
|
|||
io.server
|
||||
namespaces db db.sqlite smtp
|
||||
http.server
|
||||
http.server.dispatchers
|
||||
furnace.db
|
||||
furnace.flows
|
||||
furnace.sessions
|
||||
|
|
@ -51,7 +52,7 @@ TUPLE: factor-website < dispatcher ;
|
|||
allow-password-recovery
|
||||
allow-edit-profile
|
||||
<boilerplate>
|
||||
"$factor-website/page" >>template
|
||||
{ factor-website "page" } >>template
|
||||
<flows>
|
||||
<sessions>
|
||||
test-db <db-persistence> ;
|
||||
|
|
|
|||
|
|
@ -11,9 +11,9 @@
|
|||
<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>
|
||||
|
||||
|
|
|
|||
|
|
@ -3,14 +3,22 @@
|
|||
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
|
||||
! ! !
|
||||
|
|
@ -91,7 +99,7 @@ M: annotation entity-link
|
|||
: <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 [
|
||||
|
|
@ -99,7 +107,7 @@ M: annotation entity-link
|
|||
swap
|
||||
[ summary>> >>title ]
|
||||
[ date>> >>pub-date ]
|
||||
[ entity-link adjust-url >>link ]
|
||||
[ entity-link adjust-url relative-to-request >>link ]
|
||||
tri
|
||||
] map ;
|
||||
|
||||
|
|
@ -130,7 +138,7 @@ M: annotation entity-link
|
|||
] nest-values
|
||||
] >>init
|
||||
|
||||
"$pastebin/paste" >>template ;
|
||||
{ pastebin "paste" } >>template ;
|
||||
|
||||
: paste-feed-entries ( paste -- entries )
|
||||
fetch-annotations annotations>> pastebin-feed-entries ;
|
||||
|
|
@ -139,7 +147,7 @@ M: annotation entity-link
|
|||
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 ;
|
||||
|
||||
|
|
@ -168,7 +176,9 @@ M: annotation entity-link
|
|||
mode-names "modes" set-value
|
||||
] >>init
|
||||
|
||||
"$pastebin/new-paste" >>template
|
||||
{ pastebin "new-paste" } >>template
|
||||
|
||||
[ mode-names "modes" set-value ] >>validate
|
||||
|
||||
[
|
||||
validate-entity
|
||||
|
|
@ -225,8 +235,6 @@ M: annotation entity-link
|
|||
bi
|
||||
] >>submit ;
|
||||
|
||||
TUPLE: pastebin < dispatcher ;
|
||||
|
||||
SYMBOL: can-delete-pastes?
|
||||
|
||||
can-delete-pastes? define-capability
|
||||
|
|
@ -242,7 +250,7 @@ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
<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>
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
<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">
|
||||
|
|
@ -11,7 +11,7 @@
|
|||
</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>
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
|
||||
<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>
|
||||
|
|
|
|||
|
|
@ -9,8 +9,8 @@
|
|||
| <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>
|
||||
|
||||
|
|
|
|||
|
|
@ -7,12 +7,19 @@ html.components
|
|||
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>> ;
|
||||
|
|
@ -58,7 +65,7 @@ posting "POSTINGS"
|
|||
: <edit-blogroll-action> ( -- action )
|
||||
<page-action>
|
||||
[ blogroll "blogroll" set-value ] >>init
|
||||
"$planet-factor/admin" >>template ;
|
||||
{ planet-factor "admin" } >>template ;
|
||||
|
||||
: <planet-action> ( -- action )
|
||||
<page-action>
|
||||
|
|
@ -67,7 +74,7 @@ posting "POSTINGS"
|
|||
postings "postings" set-value
|
||||
] >>init
|
||||
|
||||
"$planet-factor/planet" >>template ;
|
||||
{ planet-factor "planet" } >>template ;
|
||||
|
||||
: planet-feed ( -- feed )
|
||||
feed new
|
||||
|
|
@ -131,7 +138,7 @@ posting "POSTINGS"
|
|||
|
||||
: <new-blog-action> ( -- action )
|
||||
<page-action>
|
||||
"$planet-factor/new-blog" >>template
|
||||
{ planet-factor "new-blog" } >>template
|
||||
|
||||
[ validate-blog ] >>validate
|
||||
|
||||
|
|
@ -155,7 +162,7 @@ posting "POSTINGS"
|
|||
"id" value <blog> select-tuple from-object
|
||||
] >>init
|
||||
|
||||
"$planet-factor/edit-blog" >>template
|
||||
{ planet-factor "edit-blog" } >>template
|
||||
|
||||
[
|
||||
validate-integer-id
|
||||
|
|
@ -175,8 +182,6 @@ posting "POSTINGS"
|
|||
tri
|
||||
] >>submit ;
|
||||
|
||||
TUPLE: planet-factor-admin < dispatcher ;
|
||||
|
||||
: <planet-factor-admin> ( -- responder )
|
||||
planet-factor-admin new-dispatcher
|
||||
<edit-blogroll-action> "blogroll" add-main-responder
|
||||
|
|
@ -189,15 +194,13 @@ SYMBOL: can-administer-planet-factor?
|
|||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
<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">
|
||||
|
|
@ -19,7 +19,7 @@
|
|||
</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>
|
||||
|
|
|
|||
|
|
@ -4,15 +4,19 @@ USING: accessors kernel sequences namespaces
|
|||
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"
|
||||
|
|
@ -38,7 +42,7 @@ todo "TODO"
|
|||
"id" value <todo> select-tuple from-object
|
||||
] >>init
|
||||
|
||||
"$todo-list/view-todo" >>template ;
|
||||
{ todo-list "view-todo" } >>template ;
|
||||
|
||||
: validate-todo ( -- )
|
||||
{
|
||||
|
|
@ -51,7 +55,7 @@ todo "TODO"
|
|||
<page-action>
|
||||
[ 0 "priority" set-value ] >>init
|
||||
|
||||
"$todo-list/new-todo" >>template
|
||||
{ todo-list "new-todo" } >>template
|
||||
|
||||
[ validate-todo ] >>validate
|
||||
|
||||
|
|
@ -75,7 +79,7 @@ todo "TODO"
|
|||
"id" value <todo> select-tuple from-object
|
||||
] >>init
|
||||
|
||||
"$todo-list/edit-todo" >>template
|
||||
{ todo-list "edit-todo" } >>template
|
||||
|
||||
[
|
||||
validate-integer-id
|
||||
|
|
@ -107,9 +111,7 @@ todo "TODO"
|
|||
: <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
|
||||
|
|
@ -119,5 +121,5 @@ TUPLE: todo-list < dispatcher ;
|
|||
<edit-action> "edit" add-responder
|
||||
<delete-action> "delete" add-responder
|
||||
<boilerplate>
|
||||
"$todo-list/todo" >>template
|
||||
{ todo-list "todo" } >>template
|
||||
f <protected> ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
<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>
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ USING: kernel sequences accessors namespaces combinators words
|
|||
assocs db.tuples arrays splitting strings validators urls
|
||||
html.elements
|
||||
html.components
|
||||
furnace
|
||||
furnace.boilerplate
|
||||
furnace.auth.providers
|
||||
furnace.auth.providers.db
|
||||
|
|
@ -11,9 +12,12 @@ furnace.auth.login
|
|||
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 ;
|
||||
|
||||
|
|
@ -29,7 +33,7 @@ IN: webapps.user-admin
|
|||
: <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 ;
|
||||
|
|
@ -46,7 +50,7 @@ IN: webapps.user-admin
|
|||
init-capabilities
|
||||
] >>init
|
||||
|
||||
"$user-admin/new-user" >>template
|
||||
{ user-admin "new-user" } >>template
|
||||
|
||||
[
|
||||
init-capabilities
|
||||
|
|
@ -94,7 +98,7 @@ IN: webapps.user-admin
|
|||
capabilities get words>strings "capabilities" set-value
|
||||
] >>init
|
||||
|
||||
"$user-admin/edit-user" >>template
|
||||
{ user-admin "edit-user" } >>template
|
||||
|
||||
[
|
||||
init-capabilities
|
||||
|
|
@ -140,8 +144,6 @@ IN: webapps.user-admin
|
|||
URL" $user-admin" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
TUPLE: user-admin < dispatcher ;
|
||||
|
||||
SYMBOL: can-administer-users?
|
||||
|
||||
can-administer-users? define-capability
|
||||
|
|
@ -153,7 +155,7 @@ 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 -- )
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
<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>
|
||||
|
||||
|
|
|
|||
|
|
@ -10,9 +10,9 @@
|
|||
| <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>
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,8 @@ USING: accessors kernel hashtables calendar
|
|||
namespaces splitting sequences sorting math.order
|
||||
html.components
|
||||
http.server
|
||||
http.server.dispatchers
|
||||
furnace
|
||||
furnace.actions
|
||||
furnace.auth
|
||||
furnace.auth.login
|
||||
|
|
@ -12,6 +14,8 @@ validators
|
|||
db.types db.tuples lcs farkup urls ;
|
||||
IN: webapps.wiki
|
||||
|
||||
TUPLE: wiki < dispatcher ;
|
||||
|
||||
TUPLE: article title revision ;
|
||||
|
||||
article "ARTICLES" {
|
||||
|
|
@ -64,7 +68,7 @@ revision "REVISIONS" {
|
|||
[
|
||||
"title" value dup <article> select-tuple [
|
||||
revision>> <revision> select-tuple from-object
|
||||
"$wiki/view" <chloe-content>
|
||||
{ wiki "view" } <chloe-content>
|
||||
] [
|
||||
<url>
|
||||
"$wiki/edit" >>path
|
||||
|
|
@ -81,7 +85,7 @@ revision "REVISIONS" {
|
|||
select-tuple from-object
|
||||
] >>init
|
||||
|
||||
"$wiki/view" >>template ;
|
||||
{ wiki "view" } >>template ;
|
||||
|
||||
: add-revision ( revision -- )
|
||||
[ insert-tuple ]
|
||||
|
|
@ -102,7 +106,7 @@ revision "REVISIONS" {
|
|||
] when*
|
||||
] >>init
|
||||
|
||||
"$wiki/edit" >>template
|
||||
{ wiki "edit" } >>template
|
||||
|
||||
[
|
||||
validate-title
|
||||
|
|
@ -131,7 +135,7 @@ revision "REVISIONS" {
|
|||
"revisions" set-value
|
||||
] >>init
|
||||
|
||||
"$wiki/revisions" >>template ;
|
||||
{ wiki "revisions" } >>template ;
|
||||
|
||||
: <rollback-action> ( -- action )
|
||||
<action>
|
||||
|
|
@ -158,7 +162,7 @@ revision "REVISIONS" {
|
|||
"changes" set-value
|
||||
] >>init
|
||||
|
||||
"$wiki/changes" >>template ;
|
||||
{ wiki "changes" } >>template ;
|
||||
|
||||
: <delete-action> ( -- action )
|
||||
<action>
|
||||
|
|
@ -185,7 +189,7 @@ revision "REVISIONS" {
|
|||
2bi
|
||||
] >>init
|
||||
|
||||
"$wiki/diff" >>template ;
|
||||
{ wiki "diff" } >>template ;
|
||||
|
||||
: <list-articles-action> ( -- action )
|
||||
<page-action>
|
||||
|
|
@ -195,7 +199,7 @@ revision "REVISIONS" {
|
|||
"articles" set-value
|
||||
] >>init
|
||||
|
||||
"$wiki/articles" >>template ;
|
||||
{ wiki "articles" } >>template ;
|
||||
|
||||
: <user-edits-action> ( -- action )
|
||||
<page-action>
|
||||
|
|
@ -205,9 +209,7 @@ revision "REVISIONS" {
|
|||
select-tuples "user-edits" set-value
|
||||
] >>init
|
||||
|
||||
"$wiki/user-edits" >>template ;
|
||||
|
||||
TUPLE: wiki < dispatcher ;
|
||||
{ wiki "user-edits" } >>template ;
|
||||
|
||||
: <wiki> ( -- dispatcher )
|
||||
wiki new-dispatcher
|
||||
|
|
@ -223,4 +225,4 @@ TUPLE: wiki < dispatcher ;
|
|||
<edit-article-action> { } <protected> "edit" add-responder
|
||||
<delete-action> { } <protected> "delete" add-responder
|
||||
<boilerplate>
|
||||
"$wiki/wiki-common" >>template ;
|
||||
{ wiki "wiki-common" } >>template ;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,12 @@
|
|||
IN: furnace.callbacks
|
||||
USING: furnace.actions furnace.callbacks accessors
|
||||
http.server http tools.test namespaces io fry sequences
|
||||
USING: furnace furnace.actions furnace.callbacks accessors
|
||||
http http.server http.server.responses tools.test
|
||||
namespaces io fry sequences
|
||||
splitting kernel hashtables continuations ;
|
||||
IN: furnace.callbacks.tests
|
||||
|
||||
[ 123 ] [
|
||||
[
|
||||
init-request
|
||||
|
||||
<request> "GET" >>method request set
|
||||
<request> "GET" >>method init-request
|
||||
[
|
||||
exit-continuation set
|
||||
{ }
|
||||
|
|
@ -19,8 +18,6 @@ splitting kernel hashtables continuations ;
|
|||
] unit-test
|
||||
|
||||
[
|
||||
init-request
|
||||
|
||||
<action> [
|
||||
[
|
||||
"hello" print
|
||||
|
|
@ -32,9 +29,11 @@ splitting kernel hashtables continuations ;
|
|||
<callback-responder> "r" set
|
||||
|
||||
[ 123 ] [
|
||||
<request> init-request
|
||||
|
||||
[
|
||||
exit-continuation set
|
||||
<request> "GET" >>method request set
|
||||
<request> "GET" >>method init-request
|
||||
{ } "r" get call-responder
|
||||
] callcc1
|
||||
|
||||
|
|
@ -42,9 +41,9 @@ splitting kernel hashtables continuations ;
|
|||
|
||||
<request>
|
||||
"GET" >>method
|
||||
swap cont-id associate >>query
|
||||
"/" >>path
|
||||
request set
|
||||
dup url>> rot cont-id associate >>query drop
|
||||
dup url>> "/" >>path drop
|
||||
init-request
|
||||
|
||||
[
|
||||
exit-continuation set
|
||||
|
|
@ -55,9 +54,9 @@ splitting kernel hashtables continuations ;
|
|||
! get-post-get
|
||||
<request>
|
||||
"GET" >>method
|
||||
swap "location" header "=" last-split1 nip cont-id associate >>query
|
||||
"/" >>path
|
||||
request set
|
||||
dup url>> rot "location" header query>> >>query drop
|
||||
dup url>> "/" >>path drop
|
||||
init-request
|
||||
|
||||
[
|
||||
exit-continuation set
|
||||
|
|
@ -3,7 +3,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: http http.server io kernel math namespaces
|
||||
continuations calendar sequences assocs hashtables
|
||||
accessors arrays alarms quotations combinators fry assocs.lib ;
|
||||
accessors arrays alarms quotations combinators fry
|
||||
http.server.redirection furnace assocs.lib urls ;
|
||||
IN: furnace.callbacks
|
||||
|
||||
SYMBOL: responder
|
||||
|
|
@ -11,9 +12,6 @@ SYMBOL: responder
|
|||
TUPLE: callback-responder responder callbacks ;
|
||||
|
||||
: <callback-responder> ( responder -- responder' )
|
||||
#! A continuation responder is a special type of session
|
||||
#! manager. However it works entirely differently from
|
||||
#! the URL and cookie session managers.
|
||||
H{ } clone callback-responder boa ;
|
||||
|
||||
TUPLE: callback cont quot expires alarm responder ;
|
||||
|
|
@ -44,7 +42,7 @@ TUPLE: callback cont quot expires alarm responder ;
|
|||
: register-callback ( cont quot expires? -- id )
|
||||
<callback> callback-responder get callbacks>> set-at-unique ;
|
||||
|
||||
: forward-to-url ( url query -- * )
|
||||
: forward-to-url ( url -- * )
|
||||
#! When executed inside a 'show' call, this will force a
|
||||
#! HTTP 302 to occur to instruct the browser to forward to
|
||||
#! the request URL.
|
||||
|
|
@ -56,7 +54,8 @@ TUPLE: callback cont quot expires alarm responder ;
|
|||
#! When executed inside a 'show' call, this will force a
|
||||
#! HTTP 302 to occur to instruct the browser to forward to
|
||||
#! the request URL.
|
||||
f swap cont-id associate forward-to-url ;
|
||||
<url>
|
||||
swap cont-id set-query-param forward-to-url ;
|
||||
|
||||
: restore-request ( pair -- )
|
||||
first3 exit-continuation set request set call ;
|
||||
|
|
@ -94,7 +93,7 @@ SYMBOL: current-show
|
|||
call exit-with ; inline
|
||||
|
||||
: resuming-callback ( responder request -- id )
|
||||
cont-id query-param swap callbacks>> at ;
|
||||
url>> cont-id query-param swap callbacks>> at ;
|
||||
|
||||
M: callback-responder call-responder* ( path responder -- response )
|
||||
'[
|
||||
Loading…
Reference in New Issue