More stuff

db4
Slava Pestov 2008-05-26 00:48:02 -05:00
parent d589ac19dd
commit 8d8cb11e2a
9 changed files with 83 additions and 141 deletions

View File

@ -19,11 +19,8 @@ C: <tangle> tangle
: with-tangle ( tangle quot -- ) : with-tangle ( tangle quot -- )
[ [ db>> ] [ seq>> ] bi ] dip with-db ; [ [ db>> ] [ seq>> ] bi ] dip with-db ;
: <text-response> ( text -- response )
"text/plain" <content> swap >>body ;
: node-response ( id -- response ) : node-response ( id -- response )
load-node [ node-content <text-response> ] [ <404> ] if* ; load-node [ node-content <text-content> ] [ <404> ] if* ;
: display-node ( params -- response ) : display-node ( params -- response )
[ [
@ -39,7 +36,7 @@ C: <tangle> tangle
: submit-node ( params -- response ) : submit-node ( params -- response )
[ [
"node_content" swap at* [ "node_content" swap at* [
create-node id>> number>string <text-response> create-node id>> number>string <text-content>
] [ ] [
drop <400> drop <400>
] if ] if
@ -55,10 +52,7 @@ TUPLE: path-responder ;
C: <path-responder> path-responder C: <path-responder> path-responder
M: path-responder call-responder* ( path responder -- response ) M: path-responder call-responder* ( path responder -- response )
drop path>file [ node-content <text-response> ] [ <404> ] if* ; drop path>file [ node-content <text-content> ] [ <404> ] if* ;
: <json-response> ( obj -- response )
"application/json" <content> swap >json >>body ;
TUPLE: tangle-dispatcher < dispatcher tangle ; TUPLE: tangle-dispatcher < dispatcher tangle ;
@ -67,7 +61,7 @@ TUPLE: tangle-dispatcher < dispatcher tangle ;
<path-responder> >>default <path-responder> >>default
"resource:extra/tangle/resources" <static> "resources" add-responder "resource:extra/tangle/resources" <static> "resources" add-responder
<node-responder> "node" add-responder <node-responder> "node" add-responder
<action> [ all-node-ids <json-response> ] >>display "all" add-responder ; <action> [ all-node-ids <json-content> ] >>display "all" add-responder ;
M: tangle-dispatcher call-responder* ( path dispatcher -- response ) M: tangle-dispatcher call-responder* ( path dispatcher -- response )
dup tangle>> [ dup tangle>> [

View File

@ -1,8 +1,28 @@
IN: validators.tests 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 [ "foo" v-number ] must-fail
[ 123 ] [ "123" v-number ] unit-test [ 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" ] [
"slava@factorcode.org" v-email "slava@factorcode.org" v-email
@ -29,13 +49,13 @@ USING: kernel sequences tools.test validators accessors ;
[ 14 V{ } ] [ [ 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 ] with-validation
] unit-test ] unit-test
[ f t ] [ [ 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 ] with-validation first
[ first "age" = ] [ first "age" = ]
[ second validation-error? ] [ second validation-error? ]
@ -46,25 +66,38 @@ USING: kernel sequences tools.test validators accessors ;
TUPLE: person name age ; TUPLE: person name age ;
person { person {
{ "name" [ v-required ] } { "name" [ ] }
{ "age" [ v-number 13 v-min-value 100 v-max-value ] } { "age" [ v-number 13 v-min-value 100 v-max-value ] }
} define-validators } define-validators
[ 14 V{ } ] [ [ t t ] [
[
person new dup
{ { "age" "14" } }
deposit-slots
age>>
] with-validation
] unit-test
[ t ] [
[ [
{ { "age" "" } } required-values { { "age" "" } } required-values
validation-failed?
] with-validation first ] with-validation first
[ first "age" = ] [ first "age" = ]
[ second validation-error? ] [ second validation-error? ]
[ second message>> "required" = ] [ second message>> "required" = ]
tri and and tri and and
] unit-test ] 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

View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces sets USING: kernel continuations sequences math namespaces sets
math.parser assocs regexp fry unicode.categories sequences 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 IN: validators
: v-default ( str def -- str ) : v-default ( str def -- str )
@ -33,8 +34,8 @@ IN: validators
: v-number ( str -- n ) : v-number ( str -- n )
dup string>number [ ] [ "must be a number" throw ] ?if ; dup string>number [ ] [ "must be a number" throw ] ?if ;
: v-integer ( n -- n ) : v-integer ( str -- n )
dup integer? [ "must be an integer" throw ] unless ; v-number dup integer? [ "must be an integer" throw ] unless ;
: v-min-value ( x n -- x ) : v-min-value ( x n -- x )
2dup < [ 2dup < [
@ -70,25 +71,38 @@ IN: validators
dup empty? [ "must remain blank" throw ] unless ; dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str ) : v-one-line ( str -- str )
v-required
dup "\r\n" intersect empty? dup "\r\n" intersect empty?
[ "must be a single line" throw ] unless ; [ "must be a single line" throw ] unless ;
: v-one-word ( str -- str ) : v-one-word ( str -- str )
v-required
dup [ alpha? ] all? dup [ alpha? ] all?
[ "must be a single word" throw ] unless ; [ "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-password ( str -- str )
V{ } clone [ 6 v-min-length 40 v-max-length v-one-line ;
validation-messages rot with-variable
] keep ; inline : 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-message) ( obj -- )
validation-messages get push ; validation-messages get push ;
: (validation-message-for) ( obj name -- ) : (validation-message-for) ( obj name -- )
swap 2array (validation-message) ; named-validation-messages get set-at ;
TUPLE: validation-message message ; TUPLE: validation-message message ;
@ -100,39 +114,29 @@ C: <validation-message> validation-message
: validation-message-for ( string name -- ) : validation-message-for ( string name -- )
[ <validation-message> ] dip (validation-message-for) ; [ <validation-message> ] dip (validation-message-for) ;
TUPLE: validation-error value message ; TUPLE: validation-error message value ;
C: <validation-error> validation-error C: <validation-error> validation-error
: validation-error ( reason -- ) : validation-error ( message -- )
f <validation-error> (validation-message) ; f <validation-error> (validation-message) ;
: validation-error-for ( reason value name -- ) : validation-error-for ( message value name -- )
[ <validation-error> ] dip (validation-message-for) ; [ <validation-error> ] dip (validation-message-for) ;
: validation-failed? ( -- ? ) : validation-failed? ( -- ? )
validation-messages get [ validation-messages get [ validation-error? ] contains?
dup pair? [ second ] when validation-error? named-validation-messages get [ nip validation-error? ] assoc-contains?
] contains? ; or ;
: define-validators ( class validators -- ) : define-validators ( class validators -- )
>hashtable "validators" set-word-prop ; >hashtable "validators" set-word-prop ;
: validate ( value name quot -- result ) : validate ( value name quot -- result )
[ swap validation-error-for f ] recover ; inline '[ drop @ ] [ -rot validation-error-for f ] recover ; inline
: validate-value ( value name validators -- result )
'[ , at call ] validate ;
: required-values ( assoc -- ) : required-values ( assoc -- )
[ swap [ drop v-required ] validate drop ] assoc-each ; [ swap [ v-required ] validate drop ] assoc-each ;
: validate-values ( assoc validators -- assoc' ) : validate-values ( assoc validators -- assoc' )
'[ over , validate-value ] assoc-map ; swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ;
: deposit-values ( destination assoc validators -- )
validate-values update ;
: deposit-slots ( tuple assoc -- )
[ [ <mirror> ] [ class "validators" word-prop ] bi ] dip
swap deposit-values ;

View File

@ -1,10 +0,0 @@
<% USING: io math.parser http.server.sessions webapps.counter ; %>
<html>
<body>
<h1><% count sget number>string write %></h1>
<a href="inc">++</a>
<a href="dec">--</a>
</body>
</html>

View File

@ -1,17 +0,0 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2>Annotation: <t:view t:component="summary" /></h2>
<table>
<tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:view t:component="mode" /></td></tr>
<tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
</table>
<pre class="description"><t:view t:component="contents" /></pre>
<t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
</t:chloe>

View File

@ -1,24 +0,0 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>New Annotation</t:title>
<t:form t:action="$pastebin/annotate" t:for="id">
<table>
<tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
<tr><th class="field-label">Author: </th><td><t:edit t:component="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:edit t:component="mode" /></td></tr>
<tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="contents" /></td></tr>
<tr><th class="field-label">Captcha: </th><td><t:edit t:component="captcha" /></td></tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
</tr>
</table>
<input type="SUBMIT" value="Done" />
</t:form>
</t:chloe>

View File

@ -1,11 +0,0 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<tr>
<td><t:a t:href="$pastebin/view-paste" t:query="id"><t:view t:component="summary" /></t:a></td>
<td><t:view t:component="author" /></td>
<td><t:view t:component="date" /></td>
</tr>
</t:chloe>

View File

@ -1,7 +0,0 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:a t:href="$planet-factor/admin/edit-blog" t:query="id"><t:view t:component="name" /></t:a>
</t:chloe>

View File

@ -1,20 +0,0 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<tr>
<td>
<t:view t:component="summary" />
</td>
<td>
<t:view t:component="priority" />
</td>
<td>
<t:a t:href="$todo-list/view" t:query="id">View</t:a>
</td>
<td>
<t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
</td>
</tr>
</t:chloe>