]> gitweb.factorcode.org Git - factor.git/commitdiff
Re-arrange furnce to avoid circularity
authorSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Tue, 25 Nov 2008 02:26:11 +0000 (20:26 -0600)
committerSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Tue, 25 Nov 2008 02:26:11 +0000 (20:26 -0600)
21 files changed:
basis/furnace/actions/actions.factor
basis/furnace/asides/asides.factor
basis/furnace/auth/auth.factor
basis/furnace/auth/features/recover-password/recover-password.factor
basis/furnace/auth/features/registration/registration.factor
basis/furnace/auth/login/login.factor
basis/furnace/boilerplate/boilerplate.factor
basis/furnace/chloe-tags/chloe-tags.factor
basis/furnace/conversations/conversations.factor
basis/furnace/furnace-docs.factor
basis/furnace/furnace-tests.factor
basis/furnace/furnace.factor
basis/furnace/redirection/redirection.factor
basis/furnace/referrer/referrer-docs.factor
basis/furnace/referrer/referrer.factor
basis/furnace/sessions/sessions-tests.factor
basis/furnace/sessions/sessions.factor
basis/furnace/syndication/syndication.factor
basis/furnace/utilities/utilities-docs.factor [new file with mode: 0644]
basis/furnace/utilities/utilities.factor
extra/webapps/wiki/wiki.factor

index 6c56a8ad7babe82ad3d98a762c6ab59381e352eb..72a7b76d23b086188e99d14fcd09cc3892dee05e 100644 (file)
@@ -6,7 +6,7 @@ io arrays math boxes splitting urls
 xml.entities\r
 http.server\r
 http.server.responses\r
-furnace\r
+furnace.utilities\r
 furnace.redirection\r
 furnace.conversations\r
 html.forms\r
index 6d4196cf0b73ae928186aa7f2ff15bf1cdee46cf..7489d19f944e52d33e537873ec396036ef54665f 100644 (file)
@@ -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
 
index 1b5c5f9e73b940a83aa629d64e0c45349144425b..b9c961941c94b808395bb74f47c9fdd718805f0b 100644 (file)
@@ -8,8 +8,8 @@ html.forms
 http.server\r
 http.server.filters\r
 http.server.dispatchers\r
-furnace\r
 furnace.actions\r
+furnace.utilities\r
 furnace.redirection\r
 furnace.boilerplate\r
 furnace.auth.providers\r
index 5885aaef616d238def6106072dbd3b7cd94d6887..77be30a2d184d6c39bfb0be0adef97c5bb3cd107 100644 (file)
@@ -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
index 0484c11727dd4e47f5a6773240da7bdd20adf3d8..7f73f0c4045370bde1bc16e10ccfd4eb5f23e928 100644 (file)
@@ -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
 
index 4fc4e7e8be517783d15b8365d43df58a4b5946c3..fff301eb2f76379fbcd08bec032daf7ef21fd53f 100644 (file)
@@ -3,7 +3,6 @@
 USING: kernel accessors namespaces sequences math.parser\r
 calendar validators urls logging html.forms\r
 http http.server http.server.dispatchers\r
-furnace\r
 furnace.auth\r
 furnace.asides\r
 furnace.actions\r
index 946372e1f8c3f62dd14f47d3ceb4b4f3d05838e1..95e93f2ee8b067be02aa980f57c43b9d61990c7c 100644 (file)
@@ -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 ;
index 697c885a0143c7a0fc8d6b3362fb29f8937f5350..8ab70ded7b1c7d1ae4016d151bbed48e5635cdd2 100644 (file)
@@ -19,7 +19,7 @@ http
 http.server
 http.server.redirection
 http.server.responses
-furnace ;
+furnace.utilities ;
 QUALIFIED-WITH: assocs a
 IN: furnace.chloe-tags
 
index 671296ce575975d871f694be5aaf8a45e2d96a2f..266958c8a4cebb26cec2c6bfec998c50b45ea7c2 100644 (file)
@@ -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
 
index 911433d100ee0476d56cdbc4441116ef85298994..c6191b295e41815bef0c0646f73a9c9b5e556529 100644 (file)
@@ -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:"
index 00e4f6f152584903da3a5e6840eccffc9b59547c..f6e543499768997bb5624d3988f741456d0d5875 100644 (file)
@@ -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 ;
index 29eb00a8f4a44f8fd1dea230ea6a4c9fda9fdafb..adafb215242dc85aee1849c832acf3ac75da4cad 100644 (file)
@@ -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
index c5a63a795c7aff7de58eea2e677967334f2bfcac..01297288dc8fb4274320854ce9aaeec20f63191a 100644 (file)
@@ -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 )
index 599461c37c5e99fe472e43cf1af6071463f221a7..b57bcb262bd1a66879ddb7d85f7dbe474683807b 100644 (file)
@@ -1,5 +1,5 @@
 USING: help.markup help.syntax io.streams.string
-furnace ;
+furnace.utilities ;
 IN: furnace.referrer
 
 HELP: <check-form-submissions>
index 003028ab1ea787e2e173f5f2590acf2f4b5c78ca..e5666c269849d4e63bdaa6aad7739b6a25e97066 100644 (file)
@@ -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 ;
index 6bb3c1cd6927bdfa73c949184a9bf7355d9e9294..907e657125b514e65ba2107003929b1beb24d35c 100644 (file)
@@ -3,7 +3,8 @@ USING: tools.test http furnace.sessions furnace.actions
 http.server http.server.responses math namespaces make kernel\r
 accessors io.sockets io.servers.connection prettyprint\r
 io.streams.string io.files splitting destructors sequences db\r
-db.tuples db.sqlite continuations urls math.parser furnace ;\r
+db.tuples db.sqlite continuations urls math.parser furnace\r
+furnace.utilities ;\r
 \r
 : with-session\r
     [\r
index b7120aaf11cc765a98ffc2f62d17021f7932ad3b..cde95f28316152ad50d78898f22141570834d1c3 100644 (file)
@@ -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 ;
index a326e62f02c94907c0c381c05bcbc3ec20512a5c..876aaf8c98ab45f46aaacd37fdda2206ac81f5d6 100644 (file)
@@ -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 )
diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor
new file mode 100644 (file)
index 0000000..1402e9c
--- /dev/null
@@ -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 } ;
index 4bfbdcd943888c82ff58e331761847cfdced9ee8..f2b71fb89f08d64e20598bae09977efdb777af90 100644 (file)
@@ -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 ;
index b833cc8cc2b8ae5e666e7ea100a47e458a058509..b78dc25d7997fb074d331012800c6b2e4ff7db57 100644 (file)
@@ -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