basis/http/server/server.factor

   1 ! Copyright (C) 2003, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit continuations debugger destructors fry
   5 hashtables html html.streams html.templates http
   6 http.server.remapping http.server.requests http.server.responses
   7 io io.crlf io.encodings io.encodings.ascii io.encodings.iana
   8 io.encodings.utf8 io.servers io.sockets io.sockets.secure
   9 io.streams.limited kernel logging logging.insomniac math
  10 mime.types namespaces present sequences splitting tools.time
  11 urls vectors vocabs vocabs.refresh xml.writer ;
  12 IN: http.server
  13
  14 GENERIC: write-response ( response -- )
  15
  16 GENERIC: write-full-response ( request response -- )
  17
  18 : write-response-line ( response -- response )
  19     dup
  20     [ "HTTP/" write version>> write bl ]
  21     [ code>> present write bl ]
  22     [ message>> write crlf ]
  23     tri ;
  24
  25 : unparse-content-type ( request -- content-type )
  26     [ content-type>> ] [ content-charset>> ] bi
  27     over mime-type-encoding encoding>name or
  28     [ "application/octet-stream" or ] dip
  29     [ "; charset=" glue ] when* ;
  30
  31 : ensure-domain ( cookie -- cookie )
  32     [
  33         url get host>> dup "localhost" =
  34         [ drop ] [ or ] if
  35     ] change-domain ;
  36
  37 : write-response-header ( response -- response )
  38     ! We send one set-cookie header per cookie, because that's
  39     ! what Firefox expects.
  40     dup header>> >alist >vector
  41     over unparse-content-type "content-type" pick set-at
  42     over cookies>> [
  43         ensure-domain unparse-set-cookie
  44         "set-cookie" swap 2array suffix!
  45     ] each
  46     write-header ;
  47
  48 : write-response-body ( response -- response )
  49     dup body>> call-template ;
  50
  51 M: response write-response ( respose -- )
  52     write-response-line
  53     write-response-header
  54     flush
  55     drop ;
  56
  57 M: response write-full-response ( request response -- )
  58     dup write-response
  59     swap method>> "HEAD" = [
  60         [ content-encoding>> encode-output ]
  61         [ write-response-body ]
  62         bi
  63     ] unless drop ;
  64
  65 M: raw-response write-response ( respose -- )
  66     write-response-line
  67     write-response-body
  68     drop ;
  69
  70 M: raw-response write-full-response ( request response -- )
  71     nip write-response ;
  72
  73 : post-request? ( -- ? ) request get method>> "POST" = ;
  74
  75 SYMBOL: responder-nesting
  76
  77 SYMBOL: main-responder
  78
  79 SYMBOL: development?
  80
  81 SYMBOL: benchmark?
  82
  83 ! path is a sequence of path component strings
  84 GENERIC: call-responder* ( path responder -- response )
  85
  86 TUPLE: trivial-responder response ;
  87
  88 C: <trivial-responder> trivial-responder
  89
  90 M: trivial-responder call-responder* nip response>> clone ;
  91
  92 main-responder [ <404> <trivial-responder> ] initialize
  93
  94 : invert-slice ( slice -- slice' )
  95     dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
  96
  97 : add-responder-nesting ( path responder -- )
  98     [ invert-slice ] dip 2array responder-nesting get push ;
  99
 100 : call-responder ( path responder -- response )
 101     [ add-responder-nesting ] [ call-responder* ] 2bi ;
 102
 103 : make-http-error ( error -- xml )
 104     [ "Internal server error" f ] dip
 105     [ print-error nl :c ] with-html-writer
 106     simple-page ;
 107
 108 : <500> ( error -- response )
 109     500 "Internal server error" <trivial-response>
 110     swap development? get [ make-http-error >>body ] [ drop ] if ;
 111
 112 : do-response ( response -- )
 113     '[ request get _ write-full-response ]
 114     [
 115         [ \ do-response log-error ]
 116         [
 117             utf8 [
 118                 development? get
 119                 [ make-http-error ] [ drop "Response error" ] if
 120                 write-xml
 121             ] with-encoded-output
 122         ] bi
 123     ] recover ;
 124
 125 LOG: httpd-hit NOTICE
 126
 127 LOG: httpd-header NOTICE
 128
 129 : log-header ( request name -- )
 130     [ nip ] [ header ] 2bi 2array httpd-header ;
 131
 132 : log-request ( request -- )
 133     [ [ method>> ] [ url>> ] bi 2array httpd-hit ]
 134     [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
 135     bi ;
 136
 137 : split-path ( string -- path )
 138     "/" split harvest ;
 139
 140 : request-params ( request -- assoc )
 141     dup method>> {
 142         { "GET" [ url>> query>> ] }
 143         { "HEAD" [ url>> query>> ] }
 144         { "POST" [ post-data>> params>> ] }
 145     } case ;
 146
 147 SYMBOL: params
 148
 149 : param ( name -- value )
 150     params get at ;
 151
 152 : set-param ( value name -- )
 153     params get set-at ;
 154
 155 : init-request ( request -- )
 156     [ request set ]
 157     [ url>> url set ]
 158     [ request-params >hashtable params set ] tri
 159     V{ } clone responder-nesting set ;
 160
 161 : dispatch-request ( request -- response )
 162     url>> path>> split-path main-responder get call-responder ;
 163
 164 : prepare-request ( request -- )
 165     [
 166         local-address get
 167         [ secure? "https" "http" ? >>protocol ]
 168         [ port>> remap-port >>port ]
 169         bi
 170     ] change-url drop ;
 171
 172 : valid-request? ( request -- ? )
 173     url>> port>> remap-port
 174     local-address get port>> remap-port = ;
 175
 176 : do-request ( request -- response )
 177     '[
 178         _
 179         {
 180             [ prepare-request ]
 181             [ init-request ]
 182             [ log-request ]
 183             [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
 184         } cleave
 185     ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
 186
 187 : ?refresh-all ( -- )
 188     development? get-global [ [ refresh-all ] with-global ] when ;
 189
 190 LOG: httpd-benchmark DEBUG
 191
 192 : ?benchmark ( quot -- )
 193     benchmark? get [
 194         [ benchmark ] [ first ] bi url get rot 3array
 195         httpd-benchmark
 196     ] [ call ] if ; inline
 197
 198 TUPLE: http-server < threaded-server ;
 199
 200 SYMBOL: request-limit
 201
 202 request-limit [ 64 1024 * ] initialize
 203
 204 LOG: httpd-bad-request NOTICE
 205
 206 : handle-client-error ( error -- )
 207     dup request-error? [
 208         dup { [ bad-request-line? ] [ parse-error>> got>> empty? ] } 1&&
 209         [ drop ] [ httpd-bad-request <400> write-response ] if
 210     ] [ rethrow ] if ;
 211
 212 M: http-server handle-client*
 213     drop [
 214         [
 215             ?refresh-all
 216             request-limit get limited-input
 217             [ read-request ] ?benchmark
 218             [ do-request ] ?benchmark
 219             [ do-response ] ?benchmark
 220         ] [ handle-client-error ] recover
 221     ] with-destructors ;
 222
 223 : <http-server> ( -- server )
 224     ascii http-server new-threaded-server
 225         "http.server" >>name
 226         "http" protocol-port >>insecure
 227         "https" protocol-port >>secure ;
 228
 229 : httpd ( port -- http-server )
 230     <http-server>
 231         swap >>insecure
 232         f >>secure
 233     start-server ;
 234
 235 : http-insomniac ( -- )
 236     "http.server" { "httpd-hit" } schedule-insomniac ;
 237
 238 "http.server.filters" require
 239 "http.server.dispatchers" require
 240 "http.server.redirection" require
 241 "http.server.static" require
 242 "http.server.cgi" require