basis/furnace/utilities/utilities.factor

   1 ! Copyright (C) 2008, 2010 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 http http.server xml.syntax xml.writer
   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-word 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 ERROR: no-such-responder responder ;
  31
  32 : base-path ( string -- seq )
  33     dup responder-nesting get
  34     [ second class-of superclasses [ name>> = ] with any? ] with find nip
  35     [ first ] [ no-such-responder ] ?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: modify-redirect-query ( query responder -- query' )
  57
  58 M: object modify-redirect-query drop ;
  59
  60 GENERIC: adjust-url ( url -- url' )
  61
  62 M: url adjust-url
  63     clone
  64         [ [ modify-query ] each-responder ] change-query
  65         [ resolve-base-path ] change-path
  66     relative-to-request ;
  67
  68 M: string adjust-url ;
  69
  70 GENERIC: adjust-redirect-url ( url -- url' )
  71
  72 M: url adjust-redirect-url
  73     adjust-url
  74     [ [ modify-redirect-query ] each-responder ] change-query ;
  75
  76 M: string adjust-redirect-url ;
  77
  78 GENERIC: link-attr ( tag responder -- )
  79
  80 M: object link-attr 2drop ;
  81
  82 GENERIC: modify-form ( responder -- xml/f )
  83
  84 M: object modify-form drop f ;
  85
  86 : form-modifications ( -- xml )
  87     [ [ modify-form [ , ] when* ] each-responder ] { } make ;
  88
  89 : hidden-form-field ( value name -- xml )
  90     over [
  91         [XML <input type="hidden" value=<-> name=<->/> XML]
  92     ] [ drop ] if ;
  93
  94 CONSTANT: nested-forms-key "__n"
  95
  96 : referrer ( -- referrer/f )
  97     #! Typo is intentional, it's in the HTTP spec!
  98     "referer" request get header>> at
  99     dup [ >url ensure-port [ remap-port ] change-port ] when ;
 100
 101 : user-agent ( -- user-agent )
 102     "user-agent" request get header>> at "" or ;
 103
 104 : same-host? ( url -- ? )
 105     dup [
 106         url get [
 107             [ protocol>> ]
 108             [ host>> ]
 109             [ port>> remap-port ]
 110             tri 3array
 111         ] same?
 112     ] when ;
 113
 114 : cookie-client-state ( key request -- value/f )
 115     swap get-cookie dup [ value>> ] when ;
 116
 117 : post-client-state ( key request -- value/f )
 118     request-params at ;
 119
 120 : client-state ( key -- value/f )
 121     request get dup method>> {
 122         { "GET" [ cookie-client-state ] }
 123         { "HEAD" [ cookie-client-state ] }
 124         { "POST" [ post-client-state ] }
 125     } case ;
 126
 127 SYMBOL: exit-continuation
 128
 129 : exit-with ( value -- * )
 130     exit-continuation get continue-with ;
 131
 132 : with-exit-continuation ( quot -- value )
 133     '[ exit-continuation set @ ] callcc1 exit-continuation off ; inline