From a8e8b0533901a75f33d87f5495d9383b74d41ebf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 25 Apr 2008 03:23:47 -0500 Subject: [PATCH] Improved HTTP server dispatcher --- extra/http/http-tests.factor | 62 ++++- .../http/server/actions/actions-tests.factor | 26 +- extra/http/server/actions/actions.factor | 21 +- extra/http/server/auth/login/login.factor | 16 +- .../server/callbacks/callbacks-tests.factor | 8 +- extra/http/server/components/code/code.factor | 18 ++ .../http/server/components/components.factor | 23 ++ extra/http/server/server-tests.factor | 82 +++++- extra/http/server/server.factor | 75 ++++-- .../server/sessions/sessions-tests.factor | 10 +- extra/http/server/static/static.factor | 32 +-- .../http/server/templating/chloe/chloe.factor | 3 +- .../factor-website/factor-website.factor | 51 +++- extra/webapps/factor-website/page.xml | 14 + extra/webapps/pastebin/annotation.xml | 23 ++ extra/webapps/pastebin/authors.txt | 1 + extra/webapps/pastebin/new-annotation.xml | 25 ++ extra/webapps/pastebin/new-paste.xml | 23 ++ extra/webapps/pastebin/paste-list.xml | 15 ++ extra/webapps/pastebin/paste-summary.xml | 11 + extra/webapps/pastebin/paste.xml | 27 ++ extra/webapps/pastebin/pastebin.css | 7 + extra/webapps/pastebin/pastebin.factor | 253 ++++++++++++++++++ extra/webapps/pastebin/pastebin.xml | 29 ++ extra/webapps/planet/admin.xml | 3 +- extra/webapps/planet/blog-admin-link.xml | 2 +- extra/webapps/planet/edit-blog.xml | 10 +- extra/webapps/planet/planet.factor | 45 +--- extra/webapps/planet/planet.xml | 13 +- extra/webapps/planet/view-blog.xml | 41 --- extra/webapps/todo/edit-todo.xml | 10 +- extra/webapps/todo/todo-summary.xml | 4 +- extra/webapps/todo/todo.css | 12 - extra/webapps/todo/todo.factor | 25 +- extra/webapps/todo/todo.xml | 10 +- extra/webapps/todo/view-todo.xml | 4 +- 36 files changed, 783 insertions(+), 251 deletions(-) create mode 100644 extra/http/server/components/code/code.factor create mode 100644 extra/webapps/pastebin/annotation.xml create mode 100755 extra/webapps/pastebin/authors.txt create mode 100644 extra/webapps/pastebin/new-annotation.xml create mode 100644 extra/webapps/pastebin/new-paste.xml create mode 100644 extra/webapps/pastebin/paste-list.xml create mode 100644 extra/webapps/pastebin/paste-summary.xml create mode 100644 extra/webapps/pastebin/paste.xml create mode 100644 extra/webapps/pastebin/pastebin.css create mode 100644 extra/webapps/pastebin/pastebin.factor create mode 100644 extra/webapps/pastebin/pastebin.xml delete mode 100644 extra/webapps/planet/view-blog.xml diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 3a50630335..473bc964d3 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -133,16 +133,20 @@ read-response-test-1' 1array [ ] unit-test ! Live-fire exercise -USING: http.server http.server.static http.server.actions -http.client io.server io.files io accessors namespaces threads +USING: http.server http.server.static http.server.sessions +http.server.actions http.server.auth.login http.client +io.server io.files io accessors namespaces threads io.encodings.ascii ; +: add-quit-action + + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display + "quit" add-responder ; + [ ] [ [ - - [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display - "quit" add-responder + add-quit-action "extra/http/test" resource-path >>default "nested" add-responder @@ -176,3 +180,51 @@ io.encodings.ascii ; [ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test + +! Dispatcher bugs +[ ] [ + [ + + + + "" add-responder + add-quit-action + + "a" add-main-responder + "d" add-responder + main-responder set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ ] [ 1000 sleep ] unit-test + +: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; + +! This should give a 404 not an infinite redirect loop +[ "http://localhost:1237/d/blah" http-get ] [ 404? ] must-fail-with + +! This should give a 404 not an infinite redirect loop +[ "http://localhost:1237/blah/" http-get ] [ 404? ] must-fail-with + +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test + +[ ] [ + [ + + [ "text/plain" [ "Hi" write ] >>body ] >>display + + "" add-responder + add-quit-action + main-responder set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ ] [ 1000 sleep ] unit-test + +[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test + +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 90e632d7f5..615077821a 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,7 +1,7 @@ -IN: http.server.actions.tests USING: http.server.actions http.server.validators tools.test math math.parser multiline namespaces http io.streams.string http.server sequences splitting accessors ; +IN: http.server.actions.tests [ "a" [ v-number ] { { "a" "123" } } validate-param @@ -25,27 +25,5 @@ blah action-request-test-1 lf>crlf [ read-request ] with-string-reader request set - "/blah" - "action-1" get call-responder -] unit-test - - - [ +append-path get "xxx" get "X" concat append ] >>submit - { { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params -"action-2" set - -STRING: action-request-test-2 -POST http://foo/bar/baz HTTP/1.1 -content-length: 5 -content-type: application/x-www-form-urlencoded - -xxx=4 -; - -[ "/blahXXXX" ] [ - action-request-test-2 lf>crlf - [ read-request ] with-string-reader - request set - "/blah" - "action-2" get call-responder + { } "action-1" get call-responder ] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 2b2aaea6a8..bfcbd20cca 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces fry continuations locals ; IN: http.server.actions -SYMBOL: +append-path +SYMBOL: +path+ SYMBOL: params @@ -39,12 +39,15 @@ TUPLE: action init display submit get-params post-params ; M: action call-responder ( path action -- response ) '[ - , , - [ +append-path associate request-params assoc-union params set ] - [ action set ] bi* - request get method>> { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case + , [ CHAR: / = ] right-trim empty? [ + , action set + request-params params set + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case + ] [ + <404> + ] if ] with-exit-continuation ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 7593f217f7..1b6ceeb51b 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -60,7 +60,7 @@ M: user-saver dispose : successful-login ( user -- response ) logged-in-user sset - post-login-url sget "" or f + post-login-url sget "$login" or f f post-login-url sset ; :: ( -- action ) @@ -162,10 +162,12 @@ SYMBOL: previous-page [ blank-values + logged-in-user sget - dup username>> "username" set-value - dup realname>> "realname" set-value - dup email>> "email" set-value + [ username>> "username" set-value ] + [ realname>> "realname" set-value ] + [ email>> "email" set-value ] + tri ] >>init [ form edit-form ] >>display @@ -190,6 +192,8 @@ SYMBOL: previous-page "realname" value >>realname "email" value >>email + drop + user-profile-changed? on previous-page sget f @@ -329,7 +333,7 @@ SYMBOL: lost-password-from [ f logged-in-user sset - "login" f + "$login/login" f ] >>submit ; ! ! ! Authentication logic @@ -340,7 +344,7 @@ C: protected : show-login-page ( -- response ) request get request-url post-login-url sset - "login" f ; + "$login/login" f ; M: protected call-responder ( path responder -- response ) logged-in-user sget dup [ diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor index 4cad097cf5..498f120cd8 100755 --- a/extra/http/server/callbacks/callbacks-tests.factor +++ b/extra/http/server/callbacks/callbacks-tests.factor @@ -8,7 +8,7 @@ splitting kernel hashtables continuations ; "GET" >>method request set [ exit-continuation set - "xxx" + { } [ [ "hello" print 123 ] show-final ] >>display call-responder @@ -31,7 +31,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set "GET" >>method request set - "" "r" get call-responder + { } "r" get call-responder ] callcc1 body>> first @@ -44,7 +44,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set - "/" + { } "r" get call-responder ] callcc1 @@ -57,7 +57,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set - "/" + { } "r" get call-responder ] callcc1 ] unit-test diff --git a/extra/http/server/components/code/code.factor b/extra/http/server/components/code/code.factor new file mode 100644 index 0000000000..90b70c7bcc --- /dev/null +++ b/extra/http/server/components/code/code.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: splitting kernel io sequences xmode.code2html accessors +http.server.components ; +IN: http.server.components.code + +TUPLE: code-renderer < text-renderer mode ; + +: ( mode -- renderer ) + code-renderer new-text-renderer + swap >>mode ; + +M: code-renderer render-view* + [ string-lines ] [ mode>> value ] bi* htmlize-lines ; + +: ( id mode -- component ) + swap + swap >>renderer ; diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 331231dfb3..f0e7955947 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -336,3 +336,26 @@ TUPLE: list < component ; list swap new-component ; M: list component-string drop ; + +! Choice +TUPLE: choice-renderer choices ; + +C: choice-renderer + +M: choice-renderer render-view* + drop write ; + +M: choice-renderer render-edit* + ; + +TUPLE: choice < string ; + +: ( id choices -- component ) + swap choice new-string + swap >>renderer ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 346a31f30f..84e873d001 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,7 +1,9 @@ USING: http.server tools.test kernel namespaces accessors -io http math sequences assocs ; +io http math sequences assocs arrays classes words ; IN: http.server.tests +\ find-responder must-infer + [ "www.apple.com" >>host @@ -29,7 +31,9 @@ M: mock-responder call-responder "text/plain" ; : check-dispatch ( tag path -- ? ) + H{ } clone base-paths set over off + split-path main-responder get call-responder write-response get ; @@ -44,11 +48,11 @@ M: mock-responder call-responder main-responder set [ "foo" ] [ - "foo" main-responder get find-responder path>> nip + { "foo" } main-responder get find-responder path>> nip ] unit-test [ "bar" ] [ - "bar" main-responder get find-responder path>> nip + { "bar" } main-responder get find-responder path>> nip ] unit-test [ t ] [ "foo" "foo" check-dispatch ] unit-test @@ -60,14 +64,6 @@ M: mock-responder call-responder [ t ] [ "123" "baz/123" check-dispatch ] unit-test [ t ] [ "123" "baz///123" check-dispatch ] unit-test - [ t ] [ - - "baz" >>path - request set - "baz" main-responder get call-responder - dup code>> 300 399 between? >r - header>> "location" swap at "baz/" tail? r> and - ] unit-test ] with-scope [ @@ -77,3 +73,67 @@ M: mock-responder call-responder [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test ] with-scope + +! Make sure path for default responder isn't chopped +TUPLE: path-check-responder ; + +C: path-check-responder + +M: path-check-responder call-responder + drop + "text/plain" swap >array >>body ; + +[ { "c" } ] [ + H{ } clone base-paths set + + { "b" "c" } + + + >>default + "b" add-responder + call-responder + body>> +] unit-test + +! Test that "" dispatcher works with default>> +[ ] [ + + "" "" add-responder + "bar" "bar" add-responder + "baz" >>default + main-responder set + + [ t ] [ "" "" check-dispatch ] unit-test + [ f ] [ "" "quux" check-dispatch ] unit-test + [ t ] [ "baz" "quux" check-dispatch ] unit-test + [ f ] [ "foo" "bar" check-dispatch ] unit-test + [ t ] [ "bar" "bar" check-dispatch ] unit-test + [ t ] [ "baz" "xxx" check-dispatch ] unit-test +] unit-test + +TUPLE: funny-dispatcher < dispatcher ; + +: funny-dispatcher new-dispatcher ; + +TUPLE: base-path-check-responder ; + +C: base-path-check-responder + +M: base-path-check-responder call-responder + 2drop + "$funny-dispatcher" resolve-base-path + "text/plain" swap >>body ; + +[ ] [ + + + + "c" add-responder + "b" add-responder + "a" add-responder + main-responder set +] unit-test + +[ "/a/b/" ] [ + "a/b/c" split-path main-responder get call-responder body>> +] unit-test diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index d3bd6c6bbe..88a748d949 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -4,9 +4,11 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar html.elements accessors math.parser combinators.lib tools.vocabs debugger html continuations random combinators -destructors io.encodings.8-bit fry ; +destructors io.encodings.8-bit fry classes words ; IN: http.server +! path is a sequence of path component strings + GENERIC: call-responder ( path responder -- response ) : request-params ( -- assoc ) @@ -52,13 +54,39 @@ SYMBOL: 404-responder [ <404> ] 404-responder set-global +SYMBOL: base-paths + +: invert-slice ( slice -- slice' ) + dup slice? [ + [ seq>> ] [ from>> ] bi head-slice + ] [ + drop { } + ] if ; + +: add-base-path ( path dispatcher -- ) + [ invert-slice ] [ class word-name ] bi* + base-paths get set-at ; + SYMBOL: link-hook : modify-query ( query -- query ) link-hook get [ ] or call ; +: base-path ( string -- path ) + dup base-paths get at + [ ] [ "No such responder: " swap append throw ] ?if ; + +: resolve-base-path ( string -- string' ) + "$" ?head [ + [ + "/" split1 >r + base-path [ "/" % % ] each "/" % + r> % + ] "" make + ] when ; + : link>string ( url query -- url' ) - modify-query (link>string) ; + [ resolve-base-path ] [ modify-query ] bi* (link>string) ; : write-link ( url query -- ) link>string write ; @@ -71,8 +99,9 @@ SYMBOL: form-hook : absolute-redirect ( to query -- url ) #! Same host. request get clone - swap [ >>query ] when* - swap url-encode >>path + swap [ >>query ] when* + swap url-encode >>path + [ modify-query ] change-query request-url ; : replace-last-component ( path with -- path' ) @@ -82,13 +111,14 @@ SYMBOL: form-hook request get clone swap [ >>query ] when* swap [ '[ , replace-last-component ] change-path ] when* - dup query>> modify-query >>query + [ modify-query ] change-query request-url ; : derive-url ( to query -- url ) { { [ over "http://" head? ] [ link>string ] } { [ over "/" head? ] [ absolute-redirect ] } + { [ over "$" head? ] [ >r resolve-base-path r> derive-url ] } [ relative-redirect ] } cond ; @@ -113,22 +143,17 @@ TUPLE: dispatcher default responders ; : ( -- dispatcher ) dispatcher new-dispatcher ; -: split-path ( path -- rest first ) - [ CHAR: / = ] left-trim "/" split1 swap ; - : find-responder ( path dispatcher -- path responder ) - over split-path pick responders>> at* - [ >r >r 2drop r> r> ] [ 2drop default>> ] if ; - -: redirect-with-/ ( -- response ) - request get path>> "/" append f ; + over empty? [ + "" over responders>> at* + [ nip ] [ drop default>> ] if + ] [ + over first over responders>> at* + [ >r drop 1 tail-slice r> ] [ drop default>> ] if + ] if ; M: dispatcher call-responder ( path dispatcher -- response ) - over [ - find-responder call-responder - ] [ - 2drop redirect-with-/ - ] if ; + [ add-base-path ] [ find-responder call-responder ] 2bi ; TUPLE: vhost-dispatcher default responders ; @@ -142,15 +167,13 @@ TUPLE: vhost-dispatcher default responders ; M: vhost-dispatcher call-responder ( path dispatcher -- response ) find-vhost call-responder ; -: set-main ( dispatcher name -- dispatcher ) - '[ , f ] - >>default ; - : add-responder ( dispatcher responder path -- dispatcher ) pick responders>> set-at ; : add-main-responder ( dispatcher responder path -- dispatcher ) - [ add-responder ] keep set-main ; + [ add-responder drop ] + [ drop "" add-responder drop ] + [ 2drop ] 3tri ; SYMBOL: main-responder @@ -197,11 +220,15 @@ SYMBOL: exit-continuation : with-exit-continuation ( quot -- ) '[ exit-continuation set @ ] callcc1 exit-continuation off ; +: split-path ( string -- path ) + "/" split [ empty? not ] subset ; + : do-request ( request -- response ) [ + H{ } clone base-paths set [ log-request ] [ request set ] - [ path>> main-responder get call-responder ] tri + [ path>> split-path main-responder get call-responder ] tri [ <404> ] unless* ] [ [ \ do-request log-error ] diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 26e6927d7c..02dee1f7e0 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -61,7 +61,7 @@ M: foo call-responder "GET" >>method request set - "/etc" "manager" get call-responder + { "etc" } "manager" get call-responder response set ] unit-test @@ -76,7 +76,7 @@ M: foo call-responder "id" get session-id-key set-query-param "/" >>path request set - "/" "manager" get call-responder + { } "manager" get call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; @@ -96,7 +96,7 @@ M: foo call-responder "GET" >>method "/" >>path request set - "/etc" "manager" get call-responder response set + { "etc" } "manager" get call-responder response set [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test response get ] with-destructors @@ -111,7 +111,7 @@ response set "cookies" get >>cookies "/" >>path request set - "/" "manager" get call-responder + { } "manager" get call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; @@ -134,7 +134,7 @@ response set request set [ - "/" + { } call-responder ] with-destructors response set ] unit-test diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 2d4a97c3c0..1605144b61 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -69,32 +69,24 @@ TUPLE: file-responder root hook special ; swap '[ , directory. ] >>body ; : find-index ( filename -- path ) - { "index.html" "index.fhtml" } [ append-path ] with map - [ exists? ] find nip ; + "index.html" append-path dup exists? [ drop f ] unless ; : serve-directory ( filename -- response ) - dup "/" tail? [ - dup find-index - [ serve-file ] [ list-directory ] ?if + request get path>> "/" tail? [ + dup + find-index [ serve-file ] [ list-directory ] ?if ] [ - drop request get redirect-with-/ + drop + request get path>> "/" append f ] if ; : serve-object ( filename -- response ) - serving-path dup exists? [ - dup directory? [ serve-directory ] [ serve-file ] if - ] [ - drop <404> - ] if ; + serving-path dup exists? + [ dup directory? [ serve-directory ] [ serve-file ] if ] + [ drop <404> ] + if ; M: file-responder call-responder ( path responder -- response ) file-responder set - dup [ - ".." over subseq? [ - drop <400> - ] [ - serve-object - ] if - ] [ - drop redirect-with-/ - ] if ; + ".." over member? + [ drop <400> ] [ "/" join serve-object ] if ; diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor index 685988dfaf..3793604929 100644 --- a/extra/http/server/templating/chloe/chloe.factor +++ b/extra/http/server/templating/chloe/chloe.factor @@ -104,7 +104,8 @@ SYMBOL: tags : form-start-tag ( tag -- )
hidden-form-field ; diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 3483d4321e..d78fd4b6c2 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -1,21 +1,25 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences io.files io.sockets -db.sqlite smtp namespaces db +USING: accessors kernel sequences assocs io.files io.sockets +namespaces db db.sqlite smtp +http.server http.server.db http.server.sessions http.server.auth.login http.server.auth.providers.db http.server.sessions.storage.db http.server.boilerplate -http.server.templating.chloe ; +http.server.templating.chloe +webapps.pastebin +webapps.planet +webapps.todo ; IN: webapps.factor-website +: test-db "test.db" resource-path sqlite-db ; + : factor-template ( path -- template ) "resource:extra/webapps/factor-website/" swap ".xml" 3append ; -: test-db "todo.db" resource-path sqlite-db ; - : ( responder -- responder' ) users-in-db >>users @@ -28,11 +32,40 @@ IN: webapps.factor-website sessions-in-db >>sessions test-db ; +: ( -- responder ) + ; + +: ( -- responder ) + ; + +: ( -- responder ) + ; + +: init-factor-db ( -- ) + test-db [ + init-users-table + init-sessions-table + + init-pastes-table + init-annotations-table + + init-blog-table + + init-todo-table + ] with-db ; + +: ( -- responder ) + + "todo" add-responder + "pastebin" add-responder + "planet" add-responder ; + : init-factor-website ( -- ) "factorcode.org" 25 smtp-server set-global "todo@factorcode.org" lost-password-from set-global - test-db [ - init-sessions-table - init-users-table - ] with-db ; + init-factor-db + + main-responder set-global + + "planet" main-responder get responders>> at start-update-task ; diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml index d929042320..2f67b5e857 100644 --- a/extra/webapps/factor-website/page.xml +++ b/extra/webapps/factor-website/page.xml @@ -10,6 +10,8 @@ + + body, button { font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; @@ -47,6 +49,18 @@ padding: 5px; border: 1px solid #ccc; } + + .big-field-label { + vertical-align: top; + } + + .description { + border: 1px dashed #ccc; + background-color: #f5f5f5; + padding: 5px; + font-size: 150%; + color: #000000; + } diff --git a/extra/webapps/pastebin/annotation.xml b/extra/webapps/pastebin/annotation.xml new file mode 100644 index 0000000000..af6a835a64 --- /dev/null +++ b/extra/webapps/pastebin/annotation.xml @@ -0,0 +1,23 @@ + + + + +

Annotation:

+ + + + + +
Author:
Mode:
Date:
+ +
+ +
+ + + + + + + + diff --git a/extra/webapps/pastebin/authors.txt b/extra/webapps/pastebin/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/pastebin/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/webapps/pastebin/new-annotation.xml b/extra/webapps/pastebin/new-annotation.xml new file mode 100644 index 0000000000..4afc5cfec5 --- /dev/null +++ b/extra/webapps/pastebin/new-annotation.xml @@ -0,0 +1,25 @@ + + + + + New Annotation + + + + + + + + + + + + + + +
Summary:
Author:
Mode:
Description:
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
+ + + + + diff --git a/extra/webapps/pastebin/new-paste.xml b/extra/webapps/pastebin/new-paste.xml new file mode 100644 index 0000000000..4b2b4a46ce --- /dev/null +++ b/extra/webapps/pastebin/new-paste.xml @@ -0,0 +1,23 @@ + + + + + New Paste + + + + + + + + + + + + + +
Summary:
Author:
Mode:
Description:
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
+ + + + diff --git a/extra/webapps/pastebin/paste-list.xml b/extra/webapps/pastebin/paste-list.xml new file mode 100644 index 0000000000..12b926c7d1 --- /dev/null +++ b/extra/webapps/pastebin/paste-list.xml @@ -0,0 +1,15 @@ + + + + + Pastebin + + + + + + + +
Summary:Paste by:Date:
+ + diff --git a/extra/webapps/pastebin/paste-summary.xml b/extra/webapps/pastebin/paste-summary.xml new file mode 100644 index 0000000000..952d0de73d --- /dev/null +++ b/extra/webapps/pastebin/paste-summary.xml @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml new file mode 100644 index 0000000000..89d1891221 --- /dev/null +++ b/extra/webapps/pastebin/paste.xml @@ -0,0 +1,27 @@ + + + + + Pastebin + +

Paste:

+ + + + + +
Author:
Mode:
Date:
+ +
+ +
+ + + + + + | + Annotate + + + diff --git a/extra/webapps/pastebin/pastebin.css b/extra/webapps/pastebin/pastebin.css new file mode 100644 index 0000000000..16814770a2 --- /dev/null +++ b/extra/webapps/pastebin/pastebin.css @@ -0,0 +1,7 @@ +pre.code { + border:1px dashed #ccc; + background-color:#f5f5f5; + padding:5px; + font-size:150%; + color:#000000; +} diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor new file mode 100644 index 0000000000..4fa8f55ca8 --- /dev/null +++ b/extra/webapps/pastebin/pastebin.factor @@ -0,0 +1,253 @@ +USING: namespaces assocs sorting sequences kernel accessors +hashtables sequences.lib locals db.types db.tuples db +calendar calendar.format rss xml.writer +xmode.catalog +http.server +http.server.crud +http.server.actions +http.server.components +http.server.components.code +http.server.templating.chloe +http.server.boilerplate +http.server.validators +http.server.forms ; +IN: webapps.pastebin + +: ( id -- component ) + modes keys natural-sort ; + +: pastebin-template ( name -- template ) + "resource:extra/webapps/pastebin/" swap ".xml" 3append ; + +TUPLE: paste id summary author mode date contents annotations captcha ; + +paste "PASTE" +{ + { "id" "ID" INTEGER +native-id+ } + { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } + { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } + { "mode" "MODE" { VARCHAR 256 } +not-null+ } + { "date" "DATE" DATETIME +not-null+ } + { "contents" "CONTENTS" TEXT +not-null+ } +} define-persistent + +: ( id -- paste ) + paste new + swap >>id ; + +: pastes ( -- pastes ) + f select-tuples ; + +TUPLE: annotation aid id summary author mode contents date captcha ; + +annotation "ANNOTATION" +{ + { "aid" "AID" INTEGER +native-id+ } + { "id" "ID" INTEGER +not-null+ } + { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } + { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } + { "mode" "MODE" { VARCHAR 256 } +not-null+ } + { "date" "DATE" DATETIME +not-null+ } + { "contents" "CONTENTS" TEXT +not-null+ } +} define-persistent + +: ( id aid -- annotation ) + annotation new + swap >>aid + swap >>id ; + +: fetch-annotations ( paste -- paste ) + dup annotations>> [ + dup id>> f select-tuples >>annotations + ] unless ; + +: ( -- form ) + "paste" + "id" + hidden >>renderer + add-field + "aid" + hidden >>renderer + add-field + "annotation" pastebin-template >>view-template + "summary" add-field + "author" add-field + "mode" add-field + "contents" "mode" add-field + "date" add-field ; + +: ( -- form ) + "paste" + "new-annotation" pastebin-template >>edit-template + "id" + hidden >>renderer + t >>required add-field + "summary" + t >>required add-field + "author" + t >>required + add-field + "mode" + "factor" >>default + t >>required + add-field + "contents" "mode" + t >>required add-field + "captcha" add-field ; + +: ( -- form ) + "paste" + "paste" pastebin-template >>view-template + "paste-summary" pastebin-template >>summary-template + "id" + hidden >>renderer add-field + "summary" add-field + "author" add-field + "mode" add-field + "date" add-field + "contents" "mode" add-field + "annotations" +plain+ add-field ; + +: ( -- form ) + "paste" + "new-paste" pastebin-template >>edit-template + "summary" + t >>required add-field + "author" + t >>required add-field + "mode" + "factor" >>default + t >>required + add-field + "contents" "mode" + t >>required add-field + "captcha" add-field ; + +: ( -- form ) + "pastebin" + "paste-list" pastebin-template >>view-template + "pastes" +plain+ add-field ; + +:: ( -- action ) + [let | form [ ] | + + [ + blank-values + + pastes "pastes" set-value + + form view-form + ] >>display + ] ; + +:: ( form ctor next -- action ) + + { { "id" [ v-number ] } } >>get-params + + [ + "id" get f ctor call + + from-tuple form set-defaults + ] >>init + + [ form edit-form ] >>display + + [ + f f ctor call from-tuple + + form validate-form + + values-tuple insert-tuple + + "id" value next + ] >>submit ; + +: pastebin-feed-entries ( -- entries ) + pastes 20 short head [ + [ summary>> ] + [ "$pastebin/view-paste" swap id>> "id" associate link>string ] + [ date>> ] tri + f swap + ] map ; + +: pastebin-feed ( -- feed ) + feed new + "Factor Pastebin" >>title + "http://paste.factorcode.org" >>link + pastebin-feed-entries >>entries ; + +: ( -- action ) + + [ + "text/xml" + [ pastebin-feed feed>xml write-xml ] >>body + ] >>display ; + +:: ( form ctor -- action ) + + { { "id" [ v-number ] } } >>get-params + + [ "id" get ctor call select-tuple fetch-annotations from-tuple ] >>init + + [ form view-form ] >>display ; + +:: ( ctor next -- action ) + + { { "id" [ v-number ] } } >>post-params + + [ + "id" get ctor call delete-tuple + + "id" get f select-tuples [ delete-tuple ] each + + next f + ] >>submit ; + +:: ( ctor next -- action ) + + { { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params + + [ + "id" get "aid" get ctor call delete-tuple + + "id" get next + ] >>submit ; + +:: ( form ctor next -- action ) + + [ + f ctor call from-tuple + + form set-defaults + ] >>init + + [ form edit-form ] >>display + + [ + f ctor call from-tuple + + form validate-form + + values-tuple insert-tuple + + "id" value next + ] >>submit ; + +TUPLE: pastebin < dispatcher ; + +: ( -- responder ) + pastebin new-dispatcher + "list" add-main-responder + "feed.xml" add-responder + [ ] "view-paste" add-responder + [ ] "$pastebin/list" "delete-paste" add-responder + [ ] "$pastebin/view-paste" "delete-annotation" add-responder + [ ] "$pastebin/view-paste" add-responder + [ now >>date ] "$pastebin/view-paste" "new-paste" add-responder + [ now >>date ] "$pastebin/view-paste" "annotate" add-responder + + "pastebin" pastebin-template >>template ; + +: init-pastes-table paste ensure-table ; + +: init-annotations-table annotation ensure-table ; diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml new file mode 100644 index 0000000000..2d335fe9ce --- /dev/null +++ b/extra/webapps/pastebin/pastebin.xml @@ -0,0 +1,29 @@ + + + + + + + + +
+ Pastes + | New Paste + | Atom Feed + + + + | Edit Profile + + + + | + + +
+ +

+ + + + diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index 1a18cad94b..3bd406ee38 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -7,7 +7,8 @@

- Add Blog | Update + Add Blog + | Update

diff --git a/extra/webapps/planet/blog-admin-link.xml b/extra/webapps/planet/blog-admin-link.xml index 712db4ba0d..a92af8dd1d 100644 --- a/extra/webapps/planet/blog-admin-link.xml +++ b/extra/webapps/planet/blog-admin-link.xml @@ -2,6 +2,6 @@ - + diff --git a/extra/webapps/planet/edit-blog.xml b/extra/webapps/planet/edit-blog.xml index 890b23dcce..83273540a5 100644 --- a/extra/webapps/planet/edit-blog.xml +++ b/extra/webapps/planet/edit-blog.xml @@ -4,7 +4,7 @@ Edit Blog - + @@ -21,8 +21,8 @@ - Atom feed: - + Feed: + @@ -31,9 +31,7 @@ - View - | - + diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 464e2bbfb3..3cd35be5fb 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sorting locals math calendar alarms logging concurrency.combinators namespaces -db.types db.tuples db +sequences.lib db.types db.tuples db rss xml.writer http.server http.server.crud @@ -11,8 +11,7 @@ http.server.actions http.server.boilerplate http.server.templating.chloe http.server.components -http.server.auth.login -webapps.factor-website ; +http.server.auth.login ; IN: webapps.planet TUPLE: planet-factor < dispatcher postings ; @@ -20,7 +19,7 @@ TUPLE: planet-factor < dispatcher postings ; : planet-template ( name -- template ) "resource:extra/webapps/planet/" swap ".xml" 3append ; -TUPLE: blog id name www-url atom-url ; +TUPLE: blog id name www-url feed-url ; M: blog link-title name>> ; @@ -31,7 +30,7 @@ blog "BLOGS" { "id" "ID" INTEGER +native-id+ } { "name" "NAME" { VARCHAR 256 } +not-null+ } { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ } - { "atom-url" "ATOMURL" { VARCHAR 256 } +not-null+ } + { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ } } define-persistent : init-blog-table blog ensure-table ; @@ -54,7 +53,6 @@ blog "BLOGS" : ( -- form ) "blog" "edit-blog" planet-template >>edit-template - "view-blog" planet-template >>view-template "blog-admin-link" planet-template >>summary-template "id" hidden >>renderer @@ -65,7 +63,7 @@ blog "BLOGS" "www-url" t >>required add-field - "atom-url" + "feed-url" t >>required add-field ; @@ -106,14 +104,11 @@ blog "BLOGS" ] >>display ] ; -: safe-head ( seq n -- seq' ) - over length min head ; - :: planet-feed ( planet -- feed ) feed new - "[ planet-factor ]" >>title + "Planet Factor" >>title "http://planet.factorcode.org" >>link - planet postings>> 16 safe-head >>entries ; + planet postings>> 16 short head >>entries ; :: ( planet -- action ) @@ -132,7 +127,7 @@ blog "BLOGS" : fetch-blogroll ( blogroll -- entries ) dup - [ atom-url>> fetch-feed ] parallel-map + [ feed-url>> fetch-feed ] parallel-map [ >r name>> r> [ ] with map ] 2map concat ; : sort-entries ( entries -- entries' ) @@ -140,7 +135,7 @@ blog "BLOGS" : update-cached-postings ( planet -- ) "webapps.planet" [ - blogroll fetch-blogroll sort-entries 8 safe-head + blogroll fetch-blogroll sort-entries 8 short head >>postings drop ] with-logging ; @@ -157,32 +152,20 @@ blog "BLOGS" planet-factor >>default + planet-factor "update" add-responder + ! Administrative CRUD - blog-ctor "" "delete-blog" add-responder - blog-form blog-ctor "view-blog" add-responder - blog-form blog-ctor "view-blog" "edit-blog" add-responder + blog-ctor "$planet-factor/admin" "delete-blog" add-responder + blog-form blog-ctor "$planet-factor/admin" "edit-blog" add-responder ] ; : ( -- responder ) planet-factor new-dispatcher - dup >>default + dup "list" add-main-responder dup "feed.xml" add-responder - dup "update" add-responder dup "admin" add-responder "planet" planet-template >>template ; - -: ( -- responder ) - ; : start-update-task ( planet -- ) [ update-cached-postings ] curry 10 minutes every drop ; - -: init-planet ( -- ) - test-db [ - init-blog-table - ] with-db - - - "planet" add-responder - main-responder set-global ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 772f81906d..c96a143246 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -3,22 +3,21 @@ - +
- Front Page - | Atom Feed - - | Admin + Front Page + | Atom Feed + | Admin - | Edit Profile + | Edit Profile - + | diff --git a/extra/webapps/planet/view-blog.xml b/extra/webapps/planet/view-blog.xml deleted file mode 100644 index fbc03aff25..0000000000 --- a/extra/webapps/planet/view-blog.xml +++ /dev/null @@ -1,41 +0,0 @@ - - - - - View Blog - - - - - - - - - - - - - - - - - - -
Blog name:
Home page: - - - -
Atom feed: - - - -
- - Edit - | - - - - - - diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml index 71d6900f1a..ef1e1fd26a 100644 --- a/extra/webapps/todo/edit-todo.xml +++ b/extra/webapps/todo/edit-todo.xml @@ -4,21 +4,21 @@ Edit Item - + - - + +
Summary:
Priority:
Summary:
Priority:
Description:
 - View + View | - + diff --git a/extra/webapps/todo/todo-summary.xml b/extra/webapps/todo/todo-summary.xml index 9e03b7f135..008b0acaf5 100644 --- a/extra/webapps/todo/todo-summary.xml +++ b/extra/webapps/todo/todo-summary.xml @@ -10,10 +10,10 @@ - View + View - Edit + Edit diff --git a/extra/webapps/todo/todo.css b/extra/webapps/todo/todo.css index 2520a56128..26a0fe0960 100644 --- a/extra/webapps/todo/todo.css +++ b/extra/webapps/todo/todo.css @@ -1,15 +1,3 @@ -.big-field-label { - vertical-align: top; -} - -.description { - border: 1px dashed #ccc; - background-color: #f5f5f5; - padding: 5px; - font-size: 150%; - color: #000000; -} - pre { font-size: 75%; } diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 97af356dc5..bb4a4b9cd2 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -7,8 +7,7 @@ http.server.forms http.server.templating.chloe http.server.boilerplate http.server.crud http.server.auth http.server.actions http.server.db http.server.auth.login -http.server -webapps.factor-website ; +http.server ; IN: webapps.todo TUPLE: todo uid id priority summary description ; @@ -58,29 +57,17 @@ todo "TODO" "list" +plain+ add-field ; -TUPLE: todo-responder < dispatcher ; +TUPLE: todo-list < dispatcher ; -:: ( -- responder ) +:: ( -- responder ) [let | todo-form [ ] list-form [ ] ctor [ [ ] ] | - todo-responder new-dispatcher + todo-list new-dispatcher list-form ctor "list" add-main-responder todo-form ctor "view" add-responder - todo-form ctor "view" "edit" add-responder - ctor "list" "delete" add-responder + todo-form ctor "$todo-list/view" "edit" add-responder + ctor "$todo-list/list" "delete" add-responder "todo" todo-template >>template ] ; - -: ( -- responder ) - ; - -: init-todo ( -- ) - test-db [ - init-todo-table - ] with-db - - - "todo" add-responder - main-responder set-global ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index 81a5d3a425..70bbb1250b 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -4,17 +4,15 @@ - -
- List Items - | Add Item + List Items + | Add Item - | Edit Profile + | Edit Profile - + |
diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml index fea77c1189..e8c2fd3983 100644 --- a/extra/webapps/todo/view-todo.xml +++ b/extra/webapps/todo/view-todo.xml @@ -13,9 +13,9 @@
- Edit + Edit | - +