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 http http.server
   5 http.server.responses kernel namespaces sequences splitting urls
   6 validators ;
   7 FROM: html.templates.chloe => <chloe> ;
   8 IN: furnace.actions
   9
  10 SYMBOL: rest
  11
  12 TUPLE: action rest init authorize display validate submit update replace ;
  13
  14 : new-action ( class -- action )
  15     new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
  16
  17 : <action> ( -- action )
  18     action new-action ;
  19
  20 : merge-forms ( form -- )
  21     [ form get ] dip
  22     [ [ errors>> ] bi@ append! drop ]
  23     [ [ values>> ] bi@ assoc-union! drop ]
  24     [ validation-failed>> >>validation-failed drop ]
  25     2tri ;
  26
  27 : set-nested-form ( form name -- )
  28     [
  29         merge-forms
  30     ] [
  31         unclip [ set-nested-form ] nest-form
  32     ] if-empty ;
  33
  34 : restore-validation-errors ( -- )
  35     form cget [
  36         nested-forms cget set-nested-form
  37     ] when* ;
  38
  39 : handle-get ( action -- response )
  40     '[
  41         _ dup display>> [
  42             {
  43                 [ init>> call( -- ) ]
  44                 [ authorize>> call( -- ) ]
  45                 [ drop restore-validation-errors ]
  46                 [ display>> call( -- response ) ]
  47             } cleave
  48         ] [ drop <400> ] if
  49     ] with-exit-continuation ;
  50
  51 CONSTANT: revalidate-url-key "__u"
  52
  53 : revalidate-url ( -- url/f )
  54     revalidate-url-key param
  55     dup [ >url ensure-port [ same-host? ] keep and ] when ;
  56
  57 : validation-failed ( -- * )
  58     post-request? revalidate-url and [
  59         begin-conversation
  60         nested-forms-key param " " split 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-rest ( path action -- )
  97     rest>> [ [ "/" join ] dip set-param ] [ drop ] if* ;
  98
  99 : init-action ( path action -- )
 100     begin-form
 101     handle-rest ;
 102
 103 M: action call-responder*
 104     [ init-action ] keep
 105     request get method>> {
 106         { "GET"   [ handle-get ] }
 107         { "HEAD"  [ handle-get ] }
 108         { "POST"  [ handle-post ] }
 109         { "PUT"   [ handle-put ] }
 110         { "PATCH" [ handle-patch ] }
 111         [ 2drop <405> ]
 112     } case ;
 113
 114 M: action modify-form
 115     drop url get revalidate-url-key hidden-form-field ;
 116
 117 : check-validation ( -- )
 118     validation-failed? [ validation-failed ] when ;
 119
 120 : validate-params ( validators -- )
 121     params get swap validate-values check-validation ;
 122
 123 : validate-integer-id ( -- )
 124     { { "id" [ v-number ] } } validate-params ;
 125
 126 TUPLE: page-action < action template ;
 127
 128 : <chloe-content> ( path -- response )
 129     resolve-template-path <chloe> <html-content> ;
 130
 131 : <page-action> ( -- page )
 132     page-action new-action
 133         dup '[ _ template>> <chloe-content> ] >>display ;