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