basis/furnace/actions/actions.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators furnace.conversations furnace.utilities
   4 html.forms http http.server http.server.responses kernel namespaces sequences
   5 splitting urls validators ;
   6 FROM: html.templates.chloe => <chloe> ;
   7 IN: furnace.actions
   8
   9 SYMBOL: rest
  10
  11 TUPLE: action rest init authorize display validate submit update replace delete ;
  12
  13 : new-action ( class -- action )
  14     new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
  15
  16 : <action> ( -- action )
  17     action new-action ;
  18
  19 : merge-forms ( form -- )
  20     [ form get ] dip
  21     [ [ errors>> ] bi@ append! drop ]
  22     [ [ values>> ] bi@ assoc-union! drop ]
  23     [ validation-failed>> >>validation-failed drop ]
  24     2tri ;
  25
  26 : set-nested-form ( form name -- )
  27     [
  28         merge-forms
  29     ] [
  30         unclip [ set-nested-form ] nest-form
  31     ] if-empty ;
  32
  33 : restore-validation-errors ( -- )
  34     form cget [
  35         nested-forms cget set-nested-form
  36     ] when* ;
  37
  38 : handle-get ( action -- response )
  39     '[
  40         _ dup display>> [
  41             {
  42                 [ init>> call( -- ) ]
  43                 [ authorize>> call( -- ) ]
  44                 [ drop restore-validation-errors ]
  45                 [ display>> call( -- response ) ]
  46             } cleave
  47         ] [ drop <400> ] if
  48     ] with-exit-continuation ;
  49
  50 CONSTANT: revalidate-url-key "__u"
  51
  52 : revalidate-url ( -- url/f )
  53     revalidate-url-key param
  54     dup [ >url ensure-port [ same-host? ] keep and ] when ;
  55
  56 : validation-failed ( -- * )
  57     post-request? "DELETE" method= or
  58     revalidate-url and [
  59         begin-conversation
  60         nested-forms-key param split-words harvest nested-forms cset
  61         form get form cset
  62         <continue-conversation>
  63     ] [ <400> ] if*
  64     exit-with ;
  65
  66 : handle-post ( action -- response )
  67     '[
  68         _ dup submit>> [
  69             [ validate>> call( -- ) ]
  70             [ authorize>> call( -- ) ]
  71             [ submit>> call( -- response ) ]
  72             tri
  73         ] [ drop <400> ] if
  74     ] with-exit-continuation ;
  75
  76 : handle-put ( action -- response )
  77     '[
  78         _ dup submit>> [
  79             [ validate>> call( -- ) ]
  80             [ authorize>> call( -- ) ]
  81             [ replace>> call( -- response ) ]
  82             tri
  83         ] [ drop <400> ] if
  84     ] with-exit-continuation ;
  85
  86 : handle-patch ( action -- response )
  87     '[
  88         _ dup submit>> [
  89             [ validate>> call( -- ) ]
  90             [ authorize>> call( -- ) ]
  91             [ update>> call( -- response ) ]
  92             tri
  93         ] [ drop <400> ] if
  94     ] with-exit-continuation ;
  95
  96 : handle-delete ( action -- response )
  97     '[
  98         _ dup delete>> [
  99             [ init>> call( -- ) ]
 100             [ authorize>> call( -- ) ]
 101             [ delete>> call( -- response ) ]
 102             tri
 103         ] [ drop <400> ] if
 104     ] with-exit-continuation ;
 105
 106 : handle-rest ( path action -- )
 107     rest>> [ [ "/" join ] dip set-param ] [ drop ] if* ;
 108
 109 : init-action ( path action -- )
 110     begin-form
 111     handle-rest ;
 112
 113 M: action call-responder*
 114     [ init-action ] keep
 115     request get method>> {
 116         { "GET"   [ handle-get ] }
 117         { "HEAD"  [ handle-get ] }
 118         { "POST"  [ handle-post ] }
 119         { "PUT"   [ handle-put ] }
 120         { "PATCH" [ handle-patch ] }
 121         { "DELETE" [ handle-delete ] }
 122         [ 2drop <405> ]
 123     } case ;
 124
 125 M: action modify-form
 126     drop url get revalidate-url-key hidden-form-field ;
 127
 128 : check-validation ( -- )
 129     validation-failed? [ validation-failed ] when ;
 130
 131 : validate-params ( validators -- )
 132     params get swap validate-values check-validation ;
 133
 134 : validate-integer-id ( -- )
 135     { { "id" [ v-number ] } } validate-params ;
 136
 137 TUPLE: page-action < action template ;
 138
 139 : <chloe-content> ( path -- response )
 140     resolve-template-path <chloe> <html-content> ;
 141
 142 : <page-action> ( -- page )
 143     page-action new-action
 144         dup '[ _ template>> <chloe-content> ] >>display ;