461 lines
12 KiB
Factor
461 lines
12 KiB
Factor
USING: destructors http http.server http.server.requests http.client
|
|
http.client.private tools.test multiline fry io.streams.string io.crlf
|
|
io.encodings.utf8 io.encodings.latin1 io.encodings.binary io.encodings.string
|
|
io.encodings.ascii kernel arrays splitting sequences assocs io.sockets db
|
|
db.sqlite make continuations urls hashtables accessors namespaces xml.data
|
|
random combinators.short-circuit literals ;
|
|
IN: http.tests
|
|
|
|
{ "text/plain" "UTF-8" } [ "text/plain" parse-content-type ] unit-test
|
|
|
|
{ "text/html" "ASCII" } [ "text/html; charset=ASCII" parse-content-type ] unit-test
|
|
|
|
{ "text/html" "utf-8" } [ "text/html; charset=\"utf-8\"" parse-content-type ] unit-test
|
|
|
|
{ "application/octet-stream" f } [ "application/octet-stream" parse-content-type ] unit-test
|
|
|
|
{ "localhost" f } [ "localhost" parse-host ] unit-test
|
|
{ "localhost" 8888 } [ "localhost:8888" parse-host ] unit-test
|
|
{ "::1" 8888 } [ "::1:8888" parse-host ] unit-test
|
|
{ "127.0.0.1" 8888 } [ "127.0.0.1:8888" parse-host ] unit-test
|
|
|
|
{ "localhost" } [ T{ url { protocol "http" } { host "localhost" } } unparse-host ] unit-test
|
|
{ "localhost" } [ T{ url { protocol "http" } { host "localhost" } { port 80 } } unparse-host ] unit-test
|
|
{ "localhost" } [ T{ url { protocol "https" } { host "localhost" } { port 443 } } unparse-host ] unit-test
|
|
{ "localhost:8080" } [ T{ url { protocol "http" } { host "localhost" } { port 8080 } } unparse-host ] unit-test
|
|
{ "localhost:8443" } [ T{ url { protocol "https" } { host "localhost" } { port 8443 } } unparse-host ] unit-test
|
|
|
|
STRING: read-request-test-1
|
|
POST /bar HTTP/1.1
|
|
Some-Header: 1
|
|
Some-Header: 2
|
|
Content-Length: 4
|
|
Content-type: application/octet-stream
|
|
|
|
blah
|
|
;
|
|
|
|
{
|
|
T{ request
|
|
{ url T{ url { path "/bar" } } }
|
|
{ proxy-url T{ url } }
|
|
{ method "POST" }
|
|
{ version "1.1" }
|
|
{ header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
|
|
{ post-data T{ post-data { data "blah" } { content-type "application/octet-stream" } } }
|
|
{ cookies V{ } }
|
|
{ redirects 10 }
|
|
}
|
|
} [
|
|
read-request-test-1 lf>crlf [
|
|
read-request
|
|
] with-string-reader
|
|
] unit-test
|
|
|
|
STRING: read-request-test-1'
|
|
POST /bar HTTP/1.1
|
|
content-length: 4
|
|
content-type: application/octet-stream
|
|
some-header: 1; 2
|
|
|
|
blah
|
|
;
|
|
|
|
${ read-request-test-1' } [
|
|
read-request-test-1 lf>crlf
|
|
[ read-request ] with-string-reader
|
|
[ write-request ] with-string-writer
|
|
! normalize crlf
|
|
string-lines "\n" join
|
|
] unit-test
|
|
|
|
STRING: read-request-test-2
|
|
HEAD /bar HTTP/1.1
|
|
Host: www.sex.com
|
|
|
|
;
|
|
|
|
{
|
|
T{ request
|
|
{ url T{ url { host "www.sex.com" } { path "/bar" } } }
|
|
{ proxy-url T{ url } }
|
|
{ method "HEAD" }
|
|
{ version "1.1" }
|
|
{ header H{ { "host" "www.sex.com" } } }
|
|
{ cookies V{ } }
|
|
{ redirects 10 }
|
|
}
|
|
} [
|
|
read-request-test-2 lf>crlf [
|
|
read-request
|
|
] with-string-reader
|
|
] unit-test
|
|
|
|
STRING: read-request-test-2'
|
|
HEAD /bar HTTP/1.1
|
|
Host: www.sex.com:101
|
|
|
|
;
|
|
|
|
{
|
|
T{ request
|
|
{ url T{ url { host "www.sex.com" } { port 101 } { path "/bar" } } }
|
|
{ proxy-url T{ url } }
|
|
{ method "HEAD" }
|
|
{ version "1.1" }
|
|
{ header H{ { "host" "www.sex.com:101" } } }
|
|
{ cookies V{ } }
|
|
{ redirects 10 }
|
|
}
|
|
} [
|
|
read-request-test-2' lf>crlf [
|
|
read-request
|
|
] with-string-reader
|
|
] unit-test
|
|
|
|
STRING: read-request-test-3
|
|
GET nested HTTP/1.0
|
|
|
|
;
|
|
|
|
STRING: read-request-test-4
|
|
GET /blah HTTP/1.0
|
|
Host: "www.amazon.com"
|
|
;
|
|
|
|
{ "www.amazon.com" }
|
|
[
|
|
read-request-test-4 lf>crlf [ read-request ] with-string-reader
|
|
"host" header
|
|
] unit-test
|
|
|
|
STRING: read-response-test-1
|
|
HTTP/1.1 404 not found
|
|
Content-Type: text/html; charset=UTF-8
|
|
|
|
blah
|
|
;
|
|
|
|
{
|
|
T{ response
|
|
{ version "1.1" }
|
|
{ code 404 }
|
|
{ message "not found" }
|
|
{ header H{ { "content-type" "text/html; charset=UTF-8" } } }
|
|
{ cookies { } }
|
|
{ content-type "text/html" }
|
|
{ content-charset "UTF-8" }
|
|
{ content-encoding utf8 }
|
|
}
|
|
} [
|
|
read-response-test-1 lf>crlf
|
|
[ read-response ] with-string-reader
|
|
] unit-test
|
|
|
|
|
|
STRING: read-response-test-1'
|
|
HTTP/1.1 404 not found
|
|
content-type: text/html; charset=UTF-8
|
|
|
|
;
|
|
|
|
${ read-response-test-1' } [
|
|
URL" http://localhost/" url set
|
|
read-response-test-1 lf>crlf
|
|
[ read-response ] with-string-reader
|
|
[ write-response ] with-string-writer
|
|
! normalize crlf
|
|
string-lines "\n" join
|
|
] unit-test
|
|
|
|
{ t } [
|
|
"rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
|
|
dup parse-set-cookie first unparse-set-cookie =
|
|
] unit-test
|
|
|
|
{ t } [
|
|
"a="
|
|
dup parse-set-cookie first unparse-set-cookie =
|
|
] unit-test
|
|
|
|
STRING: read-response-test-2
|
|
HTTP/1.1 200 Content follows
|
|
Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456
|
|
|
|
|
|
;
|
|
|
|
{ 2 } [
|
|
read-response-test-2 lf>crlf
|
|
[ read-response ] with-string-reader
|
|
cookies>> length
|
|
] unit-test
|
|
|
|
STRING: read-response-test-3
|
|
HTTP/1.1 200 Content follows
|
|
Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes
|
|
|
|
|
|
;
|
|
|
|
{ 1 } [
|
|
read-response-test-3 lf>crlf
|
|
[ read-response ] with-string-reader
|
|
cookies>> length
|
|
] unit-test
|
|
|
|
! Live-fire exercise
|
|
USING: http.server.static furnace.sessions furnace.alloy
|
|
furnace.actions furnace.auth furnace.auth.login furnace.db
|
|
io.servers io.files io.files.temp io.directories io
|
|
threads
|
|
http.server.responses http.server.redirection furnace.redirection
|
|
http.server.dispatchers db.tuples ;
|
|
|
|
: add-quit-action ( responder -- responder )
|
|
<action>
|
|
[ stop-this-server "Goodbye" "text/html" <content> ] >>display
|
|
"quit" add-responder ;
|
|
|
|
: test-db-file ( -- path ) "test.db" temp-file ;
|
|
|
|
: test-db ( -- db ) test-db-file <sqlite-db> ;
|
|
|
|
: add-addr ( url -- url' )
|
|
>url clone "addr" get set-url-addr ;
|
|
|
|
: stop-test-httpd ( -- )
|
|
"http://localhost/quit" add-addr http-get nip
|
|
"Goodbye" assert= ;
|
|
|
|
{ } [
|
|
test-db-file ?delete-file
|
|
|
|
test-db [
|
|
init-furnace-tables
|
|
] with-db
|
|
] unit-test
|
|
|
|
: test-with-dispatcher ( dispatcher quot -- )
|
|
[ main-responder ] dip '[
|
|
<http-server> 0 >>insecure f >>secure
|
|
[
|
|
server-addrs random "addr" set @
|
|
] with-threaded-server
|
|
] with-variable ; inline
|
|
|
|
USING: locals ;
|
|
|
|
:: test-with-db-persistence ( db-persistence quot -- )
|
|
db-persistence [
|
|
quot test-with-dispatcher
|
|
] with-disposal ; inline
|
|
|
|
<dispatcher>
|
|
add-quit-action
|
|
<dispatcher>
|
|
"vocab:http/test" <static> >>default
|
|
"nested" add-responder
|
|
<action>
|
|
[ URL" redirect-loop" <temporary-redirect> ] >>display
|
|
"redirect-loop" add-responder [
|
|
|
|
[ t ] [
|
|
"vocab:http/test/foo.html" ascii file-contents
|
|
"http://localhost/nested/foo.html" add-addr http-get nip =
|
|
] unit-test
|
|
|
|
[ "http://localhost/redirect-loop" add-addr http-get nip ]
|
|
[ too-many-redirects? ] must-fail-with
|
|
|
|
[ "Goodbye" ] [
|
|
"http://localhost/quit" add-addr http-get nip
|
|
] unit-test
|
|
|
|
] test-with-dispatcher
|
|
|
|
! HTTP client redirect bug
|
|
<dispatcher>
|
|
add-quit-action
|
|
<action> [ "quit" <temporary-redirect> ] >>display
|
|
"redirect" add-responder [
|
|
|
|
[ "Goodbye" ] [
|
|
"http://localhost/redirect" add-addr http-get nip
|
|
] unit-test
|
|
|
|
[ ] [
|
|
[ stop-test-httpd ] ignore-errors
|
|
] unit-test
|
|
|
|
] test-with-dispatcher
|
|
|
|
! Dispatcher bugs
|
|
: 404? ( response -- ? )
|
|
{
|
|
[ download-failed? ]
|
|
[ response>> response? ]
|
|
[ response>> code>> 404 = ]
|
|
} 1&& ;
|
|
|
|
<dispatcher>
|
|
<action> <protected>
|
|
"Test" <login-realm>
|
|
<sessions>
|
|
"" add-responder
|
|
add-quit-action
|
|
<dispatcher>
|
|
<action> "" add-responder
|
|
"d" add-responder
|
|
test-db <db-persistence> [
|
|
|
|
! This should give a 404 not an infinite redirect loop
|
|
[ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with
|
|
|
|
! This should give a 404 not an infinite redirect loop
|
|
[ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with
|
|
|
|
[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
|
|
|
|
] test-with-db-persistence
|
|
|
|
<dispatcher>
|
|
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
|
|
"Test" <login-realm>
|
|
<sessions>
|
|
"" add-responder
|
|
add-quit-action
|
|
test-db <db-persistence> [
|
|
|
|
[ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test
|
|
|
|
[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
|
|
|
|
] test-with-db-persistence
|
|
|
|
USING: html.components html.forms
|
|
xml xml.traversal validators
|
|
furnace furnace.conversations ;
|
|
|
|
SYMBOL: a
|
|
|
|
: test-a ( xml -- value )
|
|
string>xml body>> "input" deep-tag-named "value" attr ;
|
|
|
|
<dispatcher>
|
|
<action>
|
|
[ a get-global "a" set-value ] >>init
|
|
[ [ "<!DOCTYPE html><html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display
|
|
[ { { "a" [ v-integer ] } } validate-params ] >>validate
|
|
[ "a" value a set-global URL" " <redirect> ] >>submit
|
|
<conversations>
|
|
<sessions>
|
|
>>default
|
|
add-quit-action
|
|
test-db <db-persistence> [
|
|
|
|
3 a set-global
|
|
|
|
[ "3" ] [
|
|
"http://localhost/" add-addr http-get
|
|
swap dup cookies>> "cookies" set session-id-key get-cookie
|
|
value>> "session-id" set test-a
|
|
] unit-test
|
|
|
|
[ "4" ] [
|
|
[
|
|
"4" "a" ,,
|
|
"http://localhost" add-addr "__u" ,,
|
|
"session-id" get session-id-key ,,
|
|
] H{ } make
|
|
"http://localhost/" add-addr <post-request> "cookies" get >>cookies
|
|
http-request nip test-a
|
|
] unit-test
|
|
|
|
[ 4 ] [ a get-global ] unit-test
|
|
|
|
! Test flash scope
|
|
[ "xyz" ] [
|
|
[
|
|
"xyz" "a" ,,
|
|
"http://localhost" add-addr "__u" ,,
|
|
"session-id" get session-id-key ,,
|
|
] H{ } make
|
|
"http://localhost/" add-addr <post-request> "cookies" get >>cookies
|
|
http-request nip test-a
|
|
] unit-test
|
|
|
|
[ 4 ] [ a get-global ] unit-test
|
|
|
|
[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
|
|
|
|
] test-with-db-persistence
|
|
|
|
! Test cloning
|
|
{ f } [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
|
|
{ f } [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
|
|
|
|
! Test basic auth
|
|
{ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" } [
|
|
<request> "Aladdin" "open sesame" set-basic-auth "Authorization" header
|
|
] unit-test
|
|
|
|
! Test a corner case with static responder
|
|
<dispatcher>
|
|
add-quit-action
|
|
"vocab:http/test/foo.html" <static> >>default [
|
|
[ t ] [
|
|
"http://localhost/" add-addr http-get nip
|
|
"vocab:http/test/foo.html" ascii file-contents =
|
|
] unit-test
|
|
|
|
[ ] [ stop-test-httpd ] unit-test
|
|
|
|
] test-with-dispatcher
|
|
|
|
! Check behavior of 307 redirect (reported by Chris Double)
|
|
<dispatcher>
|
|
add-quit-action
|
|
<action>
|
|
[ "b" <temporary-redirect> ] >>submit
|
|
"a" add-responder
|
|
<action>
|
|
[
|
|
request get post-data>> data>> "data" =
|
|
[ "OK" "text/plain" <content> ] [ "OOPS" throw ] if
|
|
] >>submit
|
|
"b" add-responder [
|
|
|
|
[ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test
|
|
|
|
! Check that download throws errors (reported by Chris Double)
|
|
[
|
|
[
|
|
"http://localhost/tweet_my_twat" add-addr download
|
|
] with-temp-directory
|
|
] must-fail
|
|
|
|
[ ] [ stop-test-httpd ] unit-test
|
|
|
|
] test-with-dispatcher
|
|
|
|
! Check that index.fhtml works
|
|
<dispatcher>
|
|
"resource:basis/http/test/" <static> enable-fhtml >>default
|
|
add-quit-action [
|
|
|
|
[ "OK\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test
|
|
|
|
[ ] [ stop-test-httpd ] unit-test
|
|
|
|
] test-with-dispatcher
|
|
|
|
! Check that just closing the socket without sending anything works
|
|
<dispatcher>
|
|
add-quit-action [
|
|
[ ] [ "addr" get binary [ ] with-client ] unit-test
|
|
|
|
[ ] [ stop-test-httpd ] unit-test
|
|
|
|
] test-with-dispatcher
|