basis/furnace/actions/actions.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators fry furnace.conversations
   4 furnace.utilities html.forms html.templates.chloe http
   5 http.server http.server.responses kernel namespaces sequences
   6 splitting urls validators ;
   7 IN: furnace.actions
   8
   9 SYMBOL: rest
  10
  11 TUPLE: action rest init authorize display validate submit update replace ;
  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? revalidate-url and [
  58         begin-conversation
  59         nested-forms-key param " " split harvest nested-forms cset
  60         form get form cset
  61         <continue-conversation>
  62     ] [ <400> ] if*
  63     exit-with ;
  64
  65 : handle-post ( action -- response )
  66     '[
  67         _ dup submit>> [
  68             [ validate>> call( -- ) ]
  69             [ authorize>> call( -- ) ]
  70             [ submit>> call( -- response ) ]
  71             tri
  72         ] [ drop <400> ] if
  73     ] with-exit-continuation ;
  74
  75 : handle-put ( action -- response )
  76     '[
  77         _ dup submit>> [
  78             [ validate>> call( -- ) ]
  79             [ authorize>> call( -- ) ]
  80             [ replace>> call( -- response ) ]
  81             tri
  82         ] [ drop <400> ] if
  83     ] with-exit-continuation ;
  84
  85 : handle-patch ( action -- response )
  86     '[
  87         _ dup submit>> [
  88             [ validate>> call( -- ) ]
  89             [ authorize>> call( -- ) ]
  90             [ update>> call( -- response ) ]
  91             tri
  92         ] [ drop <400> ] if
  93     ] with-exit-continuation ;
  94
  95 : handle-rest ( path action -- )
  96     rest>> [ [ "/" join ] dip set-param ] [ drop ] if* ;
  97
  98 : init-action ( path action -- )
  99     begin-form
 100     handle-rest ;
 101
 102 M: action call-responder* ( path action -- response )
 103     [ init-action ] keep
 104     request get method>> {
 105         { "GET"   [ handle-get ] }
 106         { "HEAD"  [ handle-get ] }
 107         { "POST"  [ handle-post ] }
 108         { "PUT"   [ handle-put ] }
 109         { "PATCH" [ handle-patch ] }
 110         [ 2drop <405> ]
 111     } case ;
 112
 113 M: action modify-form
 114     drop url get revalidate-url-key hidden-form-field ;
 115
 116 : check-validation ( -- )
 117     validation-failed? [ validation-failed ] when ;
 118
 119 : validate-params ( validators -- )
 120     params get swap validate-values check-validation ;
 121
 122 : validate-integer-id ( -- )
 123     { { "id" [ v-number ] } } validate-params ;
 124
 125 TUPLE: page-action < action template ;
 126
 127 : <chloe-content> ( path -- response )
 128     resolve-template-path <chloe> <html-content> ;
 129
 130 : <page-action> ( -- page )
 131     page-action new-action
 132         dup '[ _ template>> <chloe-content> ] >>display ;