1 ! Copyright (C) 2006 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: embedded generic arrays namespaces prettyprint io
5 sequences words kernel httpd html errors hashtables http
6 callback-responder vectors strings ;
12 : define-action ( word params -- )
13 over t "action" set-word-prop
14 "action-params" set-word-prop ;
16 : define-redirect ( word quot -- )
17 "action-redirect" set-word-prop ;
19 : responder-vocab ( name -- vocab )
20 "furnace:" swap append ;
22 : lookup-action ( name webapp -- word )
23 responder-vocab lookup dup [
24 dup "action" word-prop [ drop f ] unless
27 : current-action ( url -- word/f )
28 dup empty? [ drop default-action get ] when
29 "responder" get lookup-action ;
31 PREDICATE: word action "action" word-prop ;
33 : quot>query ( seq action -- hash )
34 "action-params" word-prop
35 [ first swap 2array ] 2map alist>hash ;
37 : action-link ( query action -- url )
40 dup word-vocabulary "furnace:" ?head drop %
43 ] "" make swap build-url ;
45 : action-call? ( quot -- ? )
46 >vector dup pop action? >r [ word? not ] all? r> and ;
48 : unclip* dup 1 head* swap peek ;
50 : quot-link ( quot -- url )
52 unclip* [ quot>query ] keep action-link
54 t register-html-callback
57 : render-link ( quot name -- )
58 <a swap quot-link =href a> write </a> ;
60 : action-param ( params paramspec -- obj error/f )
61 unclip rot hash swap >quotation apply-validators ;
63 : query>quot ( params action -- seq )
64 "action-params" word-prop [ action-param drop ] map-with ;
66 SYMBOL: request-params
68 : perform-redirect ( action -- )
69 "action-redirect" word-prop
70 [ dup string? [ request-params get hash ] when ] map
71 [ quot-link redirect ] when* ;
73 : call-action ( params action -- )
74 over request-params set
75 [ query>quot ] keep [ add >quotation call ] keep
78 : service-request ( params url -- )
80 [ call-action ] [ <pre> print-error </pre> ] recover
82 "404 no such action: " "argument" get append httpd-error
85 : service-get ( url -- ) "query" get swap service-request ;
87 : service-post ( url -- ) "response" get swap service-request ;
89 : explode-tuple ( tuple -- )
90 dup tuple-slots swap class "slot-names" word-prop
95 : call-template ( model template -- )
97 >r [ dup model set explode-tuple ] when* r>
98 ".fhtml" append resource-path run-embedded-file
101 : render-template ( model template -- )
102 template-path get swap path+ call-template ;
104 : render-page ( model template title -- )
111 : web-app ( name default path -- )
112 over responder-vocab create-vocab drop
117 [ service-get ] "get" set
118 [ service-post ] "post" set
119 ! [ service-head ] "head" set