libs/httpd/responder.factor

   1 ! Copyright (C) 2004, 2005 Slava Pestov.
   2 ! See http://factor.sf.net/license.txt for BSD license.
   3 IN: httpd
   4 USING: arrays hashtables html http io kernel math namespaces
   5 parser sequences strings ;
   6
   7 ! Variables
   8 SYMBOL: vhosts
   9 SYMBOL: responders
  10
  11 : print-header ( alist -- )
  12     [ swap write ": " write print ] hash-each ;
  13
  14 : response ( header msg -- )
  15     "HTTP/1.0 " write print print-header ;
  16
  17 : error-body ( error -- body )
  18     <html> <body> <h1> write </h1> </body> </html> ;
  19
  20 : error-head ( error -- )
  21     dup log-error
  22     H{ { "Content-Type" "text/html" } } over response ;
  23
  24 : httpd-error ( error -- )
  25     #! This must be run from handle-request
  26     error-head
  27     "head" "method" get = [ drop ] [ terpri error-body ] if ;
  28
  29 : bad-request ( -- )
  30     [
  31         ! Make httpd-error print a body
  32         "get" "method" set
  33         "400 Bad request" httpd-error
  34     ] with-scope ;
  35
  36 : serving-content ( mime -- )
  37     "Content-Type" associate
  38     "200 Document follows" response terpri ;
  39
  40 : serving-html "text/html" serving-content ;
  41
  42 : serving-text "text/plain" serving-content ;
  43
  44 : redirect ( to -- )
  45     "Location" associate
  46     "301 Moved Permanently" response terpri ;
  47
  48 : directory-no/ ( -- )
  49     [
  50         "request" get % CHAR: / ,
  51         "raw-query" get [ CHAR: ? , % ] when*
  52     ] "" make redirect ;
  53
  54 : query>hash ( query -- hash )
  55     dup [
  56         "&" split [
  57             "=" split1 [ dup [ url-decode ] when ] 2apply 2array
  58         ] map
  59     ] when alist>hash ;
  60
  61 : read-post-request ( header -- hash )
  62     "Content-Length" swap hash dup
  63     [ string>number read dup "raw-response" set query>hash ] when ;
  64
  65 : log-headers ( hash -- )
  66     [
  67         drop { "User-Agent" "X-Forwarded-For" "Host" } member?
  68     ] hash-subset [ ": " swap 3append log-message ] hash-each ;
  69
  70 : prepare-url ( url -- url )
  71     #! This is executed in the with-request namespace.
  72     "?" split1
  73     dup "raw-query" set query>hash "query" set
  74     dup "request" set ;
  75
  76 : prepare-header ( -- )
  77     read-header dup "header" set
  78     dup log-headers
  79     read-post-request "response" set ;
  80
  81 ! Responders are called in a new namespace with these
  82 ! variables:
  83
  84 ! - method -- one of get, post, or head.
  85 ! - request -- the entire URL requested, including responder
  86 !              name
  87 ! - raw-query -- raw query string
  88 ! - query -- a hashtable of query parameters, eg
  89 !            foo.bar?a=b&c=d becomes
  90 !            H{ { "a" "b" } { "c" "d" } }
  91 ! - header -- a hashtable of headers from the user's client
  92 ! - response -- a hashtable of the POST request response
  93 ! - raw-response -- raw POST request response
  94
  95 : query-param ( key -- value ) "query" get hash ;
  96
  97 : add-responder ( responder -- )
  98     #! Add a responder object to the list.
  99     "responder" over hash  responders get set-hash ;
 100
 101 : add-simple-responder ( name quot -- )
 102     [
 103         [ drop ] swap append dup "get" set "post" set
 104         "responder" set
 105     ] make-hash add-responder ;
 106
 107 : make-responder ( quot -- responder )
 108     #! quot has stack effect ( url -- )
 109     [
 110         [
 111             drop "GET method not implemented" httpd-error
 112         ] "get" set
 113         [
 114             drop "POST method not implemented" httpd-error
 115         ] "post" set
 116         [
 117             drop "HEAD method not implemented" httpd-error
 118         ] "head" set
 119         [
 120             drop bad-request
 121         ] "bad" set
 122
 123         call
 124     ] make-hash add-responder ;
 125
 126 : vhost ( name -- vhost )
 127     vhosts get hash [ "default" vhost ] unless* ;
 128
 129 : responder ( name -- responder )
 130     responders get hash [ "404" responder ] unless* ;
 131
 132 : set-default-responder ( name -- )
 133     responder "default" responders get set-hash ;
 134
 135 : call-responder ( method argument responder -- )
 136     over "argument" set [ swap get call ] bind ;
 137
 138 : serve-default-responder ( method url -- )
 139     "default" responder call-responder ;
 140
 141 : log-responder ( path -- )
 142     "Calling responder " swap append log-message ;
 143
 144 : trim-/ ( url -- url )
 145     #! Trim a leading /, if there is one.
 146     "/" ?head drop ;
 147
 148 : serve-explicit-responder ( method url -- )
 149     "/" split1 dup [
 150         swap responder call-responder
 151     ] [
 152         ! Just a responder name by itself
 153         drop "request" get "/" append redirect 2drop
 154     ] if ;
 155
 156 : serve-responder ( method path host -- )
 157     #! Responder paths come in two forms:
 158     #! /foo/bar... - default responder used
 159     #! /responder/foo/bar - responder foo, argument bar
 160     vhost [
 161         dup log-responder trim-/ "responder/" ?head [
 162             serve-explicit-responder
 163         ] [
 164             serve-default-responder
 165         ] if
 166     ] bind ;
 167
 168 : no-such-responder ( -- )
 169     "404 No such responder" httpd-error ;