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 urls.encoding
27 \ parse-cookie DEBUG add-input-logging
29 : check-absolute ( url -- url )
30 dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
32 : read-request-line ( request -- request )
33 read-crlf parse-request-line first3
34 [ >>method ] [ >url check-absolute >>url ] [ >>version ] tri* ;
36 : read-request-header ( request -- request )
37 read-header >>header ;
39 : parse-post-data ( post-data -- post-data )
40 [ ] [ raw>> ] [ content-type>> ] tri
41 "application/x-www-form-urlencoded" = [ query>assoc ] when
44 : read-post-data ( request -- request )
45 dup method>> "POST" = [
47 [ "content-length" header string>number read ]
48 [ "content-type" header ] tri
49 <post-data> parse-post-data >>post-data
52 : extract-host ( request -- request )
53 [ ] [ url>> ] [ "host" header parse-host ] tri
54 [ >>host ] [ >>port ] bi*
57 : extract-cookies ( request -- request )
58 dup "cookie" header [ parse-cookie >>cookies ] when* ;
60 : read-request ( -- request )
68 GENERIC: write-response ( response -- )
70 GENERIC: write-full-response ( request response -- )
72 : write-response-line ( response -- response )
74 [ "HTTP/" write version>> write bl ]
75 [ code>> present write bl ]
76 [ message>> write crlf ]
79 : unparse-content-type ( request -- content-type )
80 [ content-type>> "application/octet-stream" or ]
81 [ content-charset>> encoding>name ]
83 [ "; charset=" swap 3append ] when* ;
85 : ensure-domain ( cookie -- cookie )
87 url get host>> dup "localhost" =
91 : write-response-header ( response -- response )
92 #! We send one set-cookie header per cookie, because that's
93 #! what Firefox expects.
94 dup header>> >alist >vector
95 over unparse-content-type "content-type" pick set-at
97 ensure-domain unparse-set-cookie
98 "set-cookie" swap 2array over push
102 : write-response-body ( response -- response )
103 dup body>> call-template ;
105 M: response write-response ( respose -- )
107 write-response-header
111 M: response write-full-response ( request response -- )
113 swap method>> "HEAD" = [
114 [ content-charset>> encode-output ]
115 [ write-response-body ]
119 M: raw-response write-response ( respose -- )
124 M: raw-response write-full-response ( response -- )
127 : post-request? ( -- ? ) request get method>> "POST" = ;
129 SYMBOL: responder-nesting
131 SYMBOL: main-responder
137 ! path is a sequence of path component strings
138 GENERIC: call-responder* ( path responder -- response )
140 TUPLE: trivial-responder response ;
142 C: <trivial-responder> trivial-responder
144 M: trivial-responder call-responder* nip response>> clone ;
146 main-responder global [ <404> <trivial-responder> or ] change-at
148 : invert-slice ( slice -- slice' )
149 dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
151 : add-responder-nesting ( path responder -- )
152 [ invert-slice ] dip 2array responder-nesting get push ;
154 : call-responder ( path responder -- response )
155 [ add-responder-nesting ] [ call-responder* ] 2bi ;
157 : http-error. ( error -- )
158 "Internal server error" [ ] [
159 [ print-error nl :c ] with-html-writer
162 : <500> ( error -- response )
163 500 "Internal server error" <trivial-response>
164 swap development? get [ '[ _ http-error. ] >>body ] [ drop ] if ;
166 : do-response ( response -- )
167 [ request get swap write-full-response ]
169 [ \ do-response log-error ]
173 [ http-error. ] [ drop "Response error" write ] if
174 ] with-encoded-output
178 LOG: httpd-hit NOTICE
180 LOG: httpd-header NOTICE
182 : log-header ( headers name -- )
183 tuck header 2array httpd-header ;
185 : log-request ( request -- )
186 [ [ method>> ] [ url>> ] bi 2array httpd-hit ]
187 [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
190 : split-path ( string -- path )
193 : init-request ( request -- )
194 [ request set ] [ url>> url set ] bi
195 V{ } clone responder-nesting set ;
197 : dispatch-request ( request -- response )
198 url>> path>> split-path main-responder get call-responder ;
200 : prepare-request ( request -- )
203 [ secure? "https" "http" ? >>protocol ]
204 [ port>> remap-port '[ _ or ] change-port ]
208 : valid-request? ( request -- ? )
209 url>> port>> remap-port
210 local-address get port>> remap-port = ;
212 : do-request ( request -- response )
219 [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
221 ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
223 : ?refresh-all ( -- )
224 development? get-global [ global [ refresh-all ] bind ] when ;
226 LOG: httpd-benchmark DEBUG
228 : ?benchmark ( quot -- )
230 [ benchmark ] [ first ] bi url get rot 3array
232 ] [ call ] if ; inline
234 TUPLE: http-server < threaded-server ;
236 M: http-server handle-client*
239 64 1024 * limit-input
241 [ read-request ] ?benchmark
242 [ do-request ] ?benchmark
243 [ do-response ] ?benchmark
246 : <http-server> ( -- server )
247 http-server new-threaded-server
249 "http" protocol-port >>insecure
250 "https" protocol-port >>secure ;
258 : http-insomniac ( -- )
259 "http.server" { "httpd-hit" } schedule-insomniac ;
263 "http.server.filters" require
264 "http.server.dispatchers" require
265 "http.server.redirection" require
266 "http.server.static" require
267 "http.server.cgi" require