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