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.templates
  14 html.templates.chloe
  15 html.templates.chloe.syntax
  16 http
  17 http.server
  18 http.server.redirection
  19 http.server.responses
  20 qualified ;
  21 QUALIFIED-WITH: assocs a
  22 EXCLUDE: xml.utilities => children>string ;
  23 IN: furnace
  24
  25 : nested-responders ( -- seq )
  26     responder-nesting get a:values ;
  27
  28 : each-responder ( quot -- )
  29    nested-responders swap each ; inline
  30
  31 : base-path ( string -- pair )
  32     dup responder-nesting get
  33     [ second class word-name = ] with find nip
  34     [ first ] [ "No such responder: " swap append throw ] ?if ;
  35
  36 : resolve-base-path ( string -- string' )
  37     "$" ?head [
  38         [
  39             "/" split1 [ base-path [  "/" % % ] each "/" % ] dip %
  40         ] "" make
  41     ] when ;
  42
  43 : vocab-path ( vocab -- path )
  44     dup vocab-dir vocab-append-path ;
  45
  46 : resolve-template-path ( pair -- path )
  47     [
  48         first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi*
  49     ] "" make ;
  50
  51 GENERIC: modify-query ( query responder -- query' )
  52
  53 M: object modify-query drop ;
  54
  55 GENERIC: adjust-url ( url -- url' )
  56
  57 M: url adjust-url
  58     clone
  59         [ [ modify-query ] each-responder ] change-query
  60         [ resolve-base-path ] change-path
  61     relative-to-request ;
  62
  63 M: string adjust-url ;
  64
  65 : <redirect> ( url -- response )
  66     adjust-url request get method>> {
  67         { "GET" [ <temporary-redirect> ] }
  68         { "HEAD" [ <temporary-redirect> ] }
  69         { "POST" [ <permanent-redirect> ] }
  70     } case ;
  71
  72 GENERIC: modify-form ( responder -- )
  73
  74 M: object modify-form drop ;
  75
  76 : request-params ( request -- assoc )
  77     dup method>> {
  78         { "GET" [ url>> query>> ] }
  79         { "HEAD" [ url>> query>> ] }
  80         { "POST" [
  81             post-data>>
  82             dup content-type>> "application/x-www-form-urlencoded" =
  83             [ content>> ] [ drop f ] if
  84         ] }
  85     } case ;
  86
  87 SYMBOL: exit-continuation
  88
  89 : exit-with ( value -- )
  90     exit-continuation get continue-with ;
  91
  92 : with-exit-continuation ( quot -- )
  93     '[ exit-continuation set @ ] callcc1 exit-continuation off ;
  94
  95 ! Chloe tags
  96 : parse-query-attr ( string -- assoc )
  97     dup empty?
  98     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
  99
 100 CHLOE: atom
 101     [ children>string ]
 102     [ "href" required-attr ]
 103     [ "query" optional-attr parse-query-attr ] tri
 104     <url>
 105         swap >>query
 106         swap >>path
 107     adjust-url relative-to-request
 108     add-atom-feed ;
 109
 110 CHLOE: write-atom drop write-atom-feeds ;
 111
 112 GENERIC: link-attr ( tag responder -- )
 113
 114 M: object link-attr 2drop ;
 115
 116 : link-attrs ( tag -- )
 117     '[ , _ link-attr ] each-responder ;
 118
 119 : a-start-tag ( tag -- )
 120     [
 121         <a
 122             dup link-attrs
 123             dup "value" optional-attr [ value f ] [
 124                 [ "href" required-attr ]
 125                 [ "query" optional-attr parse-query-attr ]
 126                 bi
 127             ] ?if
 128             <url>
 129                 swap >>query
 130                 swap >>path
 131             adjust-url relative-to-request =href
 132         a>
 133     ] with-scope ;
 134
 135 CHLOE: a
 136     [ a-start-tag ]
 137     [ process-tag-children ]
 138     [ drop </a> ]
 139     tri ;
 140
 141 : hidden-form-field ( value name -- )
 142     over [
 143         <input
 144             "hidden" =type
 145             =name
 146             present =value
 147         input/>
 148     ] [ 2drop ] if ;
 149
 150 : form-nesting-key "__n" ;
 151
 152 : form-magic ( tag -- )
 153     [ modify-form ] each-responder
 154     nested-values get " " join f like form-nesting-key hidden-form-field
 155     "for" optional-attr [ "," split [ hidden render ] each ] when* ;
 156
 157 : form-start-tag ( tag -- )
 158     [
 159         [
 160             <form
 161                 "POST" =method
 162                 [ link-attrs ]
 163                 [ "action" required-attr resolve-base-path =action ]
 164                 [ tag-attrs non-chloe-attrs-only print-attrs ]
 165                 tri
 166             form>
 167         ]
 168         [ form-magic ] bi
 169     ] with-scope ;
 170
 171 CHLOE: form
 172     [ form-start-tag ]
 173     [ process-tag-children ]
 174     [ drop </form> ]
 175     tri ;
 176
 177 STRING: button-tag-markup
 178 <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
 179     <button type="submit"></button>
 180 </t:form>
 181 ;
 182
 183 : add-tag-attrs ( attrs tag -- )
 184     tag-attrs swap update ;
 185
 186 CHLOE: button
 187     button-tag-markup string>xml delegate
 188     {
 189         [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
 190         [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
 191         [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
 192         [ nip ]
 193     } 2cleave process-chloe-tag ;