basis/http/server/server.factor

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