diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 26042d6159..5e237b02a8 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -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 ) page-action new-action dup '[ , template>> ] >>display ; - -TUPLE: feed-action < action feed ; - -: ( -- feed ) - feed-action new-action - dup '[ , feed>> call ] >>display ; diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index c42b73b825..f78cea3835 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -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 diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 85d71b574f..58ab47e3e1 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -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 : ( -- action ) - "$login/login" >>template + { login "login" } >>template [ { @@ -97,7 +101,7 @@ M: user-saver dispose : ( -- 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 : ( -- action ) - "$login/recover-1" >>template + { login "recover-1" } >>template [ { @@ -240,7 +244,7 @@ SYMBOL: lost-password-from : ( -- action ) - "$login/recover-2" >>template ; + { login "recover-2" } >>template ; : ( -- 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" ] [ - <400> + <403> ] if* ] >>submit ; : ( -- action ) - "$login/recover-4" >>template ; + { login "recover-4" } >>template ; ! ! ! Logout : ( -- 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 ) : ( responder -- responder' ) - "$login/boilerplate" >>template ; + { login "boilerplate" } >>template ; : ( responder -- auth ) login new-dispatcher diff --git a/extra/furnace/auth/login/login.xml b/extra/furnace/auth/login/login.xml index 545d7e0990..a52aed59d7 100644 --- a/extra/furnace/auth/login/login.xml +++ b/extra/furnace/auth/login/login.xml @@ -30,11 +30,11 @@

- + Register | - + Recover Password

diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index ec84ba1391..42f132ada1 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -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 ; diff --git a/extra/furnace/db/db.factor b/extra/furnace/db/db.factor index 8d7027073c..8487b4b3fc 100755 --- a/extra/furnace/db/db.factor +++ b/extra/furnace/db/db.factor @@ -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 ; diff --git a/extra/furnace/flows/flows.factor b/extra/furnace/flows/flows.factor index 001335065c..eb98c1a26b 100644 --- a/extra/furnace/flows/flows.factor +++ b/extra/furnace/flows/flows.factor @@ -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 ; diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor new file mode 100644 index 0000000000..5cf2dad9ad --- /dev/null +++ b/extra/furnace/furnace-tests.factor @@ -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 new-dispatcher ; + +TUPLE: base-path-check-responder ; + +C: base-path-check-responder + +M: base-path-check-responder call-responder* + 2drop + "$funny-dispatcher" resolve-base-path + "text/plain" ; + +[ ] [ + + + + "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 diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 80c9f948ed..370c4f84a3 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -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 ; + +: ( url -- response ) + adjust-url request get method>> { + { "GET" [ ] } + { "HEAD" [ ] } + { "POST" [ ] } + } 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 ; -: ( body -- response ) - feed>xml "application/atom+xml" ; - -: ( obj -- response ) - >json "application/json" ; - SYMBOL: exit-continuation : exit-with exit-continuation get continue-with ; @@ -38,7 +94,7 @@ CHLOE: atom 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 ; swap >>query swap >>path - adjust-url =href + adjust-url relative-to-request =href a> ] with-scope ; @@ -94,8 +150,6 @@ CHLOE: form [ drop ] tri ; -DEFER: process-chloe-tag - STRING: button-tag-markup @@ -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 ; diff --git a/extra/furnace/json/json.factor b/extra/furnace/json/json.factor new file mode 100644 index 0000000000..a5188cd355 --- /dev/null +++ b/extra/furnace/json/json.factor @@ -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 + +: ( body -- response ) + >json "application/json" ; diff --git a/extra/furnace/rss/rss.factor b/extra/furnace/rss/rss.factor new file mode 100644 index 0000000000..a94ef4fe51 --- /dev/null +++ b/extra/furnace/rss/rss.factor @@ -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 + +: ( body -- response ) + feed>xml "application/atom+xml" ; + +TUPLE: feed-action < action feed ; + +: ( -- feed ) + feed-action new-action + dup '[ , feed>> call ] >>display ; diff --git a/extra/furnace/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor index 949d04d4c3..a7a663ffa8 100755 --- a/extra/furnace/sessions/sessions-tests.factor +++ b/extra/furnace/sessions/sessions-tests.factor @@ -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 [ diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 2b6bf84bdd..5ea389c87e 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -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 ; diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 2b4920d462..8d92d9f4d7 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -190,7 +190,7 @@ SYMBOL: html swap write call - ; + ; inline : render-error ( message -- ) escape-string write ; diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index 6fb4429ea6..3a2cd10494 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -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" ; [ "
  • 1
  • 2
  • 3
" ] [ [ - "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 ; [ "
RBaxterUnknown
DougColeman
" ] [ [ - "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 ; [ "
RBaxterUnknown
DougColeman
" ] [ [ - "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 ; [ "Hello" ] [ [ - "test11" test-template call-template + "test10" test-template call-template ] run-template ] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 93afa44d81..9e0aa3fe1d 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -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 [ write-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 diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor index d30ddb9168..7eeb756a39 100644 --- a/extra/html/templates/chloe/syntax/syntax.factor +++ b/extra/html/templates/chloe/syntax/syntax.factor @@ -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 diff --git a/extra/html/templates/chloe/test/test6.xml b/extra/html/templates/chloe/test/test6.xml index b3f649333f..8e2ff2e8ad 100644 --- a/extra/html/templates/chloe/test/test6.xml +++ b/extra/html/templates/chloe/test/test6.xml @@ -2,8 +2,26 @@ - - True - + + + + + + + + + + + + + + + + + + + + + Checkbox diff --git a/extra/html/templates/chloe/test/test7.xml b/extra/html/templates/chloe/test/test7.xml index 338595e556..6166c800ed 100644 --- a/extra/html/templates/chloe/test/test7.xml +++ b/extra/html/templates/chloe/test/test7.xml @@ -2,8 +2,10 @@ - - True - +
    + +
    • +     +
diff --git a/extra/html/templates/chloe/test/test8.xml b/extra/html/templates/chloe/test/test8.xml index 8e2ff2e8ad..fd4a64ad0a 100644 --- a/extra/html/templates/chloe/test/test8.xml +++ b/extra/html/templates/chloe/test/test8.xml @@ -2,26 +2,13 @@ - - - - - - - - - - - - - - - - - - - - - Checkbox + + + + + + + +
diff --git a/extra/html/templates/chloe/test/test9.xml b/extra/html/templates/chloe/test/test9.xml index 6166c800ed..a9b2769445 100644 --- a/extra/html/templates/chloe/test/test9.xml +++ b/extra/html/templates/chloe/test/test9.xml @@ -1,11 +1,3 @@ - - -
    - -
    • -     -
- - +Hello diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 7ce066f0d7..daf4ad88d3 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -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" - - ] with-scope + "http://www.apple.com/index.html" + ] 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" - - ] with-scope + "https://www.amazon.com/index.html" + ] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 9fd5f15d6a..e6c8791e20 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -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> : ( url -- request ) - swap request-with-url - "GET" >>method ; + "GET" >>method + swap >url ensure-port >>url ; : http-get* ( url -- response data ) http-request ; @@ -100,7 +103,7 @@ M: download-failed error. : ( content-type content url -- request ) "POST" >>method - swap request-with-url + swap >url ensure-port >>url swap >>post-data swap >>post-data-type ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 5a11814f09..471d7e276b 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -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 @@ -149,7 +146,7 @@ test-db [ "resource:extra/http/test" >>default "nested" add-responder - [ URL" redirect-loop" ] >>display + [ URL" redirect-loop" ] >>display "redirect-loop" add-responder main-responder set diff --git a/extra/http/http.factor b/extra/http/http.factor index a4e6451044..e8f7189f75 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 ] [ protocol>> ] bi - secure-protocol? [ ] 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 ; : ( -- response ) raw-response new - "1.1" >>version ; + "1.1" >>version ; M: raw-response write-response ( respose -- ) write-response-version diff --git a/extra/http/server/dispatchers/dispatchers-tests.factor b/extra/http/server/dispatchers/dispatchers-tests.factor new file mode 100644 index 0000000000..5b5b30adde --- /dev/null +++ b/extra/http/server/dispatchers/dispatchers-tests.factor @@ -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 + +M: mock-responder call-responder* + nip + path>> on + [ ] "text/plain" ; + +: check-dispatch ( tag path -- ? ) + V{ } clone responder-nesting set + over off + split-path + main-responder get call-responder + write-response get ; + +[ + + "foo" "foo" add-responder + "bar" "bar" add-responder + + "123" "123" add-responder + "default" >>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 + +[ + + "default" >>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 + +M: path-check-responder call-responder* + drop + >array "text/plain" ; + +[ { "c" } ] [ + V{ } clone responder-nesting set + + { "b" "c" } + + + >>default + "b" add-responder + call-responder + body>> +] unit-test + +! Test that "" dispatcher works with default>> +[ ] [ + + "" "" add-responder + "bar" "bar" add-responder + "baz" >>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 diff --git a/extra/http/server/dispatchers/dispatchers.factor b/extra/http/server/dispatchers/dispatchers.factor new file mode 100644 index 0000000000..36eb447fc3 --- /dev/null +++ b/extra/http/server/dispatchers/dispatchers.factor @@ -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> >>default + H{ } clone >>responders ; inline + +: ( -- 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 ; + +: ( -- 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 ; diff --git a/extra/http/server/filters/filters.factor b/extra/http/server/filters/filters.factor new file mode 100644 index 0000000000..4f70113292 --- /dev/null +++ b/extra/http/server/filters/filters.factor @@ -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 ; diff --git a/extra/http/server/redirection/redirection-tests.factor b/extra/http/server/redirection/redirection-tests.factor new file mode 100644 index 0000000000..0b88231855 --- /dev/null +++ b/extra/http/server/redirection/redirection-tests.factor @@ -0,0 +1,48 @@ +IN: http.server.redirection.tests +USING: http http.server.redirection urls accessors +namespaces tools.test ; + +\ relative-to-request must-infer + +[ + + + "http" >>protocol + "www.apple.com" >>host + "/xxx/bar" >>path + { { "a" "b" } } >>query + >>url + request set + + [ "http://www.apple.com:80/xxx/bar" ] [ + relative-to-request url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/baz" ] [ + "baz" >>path relative-to-request url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/baz?c=d" ] [ + "baz" >>path { { "c" "d" } } >>query relative-to-request url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/bar?c=d" ] [ + { { "c" "d" } } >>query relative-to-request url>string + ] unit-test + + [ "http://www.apple.com:80/flip" ] [ + "/flip" >>path relative-to-request url>string + ] unit-test + + [ "http://www.apple.com:80/flip?c=d" ] [ + "/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 diff --git a/extra/http/server/redirection/redirection.factor b/extra/http/server/redirection/redirection.factor new file mode 100644 index 0000000000..3cd01345aa --- /dev/null +++ b/extra/http/server/redirection/redirection.factor @@ -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 ; + +: ( url code message -- response ) + + swap dup url? [ relative-to-request ] when + "location" set-header ; + +\ DEBUG add-input-logging + +: ( url -- response ) + 301 "Moved Permanently" ; + +: ( url -- response ) + 307 "Temporary Redirect" ; diff --git a/extra/http/server/responses/responses.factor b/extra/http/server/responses/responses.factor new file mode 100644 index 0000000000..277ca392b7 --- /dev/null +++ b/extra/http/server/responses/responses.factor @@ -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 + +: ( body content-type -- response ) + + 200 >>code + "Document follows" >>message + swap >>content-type + swap >>body ; + +: trivial-response-body ( code message -- ) + + +

[ number>string write bl ] [ write ] bi*

+ + ; + +: ( code message -- response ) + 2dup [ trivial-response-body ] with-string-writer + "text/html" + swap >>message + swap >>code ; + +: <304> ( -- response ) + 304 "Not modified" ; + +: <403> ( -- response ) + 403 "Forbidden" ; + +: <400> ( -- response ) + 400 "Bad request" ; + +: <404> ( -- response ) + 404 "Not found" ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 2fd706432b..68baeb28aa 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -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 ) -: ( body content-type -- response ) - - 200 >>code - "Document follows" >>message - swap >>content-type - swap >>body ; - TUPLE: trivial-responder response ; C: trivial-responder -M: trivial-responder call-responder* nip response>> call ; +M: trivial-responder call-responder* nip response>> clone ; -: trivial-response-body ( code message -- ) - - -

[ number>string write bl ] [ write ] bi*

- - ; - -: ( code message -- response ) - 2dup [ trivial-response-body ] with-string-writer - "text/html" - swap >>message - swap >>code ; - -: <400> ( -- response ) - 400 "Bad request" ; - -: <404> ( -- response ) - 404 "Not Found" ; - -SYMBOL: 404-responder - -[ <404> ] 404-responder set-global - -SYMBOL: responder-nesting +main-responder global [ <404> 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 ; - -: ( url code message -- response ) - - swap dup url? [ adjust-url ] when - "location" set-header ; - -\ DEBUG add-input-logging - -: ( to query -- response ) - 301 "Moved Permanently" ; - -: ( to query -- response ) - 307 "Temporary Redirect" ; - -: ( to query -- response ) - request get method>> { - { "GET" [ ] } - { "HEAD" [ ] } - { "POST" [ ] } - } case ; - -TUPLE: dispatcher default responders ; - -: new-dispatcher ( class -- dispatcher ) - new - 404-responder get >>default - H{ } clone >>responders ; inline - -: ( -- 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 ; - -: ( -- 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" - 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 ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index d64268d68e..1d86a73cfa 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -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" ; - -: <403> ( -- response ) - 403 "Forbidden" ; - : ( 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 + request get url>> clone [ "/" append ] change-path ] if ; : serve-object ( filename -- response ) diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index c5323a7ba9..5c89205d5b 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -94,10 +94,10 @@ TUPLE: url protocol username password host port path query anchor ; : ( -- 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 ) diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 29ce3f0e7c..1f80a71647 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -19,7 +19,7 @@ M: counter-app init-session* drop 0 count sset ; : ( -- action ) [ count sget "counter" set-value ] >>init - "$counter-app/counter" >>template ; + { counter-app "counter" } >>template ; : ( -- responder ) counter-app new-dispatcher diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 5565625a9c..853af6e845 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -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 - "$factor-website/page" >>template + { factor-website "page" } >>template test-db ; diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index a86404d451..5ef44ad6ce 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -11,9 +11,9 @@ Pastes | New Paste - + - + | Edit Profile diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index b2bcc685df..69650b4d73 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -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 : ( -- action ) [ pastes "pastes" set-value ] >>init - "$pastebin/pastebin" >>template ; + { pastebin "pastebin" } >>template ; : pastebin-feed-entries ( seq -- entries ) 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" add-responder { can-delete-pastes? } "delete-annotation" add-responder - "$pastebin/pastebin-common" >>template ; + { pastebin "pastebin-common" } >>template ; : init-pastes-table \ paste ensure-table ; diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml index 741b123456..70274d67d9 100644 --- a/extra/webapps/planet/entry-summary.xml +++ b/extra/webapps/planet/entry-summary.xml @@ -4,7 +4,7 @@


- Read More... + Read More...

diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml index 5e43717384..01fda67316 100644 --- a/extra/webapps/planet/entry.xml +++ b/extra/webapps/planet/entry.xml @@ -3,7 +3,7 @@

- +

@@ -11,7 +11,7 @@

- +

diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml index 7c5269b8d9..8de7216b0e 100644 --- a/extra/webapps/planet/mini-planet.xml +++ b/extra/webapps/planet/mini-planet.xml @@ -6,7 +6,7 @@


- Read More... + Read More...

diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml index 29609e12ba..e92f88c2c2 100644 --- a/extra/webapps/planet/planet-common.xml +++ b/extra/webapps/planet/planet-common.xml @@ -9,8 +9,8 @@ | Atom Feed | Admin - - + + | Edit Profile diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 39539441ce..c5fa5e25d4 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -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" : ( -- action ) [ blogroll "blogroll" set-value ] >>init - "$planet-factor/admin" >>template ; + { planet-factor "admin" } >>template ; : ( -- 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" : ( -- action ) - "$planet-factor/new-blog" >>template + { planet-factor "new-blog" } >>template [ validate-blog ] >>validate @@ -155,7 +162,7 @@ posting "POSTINGS" "id" value 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 ; - : ( -- responder ) planet-factor-admin new-dispatcher "blogroll" add-main-responder @@ -189,15 +194,13 @@ SYMBOL: can-administer-planet-factor? can-administer-planet-factor? define-capability -TUPLE: planet-factor < dispatcher ; - : ( -- responder ) planet-factor new-dispatcher "list" add-main-responder "feed.xml" add-responder { can-administer-planet-factor? } "admin" add-responder - "$planet-factor/planet-common" >>template ; + { planet-factor "planet-common" } >>template ; : start-update-task ( db params -- ) '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 4ee1c171e2..213c314d7a 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -11,7 +11,7 @@

- +

@@ -19,7 +19,7 @@

- +

diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 063c8515f7..3600e2f874 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -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 select-tuple from-object ] >>init - "$todo-list/view-todo" >>template ; + { todo-list "view-todo" } >>template ; : validate-todo ( -- ) { @@ -51,7 +55,7 @@ todo "TODO" [ 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 select-tuple from-object ] >>init - "$todo-list/edit-todo" >>template + { todo-list "edit-todo" } >>template [ validate-integer-id @@ -107,9 +111,7 @@ todo "TODO" : ( -- action ) [ f select-tuples "items" set-value ] >>init - "$todo-list/todo-list" >>template ; - -TUPLE: todo-list < dispatcher ; + { todo-list "todo-list" } >>template ; : ( -- responder ) todo-list new-dispatcher @@ -119,5 +121,5 @@ TUPLE: todo-list < dispatcher ; "edit" add-responder "delete" add-responder - "$todo-list/todo" >>template + { todo-list "todo" } >>template f ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index e892137932..3dd0b9a7d1 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -8,7 +8,7 @@ List Items | Add Item - + | Edit Profile diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index a3548fb252..b8687274f0 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -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 : ( -- action ) [ f 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" ] >>submit ; -TUPLE: user-admin < dispatcher ; - SYMBOL: can-administer-users? can-administer-users? define-capability @@ -153,7 +155,7 @@ can-administer-users? define-capability "edit" add-responder "delete" add-responder - "$user-admin/user-admin" >>template + { user-admin "user-admin" } >>template { can-administer-users? } ; : make-admin ( username -- ) diff --git a/extra/webapps/user-admin/user-admin.xml b/extra/webapps/user-admin/user-admin.xml index 05817565ed..93a701a696 100644 --- a/extra/webapps/user-admin/user-admin.xml +++ b/extra/webapps/user-admin/user-admin.xml @@ -6,7 +6,7 @@ List Users | Add User - + | Edit Profile diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 23e61e55fe..67a5b91c93 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -10,9 +10,9 @@ | All Articles | Recent Changes - + - + | Edit Profile diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index a1eb8bffc5..7444f1012e 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -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
select-tuple [ revision>> select-tuple from-object - "$wiki/view" + { wiki "view" } ] [ "$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 ; : ( -- action ) @@ -158,7 +162,7 @@ revision "REVISIONS" { "changes" set-value ] >>init - "$wiki/changes" >>template ; + { wiki "changes" } >>template ; : ( -- action ) @@ -185,7 +189,7 @@ revision "REVISIONS" { 2bi ] >>init - "$wiki/diff" >>template ; + { wiki "diff" } >>template ; : ( -- action ) @@ -195,7 +199,7 @@ revision "REVISIONS" { "articles" set-value ] >>init - "$wiki/articles" >>template ; + { wiki "articles" } >>template ; : ( -- 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 ; : ( -- dispatcher ) wiki new-dispatcher @@ -223,4 +225,4 @@ TUPLE: wiki < dispatcher ; { } "edit" add-responder { } "delete" add-responder - "$wiki/wiki-common" >>template ; + { wiki "wiki-common" } >>template ; diff --git a/extra/furnace/callbacks/callbacks-tests.factor b/unmaintained/cont-responder/callbacks-tests.factor similarity index 64% rename from extra/furnace/callbacks/callbacks-tests.factor rename to unmaintained/cont-responder/callbacks-tests.factor index f72aad3f50..db6f43c515 100755 --- a/extra/furnace/callbacks/callbacks-tests.factor +++ b/unmaintained/cont-responder/callbacks-tests.factor @@ -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 - - "GET" >>method request set + "GET" >>method init-request [ exit-continuation set { } @@ -19,8 +18,6 @@ splitting kernel hashtables continuations ; ] unit-test [ - init-request - [ [ "hello" print @@ -32,9 +29,11 @@ splitting kernel hashtables continuations ; "r" set [ 123 ] [ + init-request + [ exit-continuation set - "GET" >>method request set + "GET" >>method init-request { } "r" get call-responder ] callcc1 @@ -42,9 +41,9 @@ splitting kernel hashtables continuations ; "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 "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 diff --git a/extra/furnace/callbacks/callbacks.factor b/unmaintained/cont-responder/callbacks.factor similarity index 88% rename from extra/furnace/callbacks/callbacks.factor rename to unmaintained/cont-responder/callbacks.factor index 7b18afe781..1931be26d7 100755 --- a/extra/furnace/callbacks/callbacks.factor +++ b/unmaintained/cont-responder/callbacks.factor @@ -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 ; : ( 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-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 ; + + 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 ) '[