factor/basis/http/http-tests.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