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 : a-url-path ( tag -- string )
 101     [ "href" required-attr ] [ "rest" optional-attr value ] bi
 102     [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
 103
 104 : a-url ( tag -- url )
 105     dup "value" optional-attr [ ] [
 106         <url>
 107             swap
 108             [ a-url-path >>path ]
 109             [ "query" optional-attr parse-query-attr >>query ]
 110             bi
 111     ] ?if
 112     adjust-url relative-to-request ;
 113
 114 CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
 115
 116 CHLOE: write-atom drop write-atom-feeds ;
 117
 118 GENERIC: link-attr ( tag responder -- )
 119
 120 M: object link-attr 2drop ;
 121
 122 : link-attrs ( tag -- )
 123     #! Side-effects current namespace.
 124     '[ , _ link-attr ] each-responder ;
 125
 126 : a-start-tag ( tag -- )
 127     [ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
 128
 129 CHLOE: a
 130     [ a-start-tag ]
 131     [ process-tag-children ]
 132     [ drop </a> ]
 133     tri ;
 134
 135 : hidden-form-field ( value name -- )
 136     over [
 137         <input
 138             "hidden" =type
 139             =name
 140             present =value
 141         input/>
 142     ] [ 2drop ] if ;
 143
 144 : form-nesting-key "__n" ;
 145
 146 : form-magic ( tag -- )
 147     [ modify-form ] each-responder
 148     nested-values get " " join f like form-nesting-key hidden-form-field
 149     "for" optional-attr [ "," split [ hidden render ] each ] when* ;
 150
 151 : form-start-tag ( tag -- )
 152     [
 153         [
 154             <form
 155                 {
 156                     [ link-attrs ]
 157                     [ "method" optional-attr "post" or =method ]
 158                     [ "action" required-attr resolve-base-path =action ]
 159                     [ tag-attrs non-chloe-attrs-only print-attrs ]
 160                 } cleave
 161             form>
 162         ]
 163         [ form-magic ] bi
 164     ] with-scope ;
 165
 166 CHLOE: form
 167     [ form-start-tag ]
 168     [ process-tag-children ]
 169     [ drop </form> ]
 170     tri ;
 171
 172 STRING: button-tag-markup
 173 <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
 174     <button type="submit"></button>
 175 </t:form>
 176 ;
 177
 178 : add-tag-attrs ( attrs tag -- )
 179     tag-attrs swap update ;
 180
 181 CHLOE: button
 182     button-tag-markup string>xml delegate
 183     {
 184         [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
 185         [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
 186         [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
 187         [ nip ]
 188     } 2cleave process-chloe-tag ;