basis/http/server/server.factor

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