extra/furnace/furnace.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays kernel combinators assocs
   4 continuations namespaces sequences splitting words
   5 vocabs.loader classes strings
   6 fry urls multiline present
   7 xml
   8 xml.data
   9 xml.entities
  10 xml.writer
  11 html.components
  12 html.elements
  13 html.forms
  14 html.templates
  15 html.templates.chloe
  16 html.templates.chloe.syntax
  17 http
  18 http.server
  19 http.server.redirection
  20 http.server.responses
  21 qualified ;
  22 QUALIFIED-WITH: assocs a
  23 EXCLUDE: xml.utilities => children>string ;
  24 IN: furnace
  25
  26 : nested-responders ( -- seq )
  27     responder-nesting get a:values ;
  28
  29 : each-responder ( quot -- )
  30    nested-responders swap each ; inline
  31
  32 : base-path ( string -- pair )
  33     dup responder-nesting get
  34     [ second class superclasses [ name>> = ] with contains? ] with find nip
  35     [ first ] [ "No such responder: " swap append throw ] ?if ;
  36
  37 : resolve-base-path ( string -- string' )
  38     "$" ?head [
  39         [
  40             "/" split1 [ base-path [  "/" % % ] each "/" % ] dip %
  41         ] "" make
  42     ] when ;
  43
  44 : vocab-path ( vocab -- path )
  45     dup vocab-dir vocab-append-path ;
  46
  47 : resolve-template-path ( pair -- path )
  48     [
  49         first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
  50     ] "" make ;
  51
  52 GENERIC: modify-query ( query responder -- query' )
  53
  54 M: object modify-query drop ;
  55
  56 GENERIC: adjust-url ( url -- url' )
  57
  58 M: url adjust-url
  59     clone
  60         [ [ modify-query ] each-responder ] change-query
  61         [ resolve-base-path ] change-path
  62     relative-to-request ;
  63
  64 M: string adjust-url ;
  65
  66 GENERIC: modify-form ( responder -- )
  67
  68 M: object modify-form drop ;
  69
  70 : request-params ( request -- assoc )
  71     dup method>> {
  72         { "GET" [ url>> query>> ] }
  73         { "HEAD" [ url>> query>> ] }
  74         { "POST" [
  75             post-data>>
  76             dup content-type>> "application/x-www-form-urlencoded" =
  77             [ content>> ] [ drop f ] if
  78         ] }
  79     } case ;
  80
  81 : referrer ( -- referrer )
  82     #! Typo is intentional, its in the HTTP spec!
  83     "referer" request get header>> at >url ;
  84
  85 : user-agent ( -- user-agent )
  86     "user-agent" request get header>> at "" or ;
  87
  88 : same-host? ( url -- ? )
  89     url get
  90     [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
  91
  92 : cookie-client-state ( key request -- value/f )
  93     swap get-cookie dup [ value>> ] when ;
  94
  95 : post-client-state ( key request -- value/f )
  96     request-params at ;
  97
  98 : client-state ( key -- value/f )
  99     request get dup method>> {
 100         { "GET" [ cookie-client-state ] }
 101         { "HEAD" [ cookie-client-state ] }
 102         { "POST" [ post-client-state ] }
 103     } case ;
 104
 105 SYMBOL: exit-continuation
 106
 107 : exit-with ( value -- )
 108     exit-continuation get continue-with ;
 109
 110 : with-exit-continuation ( quot -- )
 111     '[ exit-continuation set @ ] callcc1 exit-continuation off ;
 112
 113 ! Chloe tags
 114 : parse-query-attr ( string -- assoc )
 115     dup empty?
 116     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
 117
 118 : a-url-path ( tag -- string )
 119     [ "href" required-attr ]
 120     [ "rest" optional-attr dup [ value ] when ] bi
 121     [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
 122
 123 : a-url ( tag -- url )
 124     dup "value" optional-attr
 125     [ value ] [
 126         <url>
 127             swap
 128             [ a-url-path >>path ]
 129             [ "query" optional-attr parse-query-attr >>query ]
 130             bi
 131         adjust-url relative-to-request
 132     ] ?if ;
 133
 134 CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
 135
 136 CHLOE: write-atom drop write-atom-feeds ;
 137
 138 GENERIC: link-attr ( tag responder -- )
 139
 140 M: object link-attr 2drop ;
 141
 142 : link-attrs ( tag -- )
 143     #! Side-effects current namespace.
 144     '[ , _ link-attr ] each-responder ;
 145
 146 : a-start-tag ( tag -- )
 147     [ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
 148
 149 CHLOE: a
 150     [ a-start-tag ]
 151     [ process-tag-children ]
 152     [ drop </a> ]
 153     tri ;
 154
 155 : hidden-form-field ( value name -- )
 156     over [
 157         <input
 158             "hidden" =type
 159             =name
 160             present =value
 161         input/>
 162     ] [ 2drop ] if ;
 163
 164 : nested-forms-key "__n" ;
 165
 166 : form-magic ( tag -- )
 167     [ modify-form ] each-responder
 168     nested-forms get " " join f like nested-forms-key hidden-form-field
 169     "for" optional-attr [ "," split [ hidden render ] each ] when* ;
 170
 171 : form-start-tag ( tag -- )
 172     [
 173         [
 174             <form
 175                 {
 176                     [ link-attrs ]
 177                     [ "method" optional-attr "post" or =method ]
 178                     [ "action" required-attr resolve-base-path =action ]
 179                     [ attrs>> non-chloe-attrs-only print-attrs ]
 180                 } cleave
 181             form>
 182         ]
 183         [ form-magic ] bi
 184     ] with-scope ;
 185
 186 CHLOE: form
 187     [ form-start-tag ]
 188     [ process-tag-children ]
 189     [ drop </form> ]
 190     tri ;
 191
 192 STRING: button-tag-markup
 193 <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
 194     <button type="submit"></button>
 195 </t:form>
 196 ;
 197
 198 : add-tag-attrs ( attrs tag -- )
 199     attrs>> swap update ;
 200
 201 CHLOE: button
 202     button-tag-markup string>xml body>>
 203     {
 204         [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
 205         [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
 206         [ [ children>string 1array ] dip "button" tag-named (>>children) ]
 207         [ nip ]
 208     } 2cleave process-chloe-tag ;