contrib/furnace/responder.factor

   1 ! Copyright (C) 2006 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: furnace
   4 USING: embedded generic arrays namespaces prettyprint io
   5 sequences words kernel httpd html errors hashtables http
   6 callback-responder vectors strings ;
   7
   8 SYMBOL: default-action
   9
  10 SYMBOL: template-path
  11
  12 : define-action ( word params -- )
  13     over t "action" set-word-prop
  14     "action-params" set-word-prop ;
  15
  16 : define-redirect ( word quot -- )
  17     "action-redirect" set-word-prop ;
  18
  19 : responder-vocab ( name -- vocab )
  20     "furnace:" swap append ;
  21
  22 : lookup-action ( name webapp -- word )
  23     responder-vocab lookup dup [
  24         dup "action" word-prop [ drop f ] unless
  25     ] when ;
  26
  27 : current-action ( url -- word/f )
  28     dup empty? [ drop default-action get ] when
  29     "responder" get lookup-action ;
  30
  31 PREDICATE: word action "action" word-prop ;
  32
  33 : quot>query ( seq action -- hash )
  34     "action-params" word-prop
  35     [ first swap 2array ] 2map alist>hash ;
  36
  37 : action-link ( query action -- url )
  38     [
  39         "/responder/" %
  40         dup word-vocabulary "furnace:" ?head drop %
  41         "/" %
  42         word-name %
  43     ] "" make swap build-url ;
  44
  45 : action-call? ( quot -- ? )
  46     >vector dup pop action? >r [ word? not ] all? r> and ;
  47
  48 : unclip* dup 1 head* swap peek ;
  49
  50 : quot-link ( quot -- url )
  51     dup action-call? [
  52         unclip* [ quot>query ] keep action-link
  53     ] [
  54         t register-html-callback
  55     ] if ;
  56
  57 : render-link ( quot name -- )
  58     <a swap quot-link =href a> write </a> ;
  59
  60 : action-param ( params paramspec -- obj error/f )
  61     unclip rot hash swap >quotation apply-validators ;
  62
  63 : query>quot ( params action -- seq )
  64     "action-params" word-prop [ action-param drop ] map-with ;
  65
  66 SYMBOL: request-params
  67
  68 : perform-redirect ( action -- )
  69     "action-redirect" word-prop
  70     [ dup string? [ request-params get hash ] when ] map
  71     [ quot-link redirect ] when* ;
  72
  73 : call-action ( params action -- )
  74     over request-params set
  75     [ query>quot ] keep [ add >quotation call ] keep
  76     perform-redirect ;
  77
  78 : service-request ( params url -- )
  79     current-action [
  80         [ call-action ] [ <pre> print-error </pre> ] recover
  81     ] [
  82         "404 no such action: " "argument" get append httpd-error
  83     ] if* ;
  84
  85 : service-get ( url -- ) "query" get swap service-request ;
  86
  87 : service-post ( url -- ) "response" get swap service-request ;
  88
  89 : explode-tuple ( tuple -- )
  90     dup tuple>array 2 tail swap class "slot-names" word-prop
  91     [ set ] 2each ;
  92
  93 SYMBOL: model
  94
  95 : call-template ( model template -- )
  96     [
  97         >r [ dup model set explode-tuple ] when* r>
  98         ".fhtml" append resource-path run-embedded-file
  99     ] with-scope ;
 100
 101 TUPLE: component model template ;
 102
 103 TUPLE: page title root ;
 104
 105 C: page ( title model template -- page )
 106     [ >r <component> r> set-page-root ] keep
 107     [ set-page-title ] keep ;
 108
 109 : render-template ( model template -- )
 110     template-path get swap path+ call-template ;
 111
 112 : render-page ( title model template -- )
 113     [
 114         rot [
 115             render-template
 116         ] html-document
 117     ] with-html-stream ;
 118
 119 : web-app ( name default path -- )
 120     over responder-vocab create-vocab drop
 121     [
 122         template-path set
 123         default-action set
 124         "responder" set
 125         [ service-get ] "get" set
 126         [ service-post ] "post" set
 127         ! [ service-head ] "head" set
 128     ] make-responder ;