From 8d8cb11e2a4bbbdf14458d7aea8fd451c9494b09 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 26 May 2008 00:48:02 -0500 Subject: [PATCH] More stuff --- extra/tangle/tangle.factor | 14 ++---- extra/validators/validators-tests.factor | 61 +++++++++++++++++------ extra/validators/validators.factor | 60 +++++++++++----------- extra/webapps/counter/counter.fhtml | 10 ---- extra/webapps/pastebin/annotation.xml | 17 ------- extra/webapps/pastebin/new-annotation.xml | 24 --------- extra/webapps/pastebin/paste-summary.xml | 11 ---- extra/webapps/planet/blog-admin-link.xml | 7 --- extra/webapps/todo/todo-summary.xml | 20 -------- 9 files changed, 83 insertions(+), 141 deletions(-) delete mode 100644 extra/webapps/counter/counter.fhtml delete mode 100644 extra/webapps/pastebin/annotation.xml delete mode 100644 extra/webapps/pastebin/new-annotation.xml delete mode 100644 extra/webapps/pastebin/paste-summary.xml delete mode 100644 extra/webapps/planet/blog-admin-link.xml delete mode 100644 extra/webapps/todo/todo-summary.xml diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor index 52c454f97f..8a4c6146de 100644 --- a/extra/tangle/tangle.factor +++ b/extra/tangle/tangle.factor @@ -19,11 +19,8 @@ C: tangle : with-tangle ( tangle quot -- ) [ [ db>> ] [ seq>> ] bi ] dip with-db ; -: ( text -- response ) - "text/plain" swap >>body ; - : node-response ( id -- response ) - load-node [ node-content ] [ <404> ] if* ; + load-node [ node-content ] [ <404> ] if* ; : display-node ( params -- response ) [ @@ -39,7 +36,7 @@ C: tangle : submit-node ( params -- response ) [ "node_content" swap at* [ - create-node id>> number>string + create-node id>> number>string ] [ drop <400> ] if @@ -55,10 +52,7 @@ TUPLE: path-responder ; C: path-responder M: path-responder call-responder* ( path responder -- response ) - drop path>file [ node-content ] [ <404> ] if* ; - -: ( obj -- response ) - "application/json" swap >json >>body ; + drop path>file [ node-content ] [ <404> ] if* ; TUPLE: tangle-dispatcher < dispatcher tangle ; @@ -67,7 +61,7 @@ TUPLE: tangle-dispatcher < dispatcher tangle ; >>default "resource:extra/tangle/resources" "resources" add-responder "node" add-responder - [ all-node-ids ] >>display "all" add-responder ; + [ all-node-ids ] >>display "all" add-responder ; M: tangle-dispatcher call-responder* ( path dispatcher -- response ) dup tangle>> [ diff --git a/extra/validators/validators-tests.factor b/extra/validators/validators-tests.factor index 6ed0e0363a..a981f782d3 100644 --- a/extra/validators/validators-tests.factor +++ b/extra/validators/validators-tests.factor @@ -1,8 +1,28 @@ IN: validators.tests -USING: kernel sequences tools.test validators accessors ; +USING: kernel sequences tools.test validators accessors +namespaces assocs ; + +: with-validation ( quot -- messages ) + [ + init-validation + call + validation-messages get + named-validation-messages get >alist append + ] with-scope ; inline + +[ "" v-one-line ] must-fail +[ "hello world" ] [ "hello world" v-one-line ] unit-test +[ "hello\nworld" v-one-line ] must-fail + +[ "" v-one-word ] must-fail +[ "hello" ] [ "hello" v-one-word ] unit-test +[ "hello world" v-one-word ] must-fail [ "foo" v-number ] must-fail [ 123 ] [ "123" v-number ] unit-test +[ 123 ] [ "123" v-integer ] unit-test + +[ "1.0" v-integer ] [ "must be an integer" = ] must-fail-with [ "slava@factorcode.org" ] [ "slava@factorcode.org" v-email @@ -29,13 +49,13 @@ USING: kernel sequences tools.test validators accessors ; [ 14 V{ } ] [ [ - "14" "age" [ drop v-number 13 v-min-value 100 v-max-value ] validate + "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate ] with-validation ] unit-test [ f t ] [ [ - "140" "age" [ drop v-number 13 v-min-value 100 v-max-value ] validate + "140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate ] with-validation first [ first "age" = ] [ second validation-error? ] @@ -46,25 +66,38 @@ USING: kernel sequences tools.test validators accessors ; TUPLE: person name age ; person { - { "name" [ v-required ] } + { "name" [ ] } { "age" [ v-number 13 v-min-value 100 v-max-value ] } } define-validators -[ 14 V{ } ] [ - [ - person new dup - { { "age" "14" } } - deposit-slots - age>> - ] with-validation -] unit-test - -[ t ] [ +[ t t ] [ [ { { "age" "" } } required-values + validation-failed? ] with-validation first [ first "age" = ] [ second validation-error? ] [ second message>> "required" = ] tri and and ] unit-test + +[ H{ { "a" 123 } } f V{ } ] [ + [ + H{ + { "a" "123" } + { "b" "c" } + { "c" "d" } + } + H{ + { "a" [ v-integer ] } + } validate-values + validation-failed? + ] with-validation +] unit-test + +[ t "foo" ] [ + [ + "foo" validation-error + validation-failed? + ] with-validation first message>> +] unit-test diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor index b03cc76444..2dcc2c04f9 100644 --- a/extra/validators/validators.factor +++ b/extra/validators/validators.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations sequences math namespaces sets math.parser assocs regexp fry unicode.categories sequences -arrays hashtables words combinators mirrors classes quotations ; +arrays hashtables words combinators mirrors classes quotations +xmode.catalog ; IN: validators : v-default ( str def -- str ) @@ -33,8 +34,8 @@ IN: validators : v-number ( str -- n ) dup string>number [ ] [ "must be a number" throw ] ?if ; -: v-integer ( n -- n ) - dup integer? [ "must be an integer" throw ] unless ; +: v-integer ( str -- n ) + v-number dup integer? [ "must be an integer" throw ] unless ; : v-min-value ( x n -- x ) 2dup < [ @@ -70,25 +71,38 @@ IN: validators dup empty? [ "must remain blank" throw ] unless ; : v-one-line ( str -- str ) + v-required dup "\r\n" intersect empty? [ "must be a single line" throw ] unless ; : v-one-word ( str -- str ) + v-required dup [ alpha? ] all? [ "must be a single word" throw ] unless ; -SYMBOL: validation-messages +: v-username ( str -- str ) + 2 v-min-length 16 v-max-length v-one-word ; -: with-validation ( quot -- messages ) - V{ } clone [ - validation-messages rot with-variable - ] keep ; inline +: v-password ( str -- str ) + 6 v-min-length 40 v-max-length v-one-line ; + +: v-mode ( str -- str ) + dup mode-names member? [ + "not a valid syntax mode" throw + ] unless ; + +SYMBOL: validation-messages +SYMBOL: named-validation-messages + +: init-validation ( -- ) + V{ } clone validation-messages set + H{ } clone named-validation-messages set ; : (validation-message) ( obj -- ) validation-messages get push ; : (validation-message-for) ( obj name -- ) - swap 2array (validation-message) ; + named-validation-messages get set-at ; TUPLE: validation-message message ; @@ -100,39 +114,29 @@ C: validation-message : validation-message-for ( string name -- ) [ ] dip (validation-message-for) ; -TUPLE: validation-error value message ; +TUPLE: validation-error message value ; C: validation-error -: validation-error ( reason -- ) +: validation-error ( message -- ) f (validation-message) ; -: validation-error-for ( reason value name -- ) +: validation-error-for ( message value name -- ) [ ] dip (validation-message-for) ; : validation-failed? ( -- ? ) - validation-messages get [ - dup pair? [ second ] when validation-error? - ] contains? ; + validation-messages get [ validation-error? ] contains? + named-validation-messages get [ nip validation-error? ] assoc-contains? + or ; : define-validators ( class validators -- ) >hashtable "validators" set-word-prop ; : validate ( value name quot -- result ) - [ swap validation-error-for f ] recover ; inline - -: validate-value ( value name validators -- result ) - '[ , at call ] validate ; + '[ drop @ ] [ -rot validation-error-for f ] recover ; inline : required-values ( assoc -- ) - [ swap [ drop v-required ] validate drop ] assoc-each ; + [ swap [ v-required ] validate drop ] assoc-each ; : validate-values ( assoc validators -- assoc' ) - '[ over , validate-value ] assoc-map ; - -: deposit-values ( destination assoc validators -- ) - validate-values update ; - -: deposit-slots ( tuple assoc -- ) - [ [ ] [ class "validators" word-prop ] bi ] dip - swap deposit-values ; + swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ; diff --git a/extra/webapps/counter/counter.fhtml b/extra/webapps/counter/counter.fhtml deleted file mode 100644 index 521096f105..0000000000 --- a/extra/webapps/counter/counter.fhtml +++ /dev/null @@ -1,10 +0,0 @@ -<% USING: io math.parser http.server.sessions webapps.counter ; %> - - - -

<% count sget number>string write %>

- - ++ - -- - - diff --git a/extra/webapps/pastebin/annotation.xml b/extra/webapps/pastebin/annotation.xml deleted file mode 100644 index d5b4ea8d3a..0000000000 --- a/extra/webapps/pastebin/annotation.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - -

Annotation:

- - - - - -
Author:
Mode:
Date:
- -
- - Delete Annotation - - diff --git a/extra/webapps/pastebin/new-annotation.xml b/extra/webapps/pastebin/new-annotation.xml deleted file mode 100644 index 5d18860977..0000000000 --- a/extra/webapps/pastebin/new-annotation.xml +++ /dev/null @@ -1,24 +0,0 @@ - - - - - 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/paste-summary.xml b/extra/webapps/pastebin/paste-summary.xml deleted file mode 100644 index c751b110c0..0000000000 --- a/extra/webapps/pastebin/paste-summary.xml +++ /dev/null @@ -1,11 +0,0 @@ - - - - - - - - - - - diff --git a/extra/webapps/planet/blog-admin-link.xml b/extra/webapps/planet/blog-admin-link.xml deleted file mode 100644 index 8d6c890643..0000000000 --- a/extra/webapps/planet/blog-admin-link.xml +++ /dev/null @@ -1,7 +0,0 @@ - - - - - - - diff --git a/extra/webapps/todo/todo-summary.xml b/extra/webapps/todo/todo-summary.xml deleted file mode 100644 index 056c9cab0a..0000000000 --- a/extra/webapps/todo/todo-summary.xml +++ /dev/null @@ -1,20 +0,0 @@ - - - - - - - - - - - - - View - - - Edit - - - -