contrib/furnace/responder.factor

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