extra/furnace/actions/actions.factor

   1 ! Copyright (C) 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: accessors sequences kernel assocs combinators\r
   4 validators http hashtables namespaces fry continuations locals\r
   5 io arrays math boxes splitting urls\r
   6 xml.entities\r
   7 http.server\r
   8 http.server.responses\r
   9 furnace\r
  10 furnace.flash\r
  11 html.forms\r
  12 html.elements\r
  13 html.components\r
  14 html.components\r
  15 html.templates.chloe\r
  16 html.templates.chloe.syntax ;\r
  17 IN: furnace.actions\r
  18 \r
  19 SYMBOL: params\r
  20 \r
  21 SYMBOL: rest\r
  22 \r
  23 : render-validation-messages ( -- )\r
  24     form get errors>>\r
  25     dup empty? [ drop ] [\r
  26         <ul "errors" =class ul>\r
  27             [ <li> escape-string write </li> ] each\r
  28         </ul>\r
  29     ] if ;\r
  30 \r
  31 CHLOE: validation-messages drop render-validation-messages ;\r
  32 \r
  33 TUPLE: action rest authorize init display validate submit ;\r
  34 \r
  35 : new-action ( class -- action )\r
  36     new [ ] >>init [ ] >>validate [ ] >>authorize ; inline\r
  37 \r
  38 : <action> ( -- action )\r
  39     action new-action ;\r
  40 \r
  41 : set-nested-form ( form name -- )\r
  42     dup empty? [\r
  43         drop form set\r
  44     ] [\r
  45         dup length 1 = [\r
  46             first set-value\r
  47         ] [\r
  48             unclip [ set-nested-form ] nest-form\r
  49         ] if\r
  50     ] if ;\r
  51 \r
  52 : restore-validation-errors ( -- )\r
  53     form fget [\r
  54         nested-forms fget set-nested-form\r
  55     ] when* ;\r
  56 \r
  57 : handle-get ( action -- response )\r
  58     '[\r
  59         , dup display>> [\r
  60             {\r
  61                 [ init>> call ]\r
  62                 [ authorize>> call ]\r
  63                 [ drop restore-validation-errors ]\r
  64                 [ display>> call ]\r
  65             } cleave\r
  66         ] [ drop <400> ] if\r
  67     ] with-exit-continuation ;\r
  68 \r
  69 : param ( name -- value )\r
  70     params get at ;\r
  71 \r
  72 : revalidate-url-key "__u" ;\r
  73 \r
  74 : revalidate-url ( -- url/f )\r
  75     revalidate-url-key param\r
  76     dup [ >url [ same-host? ] keep and ] when ;\r
  77 \r
  78 : validation-failed ( -- * )\r
  79     post-request? revalidate-url and\r
  80     [\r
  81         nested-forms-key param " " split harvest nested-forms set\r
  82         { form nested-forms } <flash-redirect>\r
  83     ] [ <400> ] if*\r
  84     exit-with ;\r
  85 \r
  86 : handle-post ( action -- response )\r
  87     '[\r
  88         , dup submit>> [\r
  89             [ validate>> call ]\r
  90             [ authorize>> call ]\r
  91             [ submit>> call ]\r
  92             tri\r
  93         ] [ drop <400> ] if\r
  94     ] with-exit-continuation ;\r
  95 \r
  96 : handle-rest ( path action -- assoc )\r
  97     rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
  98 \r
  99 : init-action ( path action -- )\r
 100     begin-form\r
 101     handle-rest\r
 102     request get request-params assoc-union params set ;\r
 103 \r
 104 M: action call-responder* ( path action -- response )\r
 105     [ init-action ] keep\r
 106     request get method>> {\r
 107         { "GET" [ handle-get ] }\r
 108         { "HEAD" [ handle-get ] }\r
 109         { "POST" [ handle-post ] }\r
 110     } case ;\r
 111 \r
 112 M: action modify-form\r
 113     drop url get revalidate-url-key hidden-form-field ;\r
 114 \r
 115 : check-validation ( -- )\r
 116     validation-failed? [ validation-failed ] when ;\r
 117 \r
 118 : validate-params ( validators -- )\r
 119     params get swap validate-values check-validation ;\r
 120 \r
 121 : validate-integer-id ( -- )\r
 122     { { "id" [ v-number ] } } validate-params ;\r
 123 \r
 124 TUPLE: page-action < action template ;\r
 125 \r
 126 : <chloe-content> ( path -- response )\r
 127     resolve-template-path <chloe> "text/html" <content> ;\r
 128 \r
 129 : <page-action> ( -- page )\r
 130     page-action new-action\r
 131         dup '[ , template>> <chloe-content> ] >>display ;\r