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