basis/furnace/utilities/utilities.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces make assocs sequences kernel classes splitting
   4 words vocabs.loader accessors strings combinators arrays
   5 continuations present fry urls html.elements http http.server
   6 http.server.redirection http.server.remapping ;
   7 IN: furnace.utilities
   8
   9 : word>string ( word -- string )
  10     [ vocabulary>> ] [ name>> ] bi ":" glue ;
  11
  12 : words>strings ( seq -- seq' )
  13     [ word>string ] map ;
  14
  15 ERROR: no-such-word name vocab ;
  16
  17 : string>word ( string -- word )
  18     ":" split1 swap 2dup lookup dup
  19     [ 2nip ] [ drop no-such-word ] if ;
  20
  21 : strings>words ( seq -- seq' )
  22     [ string>word ] map ;
  23
  24 : nested-responders ( -- seq )
  25     responder-nesting get values ;
  26
  27 : each-responder ( quot -- )
  28    nested-responders swap each ; inline
  29
  30 : base-path ( string -- pair )
  31     dup responder-nesting get
  32     [ second class superclasses [ name>> = ] with contains? ] with find nip
  33     [ first ] [ "No such responder: " swap append throw ] ?if ;
  34
  35 : resolve-base-path ( string -- string' )
  36     "$" ?head [
  37         [
  38             "/" split1 [ base-path [  "/" % % ] each "/" % ] dip %
  39         ] "" make
  40     ] when ;
  41
  42 : vocab-path ( vocab -- path )
  43     dup vocab-dir vocab-append-path ;
  44
  45 : resolve-template-path ( pair -- path )
  46     [
  47         first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
  48     ] "" make ;
  49
  50 GENERIC: modify-query ( query responder -- query' )
  51
  52 M: object modify-query drop ;
  53
  54 GENERIC: modify-redirect-query ( query responder -- query' )
  55
  56 M: object modify-redirect-query drop ;
  57
  58 GENERIC: adjust-url ( url -- url' )
  59
  60 M: url adjust-url
  61     clone
  62         [ [ modify-query ] each-responder ] change-query
  63         [ resolve-base-path ] change-path
  64     relative-to-request ;
  65
  66 M: string adjust-url ;
  67
  68 GENERIC: adjust-redirect-url ( url -- url' )
  69
  70 M: url adjust-redirect-url
  71     adjust-url
  72     [ [ modify-redirect-query ] each-responder ] change-query ;
  73
  74 M: string adjust-redirect-url ;
  75
  76 GENERIC: link-attr ( tag responder -- )
  77
  78 M: object link-attr 2drop ;
  79
  80 GENERIC: modify-form ( responder -- )
  81
  82 M: object modify-form drop ;
  83
  84 : hidden-form-field ( value name -- )
  85     over [
  86         <input
  87             "hidden" =type
  88             =name
  89             present =value
  90         input/>
  91     ] [ 2drop ] if ;
  92
  93 : nested-forms-key "__n" ;
  94
  95 : request-params ( request -- assoc )
  96     dup method>> {
  97         { "GET" [ url>> query>> ] }
  98         { "HEAD" [ url>> query>> ] }
  99         { "POST" [
 100             post-data>>
 101             dup content-type>> "application/x-www-form-urlencoded" =
 102             [ content>> ] [ drop f ] if
 103         ] }
 104     } case ;
 105
 106 : referrer ( -- referrer/f )
 107     #! Typo is intentional, it's in the HTTP spec!
 108     "referer" request get header>> at
 109     dup [ >url ensure-port [ remap-port ] change-port ] when ;
 110
 111 : user-agent ( -- user-agent )
 112     "user-agent" request get header>> at "" or ;
 113
 114 : same-host? ( url -- ? )
 115     dup [
 116         url get [
 117             [ protocol>> ]
 118             [ host>> ]
 119             [ port>> remap-port ]
 120             tri 3array
 121         ] bi@ =
 122     ] when ;
 123
 124 : cookie-client-state ( key request -- value/f )
 125     swap get-cookie dup [ value>> ] when ;
 126
 127 : post-client-state ( key request -- value/f )
 128     request-params at ;
 129
 130 : client-state ( key -- value/f )
 131     request get dup method>> {
 132         { "GET" [ cookie-client-state ] }
 133         { "HEAD" [ cookie-client-state ] }
 134         { "POST" [ post-client-state ] }
 135     } case ;
 136
 137 SYMBOL: exit-continuation
 138
 139 : exit-with ( value -- )
 140     exit-continuation get continue-with ;
 141
 142 : with-exit-continuation ( quot -- value )
 143     '[ exit-continuation set @ ] callcc1 exit-continuation off ;