1 USING: destructors http http.server http.server.requests http.client
2 http.client.private tools.test multiline fry io.streams.string io.crlf
3 io.encodings.utf8 io.encodings.latin1 io.encodings.binary io.encodings.string
4 io.encodings.ascii kernel arrays splitting sequences assocs io.sockets db
5 db.sqlite make continuations urls hashtables accessors namespaces xml.data
6 random combinators.short-circuit literals ;
9 { "text/plain" "UTF-8" } [ "text/plain" parse-content-type ] unit-test
11 { "text/html" "ASCII" } [ "text/html; charset=ASCII" parse-content-type ] unit-test
13 { "text/html" "utf-8" } [ "text/html; charset=\"utf-8\"" parse-content-type ] unit-test
15 { "application/octet-stream" f } [ "application/octet-stream" parse-content-type ] unit-test
17 { "localhost" f } [ "localhost" parse-host ] unit-test
18 { "localhost" 8888 } [ "localhost:8888" parse-host ] unit-test
19 { "::1" 8888 } [ "::1:8888" parse-host ] unit-test
20 { "127.0.0.1" 8888 } [ "127.0.0.1:8888" parse-host ] unit-test
22 { "localhost" } [ T{ url { protocol "http" } { host "localhost" } } unparse-host ] unit-test
23 { "localhost" } [ T{ url { protocol "http" } { host "localhost" } { port 80 } } unparse-host ] unit-test
24 { "localhost" } [ T{ url { protocol "https" } { host "localhost" } { port 443 } } unparse-host ] unit-test
25 { "localhost:8080" } [ T{ url { protocol "http" } { host "localhost" } { port 8080 } } unparse-host ] unit-test
26 { "localhost:8443" } [ T{ url { protocol "https" } { host "localhost" } { port 8443 } } unparse-host ] unit-test
28 STRING: read-request-test-1
33 Content-type: application/octet-stream
40 { url T{ url { path "/bar" } } }
41 { proxy-url T{ url } }
44 { header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
45 { post-data T{ post-data { data "blah" } { content-type "application/octet-stream" } } }
50 read-request-test-1 lf>crlf [
55 STRING: read-request-test-1'
58 content-type: application/octet-stream
64 ${ read-request-test-1' } [
65 read-request-test-1 lf>crlf
66 [ read-request ] with-string-reader
67 [ write-request ] with-string-writer
69 split-lines join-lines
72 STRING: read-request-test-2
80 { url T{ url { host "www.sex.com" } { path "/bar" } } }
81 { proxy-url T{ url } }
84 { header H{ { "host" "www.sex.com" } } }
89 read-request-test-2 lf>crlf [
94 STRING: read-request-test-2'
102 { url T{ url { host "www.sex.com" } { port 101 } { path "/bar" } } }
103 { proxy-url T{ url } }
106 { header H{ { "host" "www.sex.com:101" } } }
111 read-request-test-2' lf>crlf [
116 STRING: read-request-test-3
121 STRING: read-request-test-4
123 Host: "www.amazon.com"
128 read-request-test-4 lf>crlf [ read-request ] with-string-reader
132 STRING: read-response-test-1
133 HTTP/1.1 404 not found
134 Content-Type: text/html; charset=UTF-8
143 { message "not found" }
144 { header H{ { "content-type" "text/html; charset=UTF-8" } } }
146 { content-type "text/html" }
147 { content-charset "UTF-8" }
148 { content-encoding utf8 }
151 read-response-test-1 lf>crlf
152 [ read-response ] with-string-reader
156 STRING: read-response-test-1'
157 HTTP/1.1 404 not found
158 content-type: text/html; charset=UTF-8
162 ${ read-response-test-1' } [
163 URL" http://localhost/" url set
164 read-response-test-1 lf>crlf
165 [ read-response ] with-string-reader
166 [ write-response ] with-string-writer
168 split-lines join-lines
172 "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
173 dup parse-set-cookie first unparse-set-cookie =
182 { domain "example.com" }
185 } [ "lang=en-US; Path=/; Domain=example.com" parse-set-cookie ] unit-test
189 dup parse-set-cookie first unparse-set-cookie =
192 STRING: read-response-test-2
193 HTTP/1.1 200 Content follows
194 Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456
200 read-response-test-2 lf>crlf
201 [ read-response ] with-string-reader
205 STRING: read-response-test-3
206 HTTP/1.1 200 Content follows
207 Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes
213 read-response-test-3 lf>crlf
214 [ read-response ] with-string-reader
219 USING: http.server.static furnace.sessions furnace.alloy
220 furnace.actions furnace.auth furnace.auth.login furnace.db
221 io.servers io.files io.files.temp io.directories io
223 http.server.responses http.server.redirection furnace.redirection
224 http.server.dispatchers db.tuples ;
226 : add-quit-action ( responder -- responder )
228 [ stop-this-server "Goodbye" "text/html" <content> ] >>display
229 "quit" add-responder ;
231 : test-db-file ( -- path ) "test.db" temp-file ;
233 : test-db ( -- db ) test-db-file <sqlite-db> ;
235 : add-addr ( url -- url' )
236 >url clone "addr" get set-url-addr ;
238 : stop-test-httpd ( -- )
239 "http://localhost/quit" add-addr http-get nip
243 test-db-file ?delete-file
250 : test-with-dispatcher ( dispatcher quot -- )
251 [ main-responder ] dip '[
252 <http-server> 0 >>insecure f >>secure
254 server-addrs random "addr" set @
255 ] with-threaded-server
256 ] with-variable ; inline
260 :: test-with-db-persistence ( db-persistence quot -- )
262 quot test-with-dispatcher
263 ] with-disposal ; inline
268 "vocab:http/test" <static> >>default
269 "nested" add-responder
271 [ URL" redirect-loop" <temporary-redirect> ] >>display
272 "redirect-loop" add-responder [
275 "vocab:http/test/foo.html" ascii file-contents
276 "http://localhost/nested/foo.html" add-addr http-get nip =
279 [ "http://localhost/redirect-loop" add-addr http-get nip ]
280 [ too-many-redirects? ] must-fail-with
283 "http://localhost/quit" add-addr http-get nip
286 ] test-with-dispatcher
288 ! HTTP client redirect bug
291 <action> [ "quit" <temporary-redirect> ] >>display
292 "redirect" add-responder [
295 "http://localhost/redirect" add-addr http-get nip
299 [ stop-test-httpd ] ignore-errors
302 ] test-with-dispatcher
305 : 404? ( response -- ? )
308 [ response>> response? ]
309 [ response>> code>> 404 = ]
319 <action> "" add-responder
321 test-db <db-persistence> [
323 ! This should give a 404 not an infinite redirect loop
324 [ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with
326 ! This should give a 404 not an infinite redirect loop
327 [ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with
329 [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
331 ] test-with-db-persistence
334 <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
339 test-db <db-persistence> [
341 [ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test
343 [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
345 ] test-with-db-persistence
347 USING: html.components html.forms
348 xml xml.traversal validators
349 furnace furnace.conversations ;
353 : test-a ( xml -- value )
354 string>xml body>> "input" deep-tag-named "value" attr ;
358 [ a get-global "a" set-value ] >>init
359 [ [ "<!DOCTYPE html><html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display
360 [ { { "a" [ v-integer ] } } validate-params ] >>validate
361 [ "a" value a set-global URL" " <redirect> ] >>submit
366 test-db <db-persistence> [
371 "http://localhost/" add-addr http-get
372 swap dup cookies>> "cookies" set session-id-key get-cookie
373 value>> "session-id" set test-a
379 "http://localhost" add-addr "__u" ,,
380 "session-id" get session-id-key ,,
382 "http://localhost/" add-addr <post-request> "cookies" get >>cookies
383 http-request nip test-a
386 [ 4 ] [ a get-global ] unit-test
392 "http://localhost" add-addr "__u" ,,
393 "session-id" get session-id-key ,,
395 "http://localhost/" add-addr <post-request> "cookies" get >>cookies
396 http-request nip test-a
399 [ 4 ] [ a get-global ] unit-test
401 [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
403 ] test-with-db-persistence
406 { f } [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
407 { f } [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
410 { "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" } [
411 <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header
414 ! Test a corner case with static responder
417 "vocab:http/test/foo.html" <static> >>default [
419 "http://localhost/" add-addr http-get nip
420 "vocab:http/test/foo.html" ascii file-contents =
423 [ ] [ stop-test-httpd ] unit-test
425 ] test-with-dispatcher
427 ! Check behavior of 307 redirect (reported by Chris Double)
431 [ "b" <temporary-redirect> ] >>submit
435 request get post-data>> data>> "data" =
436 [ "OK" "text/plain" <content> ] [ "OOPS" throw ] if
440 [ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test
442 ! Check that download throws errors (reported by Chris Double)
445 "http://localhost/tweet_my_twat" add-addr download
446 ] with-temp-directory
449 [ ] [ stop-test-httpd ] unit-test
451 ] test-with-dispatcher
453 ! Check that index.fhtml works
455 "resource:basis/http/test/" <static> enable-fhtml >>default
458 [ "OK\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test
460 [ ] [ stop-test-httpd ] unit-test
462 ] test-with-dispatcher
464 ! Check that just closing the socket without sending anything works
467 [ ] [ "addr" get binary [ ] with-client ] unit-test
469 [ ] [ stop-test-httpd ] unit-test
471 ] test-with-dispatcher