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