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