From b8cf64bc76afe9e0017d285463a3bf2a46b52646 Mon Sep 17 00:00:00 2001 From: slava Date: Wed, 13 Sep 2006 04:48:04 +0000 Subject: [PATCH] Start of new web framework --- contrib/embedded.factor | 1 + contrib/furnace-pastebin/load.factor | 3 + contrib/furnace-pastebin/new-paste.fhtml | 22 ++++ contrib/furnace-pastebin/paste-list.fhtml | 7 ++ contrib/furnace-pastebin/paste-summary.fhtml | 7 ++ contrib/furnace-pastebin/pastebin.factor | 62 ++++++++++ contrib/furnace-pastebin/show-paste.fhtml | 9 ++ contrib/furnace/load.factor | 7 ++ contrib/furnace/page.fhtml | 9 ++ contrib/furnace/responder.factor | 114 +++++++++++++++++++ contrib/furnace/test/responder.factor | 33 ++++++ 11 files changed, 274 insertions(+) create mode 100644 contrib/furnace-pastebin/load.factor create mode 100644 contrib/furnace-pastebin/new-paste.fhtml create mode 100644 contrib/furnace-pastebin/paste-list.fhtml create mode 100644 contrib/furnace-pastebin/paste-summary.fhtml create mode 100644 contrib/furnace-pastebin/pastebin.factor create mode 100644 contrib/furnace-pastebin/show-paste.fhtml create mode 100644 contrib/furnace/load.factor create mode 100644 contrib/furnace/page.fhtml create mode 100644 contrib/furnace/responder.factor create mode 100644 contrib/furnace/test/responder.factor diff --git a/contrib/embedded.factor b/contrib/embedded.factor index b979aeeec9..0ecb0e1ff1 100644 --- a/contrib/embedded.factor +++ b/contrib/embedded.factor @@ -55,6 +55,7 @@ USING: sequences kernel parser math namespaces io ; : with-embedded-file ( filename quot -- ) [ + file-vocabs over file set ! so that reload works properly >r contents r> call ] with-scope ; diff --git a/contrib/furnace-pastebin/load.factor b/contrib/furnace-pastebin/load.factor new file mode 100644 index 0000000000..b1665aabad --- /dev/null +++ b/contrib/furnace-pastebin/load.factor @@ -0,0 +1,3 @@ +REQUIRES: contrib/furnace ; + +PROVIDE: contrib/furnace-pastebin { "pastebin.factor" } ; diff --git a/contrib/furnace-pastebin/new-paste.fhtml b/contrib/furnace-pastebin/new-paste.fhtml new file mode 100644 index 0000000000..c9a393105c --- /dev/null +++ b/contrib/furnace-pastebin/new-paste.fhtml @@ -0,0 +1,22 @@ +
+ + + + + + + + + + + + + + + + + +
Summary:
Your name:
Contents:
+ + +
diff --git a/contrib/furnace-pastebin/paste-list.fhtml b/contrib/furnace-pastebin/paste-list.fhtml new file mode 100644 index 0000000000..60465c6e73 --- /dev/null +++ b/contrib/furnace-pastebin/paste-list.fhtml @@ -0,0 +1,7 @@ +<% USING: namespaces furnace sequences ; %> + + + +<% "pastes" get [ "paste-summary" render-template ] each %>
Summary:Paste by:
+ +<% "new-paste-quot" get "New paste" render-link %> diff --git a/contrib/furnace-pastebin/paste-summary.fhtml b/contrib/furnace-pastebin/paste-summary.fhtml new file mode 100644 index 0000000000..8079bba8c7 --- /dev/null +++ b/contrib/furnace-pastebin/paste-summary.fhtml @@ -0,0 +1,7 @@ +<% USING: namespaces io kernel math furnace ; %> + + +<% "summary" get write %> +<% "author" get write %> +<% "n" get number>string "show-paste-quot" get curry "Show" render-link %> + diff --git a/contrib/furnace-pastebin/pastebin.factor b/contrib/furnace-pastebin/pastebin.factor new file mode 100644 index 0000000000..b469f6b586 --- /dev/null +++ b/contrib/furnace-pastebin/pastebin.factor @@ -0,0 +1,62 @@ +IN: furnace:pastebin +USING: calendar kernel namespaces sequences furnace hashtables +math ; + +TUPLE: paste n summary author contents date ; + +C: paste ( summary author contents -- paste ) + [ set-paste-contents ] keep + [ set-paste-author ] keep + [ set-paste-summary ] keep ; + +TUPLE: pastebin pastes ; + +C: pastebin ( -- pastebin ) + V{ } clone over set-pastebin-pastes ; + +: add-paste ( paste pastebin -- ) + now timestamp>http-string pick set-paste-date + dup pastebin-pastes length pick set-paste-n + pastebin-pastes push ; + + "pastebin" set-global + +: get-paste ( n -- paste ) + "pastebin" get pastebin-pastes nth ; + +: show-paste ( n -- ) + "Paste" + swap string>number get-paste + "show-paste" render-page ; + +\ show-paste { { "n" "0" } } define-action + +: new-paste ( -- ) + "New paste" f "new-paste" render-page ; + +\ new-paste { } define-action + +: submit-paste ( summary author contents -- ) + "pastebin" get-global add-paste ; + +\ submit-paste { + { "summary" "" } + { "author" "" } + { "contents" "" } +} define-action + +: paste-list ( -- ) + [ + [ show-paste ] "show-paste-quot" set + [ new-paste ] "new-paste-quot" set + + "Pastebin" + "pastebin" get + "paste-list" render-page + ] with-scope ; + +\ paste-list { } define-action + +\ submit-paste [ paste-list ] define-redirect + +"pastebin" "paste-list" "contrib/pastebin" web-app diff --git a/contrib/furnace-pastebin/show-paste.fhtml b/contrib/furnace-pastebin/show-paste.fhtml new file mode 100644 index 0000000000..81394e3871 --- /dev/null +++ b/contrib/furnace-pastebin/show-paste.fhtml @@ -0,0 +1,9 @@ +<% USING: namespaces io ; %> + + + + + +
Summary:<% "summary" get write %>
Paste by:<% "author" get write %>
Created:<% "date" get write %>
+ +
<% "contents" get write %>
diff --git a/contrib/furnace/load.factor b/contrib/furnace/load.factor new file mode 100644 index 0000000000..4616e604f3 --- /dev/null +++ b/contrib/furnace/load.factor @@ -0,0 +1,7 @@ +REQUIRES: contrib/httpd ; + +PROVIDE: contrib/furnace { + "responder.factor" +} { + "test/responder.factor" +} ; diff --git a/contrib/furnace/page.fhtml b/contrib/furnace/page.fhtml new file mode 100644 index 0000000000..b50ad436f3 --- /dev/null +++ b/contrib/furnace/page.fhtml @@ -0,0 +1,9 @@ +<% USING: namespaces io furnace ; %> + + + +<% "title" get write %> + +<% "root" get render-component %> + + diff --git a/contrib/furnace/responder.factor b/contrib/furnace/responder.factor new file mode 100644 index 0000000000..0bf43b2cbd --- /dev/null +++ b/contrib/furnace/responder.factor @@ -0,0 +1,114 @@ +IN: furnace +USING: embedded generic arrays namespaces prettyprint io +sequences words kernel httpd html errors hashtables http +callback-responder ; + +SYMBOL: default-action + +SYMBOL: template-path + +: define-action ( word params -- ) + over t "action" set-word-prop + "action-params" set-word-prop ; + +: define-redirect ( word quot -- ) + "action-redirect" set-word-prop ; + +: responder-vocab ( name -- vocab ) + "furnace:" swap append ; + +: lookup-action ( name webapp -- word ) + responder-vocab lookup dup [ + dup "action" word-prop [ drop f ] unless + ] when ; + +: current-action ( url -- word/f ) + dup empty? [ drop default-action get ] when + "responder" get lookup-action ; + +PREDICATE: word action "action" word-prop ; + +: quot>query ( seq action -- hash ) + "action-params" word-prop + [ first swap 2array ] 2map alist>hash ; + +: action-link ( query action -- url ) + [ + "/responder/" % "responder" get % "/" % + word-name % + ] "" make swap build-url ; + +: action-call? ( args obj -- ? ) + action? >r [ word? not ] all? r> and ; + +: quot-link ( quot -- url ) + 1 swap cut* peek 2dup action-call? [ + [ quot>query ] keep action-link + ] [ + t register-html-callback + ] if ; + +: render-link ( quot name -- ) + write ; + +: query>quot ( params action -- seq ) + "action-params" word-prop + [ dup first rot hash [ ] [ second ] ?if ] map-with ; + +: perform-redirect ( action -- ) + "action-redirect" word-prop [ quot-link redirect ] when* ; + +: call-action ( params action -- ) + [ query>quot ] keep [ add >quotation call ] keep + perform-redirect ; + +: service-request ( url params -- ) + current-action [ + [ call-action ] [ 
 print-error
] recover + ] [ + "404 no such action: " "argument" get append httpd-error + ] if* ; + +: service-get ( url -- ) "query" get swap service-request ; + +: service-post ( url -- ) "response" get swap service-request ; + +: explode-tuple ( tuple -- ) + dup tuple>array 2 tail swap class "slot-names" word-prop + [ set ] 2each ; + +: call-template ( model template -- ) + [ + >r [ explode-tuple ] when* r> + ".fhtml" append resource-path run-embedded-file + ] with-scope ; + +TUPLE: component model template ; + +TUPLE: page title root ; + +C: page ( title model template -- page ) + [ >r r> set-page-root ] keep + [ set-page-title ] keep ; + +: render-template ( model template -- ) + template-path get swap path+ call-template ; + +: render-component + dup component-model swap component-template + render-template ; + +: render-page ( title model template -- ) + serving-html + "contrib/furnace/page" call-template ; + +: web-app ( name default path -- ) + over responder-vocab create-vocab drop + [ + template-path set + default-action set + "responder" set + [ service-get ] "get" set + [ service-post ] "post" set + ! [ service-head ] "head" set + ] make-responder ; diff --git a/contrib/furnace/test/responder.factor b/contrib/furnace/test/responder.factor new file mode 100644 index 0000000000..1ae0a4f1eb --- /dev/null +++ b/contrib/furnace/test/responder.factor @@ -0,0 +1,33 @@ +IN: temporary +USING: test namespaces furnace ; + +: foo ; + +\ foo { { "foo" "2" } { "bar" f } } define-action + +[ + { "2" "hello" } +] [ + [ + H{ + { "bar" "hello" } + } "query" set + + \ foo query>quot + ] with-scope +] unit-test + +[ + H{ { "foo" "1" } { "bar" "2" } } +] [ + { "1" "2" } \ foo quot>query +] unit-test + +[ + "/responder/bar/foo?foo=3" +] [ + [ + "bar" "responder" set + [ "3" foo ] quot-link + ] with-scope +] unit-test