extra/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         request get url>>
  85         host>> dup "localhost" =
  86         [ drop ] [ or ] if
  87     ] change-domain ;
  88
  89 : write-response-header ( response -- response )
  90     #! We send one set-cookie header per cookie, because that's
  91     #! what Firefox expects.
  92     dup header>> >alist >vector
  93     over unparse-content-type "content-type" pick set-at
  94     over cookies>> [
  95         ensure-domain unparse-set-cookie
  96         "set-cookie" swap 2array over push
  97     ] each
  98     write-header ;
  99
 100 : write-response-body ( response -- response )
 101     dup body>> call-template ;
 102
 103 M: response write-response ( respose -- )
 104     write-response-line
 105     write-response-header
 106     flush
 107     drop ;
 108
 109 M: response write-full-response ( request response -- )
 110     dup write-response
 111     swap method>> "HEAD" = [
 112         [ content-charset>> encode-output ]
 113         [ write-response-body ]
 114         bi
 115     ] unless ;
 116
 117 M: raw-response write-response ( respose -- )
 118     write-response-line
 119     write-response-body
 120     drop ;
 121
 122 M: raw-response write-full-response ( response -- )
 123     write-response ;
 124
 125 : post-request? ( -- ? ) request get method>> "POST" = ;
 126
 127 SYMBOL: responder-nesting
 128
 129 SYMBOL: main-responder
 130
 131 SYMBOL: development?
 132
 133 SYMBOL: benchmark?
 134
 135 ! path is a sequence of path component strings
 136 GENERIC: call-responder* ( path responder -- response )
 137
 138 TUPLE: trivial-responder response ;
 139
 140 C: <trivial-responder> trivial-responder
 141
 142 M: trivial-responder call-responder* nip response>> clone ;
 143
 144 main-responder global [ <404> <trivial-responder> or ] change-at
 145
 146 : invert-slice ( slice -- slice' )
 147     dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
 148
 149 : add-responder-nesting ( path responder -- )
 150     [ invert-slice ] dip 2array responder-nesting get push ;
 151
 152 : call-responder ( path responder -- response )
 153     [ add-responder-nesting ] [ call-responder* ] 2bi ;
 154
 155 : http-error. ( error -- )
 156     "Internal server error" [
 157         [ print-error nl :c ] with-html-stream
 158     ] simple-page ;
 159
 160 : <500> ( error -- response )
 161     500 "Internal server error" <trivial-response>
 162     swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ;
 163
 164 : do-response ( response -- )
 165     [ request get swap write-full-response ]
 166     [
 167         [ \ do-response log-error ]
 168         [
 169             utf8 [
 170                 development? get
 171                 [ http-error. ] [ drop "Response error" write ] if
 172             ] with-encoded-output
 173         ] bi
 174     ] recover ;
 175
 176 LOG: httpd-hit NOTICE
 177
 178 LOG: httpd-header NOTICE
 179
 180 : log-header ( headers name -- )
 181     tuck header 2array httpd-header ;
 182
 183 : log-request ( request -- )
 184     [ [ method>> ] [ url>> ] bi 2array httpd-hit ]
 185     [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
 186     bi ;
 187
 188 : split-path ( string -- path )
 189     "/" split harvest ;
 190
 191 : init-request ( request -- )
 192     request set
 193     V{ } clone responder-nesting set ;
 194
 195 : dispatch-request ( request -- response )
 196     url>> path>> split-path main-responder get call-responder ;
 197
 198 : prepare-request ( request -- )
 199     [
 200         local-address get
 201         [ secure? "https" "http" ? >>protocol ]
 202         [ port>> '[ , or ] change-port ]
 203         bi
 204     ] change-url drop ;
 205
 206 : valid-request? ( request -- ? )
 207     url>> port>> local-address get port>> = ;
 208
 209 : do-request ( request -- response )
 210     '[
 211         ,
 212         {
 213             [ init-request ]
 214             [ prepare-request ]
 215             [ log-request ]
 216             [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
 217         } cleave
 218     ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
 219
 220 : ?refresh-all ( -- )
 221     development? get-global [ global [ refresh-all ] bind ] when ;
 222
 223 LOG: httpd-benchmark DEBUG
 224
 225 : ?benchmark ( quot -- )
 226     benchmark? get [
 227         [ benchmark ] [ first ] bi request get url>> rot 3array
 228         httpd-benchmark
 229     ] [ call ] if ; inline
 230
 231 TUPLE: http-server < threaded-server ;
 232
 233 M: http-server handle-client*
 234     drop
 235     [
 236         64 1024 * limit-input
 237         ?refresh-all
 238         read-request
 239         [ do-request ] ?benchmark
 240         [ do-response ] ?benchmark
 241     ] with-destructors ;
 242
 243 : <http-server> ( -- server )
 244     http-server new-threaded-server
 245         "http.server" >>name
 246         "http" protocol-port >>insecure
 247         "https" protocol-port >>secure ;
 248
 249 : httpd ( port -- )
 250     <http-server>
 251         swap >>insecure
 252         f >>secure
 253     start-server ;
 254
 255 : http-insomniac ( -- )
 256     "http.server" { "httpd-hit" } schedule-insomniac ;