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
17 fry logging logging.insomniac calendar urls
26 : check-absolute ( url -- url )
27 dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
29 : read-request-line ( request -- request )
30 read-crlf parse-request-line first3
31 [ >>method ] [ >url check-absolute >>url ] [ >>version ] tri* ;
33 : read-request-header ( request -- request )
34 read-header >>header ;
36 : parse-post-data ( post-data -- post-data )
37 [ ] [ raw>> ] [ content-type>> ] tri
38 "application/x-www-form-urlencoded" = [ query>assoc ] when
41 : read-post-data ( request -- request )
42 dup method>> "POST" = [
44 [ "content-length" header string>number read ]
45 [ "content-type" header ] tri
46 <post-data> parse-post-data >>post-data
49 : extract-host ( request -- request )
50 [ ] [ url>> ] [ "host" header parse-host ] tri
51 [ >>host ] [ >>port ] bi*
54 : extract-cookies ( request -- request )
55 dup "cookie" header [ parse-cookie >>cookies ] when* ;
57 : read-request ( -- request )
65 GENERIC: write-response ( response -- )
67 GENERIC: write-full-response ( request response -- )
69 : write-response-line ( response -- response )
71 [ "HTTP/" write version>> write bl ]
72 [ code>> present write bl ]
73 [ message>> write crlf ]
76 : unparse-content-type ( request -- content-type )
77 [ content-type>> "application/octet-stream" or ]
78 [ content-charset>> encoding>name ]
80 [ "; charset=" swap 3append ] when* ;
82 : ensure-domain ( cookie -- cookie )
84 url get host>> dup "localhost" =
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
94 ensure-domain unparse-set-cookie
95 "set-cookie" swap 2array over push
99 : write-response-body ( response -- response )
100 dup body>> call-template ;
102 M: response write-response ( respose -- )
104 write-response-header
108 M: response write-full-response ( request response -- )
110 swap method>> "HEAD" = [
111 [ content-charset>> encode-output ]
112 [ write-response-body ]
116 M: raw-response write-response ( respose -- )
121 M: raw-response write-full-response ( response -- )
124 : post-request? ( -- ? ) request get method>> "POST" = ;
126 SYMBOL: responder-nesting
128 SYMBOL: main-responder
134 ! path is a sequence of path component strings
135 GENERIC: call-responder* ( path responder -- response )
137 TUPLE: trivial-responder response ;
139 C: <trivial-responder> trivial-responder
141 M: trivial-responder call-responder* nip response>> clone ;
143 main-responder global [ <404> <trivial-responder> or ] change-at
145 : invert-slice ( slice -- slice' )
146 dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
148 : add-responder-nesting ( path responder -- )
149 [ invert-slice ] dip 2array responder-nesting get push ;
151 : call-responder ( path responder -- response )
152 [ add-responder-nesting ] [ call-responder* ] 2bi ;
154 : http-error. ( error -- )
155 "Internal server error" [
156 [ print-error nl :c ] with-html-stream
159 : <500> ( error -- response )
160 500 "Internal server error" <trivial-response>
161 swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ;
163 : do-response ( response -- )
164 [ request get swap write-full-response ]
166 [ \ do-response log-error ]
170 [ http-error. ] [ drop "Response error" write ] if
171 ] with-encoded-output
175 LOG: httpd-hit NOTICE
177 LOG: httpd-header NOTICE
179 : log-header ( headers name -- )
180 tuck header 2array httpd-header ;
182 : log-request ( request -- )
183 [ [ method>> ] [ url>> ] bi 2array httpd-hit ]
184 [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
187 : split-path ( string -- path )
190 : init-request ( request -- )
191 [ request set ] [ url>> url set ] bi
192 V{ } clone responder-nesting set ;
194 : dispatch-request ( request -- response )
195 url>> path>> split-path main-responder get call-responder ;
197 : prepare-request ( request -- )
200 [ secure? "https" "http" ? >>protocol ]
201 [ port>> '[ , or ] change-port ]
205 : valid-request? ( request -- ? )
206 url>> port>> local-address get port>> = ;
208 : do-request ( request -- response )
215 [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
217 ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
219 : ?refresh-all ( -- )
220 development? get-global [ global [ refresh-all ] bind ] when ;
222 LOG: httpd-benchmark DEBUG
224 : ?benchmark ( quot -- )
226 [ benchmark ] [ first ] bi url get rot 3array
228 ] [ call ] if ; inline
230 TUPLE: http-server < threaded-server ;
232 M: http-server handle-client*
235 64 1024 * limit-input
237 [ read-request ] ?benchmark
238 [ do-request ] ?benchmark
239 [ do-response ] ?benchmark
242 : <http-server> ( -- server )
243 http-server new-threaded-server
245 "http" protocol-port >>insecure
246 "https" protocol-port >>secure ;
254 : http-insomniac ( -- )
255 "http.server" { "httpd-hit" } schedule-insomniac ;