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 ;
14 GENERIC: write-response ( response -- )
16 GENERIC: write-full-response ( request response -- )
18 : write-response-line ( response -- response )
20 [ "HTTP/" write version>> write bl ]
21 [ code>> present write bl ]
22 [ message>> write crlf ]
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* ;
31 : ensure-domain ( cookie -- cookie )
33 url get host>> dup "localhost" =
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
43 ensure-domain unparse-set-cookie
44 "set-cookie" swap 2array suffix!
48 : write-response-body ( response -- response )
49 dup body>> call-template ;
51 M: response write-response
57 M: response write-full-response
59 swap method>> "HEAD" = [
60 [ content-encoding>> encode-output ]
61 [ write-response-body ]
65 M: raw-response write-response
70 M: raw-response write-full-response
73 : post-request? ( -- ? ) request get method>> "POST" = ;
75 SYMBOL: responder-nesting
77 SYMBOL: main-responder
83 ! path is a sequence of path component strings
84 GENERIC: call-responder* ( path responder -- response )
86 TUPLE: trivial-responder response ;
88 C: <trivial-responder> trivial-responder
90 M: trivial-responder call-responder* nip response>> clone ;
92 main-responder [ <404> <trivial-responder> ] initialize
94 : invert-slice ( slice -- slice' )
95 dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
97 : add-responder-nesting ( path responder -- )
98 [ invert-slice ] dip 2array responder-nesting get push ;
100 : call-responder ( path responder -- response )
101 [ add-responder-nesting ] [ call-responder* ] 2bi ;
103 : make-http-error ( error -- xml )
104 [ "Internal server error" f ] dip
105 [ print-error nl :c ] with-html-writer
108 : <500> ( error -- response )
109 500 "Internal server error" <trivial-response>
110 swap development? get [ make-http-error >>body ] [ drop ] if ;
112 : do-response ( response -- )
113 '[ request get _ write-full-response ]
115 [ \ do-response log-error ]
119 [ make-http-error ] [ drop "Response error" ] if
121 ] with-encoded-output
125 LOG: httpd-hit NOTICE
127 LOG: httpd-header NOTICE
129 : log-header ( request name -- )
130 [ nip ] [ header ] 2bi 2array httpd-header ;
132 : log-request ( request -- )
133 [ [ method>> ] [ url>> ] bi 2array httpd-hit ]
134 [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
137 : split-path ( string -- path )
140 : request-params ( request -- assoc )
142 { "GET" [ url>> query>> ] }
143 { "HEAD" [ url>> query>> ] }
144 { "POST" [ post-data>> params>> ] }
149 : param ( name -- value )
152 : set-param ( value name -- )
155 : init-request ( request -- )
158 [ request-params >hashtable params set ] tri
159 V{ } clone responder-nesting set ;
161 : dispatch-request ( request -- response )
162 url>> path>> split-path main-responder get call-responder ;
164 : prepare-request ( request -- )
167 [ secure? "https" "http" ? >>protocol ]
168 [ port>> remap-port >>port ]
172 : valid-request? ( request -- ? )
173 url>> port>> remap-port
174 local-address get port>> remap-port = ;
176 : do-request ( request -- response )
183 [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
185 ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
187 : ?refresh-all ( -- )
188 development? get-global [ [ refresh-all ] with-global ] when ;
190 LOG: httpd-benchmark DEBUG
192 : ?benchmark ( quot -- )
194 [ benchmark ] [ first ] bi url get rot 3array
196 ] [ call ] if ; inline
198 TUPLE: http-server < threaded-server ;
200 SYMBOL: request-limit
202 request-limit [ 64 1024 * ] initialize
204 LOG: httpd-bad-request NOTICE
206 : handle-client-error ( error -- )
208 dup { [ bad-request-line? ] [ parse-error>> got>> empty? ] } 1&&
209 [ drop ] [ httpd-bad-request <400> write-response ] if
212 M: http-server handle-client*
216 request-limit get limited-input
217 [ read-request ] ?benchmark
218 [ do-request ] ?benchmark
219 [ do-response ] ?benchmark
220 ] [ handle-client-error ] recover
223 : <http-server> ( -- server )
224 ascii http-server new-threaded-server
226 "http" protocol-port >>insecure
227 "https" protocol-port >>secure ;
229 : httpd ( port -- http-server )
235 : http-insomniac ( -- )
236 "http.server" { "httpd-hit" } schedule-insomniac ;
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