--- /dev/null
+<% USING: namespaces math io ; %>
+
+<h1>Annotate</h1>
+
+<form method="POST" action="/responder/pastebin/annotate-paste">
+
+<table>
+
+<input type="hidden" name="n" value="<% "n" get number>string write %>" />
+
+<tr>
+<th>Summary:</th>
+<td><input type="TEXT" name="summary" value="" /></td>
+</tr>
+
+<tr>
+<th>Your name:</th>
+<td><input type="TEXT" name="author" value="" /></td>
+</tr>
+
+<tr>
+<th valign="top">Contents:</th>
+<td><textarea rows="24" cols="60" name="contents"></textarea></td>
+</tr>
+</table>
+
+<input type="SUBMIT" value="Annotate" />
+</form>
--- /dev/null
+<% USING: namespaces io ; %>
+
+<h2>Annotation: <% "summary" get write %></h2>
+
+<table>
+<tr><th>Annotation by:</th><td><% "author" get write %></td></tr>
+<tr><th>Channel:</th><td><% "channel" get write %></td></tr>
+<tr><th>Created:</th><td><% "date" get write %></td></tr>
+</table>
+
+<pre><% "contents" get write %></pre>
<td><input type="TEXT" name="author" value="" /></td>
</tr>
+<tr>
+<th>Channel:</th>
+<td><input type="TEXT" name="channel" value="" /></td>
+</tr>
+
<tr>
<th valign="top">Contents:</th>
<td><textarea rows="24" cols="60" name="contents"></textarea></td>
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 ;
dup pastebin-pastes length pick set-paste-n
pastebin-pastes push ;
-<pastebin> "pastebin" set-global
+<pastebin> 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 -- )
- <paste> "pastebin" get-global add-paste ;
+: submit-paste ( summary author channel contents -- )
+ <paste> 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 ( -- )
[ new-paste ] "new-paste-quot" set
"Pastebin"
- "pastebin" get
+ pastebin get
"paste-list" render-page
] with-scope ;
\ submit-paste [ paste-list ] define-redirect
"pastebin" "paste-list" "contrib/furnace-pastebin" web-app
+
+: annotate-paste ( paste# summary author contents -- )
+ <annotation> 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
-<% USING: namespaces io ; %>
+<% USING: namespaces io furnace sequences ; %>
+
+<h1>Paste: <% "summary" get write %></h1>
<table>
-<tr><th>Summary:</th><td><% "summary" get write %></td></tr>
<tr><th>Paste by:</th><td><% "author" get write %></td></tr>
+<tr><th>Channel:</th><td><% "channel" get write %></td></tr>
<tr><th>Created:</th><td><% "date" get write %></td></tr>
</table>
<pre><% "contents" get write %></pre>
+
+<% "annotations" get [ "annotation" render-template ] each %>
+
+<% model get "annotate-paste" render-template %>
REQUIRES: contrib/httpd ;
PROVIDE: contrib/furnace {
+ "validator.factor"
"responder.factor"
} {
+ "test/validator.factor"
"test/responder.factor"
} ;
+! 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
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 ;
: render-link ( quot name -- )
<a swap quot-link =href a> write </a> ;
+: 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 ] [ <pre> print-error </pre> ] recover
] [
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 ;
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" }
[
H{
{ "bar" "hello" }
- } "query" set
-
- \ foo query>quot
+ } \ foo query>quot
] with-scope
] unit-test
--- /dev/null
+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
--- /dev/null
+! 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 -- * ) <validation-error> 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* ;