basis/http/server/server.factor

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