basis/furnace/furnace.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 vocabs.loader accessors strings combinators arrays
   5 continuations present fry
   6 urls html.elements
   7 http http.server http.server.redirection ;
   8 IN: furnace
   9
  10 : nested-responders ( -- seq )
  11     responder-nesting get values ;
  12
  13 : each-responder ( quot -- )
  14    nested-responders swap each ; inline
  15
  16 : base-path ( string -- pair )
  17     dup responder-nesting get
  18     [ second class superclasses [ name>> = ] with contains? ] with find nip
  19     [ first ] [ "No such responder: " swap append throw ] ?if ;
  20
  21 : resolve-base-path ( string -- string' )
  22     "$" ?head [
  23         [
  24             "/" split1 [ base-path [  "/" % % ] each "/" % ] dip %
  25         ] "" make
  26     ] when ;
  27
  28 : vocab-path ( vocab -- path )
  29     dup vocab-dir vocab-append-path ;
  30
  31 : resolve-template-path ( pair -- path )
  32     [
  33         first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
  34     ] "" make ;
  35
  36 GENERIC: modify-query ( query responder -- query' )
  37
  38 M: object modify-query drop ;
  39
  40 GENERIC: adjust-url ( url -- url' )
  41
  42 M: url adjust-url
  43     clone
  44         [ [ modify-query ] each-responder ] change-query
  45         [ resolve-base-path ] change-path
  46     relative-to-request ;
  47
  48 M: string adjust-url ;
  49
  50 GENERIC: link-attr ( tag responder -- )
  51
  52 M: object link-attr 2drop ;
  53
  54 GENERIC: modify-form ( responder -- )
  55
  56 M: object modify-form drop ;
  57
  58 : hidden-form-field ( value name -- )
  59     over [
  60         <input
  61             "hidden" =type
  62             =name
  63             present =value
  64         input/>
  65     ] [ 2drop ] if ;
  66
  67 : nested-forms-key "__n" ;
  68
  69 : request-params ( request -- assoc )
  70     dup method>> {
  71         { "GET" [ url>> query>> ] }
  72         { "HEAD" [ url>> query>> ] }
  73         { "POST" [
  74             post-data>>
  75             dup content-type>> "application/x-www-form-urlencoded" =
  76             [ content>> ] [ drop f ] if
  77         ] }
  78     } case ;
  79
  80 : referrer ( -- referrer )
  81     #! Typo is intentional, its in the HTTP spec!
  82     "referer" request get header>> at >url ;
  83
  84 : user-agent ( -- user-agent )
  85     "user-agent" request get header>> at "" or ;
  86
  87 : same-host? ( url -- ? )
  88     url get
  89     [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
  90
  91 : cookie-client-state ( key request -- value/f )
  92     swap get-cookie dup [ value>> ] when ;
  93
  94 : post-client-state ( key request -- value/f )
  95     request-params at ;
  96
  97 : client-state ( key -- value/f )
  98     request get dup method>> {
  99         { "GET" [ cookie-client-state ] }
 100         { "HEAD" [ cookie-client-state ] }
 101         { "POST" [ post-client-state ] }
 102     } case ;
 103
 104 SYMBOL: exit-continuation
 105
 106 : exit-with ( value -- )
 107     exit-continuation get continue-with ;
 108
 109 : with-exit-continuation ( quot -- )
 110     '[ exit-continuation set @ ] callcc1 exit-continuation off ;
 111
 112 "furnace.chloe-tags" require