factor/extra/furnace/furnace.factor

144 lines
3.9 KiB
Factor

! Copyright (C) 2006 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vectors io assocs quotations splitting strings
words sequences namespaces arrays hashtables debugger
continuations tuples classes io.files
http http.server.templating http.basic-authentication
http.server.responders.callback html html.elements
http.server.responders furnace.validator ;
IN: furnace
SYMBOL: default-action
SYMBOL: template-path
: define-authenticated-action ( word params realm -- )
pick swap "action-realm" set-word-prop
over t "action" set-word-prop
"action-params" set-word-prop ;
: define-action ( word params -- )
f define-authenticated-action ;
: define-redirect ( word quot -- )
"action-redirect" set-word-prop ;
: responder-vocab ( name -- vocab )
"webapps." swap append ;
: lookup-action ( name webapp -- word )
responder-vocab lookup dup [
dup "action" word-prop [ drop f ] unless
] when ;
: truncate-url ( url -- action-name )
CHAR: / over index [ head ] when* ;
: current-action ( url -- word/f )
dup empty? [ drop default-action get ] when
truncate-url "responder" get lookup-action ;
PREDICATE: word action "action" word-prop ;
: quot>query ( seq action -- hash )
>r >array r> "action-params" word-prop
[ first swap 2array ] 2map >hashtable ;
: action-link ( query action -- url )
[
"/responder/" %
dup word-vocabulary "webapps." ?head drop %
"/" %
word-name %
] "" make swap build-url ;
: action-call? ( quot -- ? )
>vector dup pop action? >r [ word? not ] all? r> and ;
: unclip* dup 1 head* swap peek ;
: quot-link ( quot -- url )
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 at swap >quotation apply-validators ;
: query>quot ( params action -- seq )
"action-params" word-prop [ action-param drop ] curry* map ;
SYMBOL: request-params
: perform-redirect ( action -- )
"action-redirect" word-prop
[ dup string? [ request-params get at ] when ] map
[ quot-link permanent-redirect ] when* ;
: (call-action) ( params action -- )
over request-params set
[ query>quot ] keep [ add >quotation call ] keep
perform-redirect ;
: call-action ( params action -- )
dup "action-realm" word-prop [
[ (call-action) ] with-basic-authentication
] [ (call-action) ] if* ;
: service-request ( params url -- )
current-action [
[ call-action ] [ <pre> print-error </pre> ] recover
] [
"404 no such action: " "argument" get append httpd-error
] if* ;
: service-get ( url -- ) "query" get swap service-request ;
: service-post ( url -- ) "response" get swap service-request ;
: explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ;
SYMBOL: model
: call-template ( model template -- )
[
>r [ dup model set explode-tuple ] when* r>
".furnace" append resource-path run-template-file
] with-scope ;
: render-template ( model template -- )
template-path get swap path+ call-template ;
: render-page* ( model body-template head-template -- )
[
[ render-template ] [ f rot render-template ] html-document*
] serve-html ;
: render-titled-page* ( model body-template head-template title -- )
[
[ render-template ] swap [ <title> write </title> f rot render-template ] curry html-document*
] serve-html ;
: render-page ( model template title -- )
[
[ render-template ] html-document
] serve-html ;
: web-app ( name default path -- )
[
template-path set
default-action set
"responder" set
[ service-get ] "get" set
[ service-post ] "post" set
! [ service-head ] "head" set
] make-responder ;