More stuff
parent
d589ac19dd
commit
8d8cb11e2a
|
@ -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>> [
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
|
||||||
|
|
|
@ -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>
|
|
|
@ -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>
|
|
|
@ -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>
|
|
|
@ -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>
|
|
|
@ -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>
|
|
|
@ -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>
|
|
Loading…
Reference in New Issue