basis/furnace/actions/actions.factor

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