basis/http/server/server.factor

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