From c91cd333e9acd0d9c4b6ad9dfdb2f543e7b856a9 Mon Sep 17 00:00:00 2001 From: slava Date: Mon, 16 Oct 2006 03:59:04 +0000 Subject: [PATCH] Working on furnace --- contrib/furnace-pastebin/annotate-paste.fhtml | 28 ++++++++++++ contrib/furnace-pastebin/annotation.fhtml | 11 +++++ contrib/furnace-pastebin/new-paste.fhtml | 5 +++ contrib/furnace-pastebin/pastebin.factor | 41 ++++++++++++------ contrib/furnace-pastebin/show-paste.fhtml | 10 ++++- contrib/furnace/load.factor | 2 + contrib/furnace/responder.factor | 33 +++++++++----- contrib/furnace/test/responder.factor | 25 ++++++++--- contrib/furnace/test/validator.factor | 30 +++++++++++++ contrib/furnace/validator.factor | 43 +++++++++++++++++++ 10 files changed, 199 insertions(+), 29 deletions(-) create mode 100644 contrib/furnace-pastebin/annotate-paste.fhtml create mode 100644 contrib/furnace-pastebin/annotation.fhtml create mode 100644 contrib/furnace/test/validator.factor create mode 100644 contrib/furnace/validator.factor diff --git a/contrib/furnace-pastebin/annotate-paste.fhtml b/contrib/furnace-pastebin/annotate-paste.fhtml new file mode 100644 index 0000000000..24f0d4ea94 --- /dev/null +++ b/contrib/furnace-pastebin/annotate-paste.fhtml @@ -0,0 +1,28 @@ +<% USING: namespaces math io ; %> + +

Annotate

+ +
+ + + +string write %>" /> + + + + + + + + + + + + + + + +
Summary:
Your name:
Contents:
+ + +
diff --git a/contrib/furnace-pastebin/annotation.fhtml b/contrib/furnace-pastebin/annotation.fhtml new file mode 100644 index 0000000000..ed1bdac845 --- /dev/null +++ b/contrib/furnace-pastebin/annotation.fhtml @@ -0,0 +1,11 @@ +<% USING: namespaces io ; %> + +

Annotation: <% "summary" get write %>

+ + + + + +
Annotation by:<% "author" get write %>
Channel:<% "channel" get write %>
Created:<% "date" get write %>
+ +
<% "contents" get write %>
diff --git a/contrib/furnace-pastebin/new-paste.fhtml b/contrib/furnace-pastebin/new-paste.fhtml index c9a393105c..36f0397b67 100644 --- a/contrib/furnace-pastebin/new-paste.fhtml +++ b/contrib/furnace-pastebin/new-paste.fhtml @@ -12,6 +12,11 @@ + +Channel: + + + Contents: diff --git a/contrib/furnace-pastebin/pastebin.factor b/contrib/furnace-pastebin/pastebin.factor index 1bd2b64a2a..1b88911348 100644 --- a/contrib/furnace-pastebin/pastebin.factor +++ b/contrib/furnace-pastebin/pastebin.factor @@ -2,11 +2,15 @@ IN: furnace:pastebin USING: calendar kernel namespaces sequences furnace hashtables math ; -TUPLE: paste n summary author contents date ; +TUPLE: paste n summary author channel contents date annotations ; -C: paste ( summary author contents -- paste ) +TUPLE: annotation summary author contents ; + +C: paste ( summary author channel contents -- paste ) + V{ } clone over set-paste-annotations [ set-paste-contents ] keep [ set-paste-author ] keep + [ set-paste-channel ] keep [ set-paste-summary ] keep ; TUPLE: pastebin pastes ; @@ -19,30 +23,31 @@ C: pastebin ( -- pastebin ) dup pastebin-pastes length pick set-paste-n pastebin-pastes push ; - "pastebin" set-global + pastebin set-global : get-paste ( n -- paste ) - "pastebin" get pastebin-pastes nth ; + pastebin get pastebin-pastes nth ; : show-paste ( n -- ) "Paste" - swap string>number get-paste + swap get-paste "show-paste" render-page ; -\ show-paste { { "n" "0" } } define-action +\ show-paste { { "n" v-number } } 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 channel contents -- ) + pastebin get-global add-paste ; \ submit-paste { - { "summary" "" } - { "author" "" } - { "contents" "" } + { "summary" v-required } + { "author" v-required } + { "channel" "#concatenative" v-default } + { "contents" v-required } } define-action : paste-list ( -- ) @@ -51,7 +56,7 @@ C: pastebin ( -- pastebin ) [ new-paste ] "new-paste-quot" set "Pastebin" - "pastebin" get + pastebin get "paste-list" render-page ] with-scope ; @@ -60,3 +65,15 @@ C: pastebin ( -- pastebin ) \ submit-paste [ paste-list ] define-redirect "pastebin" "paste-list" "contrib/furnace-pastebin" web-app + +: annotate-paste ( paste# summary author contents -- ) + swap get-paste paste-annotations push ; + +\ annotate-paste { + { "n" v-required v-number } + { "summary" v-required } + { "author" v-required } + { "contents" v-required } +} define-action + +\ annotate-paste [ "n" show-paste ] define-redirect diff --git a/contrib/furnace-pastebin/show-paste.fhtml b/contrib/furnace-pastebin/show-paste.fhtml index 81394e3871..b3b4e99b6e 100644 --- a/contrib/furnace-pastebin/show-paste.fhtml +++ b/contrib/furnace-pastebin/show-paste.fhtml @@ -1,9 +1,15 @@ -<% USING: namespaces io ; %> +<% USING: namespaces io furnace sequences ; %> + +

Paste: <% "summary" get write %>

- +
Summary:<% "summary" get write %>
Paste by:<% "author" get write %>
Channel:<% "channel" get write %>
Created:<% "date" get write %>
<% "contents" get write %>
+ +<% "annotations" get [ "annotation" render-template ] each %> + +<% model get "annotate-paste" render-template %> diff --git a/contrib/furnace/load.factor b/contrib/furnace/load.factor index 4616e604f3..8fe59c6ed0 100644 --- a/contrib/furnace/load.factor +++ b/contrib/furnace/load.factor @@ -1,7 +1,9 @@ REQUIRES: contrib/httpd ; PROVIDE: contrib/furnace { + "validator.factor" "responder.factor" } { + "test/validator.factor" "test/responder.factor" } ; diff --git a/contrib/furnace/responder.factor b/contrib/furnace/responder.factor index 0bf43b2cbd..7599c8873b 100644 --- a/contrib/furnace/responder.factor +++ b/contrib/furnace/responder.factor @@ -1,7 +1,9 @@ +! Copyright (C) 2006 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. IN: furnace USING: embedded generic arrays namespaces prettyprint io sequences words kernel httpd html errors hashtables http -callback-responder ; +callback-responder vectors strings ; SYMBOL: default-action @@ -38,12 +40,14 @@ PREDICATE: word action "action" word-prop ; word-name % ] "" make swap build-url ; -: action-call? ( args obj -- ? ) - action? >r [ word? not ] all? r> and ; +: action-call? ( quot -- ? ) + >vector dup pop action? >r [ word? not ] all? r> and ; + +: unclip* dup 1 head* swap peek ; : quot-link ( quot -- url ) - 1 swap cut* peek 2dup action-call? [ - [ quot>query ] keep action-link + dup action-call? [ + unclip* [ quot>query ] keep action-link ] [ t register-html-callback ] if ; @@ -51,18 +55,25 @@ PREDICATE: word action "action" word-prop ; : render-link ( quot name -- ) write ; +: action-param ( params paramspec -- obj error/f ) + unclip rot hash swap >quotation apply-validators ; + : query>quot ( params action -- seq ) - "action-params" word-prop - [ dup first rot hash [ ] [ second ] ?if ] map-with ; + "action-params" word-prop [ action-param drop ] map-with ; + +SYMBOL: request-params : perform-redirect ( action -- ) - "action-redirect" word-prop [ quot-link redirect ] when* ; + "action-redirect" word-prop + [ dup string? [ request-params get hash ] when ] map + [ quot-link redirect ] when* ; : call-action ( params action -- ) + over request-params set [ query>quot ] keep [ add >quotation call ] keep perform-redirect ; -: service-request ( url params -- ) +: service-request ( params url -- ) current-action [ [ call-action ] [ 
 print-error
] recover ] [ @@ -77,9 +88,11 @@ PREDICATE: word action "action" word-prop ; dup tuple>array 2 tail swap class "slot-names" word-prop [ set ] 2each ; +SYMBOL: model + : call-template ( model template -- ) [ - >r [ explode-tuple ] when* r> + >r [ dup model set explode-tuple ] when* r> ".fhtml" append resource-path run-embedded-file ] with-scope ; diff --git a/contrib/furnace/test/responder.factor b/contrib/furnace/test/responder.factor index 1ae0a4f1eb..d451be5024 100644 --- a/contrib/furnace/test/responder.factor +++ b/contrib/furnace/test/responder.factor @@ -1,9 +1,26 @@ IN: temporary -USING: test namespaces furnace ; +USING: test namespaces furnace math kernel sequences ; + +TUPLE: test-tuple m n ; + +[ H{ { "m" 3 } { "n" 2 } } ] +[ + [ T{ test-tuple f 3 2 } explode-tuple ] make-hash +] unit-test + +[ + { 3 } +] [ + H{ { "n" "3" } } { { "n" v-number } } + [ action-param drop ] map-with +] unit-test : foo ; -\ foo { { "foo" "2" } { "bar" f } } define-action +\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action + +[ t ] [ [ 1 2 foo ] action-call? ] unit-test +[ f ] [ [ 2 + ] action-call? ] unit-test [ { "2" "hello" } @@ -11,9 +28,7 @@ USING: test namespaces furnace ; [ H{ { "bar" "hello" } - } "query" set - - \ foo query>quot + } \ foo query>quot ] with-scope ] unit-test diff --git a/contrib/furnace/test/validator.factor b/contrib/furnace/test/validator.factor new file mode 100644 index 0000000000..e7d92c704e --- /dev/null +++ b/contrib/furnace/test/validator.factor @@ -0,0 +1,30 @@ +IN: temporary +USING: test namespaces furnace math kernel sequences ; + +[ + 123 f +] [ + H{ { "foo" "123" } } { "foo" v-number } action-param +] unit-test + +: validation-fails + [ action-param nip not ] append [ f ] swap unit-test ; + +[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails + +[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails + +[ "ABCD" f ] +[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ] +unit-test + +[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ] +validation-fails + +[ "AB" f ] +[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ] +unit-test + +[ "AB" f ] +[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ] +unit-test diff --git a/contrib/furnace/validator.factor b/contrib/furnace/validator.factor new file mode 100644 index 0000000000..9efc944171 --- /dev/null +++ b/contrib/furnace/validator.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2006 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +IN: furnace +USING: generic kernel errors words sequences math +namespaces ; + +TUPLE: validation-error reason ; + +: apply-validators ( string quot -- obj error/f ) + [ + call f + ] [ + dup validation-error? [ >r 2drop f r> ] [ rethrow ] if + ] recover ; + +: validation-error ( msg -- * ) throw ; + +: v-default ( obj value -- obj ) + over empty? [ nip ] [ drop ] if ; + +: v-required ( str -- str ) + dup empty? [ "required" validation-error ] when ; + +: v-min-length ( str n -- str ) + over length over < [ + [ "must be at least " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-length ( str n -- str ) + over length over > [ + [ "must be no more than " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-number ( str -- n ) + string>number [ + "must be a number" validation-error + ] unless* ; -- 2.34.1