Re-arrange furnce to avoid circularity
Slava Pestov
parent
8bf3c44cb6
commit
b045a39333
|
|
@ -6,7 +6,7 @@ io arrays math boxes splitting urls
|
|||
xml.entities
|
||||
http.server
|
||||
http.server.responses
|
||||
furnace
|
||||
furnace.utilities
|
||||
furnace.redirection
|
||||
furnace.conversations
|
||||
html.forms
|
||||
|
|
|
|||
|
|
@ -4,9 +4,9 @@ USING: namespaces assocs kernel sequences accessors hashtables
|
|||
urls db.types db.tuples math.parser fry logging combinators
|
||||
html.templates.chloe.syntax
|
||||
http http.server http.server.filters http.server.redirection
|
||||
furnace
|
||||
furnace.cache
|
||||
furnace.sessions
|
||||
furnace.utilities
|
||||
furnace.redirection ;
|
||||
IN: furnace.asides
|
||||
|
||||
|
|
|
|||
|
|
@ -8,8 +8,8 @@ html.forms
|
|||
http.server
|
||||
http.server.filters
|
||||
http.server.dispatchers
|
||||
furnace
|
||||
furnace.actions
|
||||
furnace.utilities
|
||||
furnace.redirection
|
||||
furnace.boilerplate
|
||||
furnace.auth.providers
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (c) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces make accessors kernel assocs arrays io.sockets
|
||||
threads fry urls smtp validators html.forms present
|
||||
http http.server.responses http.server.redirection
|
||||
http.server.dispatchers
|
||||
furnace furnace.actions furnace.auth furnace.auth.providers
|
||||
furnace.redirection ;
|
||||
threads fry urls smtp validators html.forms present http
|
||||
http.server.responses http.server.redirection
|
||||
http.server.dispatchers furnace.actions furnace.auth
|
||||
furnace.auth.providers furnace.redirection furnace.utilities ;
|
||||
IN: furnace.auth.features.recover-password
|
||||
|
||||
SYMBOL: lost-password-from
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces validators html.forms urls
|
||||
http.server.dispatchers
|
||||
furnace furnace.auth furnace.auth.providers furnace.actions
|
||||
furnace.auth furnace.auth.providers furnace.actions
|
||||
furnace.redirection ;
|
||||
IN: furnace.auth.features.registration
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@
|
|||
USING: kernel accessors namespaces sequences math.parser
|
||||
calendar validators urls logging html.forms
|
||||
http http.server http.server.dispatchers
|
||||
furnace
|
||||
furnace.auth
|
||||
furnace.asides
|
||||
furnace.actions
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! 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.templates
|
||||
html.templates.chloe
|
||||
locals
|
||||
http.server
|
||||
http.server.filters ;
|
||||
http.server.filters
|
||||
furnace.utilities ;
|
||||
IN: furnace.boilerplate
|
||||
|
||||
TUPLE: boilerplate < filter-responder template init ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ http
|
|||
http.server
|
||||
http.server.redirection
|
||||
http.server.responses
|
||||
furnace ;
|
||||
furnace.utilities ;
|
||||
QUALIFIED-WITH: assocs a
|
||||
IN: furnace.chloe-tags
|
||||
|
||||
|
|
|
|||
|
|
@ -4,10 +4,10 @@ USING: namespaces assocs kernel sequences accessors hashtables
|
|||
urls db.types db.tuples math.parser fry logging combinators
|
||||
html.templates.chloe.syntax
|
||||
http http.server http.server.filters http.server.redirection
|
||||
furnace
|
||||
furnace.cache
|
||||
furnace.scopes
|
||||
furnace.sessions
|
||||
furnace.utilities
|
||||
furnace.redirection ;
|
||||
IN: furnace.conversations
|
||||
|
||||
|
|
|
|||
|
|
@ -2,129 +2,6 @@ USING: assocs help.markup help.syntax kernel
|
|||
quotations sequences strings urls xml.data http ;
|
||||
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"
|
||||
{ $subsection "furnace.db" }
|
||||
"Server-side state:"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: furnace.tests
|
||||
USING: http http.server.dispatchers http.server.responses
|
||||
http.server furnace tools.test kernel namespaces accessors
|
||||
io.streams.string urls ;
|
||||
http.server furnace furnace.utilities tools.test kernel
|
||||
namespaces accessors io.streams.string urls ;
|
||||
TUPLE: funny-dispatcher < dispatcher ;
|
||||
|
||||
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
|
||||
|
|
|
|||
|
|
@ -1,133 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! 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
|
||||
|
||||
: 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
|
||||
"furnace.actions" require
|
||||
"furnace.alloy" require
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors combinators namespaces fry urls http
|
||||
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
|
||||
|
||||
: <redirect> ( url -- response )
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io.streams.string
|
||||
furnace ;
|
||||
furnace.utilities ;
|
||||
IN: furnace.referrer
|
||||
|
||||
HELP: <check-form-submissions>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel http.server http.server.filters
|
||||
http.server.responses furnace ;
|
||||
http.server.responses furnace.utilities ;
|
||||
IN: furnace.referrer
|
||||
|
||||
TUPLE: referrer-check < filter-responder quot ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@ USING: tools.test http furnace.sessions furnace.actions
|
|||
http.server http.server.responses math namespaces make kernel
|
||||
accessors io.sockets io.servers.connection prettyprint
|
||||
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
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,13 +1,11 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel math.intervals math.parser namespaces
|
||||
strings random accessors quotations hashtables sequences continuations
|
||||
fry calendar combinators combinators.short-circuit destructors alarms
|
||||
io.servers.connection
|
||||
db db.tuples db.types
|
||||
strings random accessors quotations hashtables sequences
|
||||
continuations fry calendar combinators combinators.short-circuit
|
||||
destructors alarms io.servers.connection db db.tuples db.types
|
||||
http http.server http.server.dispatchers http.server.filters
|
||||
html.elements
|
||||
furnace furnace.cache furnace.scopes ;
|
||||
html.elements furnace.cache furnace.scopes furnace.utilities ;
|
||||
IN: furnace.sessions
|
||||
|
||||
TUPLE: session < scope user-agent client ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences fry
|
||||
combinators syndication
|
||||
http.server.responses http.server.redirection
|
||||
furnace furnace.actions ;
|
||||
USING: accessors kernel sequences fry combinators syndication
|
||||
http.server.responses http.server.redirection furnace.actions
|
||||
furnace.utilities ;
|
||||
IN: furnace.syndication
|
||||
|
||||
GENERIC: feed-entry-title ( object -- string )
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
|
@ -1,6 +1,9 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! 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
|
||||
|
||||
: word>string ( word -- string )
|
||||
|
|
@ -17,3 +20,124 @@ ERROR: no-such-word name vocab ;
|
|||
|
||||
: strings>words ( seq -- seq' )
|
||||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -7,8 +7,8 @@ syndication farkup
|
|||
html.components html.forms
|
||||
http.server
|
||||
http.server.dispatchers
|
||||
furnace
|
||||
furnace.actions
|
||||
furnace.utilities
|
||||
furnace.redirection
|
||||
furnace.auth
|
||||
furnace.auth.login
|
||||
|
|
|
|||
Loading…
Reference in New Issue