basis/http/server/server.factor

   1 ! Copyright (C) 2003, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit continuations debugger destructors
   5 hashtables html html.streams html.templates http
   6 http.server.remapping http.server.requests http.server.responses
   7 io io.crlf io.encodings io.encodings.ascii io.encodings.iana
   8 io.encodings.utf8 io.servers io.sockets io.sockets.secure
   9 io.streams.limited kernel logging logging.insomniac math
  10 mime.types namespaces present sequences splitting tools.time
  11 urls vectors vocabs vocabs.refresh xml.writer ;
  12 IN: http.server
  13
  14 GENERIC: write-response ( response -- )
  15
  16 GENERIC: write-full-response ( request response -- )
  17
  18 : write-response-line ( response -- response )
  19     dup
  20     [ "HTTP/" write version>> write bl ]
  21     [ code>> present write bl ]
  22     [ message>> write crlf ]
  23     tri ;
  24
  25 : unparse-content-type ( request -- content-type )
  26     [ content-type>> ] [ content-charset>> ] bi
  27     over mime-type-encoding encoding>name or
  28     [ "application/octet-stream" or ] dip
  29     [ "; charset=" glue ] when* ;
  30
  31 : ensure-domain ( cookie -- cookie )
  32     [
  33         url get host>> dup "localhost" =
  34         [ drop ] [ or ] if
  35     ] change-domain ;
  36
  37 : write-response-header ( response -- response )
  38     ! We send one set-cookie header per cookie, because that's
  39     ! what Firefox expects.
  40     dup header>> >alist >vector
  41     over unparse-content-type "content-type" pick set-at
  42     over cookies>> [
  43         ensure-domain unparse-set-cookie
  44         "set-cookie" swap 2array suffix!
  45     ] each
  46     write-header ;
  47
  48 : write-response-body ( response -- response )
  49     dup body>> call-template ;
  50
  51 M: response write-response
  52     write-response-line
  53     write-response-header
  54     flush
  55     drop ;
  56
  57 M: response write-full-response
  58     dup write-response
  59     swap method>> "HEAD" = [
  60         [ content-encoding>> encode-output ]
  61         [ write-response-body ]
  62         bi
  63     ] unless drop ;
  64
  65 M: raw-response write-response
  66     write-response-line
  67     write-response-body
  68     drop ;
  69
  70 M: raw-response write-full-response
  71     nip write-response ;
  72
  73 : post-request? ( -- ? ) request get method>> "POST" = ;
  74
  75 SYMBOL: responder-nesting
  76
  77 SYMBOL: main-responder
  78
  79 SYMBOL: development?
  80
  81 SYMBOL: benchmark?
  82
  83 ! path is a sequence of path component strings
  84 GENERIC: call-responder* ( path responder -- response )
  85
  86 TUPLE: trivial-responder response ;
  87
  88 C: <trivial-responder> trivial-responder
  89
  90 M: trivial-responder call-responder* nip response>> clone ;
  91
  92 main-responder [ <404> <trivial-responder> ] initialize
  93
  94 : invert-slice ( slice -- slice' )
  95     dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
  96
  97 : add-responder-nesting ( path responder -- )
  98     [ invert-slice ] dip 2array responder-nesting get push ;
  99
 100 : call-responder ( path responder -- response )
 101     [ add-responder-nesting ] [ call-responder* ] 2bi ;
 102
 103 : make-http-error ( error -- xml )
 104     [ "Internal server error" f ] dip
 105     [ print-error nl :c ] with-html-writer
 106     simple-page ;
 107
 108 : <500> ( error -- response )
 109     500 "Internal server error" <trivial-response>
 110     swap development? get [ make-http-error >>body ] [ drop ] if ;
 111
 112 : do-response ( response -- )
 113     '[ request get _ write-full-response ]
 114     [
 115         [ \ do-response log-error ]
 116         [
 117             utf8 [
 118                 development? get
 119                 [ make-http-error ] [ drop "Response error" ] if
 120                 write-xml
 121             ] with-encoded-output
 122         ] bi
 123     ] recover ;
 124
 125 LOG: httpd-hit NOTICE
 126
 127 LOG: httpd-header NOTICE
 128
 129 : log-header ( request name -- )
 130     [ nip ] [ header ] 2bi 2array httpd-header ;
 131
 132 : log-request ( request -- )
 133     [ [ method>> ] [ url>> ] bi 2array httpd-hit ]
 134     [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
 135     bi ;
 136
 137 : split-path ( string -- path )
 138     "/" split harvest ;
 139
 140 : request-params ( request -- assoc )
 141     dup method>> {
 142         { "GET" [ url>> query>> ] }
 143         { "HEAD" [ url>> query>> ] }
 144         { "OPTIONS" [ url>> query>> ] }
 145         { "POST" [ post-data>> params>> ] }
 146         { "PUT" [ post-data>> params>> ] }
 147     } case ;
 148
 149 SYMBOL: params
 150
 151 : param ( name -- value )
 152     params get at ;
 153
 154 : set-param ( value name -- )
 155     params get set-at ;
 156
 157 : init-request ( request -- )
 158     [ request set ]
 159     [ url>> url set ]
 160     [ request-params >hashtable params set ] tri
 161     V{ } clone responder-nesting set ;
 162
 163 : dispatch-request ( request -- response )
 164     url>> path>> split-path main-responder get call-responder ;
 165
 166 : prepare-request ( request -- )
 167     [
 168         local-address get
 169         [ secure? "https" "http" ? >>protocol ]
 170         [ port>> remap-port >>port ]
 171         bi
 172     ] change-url drop ;
 173
 174 : valid-request? ( request -- ? )
 175     url>> port>> remap-port
 176     local-address get port>> remap-port = ;
 177
 178 : do-request ( request -- response )
 179     '[
 180         _
 181         {
 182             [ prepare-request ]
 183             [ init-request ]
 184             [ log-request ]
 185             [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
 186         } cleave
 187     ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
 188
 189 : ?refresh-all ( -- )
 190     development? get-global [ [ refresh-all ] with-global ] when ;
 191
 192 LOG: httpd-benchmark DEBUG
 193
 194 : ?benchmark ( quot -- )
 195     benchmark? get [
 196         [ benchmark ] [ first ] bi url get rot 3array
 197         httpd-benchmark
 198     ] [ call ] if ; inline
 199
 200 TUPLE: http-server < threaded-server ;
 201
 202 SYMBOL: request-limit
 203
 204 request-limit [ 64 1024 * ] initialize
 205
 206 LOG: httpd-bad-request NOTICE
 207
 208 : handle-client-error ( error -- )
 209     dup request-error? [
 210         dup { [ bad-request-line? ] [ parse-error>> got>> empty? ] } 1&&
 211         [ drop ] [ httpd-bad-request <400> write-response ] if
 212     ] [ rethrow ] if ;
 213
 214 M: http-server handle-client*
 215     drop [
 216         [
 217             ?refresh-all
 218             request-limit get limited-input
 219             [ read-request ] ?benchmark
 220             [ do-request ] ?benchmark
 221             [ do-response ] ?benchmark
 222         ] [ handle-client-error ] recover
 223     ] with-destructors ;
 224
 225 : <http-server> ( -- server )
 226     ascii http-server new-threaded-server
 227         "http.server" >>name
 228         "http" protocol-port >>insecure
 229         "https" protocol-port >>secure ;
 230
 231 : httpd ( port -- http-server )
 232     <http-server>
 233         swap >>insecure
 234         f >>secure
 235     start-server ;
 236
 237 : http-insomniac ( -- )
 238     "http.server" { "httpd-hit" } schedule-insomniac ;
 239
 240 "http.server.filters" require
 241 "http.server.dispatchers" require
 242 "http.server.redirection" require
 243 "http.server.static" require
 244 "http.server.cgi" require