From c5c65a4ce4be28d9deb05db9d6db9e6d83d93cac Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 1 Jun 2008 17:22:39 -0500 Subject: [PATCH] Web framework refactoring work in progress --- .../actions/actions-tests.factor | 7 +- .../server => furnace}/actions/actions.factor | 16 +- .../{http/server => furnace}/auth/auth.factor | 6 +- .../auth/basic/basic.factor | 4 +- .../auth/login/boilerplate.xml | 0 .../auth/login/edit-profile.xml | 0 .../auth/login/login-tests.factor | 4 +- .../auth/login/login.factor | 67 +++-- .../server => furnace}/auth/login/login.xml | 0 .../auth/login/recover-1.xml | 0 .../auth/login/recover-2.xml | 0 .../auth/login/recover-3.xml | 0 .../auth/login/recover-4.xml | 0 .../auth/login/register.xml | 0 .../auth/providers/assoc/assoc-tests.factor | 6 +- .../auth/providers/assoc/assoc.factor | 5 +- .../auth/providers/db/db-tests.factor | 10 +- .../auth/providers/db/db.factor | 4 +- .../auth/providers/null/null.factor | 4 +- .../auth/providers/providers.factor | 2 +- .../boilerplate/boilerplate.factor | 10 +- .../callbacks/callbacks-tests.factor | 6 +- .../callbacks/callbacks.factor | 2 +- extra/furnace/db/db-tests.factor | 4 + extra/{http/server => furnace}/db/db.factor | 4 +- .../server => furnace}/flows/flows.factor | 62 ++-- extra/furnace/furnace.factor | 136 +++++++++ .../server => furnace}/sessions/authors.txt | 0 .../sessions/sessions-tests.factor | 34 +-- .../sessions/sessions.factor | 16 +- extra/html/components/components-tests.factor | 4 +- extra/html/components/components.factor | 43 +-- extra/html/elements/elements.factor | 18 +- extra/html/templates/chloe/chloe-tests.factor | 13 +- extra/html/templates/chloe/chloe.factor | 270 +++--------------- .../html/templates/chloe/syntax/syntax.factor | 58 ++++ extra/html/templates/chloe/test/test10.xml | 4 +- extra/html/templates/chloe/test/test11.xml | 13 +- extra/html/templates/chloe/test/test9.xml | 2 +- extra/html/templates/templates.factor | 25 +- extra/http/client/client-tests.factor | 12 +- extra/http/client/client.factor | 5 +- extra/http/http-tests.factor | 66 ++--- extra/http/http.factor | 226 +++------------ extra/http/server/cgi/cgi.factor | 9 +- extra/http/server/db/db-tests.factor | 4 - extra/http/server/server-tests.factor | 57 ++-- extra/http/server/server.factor | 183 +++++------- extra/http/server/static/static.factor | 8 +- extra/io/pools/pools.factor | 20 +- extra/lcs/diff2html/diff2html.factor | 2 +- extra/rss/rss.factor | 19 +- extra/tangle/tangle.factor | 8 +- extra/urls/urls-tests.factor | 13 +- extra/urls/urls.factor | 64 +++-- extra/webapps/counter/counter.factor | 16 +- .../factor-website/factor-website.factor | 22 +- extra/webapps/factor-website/page.xml | 2 + extra/webapps/pastebin/paste.xml | 16 +- extra/webapps/pastebin/pastebin-common.xml | 2 + extra/webapps/pastebin/pastebin.factor | 68 ++--- extra/webapps/pastebin/pastebin.xml | 6 +- extra/webapps/planet/admin.xml | 4 +- extra/webapps/planet/mini-planet.xml | 4 +- extra/webapps/planet/planet.factor | 48 ++-- extra/webapps/planet/planet.xml | 6 +- extra/webapps/todo/edit-todo.xml | 10 +- extra/webapps/todo/new-todo.xml | 17 ++ extra/webapps/todo/todo-list.xml | 4 +- extra/webapps/todo/todo.factor | 52 ++-- extra/webapps/todo/todo.xml | 2 +- extra/webapps/user-admin/edit-user.xml | 6 +- extra/webapps/user-admin/new-user.xml | 6 +- extra/webapps/user-admin/user-admin.factor | 71 ++--- extra/webapps/user-admin/user-list.xml | 4 +- extra/webapps/wiki/articles.xml | 4 +- extra/webapps/wiki/changes.xml | 4 +- extra/webapps/wiki/diff.xml | 16 +- extra/webapps/wiki/revisions.xml | 43 ++- extra/webapps/wiki/user-edits.xml | 4 +- extra/webapps/wiki/wiki.css | 26 +- extra/webapps/wiki/wiki.factor | 80 ++++-- extra/xmode/code2html/code2html.factor | 6 +- .../code2html/responder/responder.factor | 2 +- 84 files changed, 1027 insertions(+), 1079 deletions(-) rename extra/{http/server => furnace}/actions/actions-tests.factor (83%) rename extra/{http/server => furnace}/actions/actions.factor (81%) rename extra/{http/server => furnace}/auth/auth.factor (88%) rename extra/{http/server => furnace}/auth/basic/basic.factor (90%) rename extra/{http/server => furnace}/auth/login/boilerplate.xml (100%) rename extra/{http/server => furnace}/auth/login/edit-profile.xml (100%) rename extra/{http/server => furnace}/auth/login/login-tests.factor (52%) rename extra/{http/server => furnace}/auth/login/login.factor (85%) rename extra/{http/server => furnace}/auth/login/login.xml (100%) rename extra/{http/server => furnace}/auth/login/recover-1.xml (100%) rename extra/{http/server => furnace}/auth/login/recover-2.xml (100%) rename extra/{http/server => furnace}/auth/login/recover-3.xml (100%) rename extra/{http/server => furnace}/auth/login/recover-4.xml (100%) rename extra/{http/server => furnace}/auth/login/register.xml (100%) rename extra/{http/server => furnace}/auth/providers/assoc/assoc-tests.factor (79%) rename extra/{http/server => furnace}/auth/providers/assoc/assoc.factor (80%) rename extra/{http/server => furnace}/auth/providers/db/db-tests.factor (83%) rename extra/{http/server => furnace}/auth/providers/db/db.factor (92%) rename extra/{http/server => furnace}/auth/providers/null/null.factor (71%) rename extra/{http/server => furnace}/auth/providers/providers.factor (94%) rename extra/{http/server => furnace}/boilerplate/boilerplate.factor (67%) rename extra/{http/server => furnace}/callbacks/callbacks-tests.factor (87%) rename extra/{http/server => furnace}/callbacks/callbacks.factor (96%) create mode 100644 extra/furnace/db/db-tests.factor rename extra/{http/server => furnace}/db/db.factor (82%) rename extra/{http/server => furnace}/flows/flows.factor (53%) create mode 100644 extra/furnace/furnace.factor rename extra/{http/server => furnace}/sessions/authors.txt (100%) rename extra/{http/server => furnace}/sessions/sessions-tests.factor (79%) rename extra/{http/server => furnace}/sessions/sessions.factor (92%) create mode 100644 extra/html/templates/chloe/syntax/syntax.factor delete mode 100644 extra/http/server/db/db-tests.factor create mode 100644 extra/webapps/todo/new-todo.xml diff --git a/extra/http/server/actions/actions-tests.factor b/extra/furnace/actions/actions-tests.factor similarity index 83% rename from extra/http/server/actions/actions-tests.factor rename to extra/furnace/actions/actions-tests.factor index 480cbc8e96..8aa0f92b97 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/furnace/actions/actions-tests.factor @@ -1,7 +1,7 @@ -USING: kernel http.server.actions validators +USING: kernel furnace.actions validators tools.test math math.parser multiline namespaces http io.streams.string http.server sequences splitting accessors ; -IN: http.server.actions.tests +IN: furnace.actions.tests [ "a" param "b" param [ string>number ] bi@ + ] >>display @@ -16,9 +16,8 @@ blah ; [ 25 ] [ - init-request action-request-test-1 lf>crlf [ read-request ] with-string-reader - request set + init-request { } "action-1" get call-responder ] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/furnace/actions/actions.factor similarity index 81% rename from extra/http/server/actions/actions.factor rename to extra/furnace/actions/actions.factor index eb5b8bfe68..26042d6159 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors sequences kernel assocs combinators http.server validators http hashtables namespaces fry continuations locals -boxes xml.entities html.elements html.components io arrays math ; -IN: http.server.actions +boxes xml.entities html.elements html.components +html.templates.chloe io arrays math ; +IN: furnace.actions SYMBOL: params @@ -17,6 +18,8 @@ SYMBOL: rest-param ] if ; +CHLOE: validation-messages drop render-validation-messages ; + TUPLE: action rest-param init display validate submit ; : new-action ( class -- action ) @@ -75,7 +78,7 @@ M: action call-responder* ( path action -- response ) validation-failed? [ validation-failed ] when ; : validate-params ( validators -- ) - params get swap validate-values from-assoc + params get swap validate-values from-object check-validation ; : validate-integer-id ( -- ) @@ -83,12 +86,15 @@ M: action call-responder* ( path action -- response ) TUPLE: page-action < action template ; +: ( path -- response ) + resolve-template-path "text/html" ; + : ( -- page ) page-action new-action - dup '[ , template>> ] >>display ; + dup '[ , template>> ] >>display ; TUPLE: feed-action < action feed ; : ( -- feed ) - feed-action new + feed-action new-action dup '[ , feed>> call ] >>display ; diff --git a/extra/http/server/auth/auth.factor b/extra/furnace/auth/auth.factor similarity index 88% rename from extra/http/server/auth/auth.factor rename to extra/furnace/auth/auth.factor index 4b34fbe804..c42b73b825 100755 --- a/extra/http/server/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces kernel sequences sets http.server -http.server.sessions -http.server.auth.providers ; -IN: http.server.auth +furnace.sessions +furnace.auth.providers ; +IN: furnace.auth SYMBOL: logged-in-user diff --git a/extra/http/server/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor similarity index 90% rename from extra/http/server/auth/basic/basic.factor rename to extra/furnace/auth/basic/basic.factor index ff071b34e3..c57f78b315 100755 --- a/extra/http/server/auth/basic/basic.factor +++ b/extra/furnace/auth/basic/basic.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting base64 html.elements io combinators http.server -http.server.auth.providers http.server.auth.login +furnace.auth.providers furnace.auth.login http sequences ; -IN: http.server.auth.basic +IN: furnace.auth.basic TUPLE: basic-auth < filter-responder realm provider ; diff --git a/extra/http/server/auth/login/boilerplate.xml b/extra/furnace/auth/login/boilerplate.xml similarity index 100% rename from extra/http/server/auth/login/boilerplate.xml rename to extra/furnace/auth/login/boilerplate.xml diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/furnace/auth/login/edit-profile.xml similarity index 100% rename from extra/http/server/auth/login/edit-profile.xml rename to extra/furnace/auth/login/edit-profile.xml diff --git a/extra/http/server/auth/login/login-tests.factor b/extra/furnace/auth/login/login-tests.factor similarity index 52% rename from extra/http/server/auth/login/login-tests.factor rename to extra/furnace/auth/login/login-tests.factor index b69630a930..5095ebdb85 100755 --- a/extra/http/server/auth/login/login-tests.factor +++ b/extra/furnace/auth/login/login-tests.factor @@ -1,5 +1,5 @@ -IN: http.server.auth.login.tests -USING: tools.test http.server.auth.login ; +IN: furnace.auth.login.tests +USING: tools.test furnace.auth.login ; \ must-infer \ allow-registration must-infer diff --git a/extra/http/server/auth/login/login.factor b/extra/furnace/auth/login/login.factor similarity index 85% rename from extra/http/server/auth/login/login.factor rename to extra/furnace/auth/login/login.factor index fd4fbab8e8..85d71b574f 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -15,19 +15,18 @@ checksums.sha2 validators html.components html.elements -html.templates -html.templates.chloe +urls http http.server -http.server.auth -http.server.auth.providers -http.server.auth.providers.db -http.server.actions -http.server.flows -http.server.sessions -http.server.boilerplate ; +furnace.auth +furnace.auth.providers +furnace.auth.providers.db +furnace.actions +furnace.flows +furnace.sessions +furnace.boilerplate ; QUALIFIED: smtp -IN: http.server.auth.login +IN: furnace.auth.login TUPLE: login < dispatcher users checksum ; @@ -59,10 +58,6 @@ M: user-saver dispose : save-user-after ( user -- ) &dispose drop ; -: login-template ( name -- template ) - "resource:extra/http/server/auth/login/" swap ".xml" - 3append ; - ! ! ! Login : successful-login ( user -- response ) username>> set-uid "$login" end-flow ; @@ -72,8 +67,8 @@ M: user-saver dispose validation-failed ; : ( -- action ) - - [ "login" login-template ] >>display + + "$login/login" >>template [ { @@ -102,7 +97,7 @@ M: user-saver dispose : ( -- action ) - "register" login-template >>template + "$login/register" >>template [ { @@ -134,7 +129,7 @@ M: user-saver dispose ! ! ! Editing user profile : ( -- action ) - + [ logged-in-user get [ username>> "username" set-value ] @@ -143,7 +138,7 @@ M: user-saver dispose tri ] >>init - [ "edit-profile" login-template ] >>display + "$login/edit-profile" >>template [ uid "username" set-value @@ -186,10 +181,10 @@ M: user-saver dispose SYMBOL: lost-password-from : current-host ( -- string ) - request get host>> host-name or ; + request get url>> host>> host-name or ; : new-password-url ( user -- url ) - "new-password" + "recover-3" swap [ [ username>> "username" set ] [ ticket>> "ticket" set ] @@ -223,8 +218,8 @@ SYMBOL: lost-password-from "E-mail send thread" spawn drop ; : ( -- action ) - - [ "recover-1" login-template ] >>display + + "$login/recover-1" >>template [ { @@ -240,11 +235,15 @@ SYMBOL: lost-password-from send-password-email ] when* - "recover-2" login-template + URL" $login/recover-2" ] >>submit ; +: ( -- action ) + + "$login/recover-2" >>template ; + : ( -- action ) - + [ { { "username" [ v-username ] } @@ -252,7 +251,7 @@ SYMBOL: lost-password-from } validate-params ] >>init - [ "recover-3" login-template ] >>display + "$login/recover-3" >>template [ { @@ -272,12 +271,16 @@ SYMBOL: lost-password-from "new-password" value >>encoded-password users update-user - "recover-4" login-template + URL" $login/recover-4" ] [ <400> ] if* ] >>submit ; +: ( -- action ) + + "$login/recover-4" >>template ; + ! ! ! Logout : ( -- action ) @@ -294,7 +297,7 @@ C: protected : show-login-page ( -- response ) begin-flow - "$login/login" f ; + URL" $login/login" ; : check-capabilities ( responder user -- ? ) [ capabilities>> ] bi@ subset? ; @@ -317,7 +320,7 @@ M: login call-responder* ( path responder -- response ) : ( responder -- responder' ) - "boilerplate" login-template >>template ; + "$login/boilerplate" >>template ; : ( responder -- auth ) login new-dispatcher @@ -340,8 +343,12 @@ M: login call-responder* ( path responder -- response ) : allow-password-recovery ( login -- login ) "recover-password" add-responder + + "recover-2" add-responder - "new-password" add-responder ; + "recover-3" add-responder + + "recover-4" add-responder ; : allow-edit-profile? ( -- ? ) login get responders>> "edit-profile" swap key? ; diff --git a/extra/http/server/auth/login/login.xml b/extra/furnace/auth/login/login.xml similarity index 100% rename from extra/http/server/auth/login/login.xml rename to extra/furnace/auth/login/login.xml diff --git a/extra/http/server/auth/login/recover-1.xml b/extra/furnace/auth/login/recover-1.xml similarity index 100% rename from extra/http/server/auth/login/recover-1.xml rename to extra/furnace/auth/login/recover-1.xml diff --git a/extra/http/server/auth/login/recover-2.xml b/extra/furnace/auth/login/recover-2.xml similarity index 100% rename from extra/http/server/auth/login/recover-2.xml rename to extra/furnace/auth/login/recover-2.xml diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/furnace/auth/login/recover-3.xml similarity index 100% rename from extra/http/server/auth/login/recover-3.xml rename to extra/furnace/auth/login/recover-3.xml diff --git a/extra/http/server/auth/login/recover-4.xml b/extra/furnace/auth/login/recover-4.xml similarity index 100% rename from extra/http/server/auth/login/recover-4.xml rename to extra/furnace/auth/login/recover-4.xml diff --git a/extra/http/server/auth/login/register.xml b/extra/furnace/auth/login/register.xml similarity index 100% rename from extra/http/server/auth/login/register.xml rename to extra/furnace/auth/login/register.xml diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/furnace/auth/providers/assoc/assoc-tests.factor similarity index 79% rename from extra/http/server/auth/providers/assoc/assoc-tests.factor rename to extra/furnace/auth/providers/assoc/assoc-tests.factor index 91e802b91c..8f9eeaa7a5 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/furnace/auth/providers/assoc/assoc-tests.factor @@ -1,6 +1,6 @@ -IN: http.server.auth.providers.assoc.tests -USING: http.server.actions http.server.auth.providers -http.server.auth.providers.assoc http.server.auth.login +IN: furnace.auth.providers.assoc.tests +USING: furnace.actions furnace.auth.providers +furnace.auth.providers.assoc furnace.auth.login tools.test namespaces accessors kernel ; diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/furnace/auth/providers/assoc/assoc.factor similarity index 80% rename from extra/http/server/auth/providers/assoc/assoc.factor rename to extra/furnace/auth/providers/assoc/assoc.factor index d6ba587aa0..f5a79d701b 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/furnace/auth/providers/assoc/assoc.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: http.server.auth.providers.assoc -USING: accessors assocs kernel -http.server.auth.providers ; +IN: furnace.auth.providers.assoc +USING: accessors assocs kernel furnace.auth.providers ; TUPLE: users-in-memory assoc ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/furnace/auth/providers/db/db-tests.factor similarity index 83% rename from extra/http/server/auth/providers/db/db-tests.factor rename to extra/furnace/auth/providers/db/db-tests.factor index a6a92356b6..714dcb416f 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/furnace/auth/providers/db/db-tests.factor @@ -1,8 +1,8 @@ -IN: http.server.auth.providers.db.tests -USING: http.server.actions -http.server.auth.login -http.server.auth.providers -http.server.auth.providers.db tools.test +IN: furnace.auth.providers.db.tests +USING: furnace.actions +furnace.auth.login +furnace.auth.providers +furnace.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations io.files accessors kernel ; diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/furnace/auth/providers/db/db.factor similarity index 92% rename from extra/http/server/auth/providers/db/db.factor rename to extra/furnace/auth/providers/db/db.factor index 3ed4845609..90306e5181 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/furnace/auth/providers/db/db.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db db.tuples db.types accessors -http.server.auth.providers kernel continuations +furnace.auth.providers kernel continuations classes.singleton ; -IN: http.server.auth.providers.db +IN: furnace.auth.providers.db user "USERS" { diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/furnace/auth/providers/null/null.factor similarity index 71% rename from extra/http/server/auth/providers/null/null.factor rename to extra/furnace/auth/providers/null/null.factor index 30f6dbd06e..39ea812ae7 100755 --- a/extra/http/server/auth/providers/null/null.factor +++ b/extra/furnace/auth/providers/null/null.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: http.server.auth.providers kernel ; -IN: http.server.auth.providers.null +USING: furnace.auth.providers kernel ; +IN: furnace.auth.providers.null TUPLE: no-users ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/furnace/auth/providers/providers.factor similarity index 94% rename from extra/http/server/auth/providers/providers.factor rename to extra/furnace/auth/providers/providers.factor index a51c4da1b9..1933fc8c59 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/furnace/auth/providers/providers.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors random math.parser locals sequences math ; -IN: http.server.auth.providers +IN: furnace.auth.providers TUPLE: user username realname diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor similarity index 67% rename from extra/http/server/boilerplate/boilerplate.factor rename to extra/furnace/boilerplate/boilerplate.factor index 96c59edd10..ec84ba1391 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -1,8 +1,8 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces http.server html.templates -locals ; -IN: http.server.boilerplate +html.templates.chloe locals ; +IN: furnace.boilerplate TUPLE: boilerplate < filter-responder template ; @@ -12,6 +12,10 @@ M:: boilerplate call-responder* ( path responder -- ) path responder call-next-method dup content-type>> "text/html" = [ clone [| body | - [ body responder template>> with-boilerplate ] + [ + body + responder template>> resolve-template-path + with-boilerplate + ] ] change-body ] when ; diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/furnace/callbacks/callbacks-tests.factor similarity index 87% rename from extra/http/server/callbacks/callbacks-tests.factor rename to extra/furnace/callbacks/callbacks-tests.factor index 31ea164a58..f72aad3f50 100755 --- a/extra/http/server/callbacks/callbacks-tests.factor +++ b/extra/furnace/callbacks/callbacks-tests.factor @@ -1,5 +1,5 @@ -IN: http.server.callbacks -USING: http.server.actions http.server.callbacks accessors +IN: furnace.callbacks +USING: furnace.actions furnace.callbacks accessors http.server http tools.test namespaces io fry sequences splitting kernel hashtables continuations ; @@ -24,7 +24,7 @@ splitting kernel hashtables continuations ; [ [ "hello" print - '[ , write ] + "text/html" ] show-page "byebye" print [ 123 ] show-final diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/furnace/callbacks/callbacks.factor similarity index 96% rename from extra/http/server/callbacks/callbacks.factor rename to extra/furnace/callbacks/callbacks.factor index 3b819e067b..7b18afe781 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/furnace/callbacks/callbacks.factor @@ -4,7 +4,7 @@ USING: http http.server io kernel math namespaces continuations calendar sequences assocs hashtables accessors arrays alarms quotations combinators fry assocs.lib ; -IN: http.server.callbacks +IN: furnace.callbacks SYMBOL: responder diff --git a/extra/furnace/db/db-tests.factor b/extra/furnace/db/db-tests.factor new file mode 100644 index 0000000000..34357ae701 --- /dev/null +++ b/extra/furnace/db/db-tests.factor @@ -0,0 +1,4 @@ +IN: furnace.db.tests +USING: tools.test furnace.db ; + +\ must-infer diff --git a/extra/http/server/db/db.factor b/extra/furnace/db/db.factor similarity index 82% rename from extra/http/server/db/db.factor rename to extra/furnace/db/db.factor index 73d4c35e2c..8d7027073c 100755 --- a/extra/http/server/db/db.factor +++ b/extra/furnace/db/db.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db db.pools io.pools http.server http.server.sessions +USING: db db.pools io.pools http.server furnace.sessions kernel accessors continuations namespaces destructors ; -IN: http.server.db +IN: furnace.db TUPLE: db-persistence < filter-responder pool ; diff --git a/extra/http/server/flows/flows.factor b/extra/furnace/flows/flows.factor similarity index 53% rename from extra/http/server/flows/flows.factor rename to extra/furnace/flows/flows.factor index 7a9b362111..001335065c 100644 --- a/extra/http/server/flows/flows.factor +++ b/extra/furnace/flows/flows.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces sequences arrays kernel -assocs assocs.lib hashtables math.parser -html.elements http http.server http.server.sessions ; -IN: http.server.flows +assocs assocs.lib hashtables math.parser urls combinators +html.elements http http.server furnace.sessions +html.templates.chloe.syntax ; +IN: furnace.flows TUPLE: flows < filter-responder ; @@ -11,24 +12,28 @@ C: flows : begin-flow* ( -- id ) request get - [ path>> ] [ request-params ] [ method>> ] tri 3array + [ url>> ] [ post-data>> ] [ method>> ] tri 3array flows sget set-at-unique session-changed ; -: end-flow-post ( path params -- response ) +: end-flow-post ( url post-data -- response ) request [ clone "POST" >>method swap >>post-data - swap >>path + swap >>url ] change - request get path>> split-path + request get url>> path>> split-path flows get responder>> call-responder ; -: end-flow* ( default id -- response ) - flows sget at - [ first3 "POST" = [ end-flow-post ] [ ] if ] - [ f ] ?if ; +: end-flow* ( url id -- response ) + flows sget at [ + first3 { + { "GET" [ drop ] } + { "HEAD" [ drop ] } + { "POST" [ end-flow-post ] } + } case + ] [ ] ?if ; SYMBOL: flow-id @@ -40,10 +45,30 @@ SYMBOL: flow-id : end-flow ( default -- response ) flow-id get end-flow* ; -: add-flow-id ( query -- query' ) +M: flows call-responder* + dup flows set + flow-id-key request get request-params at flow-id set + call-next-method ; + +M: flows init-session* + H{ } clone flows sset + call-next-method ; + +M: flows link-attr ( tag -- ) + drop + "flow" optional-attr { + { "none" [ flow-id off ] } + { "begin" [ begin-flow ] } + { "current" [ ] } + { f [ ] } + } case ; + +M: flows modify-query ( query responder -- query' ) + drop flow-id get [ flow-id-key associate assoc-union ] when* ; -: flow-form-field ( -- ) +M: flows hidden-form-field ( responder -- ) + drop flow-id get [ ] when* ; - -M: flows call-responder* - dup flows set - [ add-flow-id ] add-link-hook - [ flow-form-field ] add-form-hook - flow-id-key request get request-params at flow-id set - call-next-method ; - -M: flows init-session* - H{ } clone flows sset - call-next-method ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor new file mode 100644 index 0000000000..80c9f948ed --- /dev/null +++ b/extra/furnace/furnace.factor @@ -0,0 +1,136 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: furnace + +GENERIC: hidden-form-field ( responder -- ) + +M: object hidden-form-field drop ; + +: request-params ( request -- assoc ) + dup method>> { + { "GET" [ url>> query>> ] } + { "HEAD" [ url>> query>> ] } + { "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 ; + +: with-exit-continuation ( quot -- ) + '[ exit-continuation set @ ] callcc1 exit-continuation off ; + +! Chloe tags +: parse-query-attr ( string -- assoc ) + dup empty? + [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; + +CHLOE: atom + [ "title" required-attr ] + [ "href" required-attr ] + [ "query" optional-attr parse-query-attr ] tri + + swap >>query + swap >>path + adjust-url + add-atom-feed ; + +CHLOE: write-atom drop write-atom-feeds ; + +GENERIC: link-attr ( tag responder -- ) + +M: object link-attr 2drop ; + +: link-attrs ( tag -- ) + '[ , _ link-attr ] each-responder ; + +: a-start-tag ( tag -- ) + [ + + swap >>query + swap >>path + adjust-url =href + a> + ] with-scope ; + +CHLOE: a + [ a-start-tag ] + [ process-tag-children ] + [ drop ] + tri ; + +: form-start-tag ( tag -- ) + [ + [ +
+ ] [ + [ hidden-form-field ] each-responder + "for" optional-attr [ hidden render ] when* + ] bi + ] with-scope ; + +CHLOE: form + [ form-start-tag ] + [ process-tag-children ] + [ drop
] + tri ; + +DEFER: process-chloe-tag + +STRING: button-tag-markup + + + +; + +: add-tag-attrs ( attrs tag -- ) + tag-attrs swap update ; + +CHLOE: button + button-tag-markup string>xml delegate + { + [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ] + [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] + [ [ children>string 1array ] dip "button" tag-named set-tag-children ] + [ nip ] + } 2cleave process-chloe-tag ; + +: attr>word ( value -- word/f ) + dup ":" split1 swap lookup + [ ] [ "No such word: " swap append throw ] ?if ; + +: attr>var ( value -- word/f ) + attr>word dup symbol? [ + "Must be a symbol: " swap append throw + ] 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 ; + +CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; diff --git a/extra/http/server/sessions/authors.txt b/extra/furnace/sessions/authors.txt similarity index 100% rename from extra/http/server/sessions/authors.txt rename to extra/furnace/sessions/authors.txt diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor similarity index 79% rename from extra/http/server/sessions/sessions-tests.factor rename to extra/furnace/sessions/sessions-tests.factor index 8ea312dcb5..949d04d4c3 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/furnace/sessions/sessions-tests.factor @@ -1,8 +1,8 @@ -IN: http.server.sessions.tests -USING: tools.test http http.server.sessions -http.server.actions http.server math namespaces kernel accessors +IN: furnace.sessions.tests +USING: tools.test http furnace.sessions +furnace.actions http.server math namespaces kernel accessors prettyprint io.streams.string io.files splitting destructors -sequences db db.sqlite continuations ; +sequences db db.sqlite continuations urls ; : with-session [ @@ -18,15 +18,16 @@ M: foo init-session* drop 0 "x" sset ; M: foo call-responder* 2drop "x" [ 1+ ] schange - [ "x" sget pprint ] ; + "x" sget number>string "text/html" ; : url-responder-mock-test [ "GET" >>method - "id" get session-id-key set-query-param - "/" >>path - request set + dup url>> + "id" get session-id-key set-query-param + "/" >>path drop + init-request { } sessions get call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; @@ -36,21 +37,21 @@ M: foo call-responder* "GET" >>method "cookies" get >>cookies - "/" >>path - request set + dup url>> "/" >>path drop + init-request { } sessions get call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; : - [ [ ] exit-with ] >>display ; + [ [ ] "text/plain" exit-with ] >>display ; [ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors "auth-test.db" temp-file sqlite-db [ - init-request + init-request init-sessions-table [ ] [ @@ -112,8 +113,8 @@ M: foo call-responder* [ - "GET" >>method - "/" >>path + "GET" >>method + dup url>> "/" >>path drop request set { "etc" } sessions get call-responder response set [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test @@ -131,8 +132,9 @@ M: foo call-responder* [ ] [ "GET" >>method - "id" get session-id-key set-query-param - "/" >>path + dup url>> + "id" get session-id-key set-query-param + "/" >>path drop request set [ diff --git a/extra/http/server/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor similarity index 92% rename from extra/http/server/sessions/sessions.factor rename to extra/furnace/sessions/sessions.factor index a7e1a141c4..2b6bf84bdd 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -4,8 +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 ; -IN: http.server.sessions +http http.server html.elements html.templates.chloe ; +IN: furnace.sessions TUPLE: session id expires uid namespace changed? ; @@ -136,7 +136,8 @@ M: session-saver dispose : put-session-cookie ( response -- response' ) session get id>> number>string put-cookie ; -: session-form-field ( -- ) +M: sessions hidden-form-field ( responder -- ) + drop ; M: sessions call-responder* ( path responder -- response ) - [ session-form-field ] add-form-hook sessions set request-session [ begin-session ] unless* existing-session put-session-cookie ; : 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/components/components-tests.factor b/extra/html/components/components-tests.factor index 1a0f849a8f..90dc156ea6 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -11,7 +11,7 @@ html.components namespaces ; TUPLE: color red green blue ; -[ ] [ 1 2 3 color boa from-tuple ] unit-test +[ ] [ 1 2 3 color boa from-object ] unit-test [ 1 ] [ "red" value ] unit-test @@ -107,7 +107,7 @@ TUPLE: color red green blue ; [ ] [ t "delivery" set-value ] unit-test -[ "Delivery" ] [ +[ "Delivery" ] [ [ "delivery" diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index efac730af6..c013007a14 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting mirrors hashtables combinators continuations math strings fry locals calendar calendar.format xml.entities validators html.elements html.streams xmode.code2html farkup inspector -lcs.diff2html ; +lcs.diff2html urls ; IN: html.components SYMBOL: values @@ -19,9 +19,9 @@ SYMBOL: values : prepare-value ( name object -- value name object ) [ [ value ] keep ] dip ; inline -: from-assoc ( assoc -- ) values get swap update ; - -: from-tuple ( tuple -- ) from-assoc ; +: from-object ( object -- ) + dup assoc? [ ] unless + values get swap update ; : deposit-values ( destination names -- ) [ dup value ] H{ } map>assoc update ; @@ -32,24 +32,19 @@ SYMBOL: values : with-each-index ( seq quot -- ) '[ [ - blank-values 1+ "index" set-value @ + values [ clone ] change + 1+ "index" set-value @ ] with-scope ] each-index ; inline : with-each-value ( seq quot -- ) '[ "value" set-value @ ] with-each-index ; inline -: with-each-assoc ( seq quot -- ) - '[ from-assoc @ ] with-each-index ; inline +: with-each-object ( seq quot -- ) + '[ from-object @ ] with-each-index ; inline -: with-each-tuple ( seq quot -- ) - '[ from-tuple @ ] with-each-index ; inline - -: with-assoc-values ( assoc quot -- ) - '[ blank-values , from-assoc @ ] with-scope ; inline - -: with-tuple-values ( assoc quot -- ) - '[ blank-values , from-tuple @ ] with-scope ; inline +: with-values ( object quot -- ) + '[ blank-values , from-object @ ] with-scope ; inline : nest-values ( name quot -- ) swap [ @@ -58,22 +53,6 @@ SYMBOL: values ] with-scope ] dip set-value ; inline -: nest-tuple ( name quot -- ) - swap [ - [ - H{ } clone [ values set call ] keep - ] with-scope - ] dip set-value ; inline - -: object>string ( object -- string ) - { - { [ dup real? ] [ number>string ] } - { [ dup timestamp? ] [ timestamp>string ] } - { [ dup string? ] [ ] } - { [ dup word? ] [ word-name ] } - { [ dup not ] [ drop "" ] } - } cond ; - GENERIC: render* ( value name render -- ) : render ( name renderer -- ) @@ -174,7 +153,7 @@ M: checkbox render* label>> escape-string write ; diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index e5377cedf8..2b4920d462 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -4,7 +4,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io kernel namespaces prettyprint quotations -sequences strings words xml.entities compiler.units effects ; +sequences strings words xml.entities compiler.units effects +urls math math.parser combinators calendar calendar.format ; IN: html.elements @@ -126,11 +127,22 @@ SYMBOL: html dup def-for-html-word- ; +: object>string ( object -- string ) + #! Should this be generic and in the core? + { + { [ dup real? ] [ number>string ] } + { [ dup timestamp? ] [ timestamp>string ] } + { [ dup url? ] [ url>string ] } + { [ dup string? ] [ ] } + { [ dup word? ] [ word-name ] } + { [ dup not ] [ drop "" ] } + } cond ; + : write-attr ( value name -- ) " " write-html write-html "='" write-html - escape-quoted-string write-html + object>string escape-quoted-string write-html "'" write-html ; : attribute-effect T{ effect f { "string" } 0 } ; @@ -162,7 +174,7 @@ SYMBOL: html "id" "onclick" "style" "valign" "accesskey" "src" "language" "colspan" "onchange" "rel" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" - "media" "title" "multiple" + "media" "title" "multiple" "checked" ] [ define-attribute-word ] each >> diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index eaa0f0dc3d..6fb4429ea6 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -27,8 +27,7 @@ IN: html.templates.chloe.tests : test-template ( name -- template ) "resource:extra/html/templates/chloe/test/" - swap - ".xml" 3append ; + prepend ; [ "Hello world" ] [ [ @@ -156,6 +155,14 @@ TUPLE: person first-name last-name ; [ "
RBaxterUnknown
DougColeman
" ] [ [ - "test11" test-template call-template + "test10" test-template call-template ] run-template [ blank? not ] filter ] unit-test + +[ ] [ 1 "id" set-value ] unit-test + +[ "Hello" ] [ + [ + "test11" 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 092f79bb36..93afa44d81 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -3,16 +3,12 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string -unicode.case tuple-syntax mirrors fry math +unicode.case tuple-syntax mirrors fry math urls multiline xml xml.data xml.writer xml.utilities html.elements html.components html.templates -http.server -http.server.auth -http.server.flows -http.server.actions -http.server.sessions ; +html.templates.chloe.syntax ; IN: html.templates.chloe ! Chloe is Ed's favorite web designer @@ -23,8 +19,6 @@ C: chloe DEFER: process-template -: chloe-ns "http://factorcode.org/chloe/1.0" ; inline - : chloe-attrs-only ( assoc -- assoc' ) [ drop name-url chloe-ns = ] assoc-filter ; @@ -38,35 +32,22 @@ DEFER: process-template [ t ] } cond nip ; -SYMBOL: tags - -MEMO: chloe-name ( string -- name ) - name new - swap >>tag - chloe-ns >>url ; - -: required-attr ( tag name -- value ) - dup chloe-name rot at* - [ nip ] [ drop " attribute is required" append throw ] if ; - -: optional-attr ( tag name -- value ) - chloe-name swap at ; - : process-tag-children ( tag -- ) [ process-template ] each ; +CHLOE: chloe process-tag-children ; + : children>string ( tag -- string ) [ process-tag-children ] with-string-writer ; -: title-tag ( tag -- ) - children>string set-title ; +CHLOE: title children>string set-title ; -: write-title-tag ( tag -- ) +CHLOE: write-title drop "head" tags get member? "title" tags get member? not and [ write-title ] [ write-title ] if ; -: style-tag ( tag -- ) +CHLOE: style dup "include" optional-attr dup [ swap children>string empty? [ "style tag cannot have both an include attribute and a body" throw @@ -76,146 +57,12 @@ MEMO: chloe-name ( string -- name ) drop children>string ] if add-style ; -: write-style-tag ( tag -- ) +CHLOE: write-style drop ; -: atom-tag ( tag -- ) - [ "title" required-attr ] - [ "href" required-attr ] - bi set-atom-feed ; +CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ; -: write-atom-tag ( tag -- ) - drop - "head" tags get member? [ - write-atom-feed - ] [ - atom-feed get value>> second write - ] if ; - -: parse-query-attr ( string -- assoc ) - dup empty? - [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; - -: flow-attr ( tag -- ) - "flow" optional-attr { - { "none" [ flow-id off ] } - { "begin" [ begin-flow ] } - { "current" [ ] } - { f [ ] } - } case ; - -: session-attr ( tag -- ) - "session" optional-attr { - { "none" [ session off flow-id off ] } - { "current" [ ] } - { f [ ] } - } case ; - -: a-start-tag ( tag -- ) - [ - string =href - a> - ] with-scope ; - -: a-tag ( tag -- ) - [ a-start-tag ] - [ process-tag-children ] - [ drop ] - tri ; - -: form-start-tag ( tag -- ) - [ - [ -
- ] [ - hidden-form-field - "for" optional-attr [ hidden render ] when* - ] bi - ] with-scope ; - -: form-tag ( tag -- ) - [ form-start-tag ] - [ process-tag-children ] - [ drop
] - tri ; - -DEFER: process-chloe-tag - -STRING: button-tag-markup - - - -; - -: add-tag-attrs ( attrs tag -- ) - tag-attrs swap update ; - -: button-tag ( tag -- ) - button-tag-markup string>xml delegate - { - [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ] - [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] - [ [ children>string 1array ] dip "button" tag-named set-tag-children ] - [ nip ] - } 2cleave process-chloe-tag ; - -: attr>word ( value -- word/f ) - dup ":" split1 swap lookup - [ ] [ "No such word: " swap append throw ] ?if ; - -: attr>var ( value -- word/f ) - attr>word dup symbol? [ - "Must be a symbol: " swap append throw - ] 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 ; - -: if-tag ( tag -- ) - dup if-satisfied? [ process-tag-children ] [ drop ] if ; - -: even-tag ( tag -- ) - "index" value even? [ process-tag-children ] [ drop ] if ; - -: odd-tag ( tag -- ) - "index" value odd? [ process-tag-children ] [ drop ] if ; - -: (each-tag) ( tag quot -- ) - [ - [ "values" required-attr value ] keep - '[ , process-tag-children ] - ] dip call ; inline - -: each-tag ( tag -- ) - [ with-each-value ] (each-tag) ; - -: each-tuple-tag ( tag -- ) - [ with-each-tuple ] (each-tag) ; - -: each-assoc-tag ( tag -- ) - [ with-each-assoc ] (each-tag) ; +CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ; : (bind-tag) ( tag quot -- ) [ @@ -223,83 +70,36 @@ STRING: button-tag-markup '[ , process-tag-children ] ] dip call ; inline -: bind-tuple-tag ( tag -- ) - [ with-tuple-values ] (bind-tag) ; +CHLOE: each [ with-each-value ] (bind-tag) ; -: bind-assoc-tag ( tag -- ) - [ with-assoc-values ] (bind-tag) ; +CHLOE: bind-each [ with-each-object ] (bind-tag) ; + +CHLOE: bind [ with-values ] (bind-tag) ; : error-message-tag ( tag -- ) children>string render-error ; -: validation-messages-tag ( tag -- ) - drop render-validation-messages ; +CHLOE: comment drop ; -: singleton-component-tag ( tag class -- ) - [ "name" required-attr ] dip render ; +CHLOE: call-next-template drop call-next-template ; -: attrs>slots ( tag tuple -- ) - [ attrs>> ] [ ] bi* - '[ - swap tag>> dup "name" = - [ 2drop ] [ , set-at ] if - ] assoc-each ; +CHLOE-SINGLETON: label +CHLOE-SINGLETON: link +CHLOE-SINGLETON: farkup +CHLOE-SINGLETON: inspector +CHLOE-SINGLETON: comparison +CHLOE-SINGLETON: html +CHLOE-SINGLETON: hidden -: tuple-component-tag ( tag class -- ) - [ drop "name" required-attr ] - [ new [ attrs>slots ] keep ] - 2bi render ; +CHLOE-TUPLE: field +CHLOE-TUPLE: password +CHLOE-TUPLE: choice +CHLOE-TUPLE: checkbox +CHLOE-TUPLE: code : process-chloe-tag ( tag -- ) - dup name-tag { - { "chloe" [ process-tag-children ] } - - ! HTML head - { "title" [ title-tag ] } - { "write-title" [ write-title-tag ] } - { "style" [ style-tag ] } - { "write-style" [ write-style-tag ] } - { "atom" [ atom-tag ] } - { "write-atom" [ write-atom-tag ] } - - ! HTML elements - { "a" [ a-tag ] } - { "button" [ button-tag ] } - - ! Components - { "label" [ label singleton-component-tag ] } - { "link" [ link singleton-component-tag ] } - { "code" [ code tuple-component-tag ] } - { "farkup" [ farkup singleton-component-tag ] } - { "inspector" [ inspector singleton-component-tag ] } - { "comparison" [ comparison singleton-component-tag ] } - { "html" [ html singleton-component-tag ] } - - ! Forms - { "form" [ form-tag ] } - { "error-message" [ error-message-tag ] } - { "validation-messages" [ validation-messages-tag ] } - { "hidden" [ hidden singleton-component-tag ] } - { "field" [ field tuple-component-tag ] } - { "password" [ password tuple-component-tag ] } - { "textarea" [ textarea tuple-component-tag ] } - { "choice" [ choice tuple-component-tag ] } - { "checkbox" [ checkbox tuple-component-tag ] } - - ! Control flow - { "if" [ if-tag ] } - { "even" [ even-tag ] } - { "odd" [ odd-tag ] } - { "each" [ each-tag ] } - { "each-assoc" [ each-assoc-tag ] } - { "each-tuple" [ each-tuple-tag ] } - { "bind-assoc" [ bind-assoc-tag ] } - { "bind-tuple" [ bind-tuple-tag ] } - { "comment" [ drop ] } - { "call-next-template" [ drop call-next-template ] } - - [ "Unknown chloe tag: " prepend throw ] - } case ; + dup name-tag tags get at + [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ; : process-tag ( tag -- ) { @@ -310,7 +110,15 @@ STRING: button-tag-markup [ drop tags get pop* ] } cleave ; +: expand-attrs ( tag -- tag ) + dup [ tag? ] is? [ + clone [ + [ "@" ?head [ value object>string ] when ] assoc-map + ] change-attrs + ] when ; + : process-template ( xml -- ) + expand-attrs { { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] } { [ dup [ tag? ] is? ] [ process-tag ] } @@ -334,6 +142,6 @@ STRING: button-tag-markup ] with-scope ; M: chloe call-template* - path>> utf8 read-xml process-chloe ; + path>> ".xml" append utf8 read-xml process-chloe ; INSTANCE: chloe template diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor new file mode 100644 index 0000000000..d30ddb9168 --- /dev/null +++ b/extra/html/templates/chloe/syntax/syntax.factor @@ -0,0 +1,58 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: html.templates.chloe.syntax +USING: accessors kernel sequences combinators kernel namespaces +classes.tuple assocs splitting words arrays memoize parser +io io.files io.encodings.utf8 io.streams.string +unicode.case tuple-syntax mirrors fry math urls +multiline xml xml.data xml.writer xml.utilities +html.elements +html.components +html.templates ; + +SYMBOL: tags + +tags global [ H{ } clone or ] change-at + +: define-chloe-tag ( name quot -- ) tags get set-at ; + +: CHLOE: + scan parse-definition swap define-chloe-tag ; + parsing + +: chloe-ns "http://factorcode.org/chloe/1.0" ; inline + +MEMO: chloe-name ( string -- name ) + name new + swap >>tag + chloe-ns >>url ; + +: required-attr ( tag name -- value ) + dup chloe-name rot at* + [ nip ] [ drop " attribute is required" append throw ] if ; + +: optional-attr ( tag name -- value ) + chloe-name swap at ; + +: singleton-component-tag ( tag class -- ) + [ "name" required-attr ] dip render ; + +: CHLOE-SINGLETON: + scan dup '[ , singleton-component-tag ] define-chloe-tag ; + parsing + +: attrs>slots ( tag tuple -- ) + [ attrs>> ] [ ] bi* + '[ + swap tag>> dup "name" = + [ 2drop ] [ , set-at ] if + ] assoc-each ; + +: tuple-component-tag ( tag class -- ) + [ drop "name" required-attr ] + [ new [ attrs>slots ] keep ] + 2bi render ; + +: CHLOE-TUPLE: + scan dup '[ , tuple-component-tag ] define-chloe-tag ; + parsing diff --git a/extra/html/templates/chloe/test/test10.xml b/extra/html/templates/chloe/test/test10.xml index afded9366f..fd4a64ad0a 100644 --- a/extra/html/templates/chloe/test/test10.xml +++ b/extra/html/templates/chloe/test/test10.xml @@ -3,12 +3,12 @@ - + - +
diff --git a/extra/html/templates/chloe/test/test11.xml b/extra/html/templates/chloe/test/test11.xml index 17e31b1a59..a9b2769445 100644 --- a/extra/html/templates/chloe/test/test11.xml +++ b/extra/html/templates/chloe/test/test11.xml @@ -1,14 +1,3 @@ - - - - - - - - - -
- - +Hello diff --git a/extra/html/templates/chloe/test/test9.xml b/extra/html/templates/chloe/test/test9.xml index bcfc468738..6166c800ed 100644 --- a/extra/html/templates/chloe/test/test9.xml +++ b/extra/html/templates/chloe/test/test9.xml @@ -3,7 +3,7 @@
    - +
diff --git a/extra/html/templates/templates.factor b/extra/html/templates/templates.factor index 580af58ecc..de774f0864 100644 --- a/extra/html/templates/templates.factor +++ b/extra/html/templates/templates.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel fry io io.encodings.utf8 io.files debugger prettyprint continuations namespaces boxes sequences -arrays strings html.elements io.streams.string quotations ; +arrays strings html.elements io.streams.string +quotations xml.data xml.writer ; IN: html.templates MIXIN: template @@ -13,6 +14,8 @@ M: string call-template* write ; M: callable call-template* call ; +M: xml call-template* write-xml ; + M: object call-template* output-stream get stream-copy ; ERROR: template-error template error ; @@ -43,17 +46,17 @@ SYMBOL: style : write-style ( -- ) style get >string write ; -SYMBOL: atom-feed +SYMBOL: atom-feeds -: set-atom-feed ( title url -- ) - 2array atom-feed get >box ; +: add-atom-feed ( title url -- ) + 2array atom-feeds get push ; -: write-atom-feed ( -- ) - atom-feed get value>> [ +: write-atom-feeds ( -- ) + atom-feeds get [ - ] when* ; + ] each ; SYMBOL: nested-template? @@ -66,9 +69,9 @@ M: f call-template* drop call-next-template ; : with-boilerplate ( body template -- ) [ - title get [ title set ] unless - atom-feed get [ atom-feed set ] unless - style get [ SBUF" " clone style set ] unless + title [ or ] change + style [ SBUF" " clone or ] change + atom-feeds [ V{ } like ] change [ [ diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index db90f746ac..7ce066f0d7 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -1,5 +1,5 @@ USING: http.client http.client.private http tools.test -tuple-syntax namespaces ; +tuple-syntax namespaces urls ; [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test @@ -10,11 +10,8 @@ tuple-syntax namespaces ; [ TUPLE{ request - protocol: http + url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" query: H{ } } method: "GET" - host: "www.apple.com" - port: 80 - path: "/index.html" version: "1.1" cookies: V{ } header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } @@ -28,11 +25,8 @@ tuple-syntax namespaces ; [ TUPLE{ request - protocol: https + url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" query: H{ } } method: "GET" - host: "www.amazon.com" - port: 443 - path: "/index.html" version: "1.1" cookies: V{ } header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 7b156a4b9b..9fd5f15d6a 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -27,8 +27,7 @@ SYMBOL: redirects redirects inc redirects get max-redirects < [ request get - swap "location" header dup absolute-url? - [ request-with-url ] [ request-with-path ] if + swap "location" header request-with-url "GET" >>method http-request ] [ too-many-redirects @@ -51,7 +50,7 @@ PRIVATE> : http-request ( request -- response data ) dup request [ - dup request-addr latin1 [ + dup url>> url-addr latin1 [ 1 minutes timeouts write-request read-response diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 151d1ce84f..5a11814f09 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,37 +1,13 @@ USING: http tools.test multiline tuple-syntax io.streams.string kernel arrays splitting sequences -assocs io.sockets db db.sqlite continuations ; +assocs io.sockets db db.sqlite continuations urls ; IN: http.tests -[ "hello%20world" ] [ "hello world" url-encode ] unit-test -[ "hello world" ] [ "hello%20world" url-decode ] unit-test -[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test -[ f ] [ "%XX%XX%XX" url-decode ] unit-test -[ f ] [ "%XX%XX%X" url-decode ] unit-test - -[ "hello world" ] [ "hello+world" url-decode ] unit-test -[ "hello world" ] [ "hello%20world" url-decode ] unit-test -[ " ! " ] [ "%20%21%20" url-decode ] unit-test -[ "hello world" ] [ "hello world%" url-decode ] unit-test -[ "hello world" ] [ "hello world%x" url-decode ] unit-test -[ "hello%20world" ] [ "hello world" url-encode ] unit-test -[ "%20%21%20" ] [ " ! " url-encode ] unit-test - -[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test - [ "/" ] [ "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 -[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test - -[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test - -[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test - -[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test - : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 @@ -45,11 +21,8 @@ blah [ TUPLE{ request - protocol: http - port: 80 + url: TUPLE{ url protocol: "http" port: 80 path: "/bar" } method: "GET" - path: "/bar" - query: H{ } version: "1.1" header: H{ { "some-header" "1; 2" } { "content-length" "4" } } post-data: "blah" @@ -85,14 +58,10 @@ Host: www.sex.com [ TUPLE{ request - protocol: http - port: 80 + url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" } method: "HEAD" - path: "/bar" - query: H{ } version: "1.1" header: H{ { "host" "www.sex.com" } } - host: "www.sex.com" cookies: V{ } } ] [ @@ -101,6 +70,15 @@ Host: www.sex.com ] with-string-reader ] unit-test +STRING: read-request-test-3 +GET nested HTTP/1.0 + +; + +[ read-request-test-3 [ read-request ] with-string-reader ] +[ "Bad request: URL" = ] +must-fail-with + STRING: read-response-test-1 HTTP/1.1 404 not found Content-Type: text/html; charset=UTF8 @@ -145,14 +123,14 @@ read-response-test-1' 1array [ ] unit-test ! Live-fire exercise -USING: http.server http.server.static http.server.sessions -http.server.actions http.server.auth.login http.server.db http.client +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 ; : add-quit-action - [ stop-server [ "Goodbye" write ] ] >>display + [ stop-server "Goodbye" "text/html" ] >>display "quit" add-responder ; : test-db "test.db" temp-file sqlite-db ; @@ -171,7 +149,7 @@ test-db [ "resource:extra/http/test" >>default "nested" add-responder - [ "redirect-loop" f ] >>display + [ URL" redirect-loop" ] >>display "redirect-loop" add-responder main-responder set @@ -186,16 +164,6 @@ test-db [ "http://localhost:1237/nested/foo.html" http-get = ] unit-test -! Try with a slightly malformed request -[ t ] [ - "localhost" 1237 ascii [ - "GET nested HTTP/1.0\r\n" write flush - "\r\n" write flush - read-crlf drop - read-header - ] with-client "location" swap at "/" head? -] unit-test - [ "http://localhost:1237/redirect-loop" http-get ] [ too-many-redirects? ] must-fail-with @@ -237,7 +205,7 @@ test-db [ [ ] [ [ - [ [ "Hi" write ] ] >>display + [ [ "Hi" write ] "text/plain" ] >>display "" add-responder diff --git a/extra/http/http.factor b/extra/http/http.factor index 89c8f62d5c..a4e6451044 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -7,88 +7,31 @@ 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.sockets io.sockets.secure io.server unicode.case unicode.categories qualified -html.templates ; +urls html.templates ; EXCLUDE: fry => , ; IN: http -SINGLETON: http +: secure-protocol? ( protocol -- ? ) + "https" = ; -SINGLETON: https +: url-addr ( url -- addr ) + [ [ host>> ] [ port>> ] bi ] [ protocol>> ] bi + secure-protocol? [ ] when ; -GENERIC: http-port ( protocol -- port ) - -M: http http-port drop 80 ; - -M: https http-port drop 443 ; - -GENERIC: protocol>string ( protocol -- string ) - -M: http protocol>string drop "http" ; - -M: https protocol>string drop "https" ; - -: string>protocol ( string -- protocol ) +: protocol-port ( protocol -- port ) { - { "http" [ http ] } - { "https" [ https ] } - [ "Unknown protocol: " swap append throw ] + { "http" [ 80 ] } + { "https" [ 443 ] } } case ; -: absolute-url? ( url -- ? ) - [ "http://" head? ] [ "https://" head? ] bi or ; - -: url-quotable? ( ch -- ? ) - #! In a URL, can this character be used without - #! URL-encoding? - { - { [ dup letter? ] [ t ] } - { [ dup LETTER? ] [ t ] } - { [ dup digit? ] [ t ] } - { [ dup "/_-.:" member? ] [ t ] } - [ f ] - } cond nip ; foldable - -: push-utf8 ( ch -- ) - 1string utf8 encode - [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; - -: url-encode ( str -- str ) - [ - [ dup url-quotable? [ , ] [ push-utf8 ] if ] each - ] "" make ; - -: url-decode-hex ( index str -- ) - 2dup length 2 - >= [ - 2drop - ] [ - [ 1+ dup 2 + ] dip subseq hex> [ , ] when* - ] if ; - -: url-decode-% ( index str -- index str ) - 2dup url-decode-hex [ 3 + ] dip ; - -: url-decode-+-or-other ( index str ch -- index str ) - dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ; - -: url-decode-iter ( index str -- ) - 2dup length >= [ - 2drop - ] [ - 2dup nth dup CHAR: % = [ - drop url-decode-% - ] [ - url-decode-+-or-other - ] if url-decode-iter - ] if ; - -: url-decode ( str -- str ) - [ 0 swap url-decode-iter ] "" make utf8 decode ; +: ensure-port ( url -- url' ) + dup protocol>> '[ , protocol-port or ] change-port ; : crlf "\r\n" write ; @@ -130,6 +73,7 @@ M: https protocol>string drop "https" ; { { [ dup number? ] [ number>string ] } { [ dup timestamp? ] [ timestamp>http-string ] } + { [ dup url? ] [ url>string ] } { [ dup string? ] [ ] } { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } } cond ; @@ -145,42 +89,6 @@ M: https protocol>string drop "https" ; header-value>string check-header-string write crlf ] assoc-each crlf ; -: add-query-param ( value key assoc -- ) - [ - at [ - { - { [ dup string? ] [ swap 2array ] } - { [ dup array? ] [ swap suffix ] } - { [ dup not ] [ drop ] } - } cond - ] when* - ] 2keep set-at ; - -: query>assoc ( query -- assoc ) - dup [ - "&" split H{ } clone [ - [ - [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip - add-query-param - ] curry each - ] keep - ] when ; - -: assoc>query ( hash -- str ) - [ - { - { [ dup number? ] [ number>string 1array ] } - { [ dup string? ] [ 1array ] } - { [ dup sequence? ] [ ] } - } cond - ] assoc-map - [ - [ - [ url-encode ] dip - [ url-encode "=" swap 3append , ] with each - ] assoc-each - ] { } make "&" join ; - TUPLE: cookie name value path domain expires max-age http-only ; : ( value name -- cookie ) @@ -236,12 +144,8 @@ TUPLE: cookie name value path domain expires max-age http-only ; [ unparse-cookie ] map concat "; " join ; TUPLE: request -protocol -host -port method -path -query +url version header post-data @@ -254,19 +158,15 @@ cookies ; : request new "1.1" >>version - http >>protocol + + "http" >>protocol + H{ } clone >>query + >>url H{ } clone >>header - H{ } clone >>query V{ } clone >>cookies "close" "connection" set-header "Factor http.client vocabulary" "user-agent" set-header ; -: query-param ( request key -- value ) - swap query>> at ; - -: set-query-param ( request value key -- request ) - pick query>> set-at ; - : chop-hostname ( str -- str' ) ":" split1 "//" ?head drop nip CHAR: / over index over length or tail @@ -284,21 +184,17 @@ cookies ; " " read-until [ "Bad request: method" throw ] unless >>method ; -: read-query ( request -- request ) - " " read-until - [ "Bad request: query params" throw ] unless - query>assoc >>query ; +: check-absolute ( url -- url ) + dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline : read-url ( request -- request ) - " ?" read-until { - { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] } - { CHAR: ? [ url>path >>path read-query ] } - [ "Bad request: URL" throw ] - } case ; + " " read-until [ + dup empty? [ drop read-url ] [ >url check-absolute >>url ] if + ] [ "Bad request: URL" throw ] if ; : parse-version ( string -- version ) - "HTTP/" ?head [ "Bad version" throw ] unless - dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; + "HTTP/" ?head [ "Bad request: version" throw ] unless + dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ; : read-request-version ( request -- request ) read-crlf [ CHAR: \s = ] left-trim @@ -325,13 +221,11 @@ SYMBOL: max-post-request : read-post-data ( request -- request ) dup header>> content-length [ read >>post-data ] when* ; -: parse-host ( string -- host port ) - "." ?tail drop ":" split1 - dup [ string>number ] when ; - : extract-host ( request -- request ) - dup [ "host" header parse-host ] keep protocol>> http-port or - [ >>host ] [ >>port ] bi* ; + [ ] [ url>> ] [ "host" header parse-host ] tri + [ >>host ] [ >>port ] bi* + ensure-port + drop ; : extract-post-data-type ( request -- request ) dup "content-type" header >>post-data-type ; @@ -349,6 +243,9 @@ SYMBOL: max-post-request : parse-content-type ( content-type -- type encoding ) ";" split1 parse-content-type-attributes "charset" swap at ; +: detect-protocol ( request -- request ) + dup url>> remote-address get secure? "https" "http" ? >>protocol drop ; + : read-request ( -- request ) read-method @@ -356,6 +253,7 @@ SYMBOL: max-post-request read-request-version read-request-header read-post-data + detect-protocol extract-host extract-post-data-type parse-post-data @@ -364,15 +262,8 @@ SYMBOL: max-post-request : write-method ( request -- request ) dup method>> write bl ; -: (link>string) ( url query -- url' ) - [ url-encode ] [ assoc>query ] bi* - dup empty? [ drop ] [ "?" swap 3append ] if ; - -: write-url ( request -- ) - [ path>> ] [ query>> ] bi (link>string) write ; - : write-request-url ( request -- request ) - dup write-url bl ; + dup url>> relative-url url>string write bl ; : write-version ( request -- request ) "HTTP/" write dup request-version write crlf ; @@ -383,24 +274,13 @@ SYMBOL: max-post-request "application/x-www-form-urlencoded" >>post-data-type ] if ; -GENERIC: protocol-addr ( request protocol -- addr ) - -M: object protocol-addr - drop [ host>> ] [ port>> ] bi ; - -M: https protocol-addr - call-next-method ; - -: request-addr ( request -- addr ) - dup protocol>> protocol-addr ; - -: request-host ( request -- string ) - [ host>> ] [ port>> ] bi dup http http-port = +: url-host ( url -- string ) + [ host>> ] [ port>> ] bi dup "http" protocol-port = [ drop ] [ ":" swap number>string 3append ] if ; : write-request-header ( request -- request ) dup header>> >hashtable - over host>> [ over request-host "host" pick set-at ] when + over url>> host>> [ over url>> url-host "host" pick set-at ] when over post-data>> [ length "content-length" pick set-at ] when* over post-data-type>> [ "content-type" pick set-at ] when* over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* @@ -419,38 +299,8 @@ M: https protocol-addr flush drop ; -: request-with-path ( request path -- request ) - [ "/" prepend ] [ "/" ] if* - "?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ; - : request-with-url ( request url -- request ) - ":" split1 - [ string>protocol >>protocol ] - [ - "//" ?head [ "Invalid URL" throw ] unless - "/" split1 - [ - parse-host [ >>host ] [ >>port ] bi* - dup protocol>> http-port '[ , or ] change-port - ] - [ request-with-path ] - bi* - ] bi* ; - -: request-url ( request -- url ) - [ - [ - dup host>> [ - [ protocol>> protocol>string write "://" write ] - [ host>> url-encode write ":" write ] - [ [ port>> ] [ protocol>> http-port or ] bi number>string write ] - tri - ] [ drop ] if - ] - [ path>> "/" head? [ "/" write ] unless ] - [ write-url ] - tri - ] with-string-writer ; + '[ , >url derive-url ensure-port ] change-url ; GENERIC: write-response ( response -- ) diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index 20eb7318d0..a706ee6998 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -14,13 +14,12 @@ IN: http.server.cgi "HTTP/" request get version>> append "SERVER_PROTOCOL" set "Factor" "SERVER_SOFTWARE" set - dup "PATH_TRANSLATED" set - "SCRIPT_FILENAME" set + [ "PATH_TRANSLATED" set ] [ "SCRIPT_FILENAME" set ] bi - request get path>> "SCRIPT_NAME" set + request get url>> path>> "SCRIPT_NAME" set - request get host>> "SERVER_NAME" set - request get port>> number>string "SERVER_PORT" set + request get url>> host>> "SERVER_NAME" set + request get url>> port>> number>string "SERVER_PORT" set "" "PATH_INFO" set "" "REMOTE_HOST" set "" "REMOTE_ADDR" set diff --git a/extra/http/server/db/db-tests.factor b/extra/http/server/db/db-tests.factor deleted file mode 100644 index 0c34745c00..0000000000 --- a/extra/http/server/db/db-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: http.server.db.tests -USING: tools.test http.server.db ; - -\ must-infer diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 0aed425ade..fb1abcc6e0 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,27 +1,52 @@ USING: http.server tools.test kernel namespaces accessors -io http math sequences assocs arrays classes words ; +io http math sequences assocs arrays classes words urls ; IN: http.server.tests \ find-responder must-infer [ - http >>protocol - "www.apple.com" >>host - "/xxx/bar" >>path - { { "a" "b" } } >>query + + "http" >>protocol + "www.apple.com" >>host + "/xxx/bar" >>path + { { "a" "b" } } >>query + >>url request set [ ] link-hook set - [ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test - [ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test - [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test - [ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test - [ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test - [ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test - [ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test - [ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test + [ "http://www.apple.com:80/xxx/bar" ] [ + adjust-url url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/baz" ] [ + "baz" >>path adjust-url url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/baz?c=d" ] [ + "baz" >>path { { "c" "d" } } >>query adjust-url url>string + ] unit-test + + [ "http://www.apple.com:80/xxx/bar?c=d" ] [ + { { "c" "d" } } >>query adjust-url url>string + ] unit-test + + [ "http://www.apple.com:80/flip" ] [ + "/flip" >>path adjust-url url>string + ] unit-test + + [ "http://www.apple.com:80/flip?c=d" ] [ + "/flip" >>path { { "c" "d" } } >>query adjust-url url>string + ] unit-test + + [ "http://www.jedit.org:80/" ] [ + "http://www.jedit.org" >url adjust-url url>string + ] unit-test + + [ "http://www.jedit.org:80/?a=b" ] [ + "http://www.jedit.org" >url { { "a" "b" } } >>query adjust-url url>string + ] unit-test ] with-scope TUPLE: mock-responder path ; @@ -31,7 +56,7 @@ C: mock-responder M: mock-responder call-responder* nip path>> on - [ ] ; + [ ] "text/plain" ; : check-dispatch ( tag path -- ? ) H{ } clone base-paths set @@ -84,7 +109,7 @@ C: path-check-responder M: path-check-responder call-responder* drop - >array ; + >array "text/plain" ; [ { "c" } ] [ H{ } clone base-paths set @@ -125,7 +150,7 @@ C: base-path-check-responder M: base-path-check-responder call-responder* 2drop "$funny-dispatcher" resolve-base-path - ; + "text/plain" ; [ ] [ diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index d68c66b829..2fd706432b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,23 +2,16 @@ ! 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.elements accessors math.parser -combinators.lib tools.vocabs debugger continuations random -combinators destructors io.encodings.8-bit fry classes words -math rss json.writer ; +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 ; IN: http.server ! path is a sequence of path component strings - GENERIC: call-responder* ( path responder -- response ) -: request-params ( request -- assoc ) - dup method>> { - { "GET" [ query>> ] } - { "HEAD" [ query>> ] } - { "POST" [ post-data>> ] } - } case ; - : ( body content-type -- response ) 200 >>code @@ -26,21 +19,6 @@ GENERIC: call-responder* ( path responder -- response ) swap >>content-type swap >>body ; -: ( body -- response ) - "text/plain" ; - -: ( body -- response ) - "text/html" ; - -: ( body -- response ) - "text/xml" ; - -: ( feed -- response ) - '[ , feed>xml ] "text/xml" ; - -: ( obj -- response ) - '[ , >json ] "application/json" ; - TUPLE: trivial-responder response ; C: trivial-responder @@ -55,7 +33,8 @@ M: trivial-responder call-responder* nip response>> call ; ; : ( code message -- response ) - 2dup '[ , , trivial-response-body ] + 2dup [ trivial-response-body ] with-string-writer + "text/html" swap >>message swap >>code ; @@ -69,7 +48,7 @@ SYMBOL: 404-responder [ <404> ] 404-responder set-global -SYMBOL: base-paths +SYMBOL: responder-nesting : invert-slice ( slice -- slice' ) dup slice? [ @@ -78,86 +57,81 @@ SYMBOL: base-paths drop { } ] if ; -: add-base-path ( path dispatcher -- ) - [ invert-slice ] [ class word-name ] bi* - base-paths get set-at ; +: 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 ; : call-responder ( path responder -- response ) - [ add-base-path ] [ call-responder* ] 2bi ; + [ add-responder-path ] [ call-responder* ] 2bi ; -SYMBOL: link-hook +: nested-responders ( -- seq ) + responder-nesting get assocs:values [ third ] map ; -: add-link-hook ( quot -- ) - link-hook [ compose ] change ; inline +: each-responder ( quot -- ) + nested-responders swap each ; inline -: modify-query ( query -- query ) - link-hook get call ; - -: base-path ( string -- path ) - dup base-paths get at +: responder-path ( string -- pair ) + dup responder-nesting get at [ ] [ "No such responder: " swap append throw ] ?if ; -: resolve-base-path ( string -- string' ) - "$" ?head [ +: base-path ( string -- path ) + responder-path first ; + +: template-path ( string -- path ) + responder-path second ; + +: resolve-responder-path ( string quot -- string' ) + [ "$" ?head ] dip '[ [ - "/" split1 [ base-path [ "/" % % ] each "/" % ] dip % + "/" split1 [ @ [ "/" % % ] each "/" % ] dip % ] "" make - ] when ; + ] when ; inline -: link>string ( url query -- url' ) - [ resolve-base-path ] [ modify-query ] bi* (link>string) ; +: resolve-base-path ( string -- string' ) + [ base-path ] resolve-responder-path ; -: write-link ( url query -- ) - link>string write ; +: resolve-template-path ( string -- string' ) + [ template-path ] resolve-responder-path ; -SYMBOL: form-hook +GENERIC: modify-query ( query responder -- query' ) -: add-form-hook ( quot -- ) - form-hook [ compose ] change ; +M: object modify-query drop ; -: hidden-form-field ( -- ) - form-hook get call ; +: 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 ; -: absolute-redirect ( to query -- url ) - #! Same host. - request get clone - swap [ >>query ] when* - swap url-encode >>path - [ modify-query ] change-query - request-url ; +: ( url code message -- response ) + + swap dup url? [ adjust-url ] when + "location" set-header ; -: replace-last-component ( path with -- path' ) - [ "/" last-split1 drop "/" ] dip 3append ; - -: relative-redirect ( to query -- url ) - request get clone - swap [ >>query ] when* - swap [ '[ , replace-last-component ] change-path ] when* - [ modify-query ] change-query - request-url ; - -: derive-url ( to query -- url ) - { - { [ over "http://" head? ] [ link>string ] } - { [ over "/" head? ] [ absolute-redirect ] } - { [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] } - [ relative-redirect ] - } cond ; - -: ( to query code message -- response ) - -rot derive-url "location" set-header ; - -\ DEBUG add-input-logging +\ DEBUG add-input-logging : ( to query -- response ) - 301 "Moved Permanently" ; + 301 "Moved Permanently" ; : ( to query -- response ) - 307 "Temporary Redirect" ; + 307 "Temporary Redirect" ; -: ( to query -- response ) - request get method>> "POST" = - [ ] [ ] if ; +: ( to query -- response ) + request get method>> { + { "GET" [ ] } + { "HEAD" [ ] } + { "POST" [ ] } + } case ; TUPLE: dispatcher default responders ; @@ -187,7 +161,7 @@ TUPLE: vhost-dispatcher default responders ; 404-responder get H{ } clone vhost-dispatcher boa ; : find-vhost ( dispatcher -- responder ) - request get host>> over responders>> at* + request get url>> host>> over responders>> at* [ nip ] [ drop default>> ] if ; M: vhost-dispatcher call-responder* ( path dispatcher -- response ) @@ -242,35 +216,28 @@ SYMBOL: development-mode LOG: httpd-hit NOTICE : log-request ( request -- ) - { method>> host>> path>> } map-exec-with httpd-hit ; - -SYMBOL: exit-continuation - -: exit-with exit-continuation get continue-with ; - -: with-exit-continuation ( quot -- ) - '[ exit-continuation set @ ] callcc1 exit-continuation off ; + [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ; : split-path ( string -- path ) "/" split harvest ; -: init-request ( -- ) - H{ } clone base-paths set +: init-request ( request -- ) + request set + H{ } clone responder-nesting set [ ] link-hook set [ ] form-hook set ; +: dispatch-request ( request -- response ) + url>> path>> split-path main-responder get call-responder ; + : do-request ( request -- response ) [ - init-request - [ request set ] + [ init-request ] [ log-request ] - [ path>> split-path main-responder get call-responder ] tri - [ <404> ] unless* - ] [ - [ \ do-request log-error ] - [ <500> ] - bi - ] recover ; + [ dispatch-request ] tri + ] + [ [ \ do-request log-error ] [ <500> ] bi ] + recover ; : ?refresh-all ( -- ) development-mode get-global diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 8814004589..d64268d68e 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -4,7 +4,7 @@ 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 ; +io.encodings.binary fry xml.entities destructors urls ; IN: http.server.static ! special maps mime types to quots with effect ( path -- ) @@ -71,7 +71,7 @@ TUPLE: file-responder root hook special allow-listings ; : list-directory ( directory -- response ) file-responder get allow-listings>> [ - '[ , directory. ] + '[ , directory. ] "text/html" ] [ drop <403> ] if ; @@ -85,7 +85,7 @@ TUPLE: file-responder root hook special allow-listings ; find-index [ serve-file ] [ list-directory ] ?if ] [ drop - request get path>> "/" append f + request get url>> clone [ "/" append ] change-path ] if ; : serve-object ( filename -- response ) @@ -101,6 +101,6 @@ M: file-responder call-responder* ( path responder -- response ) ! file responder integration : enable-fhtml ( responder -- responder ) - [ ] + [ "text/html" ] "application/x-factor-server-page" pick special>> set-at ; diff --git a/extra/io/pools/pools.factor b/extra/io/pools/pools.factor index 7ee14e03e5..033ba3cbfb 100644 --- a/extra/io/pools/pools.factor +++ b/extra/io/pools/pools.factor @@ -1,13 +1,22 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel arrays namespaces sequences continuations -destructors io.sockets ; +destructors io.sockets alien alien.syntax ; IN: io.pools -TUPLE: pool connections disposed ; +TUPLE: pool connections disposed expired ; + +: check-pool ( pool -- ) + dup check-disposed + dup expired>> expired? [ + ALIEN: 31337 >>expired + connections>> [ delete-all ] [ dispose-each ] bi + ] [ drop ] if ; : ( class -- pool ) - new V{ } clone >>connections ; inline + new V{ } clone + >>connections + dup check-pool ; inline M: pool dispose* connections>> dispose-each ; @@ -17,15 +26,14 @@ M: pool dispose* connections>> dispose-each ; TUPLE: return-connection conn pool ; : return-connection ( conn pool -- ) - dup check-disposed connections>> push ; + dup check-pool connections>> push ; GENERIC: make-connection ( pool -- conn ) : new-connection ( pool -- ) - [ make-connection ] keep return-connection ; + dup check-pool [ make-connection ] keep return-connection ; : acquire-connection ( pool -- conn ) - dup check-disposed [ dup connections>> empty? ] [ dup new-connection ] [ ] while connections>> pop ; diff --git a/extra/lcs/diff2html/diff2html.factor b/extra/lcs/diff2html/diff2html.factor index a8f649e2c9..754e69a476 100644 --- a/extra/lcs/diff2html/diff2html.factor +++ b/extra/lcs/diff2html/diff2html.factor @@ -38,7 +38,7 @@ M: delete diff-line ; : htmlize-diff ( diff -- ) - +
[ diff-line ] each
"Old" write "New" write
; diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 364c24b91f..5183af5145 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -4,7 +4,7 @@ USING: xml.utilities kernel assocs xml.generator math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client namespaces xml.generator hashtables - calendar.format accessors continuations ; + calendar.format accessors continuations urls ; IN: rss : any-tag-named ( tag names -- tag-inside ) @@ -103,18 +103,15 @@ C: entry : entry, ( entry -- ) "entry" [ - dup entry-title "title" { { "type" "html" } } simple-tag*, - "link" over entry-link "href" associate contained*, - dup entry-pub-date timestamp>rfc3339 "published" simple-tag, - entry-description [ "content" { { "type" "html" } } simple-tag*, ] when* + dup title>> "title" { { "type" "html" } } simple-tag*, + "link" over link>> dup url? [ url>string ] when "href" associate contained*, + dup pub-date>> timestamp>rfc3339 "published" simple-tag, + description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ] tag, ; : feed>xml ( feed -- xml ) "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ - dup feed-title "title" simple-tag, - "link" over feed-link "href" associate contained*, - feed-entries [ entry, ] each + dup title>> "title" simple-tag, + "link" over link>> dup url? [ url>string ] when "href" associate contained*, + entries>> [ entry, ] each ] make-xml* ; - -: write-feed ( feed -- ) - feed>xml write-xml ; diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor index 8a4c6146de..f020724d31 100644 --- a/extra/tangle/tangle.factor +++ b/extra/tangle/tangle.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ; +USING: accessors assocs db db.sqlite db.postgresql http http.server furnace.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ; IN: tangle GENERIC: render* ( content templater -- output ) @@ -20,7 +20,7 @@ C: tangle [ [ db>> ] [ seq>> ] bi ] dip with-db ; : node-response ( id -- response ) - load-node [ node-content ] [ <404> ] if* ; + load-node [ node-content "text/plain" ] [ <404> ] if* ; : display-node ( params -- response ) [ @@ -36,7 +36,7 @@ C: tangle : submit-node ( params -- response ) [ "node_content" swap at* [ - create-node id>> number>string + create-node id>> number>string "text/plain" ] [ drop <400> ] if @@ -52,7 +52,7 @@ TUPLE: path-responder ; C: path-responder M: path-responder call-responder* ( path responder -- response ) - drop path>file [ node-content ] [ <404> ] if* ; + drop path>file [ node-content "text/plain" ] [ <404> ] if* ; TUPLE: tangle-dispatcher < dispatcher tangle ; diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index e28816fdb3..e64ef283c5 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -77,10 +77,17 @@ USING: urls tools.test tuple-syntax arrays kernel assocs ; } "a/relative/path" } + { + TUPLE{ url + path: "bar" + query: H{ { "a" "b" } } + } + "bar?a=b" + } } ; urls [ - [ 1array ] [ [ string>url ] curry ] bi* unit-test + [ 1array ] [ [ >url ] curry ] bi* unit-test ] assoc-each urls [ @@ -192,3 +199,7 @@ urls [ derive-url ] unit-test + +[ "a" ] [ + "a" "b" set-query-param "b" query-param +] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index e20df65656..472eead0f2 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel unicode.categories combinators sequences splitting -fry namespaces assocs arrays strings mirrors -io.encodings.string io.encodings.utf8 -math math.parser accessors namespaces.lib ; +fry namespaces assocs arrays strings io.encodings.string +io.encodings.utf8 math math.parser accessors mirrors parser +prettyprint.backend hashtables ; IN: urls : url-quotable? ( ch -- ? ) @@ -91,11 +91,13 @@ IN: urls TUPLE: url protocol host port path query anchor ; +: ( -- url ) url new ; + : query-param ( request key -- value ) swap query>> at ; : set-query-param ( request value key -- request ) - pick query>> set-at ; + '[ , , _ ?set-at ] change-query ; : parse-host ( string -- host port ) ":" split1 [ url-decode ] [ @@ -105,40 +107,44 @@ TUPLE: url protocol host port path query anchor ; ] when ] bi* ; -: parse-host-part ( protocol rest -- string' ) - [ "protocol" set ] [ +: parse-host-part ( url protocol rest -- url string' ) + [ >>protocol ] [ "//" ?head [ "Invalid URL" throw ] unless "/" split1 [ - parse-host [ "host" set ] [ "port" set ] bi* + parse-host [ >>host ] [ >>port ] bi* ] [ "/" prepend ] bi* ] bi* ; -: string>url ( string -- url ) - [ - ":" split1 [ parse-host-part ] when* - "#" split1 [ - "?" split1 [ query>assoc "query" set ] when* - url-decode "path" set - ] [ - url-decode "anchor" set - ] bi* - ] url make-object ; +GENERIC: >url ( obj -- url ) -: unparse-host-part ( protocol -- ) +M: url >url ; + +M: string >url + swap + ":" split1 [ parse-host-part ] when* + "#" split1 [ + "?" split1 + [ url-decode >>path ] + [ [ query>assoc >>query ] when* ] bi* + ] + [ url-decode >>anchor ] bi* ; + +: unparse-host-part ( url protocol -- ) % "://" % - "host" get url-encode % - "port" get [ ":" % # ] when* - "path" get "/" head? [ "Invalid URL" throw ] unless ; + [ host>> url-encode % ] + [ port>> [ ":" % # ] when* ] + [ path>> "/" head? [ "/" % ] unless ] + tri ; : url>string ( url -- string ) [ - [ - "protocol" get [ unparse-host-part ] when* - "path" get url-encode % - "query" get [ "?" % assoc>query % ] when* - "anchor" get [ "#" % url-encode % ] when* - ] bind + { + [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ] + [ path>> url-encode % ] + [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ] + [ anchor>> [ "#" % url-encode % ] when* ] + } cleave ] "" make ; : url-append-path ( path1 path2 -- path ) @@ -158,3 +164,7 @@ TUPLE: url protocol host port path query anchor ; : relative-url ( url -- url' ) clone f >>protocol f >>host f >>port ; + +: URL" lexer get skip-blank parse-string >url parsed ; parsing + +M: url pprint* dup url>string "URL\" " "\"" pprint-string ; diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 04194adb29..29ce3f0e7c 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,6 +1,6 @@ -USING: math kernel accessors html.components -http.server http.server.actions -http.server.sessions html.templates.chloe fry ; +USING: math kernel accessors html.components http.server +furnace.actions furnace.sessions html.templates.chloe +fry urls ; IN: webapps.counter SYMBOL: count @@ -11,15 +11,15 @@ M: counter-app init-session* drop 0 count sset ; : ( quot -- action ) - swap '[ count , schange "" f ] >>submit ; - -: counter-template ( -- template ) - "resource:extra/webapps/counter/counter.xml" ; + swap '[ + count , schange + URL" $counter-app" + ] >>submit ; : ( -- action ) [ count sget "counter" set-value ] >>init - counter-template >>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 9ad4a05492..5565625a9c 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -4,13 +4,12 @@ USING: accessors kernel sequences assocs io.files io.sockets io.server namespaces db db.sqlite smtp http.server -http.server.db -http.server.flows -http.server.sessions -http.server.auth.login -http.server.auth.providers.db -http.server.boilerplate -html.templates.chloe +furnace.db +furnace.flows +furnace.sessions +furnace.auth.login +furnace.auth.providers.db +furnace.boilerplate webapps.pastebin webapps.planet webapps.todo @@ -20,9 +19,6 @@ IN: webapps.factor-website : test-db "resource:test.db" sqlite-db ; -: factor-template ( path -- template ) - "resource:extra/webapps/factor-website/" swap ".xml" 3append ; - : init-factor-db ( -- ) test-db [ init-users-table @@ -40,8 +36,10 @@ IN: webapps.factor-website init-revisions-table ] with-db ; +TUPLE: factor-website < dispatcher ; + : ( -- responder ) - + factor-website new-dispatcher "todo" add-responder "pastebin" add-responder "planet" add-responder @@ -53,7 +51,7 @@ IN: webapps.factor-website allow-password-recovery allow-edit-profile - "page" factor-template >>template + "$factor-website/page" >>template test-db ; diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml index f7080643b4..32e1223c58 100644 --- a/extra/webapps/factor-website/page.xml +++ b/extra/webapps/factor-website/page.xml @@ -15,6 +15,8 @@ + + diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 57c2fdb7c2..9f35d83fd8 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -2,7 +2,7 @@ - + Paste: @@ -12,15 +12,13 @@ Date: -
+
Delete Paste - | - Annotate - + -

Annotation:

+

Annotation:

@@ -32,9 +30,9 @@ Delete Annotation - + - +

New Annotation

@@ -55,6 +53,6 @@ - + diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index f785fceb6b..a86404d451 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -2,6 +2,8 @@ + +
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 43cae74ec8..b2bcc685df 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -2,13 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs sorting sequences kernel accessors hashtables sequences.lib db.types db.tuples db combinators -calendar calendar.format math.parser rss xml.writer +calendar calendar.format math.parser rss urls xml.writer xmode.catalog validators html.components html.templates.chloe http.server -http.server.actions -http.server.auth -http.server.auth.login -http.server.boilerplate ; +furnace.actions +furnace.auth +furnace.auth.login +furnace.boilerplate ; IN: webapps.pastebin ! ! ! @@ -58,28 +58,31 @@ annotation "ANNOTATIONS" : paste ( id -- paste ) select-tuple fetch-annotations ; -: ( id next -- response ) - swap "id" associate ; - ! ! ! ! LINKS, ETC ! ! ! : pastebin-link ( -- url ) - "$pastebin/list" f link>string ; + URL" $pastebin/list" ; GENERIC: entity-link ( entity -- url ) +: paste-link ( id -- url ) + + "$pastebin/paste" >>path + swap "id" set-query-param ; + M: paste entity-link - id>> "id" associate "$pastebin/paste" swap link>string ; + id>> paste-link ; + +: annotation-link ( parent id -- url ) + + "$pastebin/paste" >>path + swap number>string >>anchor + swap "id" set-query-param ; M: annotation entity-link - [ parent>> "parent" associate "$pastebin/paste" swap link>string ] - [ id>> number>string "#" prepend ] bi - append ; - -: pastebin-template ( name -- template ) - "resource:extra/webapps/pastebin/" swap ".xml" 3append ; + [ parent>> ] [ id>> ] bi annotation-link ; ! ! ! ! PASTE LIST @@ -88,7 +91,7 @@ M: annotation entity-link : ( -- action ) [ pastes "pastes" set-value ] >>init - "pastebin" pastebin-template >>template ; + "$pastebin/pastebin" >>template ; : pastebin-feed-entries ( seq -- entries ) 20 short head [ @@ -96,7 +99,7 @@ M: annotation entity-link swap [ summary>> >>title ] [ date>> >>pub-date ] - [ entity-link >>link ] + [ entity-link adjust-url >>link ] tri ] map ; @@ -117,7 +120,7 @@ M: annotation entity-link [ validate-integer-id - "id" value paste from-tuple + "id" value paste from-object "id" value "new-annotation" [ @@ -127,7 +130,7 @@ M: annotation entity-link ] nest-values ] >>init - "paste" pastebin-template >>template ; + "$pastebin/paste" >>template ; : paste-feed-entries ( paste -- entries ) fetch-annotations annotations>> pastebin-feed-entries ; @@ -135,15 +138,15 @@ M: annotation entity-link : paste-feed ( paste -- feed ) feed new swap - [ "Paste #" swap id>> number>string append >>title ] - [ entity-link >>link ] + [ "Paste " swap id>> number>string append >>title ] + [ entity-link adjust-url >>link ] [ paste-feed-entries >>entries ] tri ; : ( -- action ) [ validate-integer-id ] >>init - [ "id" value paste annotations>> paste-feed ] >>feed ; + [ "id" value paste paste-feed ] >>feed ; : validate-entity ( -- ) { @@ -165,7 +168,7 @@ M: annotation entity-link mode-names "modes" set-value ] >>init - "new-paste" pastebin-template >>template + "$pastebin/new-paste" >>template [ validate-entity @@ -173,7 +176,7 @@ M: annotation entity-link f [ deposit-entity-slots ] [ insert-tuple ] - [ id>> "$pastebin/paste" ] + [ id>> paste-link ] tri ] >>submit ; @@ -184,7 +187,7 @@ M: annotation entity-link [ "id" value delete-tuples "id" value f delete-tuples - "$pastebin/list" f + URL" $pastebin/list" ] >>submit ; ! ! ! @@ -192,10 +195,10 @@ M: annotation entity-link ! ! ! : ( -- action ) - + [ { { "id" [ v-integer ] } } validate-params - "id" value "$pastebin/paste" + "id" value paste-link ] >>display [ @@ -207,10 +210,7 @@ M: annotation entity-link "id" value f [ deposit-entity-slots ] [ insert-tuple ] - [ - ! Add anchor here - parent>> "$pastebin/paste" - ] + [ entity-link ] tri ] >>submit ; @@ -221,7 +221,7 @@ M: annotation entity-link [ f "id" value select-tuple [ delete-tuples ] - [ parent>> "$pastebin/paste" ] + [ parent>> paste-link ] bi ] >>submit ; @@ -242,7 +242,7 @@ can-delete-pastes? define-capability "new-annotation" add-responder { can-delete-pastes? } "delete-annotation" add-responder - "pastebin-common" pastebin-template >>template ; + "$pastebin/pastebin-common" >>template ; : init-pastes-table \ paste ensure-table ; diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml index 9ec2cb7976..a6b3078aa7 100644 --- a/extra/webapps/pastebin/pastebin.xml +++ b/extra/webapps/pastebin/pastebin.xml @@ -2,8 +2,6 @@ - - Pastebin
Author:
@@ -11,13 +9,13 @@ - + - +
Paste by: Date:
 diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index 4711ca4716..26a3e6f206 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -5,13 +5,13 @@ Planet Factor Administration
    - +
    • -     +

diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml index 1338463bcf..7c5269b8d9 100644 --- a/extra/webapps/planet/mini-planet.xml +++ b/extra/webapps/planet/mini-planet.xml @@ -2,13 +2,13 @@ - +


Read More...

- + diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 414a59f3b2..39539441ce 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -3,19 +3,16 @@ USING: kernel accessors sequences sorting math math.order calendar alarms logging concurrency.combinators namespaces sequences.lib db.types db.tuples db fry locals hashtables -html.components html.templates.chloe -rss xml.writer +html.components +rss urls xml.writer validators http.server -http.server.actions -http.server.boilerplate -http.server.auth.login -http.server.auth ; +furnace.actions +furnace.boilerplate +furnace.auth.login +furnace.auth ; IN: webapps.planet -: planet-template ( name -- template ) - "resource:extra/webapps/planet/" swap ".xml" 3append ; - TUPLE: blog id name www-url feed-url ; M: blog link-title name>> ; @@ -61,7 +58,7 @@ posting "POSTINGS" : ( -- action ) [ blogroll "blogroll" set-value ] >>init - "admin" planet-template >>template ; + "$planet-factor/admin" >>template ; : ( -- action ) @@ -70,7 +67,7 @@ posting "POSTINGS" postings "postings" set-value ] >>init - "planet" planet-template >>template ; + "$planet-factor/planet" >>template ; : planet-feed ( -- feed ) feed new @@ -110,7 +107,7 @@ posting "POSTINGS" [ update-cached-postings - "" f + URL" $planet-factor/admin" ] >>submit ; : ( -- action ) @@ -119,7 +116,7 @@ posting "POSTINGS" [ "id" value delete-tuples - "$planet-factor/admin" f + URL" $planet-factor/admin" ] >>submit ; : validate-blog ( -- ) @@ -129,15 +126,12 @@ posting "POSTINGS" { "feed-url" [ v-url ] } } validate-params ; -: ( id next -- response ) - swap "id" associate ; - : deposit-blog-slots ( blog -- ) { "name" "www-url" "feed-url" } deposit-slots ; : ( -- action ) - "new-blog" planet-template >>template + "$planet-factor/new-blog" >>template [ validate-blog ] >>validate @@ -145,7 +139,12 @@ posting "POSTINGS" f [ deposit-blog-slots ] [ insert-tuple ] - [ id>> "$planet-factor/admin/edit-blog" ] + [ + + "$planet-factor/admin/edit-blog" >>path + swap id>> "id" set-query-param + + ] tri ] >>submit ; @@ -153,10 +152,10 @@ posting "POSTINGS" [ validate-integer-id - "id" value select-tuple from-tuple + "id" value select-tuple from-object ] >>init - "edit-blog" planet-template >>template + "$planet-factor/edit-blog" >>template [ validate-integer-id @@ -167,7 +166,12 @@ posting "POSTINGS" f [ deposit-blog-slots ] [ update-tuple ] - [ id>> "$planet-factor/admin" ] + [ + + "$planet-factor/admin" >>path + swap id>> "id" set-query-param + + ] tri ] >>submit ; @@ -193,7 +197,7 @@ TUPLE: planet-factor < dispatcher ; "feed.xml" add-responder { can-administer-planet-factor? } "admin" add-responder - "planet-common" planet-template >>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 526a9b306b..4ee1c171e2 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -8,7 +8,7 @@ - +

@@ -22,7 +22,7 @@

- + @@ -31,7 +31,7 @@

Blogroll

    - +
    • diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml index 0974c8ce1b..6bae6e705e 100644 --- a/extra/webapps/todo/edit-todo.xml +++ b/extra/webapps/todo/edit-todo.xml @@ -14,12 +14,8 @@ - - - View - | - Delete - - + View + | + Delete diff --git a/extra/webapps/todo/new-todo.xml b/extra/webapps/todo/new-todo.xml new file mode 100644 index 0000000000..f557d5307b --- /dev/null +++ b/extra/webapps/todo/new-todo.xml @@ -0,0 +1,17 @@ + + + + + New Item + + + + + + +
    Summary:
    Priority:
    Description:
    + + +     + +     diff --git a/extra/webapps/todo/todo-list.xml b/extra/webapps/todo/todo-list.xml index 845c38dbf7..036c590306 100644 --- a/extra/webapps/todo/todo-list.xml +++ b/extra/webapps/todo/todo-list.xml @@ -13,7 +13,7 @@ Edit - + @@ -30,7 +30,7 @@ - + diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index e3b174eaea..063c8515f7 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -1,15 +1,15 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences namespaces -db db.types db.tuples validators hashtables +db db.types db.tuples validators hashtables urls html.components html.templates.chloe -http.server.sessions -http.server.boilerplate -http.server.auth -http.server.actions -http.server.db -http.server.auth.login +furnace.sessions +furnace.boilerplate +furnace.auth +furnace.actions +furnace.db +furnace.auth.login http.server ; IN: webapps.todo @@ -31,20 +31,14 @@ todo "TODO" swap >>id uid >>uid ; -: todo-template ( name -- template ) - "resource:extra/webapps/todo/" swap ".xml" 3append ; - : ( -- action ) [ validate-integer-id - "id" value select-tuple from-tuple + "id" value select-tuple from-object ] >>init - "view-todo" todo-template >>template ; - -: ( id next -- response ) - swap "id" associate ; + "$todo-list/view-todo" >>template ; : validate-todo ( -- ) { @@ -57,15 +51,20 @@ todo "TODO" [ 0 "priority" set-value ] >>init - "edit-todo" todo-template >>template + "$todo-list/new-todo" >>template [ validate-todo ] >>validate [ f - dup { "summary" "description" } deposit-slots + dup { "summary" "priority" "description" } deposit-slots [ insert-tuple ] - [ id>> "$todo-list/view" ] + [ + + "$todo-list/view" >>path + swap id>> "id" set-query-param + + ] bi ] >>submit ; @@ -73,10 +72,10 @@ todo "TODO" [ validate-integer-id - "id" value select-tuple from-tuple + "id" value select-tuple from-object ] >>init - "edit-todo" todo-template >>template + "$todo-list/edit-todo" >>template [ validate-integer-id @@ -87,7 +86,12 @@ todo "TODO" f dup { "id" "summary" "priority" "description" } deposit-slots [ update-tuple ] - [ id>> "$todo-list/view" ] + [ + + "$todo-list/view" >>path + swap id>> "id" set-query-param + + ] bi ] >>submit ; @@ -97,13 +101,13 @@ todo "TODO" [ "id" get delete-tuples - "$todo-list/list" f + URL" $todo-list/list" ] >>submit ; : ( -- action ) [ f select-tuples "items" set-value ] >>init - "todo-list" todo-template >>template ; + "$todo-list/todo-list" >>template ; TUPLE: todo-list < dispatcher ; @@ -115,5 +119,5 @@ TUPLE: todo-list < dispatcher ; "edit" add-responder "delete" add-responder - "todo" todo-template >>template + "$todo-list/todo" >>template f ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index 39ab5cda8b..e892137932 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -6,7 +6,7 @@
    List Items - | Add Item + | Add Item | Edit Profile diff --git a/extra/webapps/user-admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml index 3f9ac8d690..0c55f8ca76 100644 --- a/extra/webapps/user-admin/edit-user.xml +++ b/extra/webapps/user-admin/edit-user.xml @@ -35,7 +35,11 @@ Capabilities: - + + +
    +     + diff --git a/extra/webapps/user-admin/new-user.xml b/extra/webapps/user-admin/new-user.xml index 881dca9c16..b1f35c979b 100644 --- a/extra/webapps/user-admin/new-user.xml +++ b/extra/webapps/user-admin/new-user.xml @@ -35,7 +35,11 @@ Capabilities: - + + +

  • + + diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index cdaf3f5ea9..a3548fb252 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -1,45 +1,55 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors namespaces combinators words -assocs db.tuples arrays splitting strings validators +assocs db.tuples arrays splitting strings validators urls html.elements html.components -html.templates.chloe -http.server.boilerplate -http.server.auth.providers -http.server.auth.providers.db -http.server.auth.login -http.server.auth -http.server.sessions -http.server.actions +furnace.boilerplate +furnace.auth.providers +furnace.auth.providers.db +furnace.auth.login +furnace.auth +furnace.sessions +furnace.actions http.server ; IN: webapps.user-admin -: admin-template ( name -- template ) - "resource:extra/webapps/user-admin/" swap ".xml" 3append ; +: word>string ( word -- string ) + [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; : words>strings ( seq -- seq' ) - [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ; + [ word>string ] map ; + +: string>word ( string -- word ) + ":" split1 swap lookup ; : strings>words ( seq -- seq' ) - [ ":" split1 swap lookup ] map ; + [ string>word ] map ; : ( -- action ) [ f select-tuples "users" set-value ] >>init - "user-list" admin-template >>template ; + "$user-admin/user-list" >>template ; + +: init-capabilities ( -- ) + capabilities get words>strings "capabilities" set-value ; + +: selected-capabilities ( -- seq ) + "capabilities" value + [ param empty? not ] filter + [ string>word ] map ; : ( -- action ) [ - "username" param from-tuple - capabilities get words>strings "all-capabilities" set-value + "username" param from-object + init-capabilities ] >>init - "new-user" admin-template >>template + "$user-admin/new-user" >>template [ - capabilities get words>strings "all-capabilities" set-value + init-capabilities { { "username" [ v-username ] } @@ -62,10 +72,11 @@ IN: webapps.user-admin "email" value >>email "new-password" value >>encoded-password H{ } clone >>profile + selected-capabilities >>capabilities insert-tuple - "$user-admin" f + URL" $user-admin" ] >>submit ; : validate-username ( -- ) @@ -77,15 +88,16 @@ IN: webapps.user-admin validate-username "username" value select-tuple - [ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi + [ from-object ] + [ capabilities>> [ "true" swap word>string set-value ] each ] bi - capabilities get words>strings "all-capabilities" set-value + capabilities get words>strings "capabilities" set-value ] >>init - "edit-user" admin-template >>template + "$user-admin/edit-user" >>template [ - capabilities get words>strings "all-capabilities" set-value + init-capabilities { { "username" [ v-username ] } @@ -93,7 +105,6 @@ IN: webapps.user-admin { "new-password" [ [ v-password ] v-optional ] } { "verify-password" [ [ v-password ] v-optional ] } { "email" [ [ v-email ] v-optional ] } - { "capabilities" [ ] } } validate-params "new-password" "verify-password" @@ -106,19 +117,15 @@ IN: webapps.user-admin "username" value select-tuple "realname" value >>realname "email" value >>email + selected-capabilities >>capabilities "new-password" value empty? [ "new-password" value >>encoded-password ] unless - "capabilities" value { - { [ dup string? ] [ 1array ] } - { [ dup array? ] [ ] } - } cond strings>words >>capabilities - update-tuple - "$user-admin" f + URL" $user-admin" ] >>submit ; : ( -- action ) @@ -130,7 +137,7 @@ IN: webapps.user-admin [ logout-all-sessions ] bi - "$user-admin" f + URL" $user-admin" ] >>submit ; TUPLE: user-admin < dispatcher ; @@ -146,7 +153,7 @@ can-administer-users? define-capability "edit" add-responder "delete" add-responder - "user-admin" admin-template >>template + "$user-admin/user-admin" >>template { can-administer-users? } ; : make-admin ( username -- ) diff --git a/extra/webapps/user-admin/user-list.xml b/extra/webapps/user-admin/user-list.xml index 020d053e03..83b3f97cf9 100644 --- a/extra/webapps/user-admin/user-list.xml +++ b/extra/webapps/user-admin/user-list.xml @@ -6,13 +6,13 @@
      - +
      • -       +
    diff --git a/extra/webapps/wiki/articles.xml b/extra/webapps/wiki/articles.xml index a552c2618f..e19c531d3d 100644 --- a/extra/webapps/wiki/articles.xml +++ b/extra/webapps/wiki/articles.xml @@ -5,11 +5,11 @@ All Articles
      - +
      • -       +
    diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml index 5efa0c045a..95fb0de2fe 100644 --- a/extra/webapps/wiki/changes.xml +++ b/extra/webapps/wiki/changes.xml @@ -5,7 +5,7 @@ Recent Changes
      - +
    • on @@ -13,7 +13,7 @@ by
      • -       +
    diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml index 0fb0d6bae6..9feb12dc43 100644 --- a/extra/webapps/wiki/diff.xml +++ b/extra/webapps/wiki/diff.xml @@ -2,34 +2,34 @@ - + Diff: - + - + - + - + - +
    Old revision:Created on by .
    New revision:Created on by .
    - +
    Latest | Revisions | Edit | Delete
    -     +     diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 4b7bdadf50..0a0de8e470 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -4,15 +4,23 @@ Revisions of -
      - -
    • - - by - -
      • -       -
    +
    + + + + + + + + + + + + + + +
    RevisionAuthorRollback
    Rollback
    +

    View Differences

    @@ -23,9 +31,9 @@ @@ -34,9 +42,9 @@ @@ -45,4 +53,13 @@ +
    + +
    + Latest + | Revisions + | Edit + | Delete +
    + diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml index cf19a38370..61809802d9 100644 --- a/extra/webapps/wiki/user-edits.xml +++ b/extra/webapps/wiki/user-edits.xml @@ -5,13 +5,13 @@ Edits by
      - +
    • on
      • -       +
    diff --git a/extra/webapps/wiki/wiki.css b/extra/webapps/wiki/wiki.css index e737cdd898..4825839ab3 100644 --- a/extra/webapps/wiki/wiki.css +++ b/extra/webapps/wiki/wiki.css @@ -1,8 +1,3 @@ -.comparison table, { - border-color: #666; - border-style: solid; -} - .comparison th { border-width: 1px; border-color: #666; @@ -10,12 +5,13 @@ } .comparison table { + border-color: #666; + border-style: solid; border-width: 1px; border-spacing: 0; border-collapse: collapse; } - .insert { background-color: #9f9; } @@ -23,3 +19,21 @@ .delete { background-color: #f99; } + +.revisions table, .revisions td, .revisions th { + border-color: #666; + border-style: solid; +} + +.revisions table { + border-width: 0 0 1px 1px; + border-spacing: 0; + border-collapse: collapse; +} + +.revisions td, .revisions th { + margin: 0; + padding: 4px; + border-width: 1px 1px 0 0; +} + diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 344a3d40bd..a1eb8bffc5 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -3,14 +3,13 @@ USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order html.components -html.templates.chloe http.server -http.server.actions -http.server.auth -http.server.auth.login -http.server.boilerplate +furnace.actions +furnace.auth +furnace.auth.login +furnace.boilerplate validators -db.types db.tuples lcs farkup ; +db.types db.tuples lcs farkup urls ; IN: webapps.wiki TUPLE: article title revision ; @@ -41,18 +40,17 @@ revision "REVISIONS" { : init-revisions-table revision ensure-table ; -: wiki-template ( name -- template ) - "resource:extra/webapps/wiki/" swap ".xml" 3append ; - -: ( title next -- response ) - swap "title" associate ; - : validate-title ( -- ) { { "title" [ v-one-line ] } } validate-params ; : ( -- action ) - [ "Front Page" "$wiki/view" ] >>display ; + [ + + "$wiki/view" >>path + "Front Page" "title" set-query-param + + ] >>display ; : ( -- action ) @@ -65,10 +63,13 @@ revision "REVISIONS" { [ "title" value dup
    select-tuple [ - revision>> select-tuple from-tuple - "view" wiki-template + revision>> select-tuple from-object + "$wiki/view" ] [ - "$wiki/edit" + + "$wiki/edit" >>path + swap "title" set-query-param + ] ?if ] >>display ; @@ -77,10 +78,10 @@ revision "REVISIONS" { [ { { "id" [ v-integer ] } } validate-params "id" value - select-tuple from-tuple + select-tuple from-object ] >>init - "view" wiki-template >>template ; + "$wiki/view" >>template ; : add-revision ( revision -- ) [ insert-tuple ] @@ -97,11 +98,11 @@ revision "REVISIONS" { [ validate-title "title" value
    select-tuple [ - revision>> select-tuple from-tuple + revision>> select-tuple from-object ] when* ] >>init - "edit" wiki-template >>template + "$wiki/edit" >>template [ validate-title @@ -113,7 +114,12 @@ revision "REVISIONS" { logged-in-user get username>> >>author "content" value >>content [ add-revision ] - [ title>> "$wiki/view" ] bi + [ + + "$wiki/view" >>path + swap title>> "title" set-query-param + + ] bi ] >>submit ; : ( -- action ) @@ -125,7 +131,24 @@ revision "REVISIONS" { "revisions" set-value ] >>init - "revisions" wiki-template >>template ; + "$wiki/revisions" >>template ; + +: ( -- action ) + + [ + { { "id" [ v-integer ] } } validate-params + ] >>validate + + [ + "id" value select-tuple clone f >>id + [ add-revision ] + [ + + "$wiki/view" >>path + swap title>> "title" set-query-param + + ] bi + ] >>submit ; : ( -- action ) @@ -135,7 +158,7 @@ revision "REVISIONS" { "changes" set-value ] >>init - "changes" wiki-template >>template ; + "$wiki/changes" >>template ; : ( -- action ) @@ -144,7 +167,7 @@ revision "REVISIONS" { [ "title" value
    delete-tuples f "title" value >>title delete-tuples - "" f + URL" $wiki" ] >>submit ; : ( -- action ) @@ -162,7 +185,7 @@ revision "REVISIONS" { 2bi ] >>init - "diff" wiki-template >>template ; + "$wiki/diff" >>template ; : ( -- action ) @@ -172,7 +195,7 @@ revision "REVISIONS" { "articles" set-value ] >>init - "articles" wiki-template >>template ; + "$wiki/articles" >>template ; : ( -- action ) @@ -182,7 +205,7 @@ revision "REVISIONS" { select-tuples "user-edits" set-value ] >>init - "user-edits" wiki-template >>template ; + "$wiki/user-edits" >>template ; TUPLE: wiki < dispatcher ; @@ -192,6 +215,7 @@ TUPLE: wiki < dispatcher ; "view" add-responder "revision" add-responder "revisions" add-responder + "rollback" add-responder "user-edits" add-responder "diff" add-responder "articles" add-responder @@ -199,4 +223,4 @@ TUPLE: wiki < dispatcher ; { } "edit" add-responder { } "delete" add-responder - "wiki-common" wiki-template >>template ; + "$wiki/wiki-common" >>template ; diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor index 6eccddc94a..9167517bb2 100755 --- a/extra/xmode/code2html/code2html.factor +++ b/extra/xmode/code2html/code2html.factor @@ -1,14 +1,14 @@ USING: xmode.tokens xmode.marker xmode.catalog kernel html.elements io io.files sequences words io.encodings.utf8 -namespaces xml.entities ; +namespaces xml.entities accessors ; IN: xmode.code2html : htmlize-tokens ( tokens -- ) [ - dup token-str swap token-id [ + [ str>> ] [ id>> ] bi [ escape-string write ] [ - write + escape-string write ] if* ] each ; diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor index 2f56a5b819..67cb60f8a0 100755 --- a/extra/xmode/code2html/responder/responder.factor +++ b/extra/xmode/code2html/responder/responder.factor @@ -12,5 +12,5 @@ IN: xmode.code2html.responder , utf8 [ , file-name input-stream get htmlize-stream ] with-file-reader - ] + ] "text/html" ] ;