basis/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.redirection\r
  11 furnace.conversations\r
  12 html.forms\r
  13 html.elements\r
  14 html.components\r
  15 html.components\r
  16 html.templates.chloe\r
  17 html.templates.chloe.syntax\r
  18 html.templates.chloe.compiler ;\r
  19 IN: furnace.actions\r
  20 \r
  21 SYMBOL: params\r
  22 \r
  23 SYMBOL: rest\r
  24 \r
  25 : render-validation-messages ( -- )\r
  26     form get errors>>\r
  27     [\r
  28         <ul "errors" =class ul>\r
  29             [ <li> escape-string write </li> ] each\r
  30         </ul>\r
  31     ] unless-empty ;\r
  32 \r
  33 CHLOE: validation-messages\r
  34     drop [ render-validation-messages ] [code] ;\r
  35 \r
  36 TUPLE: action rest authorize init display validate submit ;\r
  37 \r
  38 : new-action ( class -- action )\r
  39     new [ ] >>init [ ] >>validate [ ] >>authorize ; inline\r
  40 \r
  41 : <action> ( -- action )\r
  42     action new-action ;\r
  43 \r
  44 : merge-forms ( form -- )\r
  45     form get\r
  46     [ [ errors>> ] bi@ push-all ]\r
  47     [ [ values>> ] bi@ swap update ]\r
  48     [ swap validation-failed>> >>validation-failed drop ]\r
  49     2tri ;\r
  50 \r
  51 : set-nested-form ( form name -- )\r
  52     [\r
  53         merge-forms\r
  54     ] [\r
  55         unclip [ set-nested-form ] nest-form\r
  56     ] if-empty ;\r
  57 \r
  58 : restore-validation-errors ( -- )\r
  59     form cget [\r
  60         nested-forms cget set-nested-form\r
  61     ] when* ;\r
  62 \r
  63 : handle-get ( action -- response )\r
  64     '[\r
  65         _ dup display>> [\r
  66             {\r
  67                 [ init>> call ]\r
  68                 [ authorize>> call ]\r
  69                 [ drop restore-validation-errors ]\r
  70                 [ display>> call ]\r
  71             } cleave\r
  72         ] [ drop <400> ] if\r
  73     ] with-exit-continuation ;\r
  74 \r
  75 : param ( name -- value )\r
  76     params get at ;\r
  77 \r
  78 : revalidate-url-key "__u" ;\r
  79 \r
  80 : revalidate-url ( -- url/f )\r
  81     revalidate-url-key param\r
  82     dup [ >url ensure-port [ same-host? ] keep and ] when ;\r
  83 \r
  84 : validation-failed ( -- * )\r
  85     post-request? revalidate-url and [\r
  86         begin-conversation\r
  87         nested-forms-key param " " split harvest nested-forms cset\r
  88         form get form cset\r
  89         <continue-conversation>\r
  90     ] [ <400> ] if*\r
  91     exit-with ;\r
  92 \r
  93 : handle-post ( action -- response )\r
  94     '[\r
  95         _ dup submit>> [\r
  96             [ validate>> call ]\r
  97             [ authorize>> call ]\r
  98             [ submit>> call ]\r
  99             tri\r
 100         ] [ drop <400> ] if\r
 101     ] with-exit-continuation ;\r
 102 \r
 103 : handle-rest ( path action -- assoc )\r
 104     rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
 105 \r
 106 : init-action ( path action -- )\r
 107     begin-form\r
 108     handle-rest\r
 109     request get request-params assoc-union params set ;\r
 110 \r
 111 M: action call-responder* ( path action -- response )\r
 112     [ init-action ] keep\r
 113     request get method>> {\r
 114         { "GET" [ handle-get ] }\r
 115         { "HEAD" [ handle-get ] }\r
 116         { "POST" [ handle-post ] }\r
 117     } case ;\r
 118 \r
 119 M: action modify-form\r
 120     drop url get revalidate-url-key hidden-form-field ;\r
 121 \r
 122 : check-validation ( -- )\r
 123     validation-failed? [ validation-failed ] when ;\r
 124 \r
 125 : validate-params ( validators -- )\r
 126     params get swap validate-values check-validation ;\r
 127 \r
 128 : validate-integer-id ( -- )\r
 129     { { "id" [ v-number ] } } validate-params ;\r
 130 \r
 131 TUPLE: page-action < action template ;\r
 132 \r
 133 : <chloe-content> ( path -- response )\r
 134     resolve-template-path <chloe> "text/html" <content> ;\r
 135 \r
 136 : <page-action> ( -- page )\r
 137     page-action new-action\r
 138         dup '[ _ template>> <chloe-content> ] >>display ;\r