steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Re-arrange furnce to avoid circularity

db4
Slava Pestov 2008-11-24 20:26:11 -06:00
parent 8bf3c44cb6
commit b045a39333
21 changed files with 280 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/furnace/actions/actions.factor
View File

@ -6,7 +6,7 @@ io arrays math boxes splitting urls
xml.entities xml.entities
http.server http.server
http.server.responses http.server.responses
furnace furnace.utilities
furnace.redirection furnace.redirection
furnace.conversations furnace.conversations
html.forms html.forms

2
basis/furnace/asides/asides.factor
View File

@ -4,9 +4,9 @@ USING: namespaces assocs kernel sequences accessors hashtables
urls db.types db.tuples math.parser fry logging combinators urls db.types db.tuples math.parser fry logging combinators
html.templates.chloe.syntax html.templates.chloe.syntax
http http.server http.server.filters http.server.redirection http http.server http.server.filters http.server.redirection
furnace
furnace.cache furnace.cache
furnace.sessions furnace.sessions
furnace.utilities
furnace.redirection ; furnace.redirection ;
IN: furnace.asides IN: furnace.asides

2
basis/furnace/auth/auth.factor
View File

@ -8,8 +8,8 @@ html.forms
http.server http.server
http.server.filters http.server.filters
http.server.dispatchers http.server.dispatchers
furnace
furnace.actions furnace.actions
furnace.utilities
furnace.redirection furnace.redirection
furnace.boilerplate furnace.boilerplate
furnace.auth.providers furnace.auth.providers

9
basis/furnace/auth/features/recover-password/recover-password.factor
View File

@ -1,11 +1,10 @@
! Copyright (c) 2008 Slava Pestov. ! Copyright (c) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make accessors kernel assocs arrays io.sockets USING: namespaces make accessors kernel assocs arrays io.sockets
threads fry urls smtp validators html.forms present threads fry urls smtp validators html.forms present http
http http.server.responses http.server.redirection http.server.responses http.server.redirection
http.server.dispatchers http.server.dispatchers furnace.actions furnace.auth
furnace furnace.actions furnace.auth furnace.auth.providers furnace.auth.providers furnace.redirection furnace.utilities ;
furnace.redirection ;
IN: furnace.auth.features.recover-password IN: furnace.auth.features.recover-password
SYMBOL: lost-password-from SYMBOL: lost-password-from

2
basis/furnace/auth/features/registration/registration.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces validators html.forms urls USING: accessors assocs kernel namespaces validators html.forms urls
http.server.dispatchers http.server.dispatchers
furnace furnace.auth furnace.auth.providers furnace.actions furnace.auth furnace.auth.providers furnace.actions
furnace.redirection ; furnace.redirection ;
IN: furnace.auth.features.registration IN: furnace.auth.features.registration

1
basis/furnace/auth/login/login.factor
View File

@ -3,7 +3,6 @@
USING: kernel accessors namespaces sequences math.parser USING: kernel accessors namespaces sequences math.parser
calendar validators urls logging html.forms calendar validators urls logging html.forms
http http.server http.server.dispatchers http http.server http.server.dispatchers
furnace
furnace.auth furnace.auth
furnace.asides furnace.asides
furnace.actions furnace.actions

5
basis/furnace/boilerplate/boilerplate.factor
View File

@ -1,12 +1,13 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math.order namespaces furnace combinators.short-circuit USING: accessors kernel math.order namespaces combinators.short-circuit
html.forms html.forms
html.templates html.templates
html.templates.chloe html.templates.chloe
locals locals
http.server http.server
http.server.filters ; http.server.filters
furnace.utilities ;
IN: furnace.boilerplate IN: furnace.boilerplate
TUPLE: boilerplate < filter-responder template init ; TUPLE: boilerplate < filter-responder template init ;

2
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -19,7 +19,7 @@ http
http.server http.server
http.server.redirection http.server.redirection
http.server.responses http.server.responses
furnace ; furnace.utilities ;
QUALIFIED-WITH: assocs a QUALIFIED-WITH: assocs a
IN: furnace.chloe-tags IN: furnace.chloe-tags

2
basis/furnace/conversations/conversations.factor
View File

@ -4,10 +4,10 @@ USING: namespaces assocs kernel sequences accessors hashtables
urls db.types db.tuples math.parser fry logging combinators urls db.types db.tuples math.parser fry logging combinators
html.templates.chloe.syntax html.templates.chloe.syntax
http http.server http.server.filters http.server.redirection http http.server http.server.filters http.server.redirection
furnace
furnace.cache furnace.cache
furnace.scopes furnace.scopes
furnace.sessions furnace.sessions
furnace.utilities
furnace.redirection ; furnace.redirection ;
IN: furnace.conversations IN: furnace.conversations

123
basis/furnace/furnace-docs.factor
View File

@ -2,129 +2,6 @@ USING: assocs help.markup help.syntax kernel
quotations sequences strings urls xml.data http ; quotations sequences strings urls xml.data http ;
IN: furnace IN: furnace
HELP: adjust-redirect-url
{ $values { "url" url } { "url'" url } }
{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ;
HELP: adjust-url
{ $values { "url" url } { "url'" url } }
{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ;
HELP: client-state
{ $values { "key" string } { "value/f" { $maybe string } } }
{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
{ $notes "This word is used by session management, conversation scope and asides." } ;
HELP: each-responder
{ $values { "quot" { $quotation "( responder -- )" } } }
{ $description "Applies the quotation to each responder involved in processing the current request." } ;
HELP: hidden-form-field
{ $values { "value" string } { "name" string } }
{ $description "Renders an HTML hidden form field tag." }
{ $notes "This word is used by session management, conversation scope and asides." }
{ $examples
{ $example
"USING: furnace io ;"
"\"bar\" \"foo\" hidden-form-field nl"
"<input type='hidden' name='foo' value='bar'/>"
}
} ;
HELP: link-attr
{ $values { "tag" tag } { "responder" "a responder" } }
{ $contract "Modifies an XHTML " { $snippet "a" } " tag." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Conversation scope adds attributes to link tags." } ;
HELP: modify-form
{ $values { "responder" "a responder" } }
{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
HELP: modify-query
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Asides add query parameters to URLs." } ;
HELP: modify-redirect-query
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." }
{ $notes "This word is called by " { $link "furnace.redirection" } "." }
{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ;
HELP: nested-responders
{ $values { "seq" "a sequence of responders" } }
{ $description "" } ;
HELP: referrer
{ $values { "referrer/f" { $maybe string } } }
{ $description "Outputs the current request's referrer URL." } ;
HELP: request-params
{ $values { "request" request } { "assoc" assoc } }
{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
HELP: resolve-base-path
{ $values { "string" string } { "string'" string } }
{ $description "" } ;
HELP: resolve-template-path
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
{ $description "" } ;
HELP: same-host?
{ $values { "url" url } { "?" "a boolean" } }
{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ;
HELP: user-agent
{ $values { "user-agent" { $maybe string } } }
{ $description "Outputs the user agent reported by the client for the current request." } ;
HELP: vocab-path
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
{ $description "" } ;
HELP: exit-with
{ $values { "value" object } }
{ $description "Exits from an outer " { $link with-exit-continuation } "." } ;
HELP: with-exit-continuation
{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } }
{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." }
{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
ARTICLE: "furnace.extension-points" "Furnace extension points"
"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
$nl
"Responders can implement methods on the following generic words:"
{ $subsection modify-query }
{ $subsection modify-redirect-query }
{ $subsection link-attr }
{ $subsection modify-form }
"Presentation-level code can call the following words:"
{ $subsection adjust-url }
{ $subsection adjust-redirect-url } ;
ARTICLE: "furnace.misc" "Miscellaneous Furnace features"
"Inspecting the chain of responders handling the current request:"
{ $subsection nested-responders }
{ $subsection each-responder }
{ $subsection resolve-base-path }
"Vocabulary root-relative resources:"
{ $subsection vocab-path }
{ $subsection resolve-template-path }
"Early return from a responder:"
{ $subsection with-exit-continuation }
{ $subsection exit-with }
"Other useful words:"
{ $subsection hidden-form-field }
{ $subsection request-params }
{ $subsection client-state }
{ $subsection user-agent } ;
ARTICLE: "furnace.persistence" "Furnace persistence layer" ARTICLE: "furnace.persistence" "Furnace persistence layer"
{ $subsection "furnace.db" } { $subsection "furnace.db" }
"Server-side state:" "Server-side state:"

4
basis/furnace/furnace-tests.factor
View File

@ -1,7 +1,7 @@
IN: furnace.tests IN: furnace.tests
USING: http http.server.dispatchers http.server.responses USING: http http.server.dispatchers http.server.responses
http.server furnace tools.test kernel namespaces accessors http.server furnace furnace.utilities tools.test kernel
io.streams.string urls ; namespaces accessors io.streams.string urls ;
TUPLE: funny-dispatcher < dispatcher ; TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ; : <funny-dispatcher> funny-dispatcher new-dispatcher ;

126
basis/furnace/furnace.factor
View File

@ -1,133 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make assocs sequences kernel classes splitting
vocabs.loader accessors strings combinators arrays
continuations present fry
urls html.elements
http http.server http.server.redirection http.server.remapping ;
IN: furnace IN: furnace
: nested-responders ( -- seq )
responder-nesting get values ;
: each-responder ( quot -- )
nested-responders swap each ; inline
: base-path ( string -- pair )
dup responder-nesting get
[ second class superclasses [ name>> = ] with contains? ] 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 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
] "" make ;
GENERIC: modify-query ( query responder -- query' )
M: object modify-query drop ;
GENERIC: modify-redirect-query ( query responder -- query' )
M: object modify-redirect-query drop ;
GENERIC: adjust-url ( url -- url' )
M: url adjust-url
clone
[ [ modify-query ] each-responder ] change-query
[ resolve-base-path ] change-path
relative-to-request ;
M: string adjust-url ;
GENERIC: adjust-redirect-url ( url -- url' )
M: url adjust-redirect-url
adjust-url
[ [ modify-redirect-query ] each-responder ] change-query ;
M: string adjust-redirect-url ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
: hidden-form-field ( value name -- )
over [
<input
"hidden" =type
=name
present =value
input/>
] [ 2drop ] if ;
: nested-forms-key "__n" ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
{ "POST" [
post-data>>
dup content-type>> "application/x-www-form-urlencoded" =
[ content>> ] [ drop f ] if
] }
} case ;
: referrer ( -- referrer/f )
#! Typo is intentional, it's in the HTTP spec!
"referer" request get header>> at
dup [ >url ensure-port [ remap-port ] change-port ] when ;
: user-agent ( -- user-agent )
"user-agent" request get header>> at "" or ;
: same-host? ( url -- ? )
dup [
url get [
[ protocol>> ]
[ host>> ]
[ port>> remap-port ]
tri 3array
] bi@ =
] when ;
: cookie-client-state ( key request -- value/f )
swap get-cookie dup [ value>> ] when ;
: post-client-state ( key request -- value/f )
request-params at ;
: client-state ( key -- value/f )
request get dup method>> {
{ "GET" [ cookie-client-state ] }
{ "HEAD" [ cookie-client-state ] }
{ "POST" [ post-client-state ] }
} case ;
SYMBOL: exit-continuation
: exit-with ( value -- )
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
USE: vocabs.loader USE: vocabs.loader
"furnace.actions" require "furnace.actions" require
"furnace.alloy" require "furnace.alloy" require

2
basis/furnace/redirection/redirection.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces fry urls http USING: kernel accessors combinators namespaces fry urls http
http.server http.server.redirection http.server.responses http.server http.server.redirection http.server.responses
http.server.remapping http.server.filters furnace ; http.server.remapping http.server.filters furnace.utilities ;
IN: furnace.redirection IN: furnace.redirection
: <redirect> ( url -- response ) : <redirect> ( url -- response )

2
basis/furnace/referrer/referrer-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io.streams.string USING: help.markup help.syntax io.streams.string
furnace ; furnace.utilities ;
IN: furnace.referrer IN: furnace.referrer
HELP: <check-form-submissions> HELP: <check-form-submissions>

2
basis/furnace/referrer/referrer.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel http.server http.server.filters USING: accessors kernel http.server http.server.filters
http.server.responses furnace ; http.server.responses furnace.utilities ;
IN: furnace.referrer IN: furnace.referrer
TUPLE: referrer-check < filter-responder quot ; TUPLE: referrer-check < filter-responder quot ;

3
basis/furnace/sessions/sessions-tests.factor
View File

@ -3,7 +3,8 @@ USING: tools.test http furnace.sessions furnace.actions
http.server http.server.responses math namespaces make kernel http.server http.server.responses math namespaces make kernel
accessors io.sockets io.servers.connection prettyprint accessors io.sockets io.servers.connection prettyprint
io.streams.string io.files splitting destructors sequences db io.streams.string io.files splitting destructors sequences db
db.tuples db.sqlite continuations urls math.parser furnace ; db.tuples db.sqlite continuations urls math.parser furnace
furnace.utilities ;
: with-session : with-session
[ [

10
basis/furnace/sessions/sessions.factor
View File

@ -1,13 +1,11 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.intervals math.parser namespaces USING: assocs kernel math.intervals math.parser namespaces
strings random accessors quotations hashtables sequences continuations strings random accessors quotations hashtables sequences
fry calendar combinators combinators.short-circuit destructors alarms continuations fry calendar combinators combinators.short-circuit
io.servers.connection destructors alarms io.servers.connection db db.tuples db.types
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters http http.server http.server.dispatchers http.server.filters
html.elements html.elements furnace.cache furnace.scopes furnace.utilities ;
furnace furnace.cache furnace.scopes ;
IN: furnace.sessions IN: furnace.sessions
TUPLE: session < scope user-agent client ; TUPLE: session < scope user-agent client ;

7
basis/furnace/syndication/syndication.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences fry USING: accessors kernel sequences fry combinators syndication
combinators syndication http.server.responses http.server.redirection furnace.actions
http.server.responses http.server.redirection furnace.utilities ;
furnace furnace.actions ;
IN: furnace.syndication IN: furnace.syndication
GENERIC: feed-entry-title ( object -- string ) GENERIC: feed-entry-title ( object -- string )

126
basis/furnace/utilities/utilities-docs.factor Normal file
View File

@ -0,0 +1,126 @@
USING: assocs help.markup help.syntax kernel
quotations sequences strings urls xml.data http ;
IN: furnace.utilities
HELP: adjust-redirect-url
{ $values { "url" url } { "url'" url } }
{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ;
HELP: adjust-url
{ $values { "url" url } { "url'" url } }
{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ;
HELP: client-state
{ $values { "key" string } { "value/f" { $maybe string } } }
{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
{ $notes "This word is used by session management, conversation scope and asides." } ;
HELP: each-responder
{ $values { "quot" { $quotation "( responder -- )" } } }
{ $description "Applies the quotation to each responder involved in processing the current request." } ;
HELP: hidden-form-field
{ $values { "value" string } { "name" string } }
{ $description "Renders an HTML hidden form field tag." }
{ $notes "This word is used by session management, conversation scope and asides." }
{ $examples
{ $example
"USING: furnace.utilities io ;"
"\"bar\" \"foo\" hidden-form-field nl"
"<input type='hidden' name='foo' value='bar'/>"
}
} ;
HELP: link-attr
{ $values { "tag" tag } { "responder" "a responder" } }
{ $contract "Modifies an XHTML " { $snippet "a" } " tag." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Conversation scope adds attributes to link tags." } ;
HELP: modify-form
{ $values { "responder" "a responder" } }
{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
HELP: modify-query
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Asides add query parameters to URLs." } ;
HELP: modify-redirect-query
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." }
{ $notes "This word is called by " { $link "furnace.redirection" } "." }
{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ;
HELP: nested-responders
{ $values { "seq" "a sequence of responders" } }
{ $description "" } ;
HELP: referrer
{ $values { "referrer/f" { $maybe string } } }
{ $description "Outputs the current request's referrer URL." } ;
HELP: request-params
{ $values { "request" request } { "assoc" assoc } }
{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
HELP: resolve-base-path
{ $values { "string" string } { "string'" string } }
{ $description "" } ;
HELP: resolve-template-path
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
{ $description "" } ;
HELP: same-host?
{ $values { "url" url } { "?" "a boolean" } }
{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ;
HELP: user-agent
{ $values { "user-agent" { $maybe string } } }
{ $description "Outputs the user agent reported by the client for the current request." } ;
HELP: vocab-path
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
{ $description "" } ;
HELP: exit-with
{ $values { "value" object } }
{ $description "Exits from an outer " { $link with-exit-continuation } "." } ;
HELP: with-exit-continuation
{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } }
{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." }
{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
ARTICLE: "furnace.extension-points" "Furnace extension points"
"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
$nl
"Responders can implement methods on the following generic words:"
{ $subsection modify-query }
{ $subsection modify-redirect-query }
{ $subsection link-attr }
{ $subsection modify-form }
"Presentation-level code can call the following words:"
{ $subsection adjust-url }
{ $subsection adjust-redirect-url } ;
ARTICLE: "furnace.misc" "Miscellaneous Furnace features"
"Inspecting the chain of responders handling the current request:"
{ $subsection nested-responders }
{ $subsection each-responder }
{ $subsection resolve-base-path }
"Vocabulary root-relative resources:"
{ $subsection vocab-path }
{ $subsection resolve-template-path }
"Early return from a responder:"
{ $subsection with-exit-continuation }
{ $subsection exit-with }
"Other useful words:"
{ $subsection hidden-form-field }
{ $subsection request-params }
{ $subsection client-state }
{ $subsection user-agent } ;

128
basis/furnace/utilities/utilities.factor
View File

@ -1,6 +1,9 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors words kernel sequences splitting ; USING: namespaces make assocs sequences kernel classes splitting
words vocabs.loader accessors strings combinators arrays
continuations present fry urls html.elements http http.server
http.server.redirection http.server.remapping ;
IN: furnace.utilities IN: furnace.utilities
: word>string ( word -- string ) : word>string ( word -- string )
@ -17,3 +20,124 @@ ERROR: no-such-word name vocab ;
: strings>words ( seq -- seq' ) : strings>words ( seq -- seq' )
[ string>word ] map ; [ string>word ] map ;
: nested-responders ( -- seq )
responder-nesting get values ;
: each-responder ( quot -- )
nested-responders swap each ; inline
: base-path ( string -- pair )
dup responder-nesting get
[ second class superclasses [ name>> = ] with contains? ] 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 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
] "" make ;
GENERIC: modify-query ( query responder -- query' )
M: object modify-query drop ;
GENERIC: modify-redirect-query ( query responder -- query' )
M: object modify-redirect-query drop ;
GENERIC: adjust-url ( url -- url' )
M: url adjust-url
clone
[ [ modify-query ] each-responder ] change-query
[ resolve-base-path ] change-path
relative-to-request ;
M: string adjust-url ;
GENERIC: adjust-redirect-url ( url -- url' )
M: url adjust-redirect-url
adjust-url
[ [ modify-redirect-query ] each-responder ] change-query ;
M: string adjust-redirect-url ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
: hidden-form-field ( value name -- )
over [
<input
"hidden" =type
=name
present =value
input/>
] [ 2drop ] if ;
: nested-forms-key "__n" ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
{ "POST" [
post-data>>
dup content-type>> "application/x-www-form-urlencoded" =
[ content>> ] [ drop f ] if
] }
} case ;
: referrer ( -- referrer/f )
#! Typo is intentional, it's in the HTTP spec!
"referer" request get header>> at
dup [ >url ensure-port [ remap-port ] change-port ] when ;
: user-agent ( -- user-agent )
"user-agent" request get header>> at "" or ;
: same-host? ( url -- ? )
dup [
url get [
[ protocol>> ]
[ host>> ]
[ port>> remap-port ]
tri 3array
] bi@ =
] when ;
: cookie-client-state ( key request -- value/f )
swap get-cookie dup [ value>> ] when ;
: post-client-state ( key request -- value/f )
request-params at ;
: client-state ( key -- value/f )
request get dup method>> {
{ "GET" [ cookie-client-state ] }
{ "HEAD" [ cookie-client-state ] }
{ "POST" [ post-client-state ] }
} case ;
SYMBOL: exit-continuation
: exit-with ( value -- )
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;

2
extra/webapps/wiki/wiki.factor
View File

@ -7,8 +7,8 @@ syndication farkup
html.components html.forms html.components html.forms
http.server http.server
http.server.dispatchers http.server.dispatchers
furnace
furnace.actions furnace.actions
furnace.utilities
furnace.redirection furnace.redirection
furnace.auth furnace.auth
furnace.auth.login furnace.auth.login