basis/http/http-tests.factor

   1 USING: accessors combinators.short-circuit continuations db
   2 db.sqlite db.tuples destructors furnace furnace.actions
   3 furnace.alloy furnace.auth furnace.auth.login
   4 furnace.conversations furnace.db furnace.redirection
   5 furnace.sessions html.components html.forms http http.client
   6 http.client.private http.download http.server
   7 http.server.dispatchers http.server.redirection
   8 http.server.requests http.server.responses http.server.static io
   9 io.crlf io.directories io.encodings.ascii io.encodings.binary
  10 io.encodings.utf8 io.files io.files.temp io.servers io.sockets
  11 io.streams.string kernel literals locals make multiline
  12 namespaces random sequences splitting threads tools.test urls
  13 validators xml xml.data xml.traversal ;
  14 IN: http.tests
  15
  16 { "text/plain" "UTF-8" } [ "text/plain" parse-content-type ] unit-test
  17
  18 { "text/html" "ASCII" } [ "text/html;  charset=ASCII" parse-content-type ] unit-test
  19
  20 { "text/html" "utf-8" } [ "text/html; charset=\"utf-8\"" parse-content-type ] unit-test
  21
  22 { "application/octet-stream" f } [ "application/octet-stream" parse-content-type ] unit-test
  23
  24 { "localhost" f } [ "localhost" parse-host ] unit-test
  25 { "localhost" 8888 } [ "localhost:8888" parse-host ] unit-test
  26 { "::1" 8888 } [ "::1:8888" parse-host ] unit-test
  27 { "127.0.0.1" 8888 } [ "127.0.0.1:8888" parse-host ] unit-test
  28
  29 { "localhost" } [ T{ url { protocol "http" } { host "localhost" } } unparse-host ] unit-test
  30 { "localhost" } [ T{ url { protocol "http" } { host "localhost" } { port 80 } } unparse-host ] unit-test
  31 { "localhost" } [ T{ url { protocol "https" } { host "localhost" } { port 443 } } unparse-host ] unit-test
  32 { "localhost:8080" } [ T{ url { protocol "http" } { host "localhost" } { port 8080 } } unparse-host ] unit-test
  33 { "localhost:8443" } [ T{ url { protocol "https" } { host "localhost" } { port 8443 } } unparse-host ] unit-test
  34
  35 STRING: read-request-test-1
  36 POST /bar HTTP/1.1
  37 Some-Header: 1
  38 Some-Header: 2
  39 Content-Length: 4
  40 Content-type: application/octet-stream
  41
  42 blah
  43 ;
  44
  45 {
  46     T{ request
  47         { url T{ url { path "/bar" } } }
  48         { proxy-url T{ url } }
  49         { method "POST" }
  50         { version "1.1" }
  51         { header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
  52         { post-data T{ post-data { data "blah" } { content-type "application/octet-stream" } } }
  53         { cookies V{ } }
  54         { redirects 10 }
  55     }
  56 } [
  57     read-request-test-1 lf>crlf [
  58         read-request
  59     ] with-string-reader
  60 ] unit-test
  61
  62 STRING: read-request-test-1'
  63 POST /bar HTTP/1.1
  64 content-length: 4
  65 content-type: application/octet-stream
  66 some-header: 1; 2
  67
  68 blah
  69 ;
  70
  71 ${ read-request-test-1' } [
  72     read-request-test-1 lf>crlf
  73     [ read-request ] with-string-reader
  74     [ write-request ] with-string-writer
  75     ! normalize crlf
  76     split-lines join-lines
  77 ] unit-test
  78
  79 STRING: read-request-test-2
  80 HEAD  /bar   HTTP/1.1
  81 Host: www.sex.com
  82
  83 ;
  84
  85 {
  86     T{ request
  87         { url T{ url { host "www.sex.com" } { path "/bar" } } }
  88         { proxy-url T{ url } }
  89         { method "HEAD" }
  90         { version "1.1" }
  91         { header H{ { "host" "www.sex.com" } } }
  92         { cookies V{ } }
  93         { redirects 10 }
  94     }
  95 } [
  96     read-request-test-2 lf>crlf [
  97         read-request
  98     ] with-string-reader
  99 ] unit-test
 100
 101 STRING: read-request-test-2'
 102 HEAD  /bar   HTTP/1.1
 103 Host: www.sex.com:101
 104
 105 ;
 106
 107 {
 108     T{ request
 109         { url T{ url { host "www.sex.com" } { port 101 } { path "/bar" } } }
 110         { proxy-url T{ url } }
 111         { method "HEAD" }
 112         { version "1.1" }
 113         { header H{ { "host" "www.sex.com:101" } } }
 114         { cookies V{ } }
 115         { redirects 10 }
 116     }
 117 } [
 118     read-request-test-2' lf>crlf [
 119         read-request
 120     ] with-string-reader
 121 ] unit-test
 122
 123 STRING: read-request-test-3
 124 GET nested HTTP/1.0
 125
 126 ;
 127
 128 STRING: read-request-test-4
 129 GET /blah HTTP/1.0
 130 Host: "www.amazon.com"
 131 ;
 132
 133 { "www.amazon.com" }
 134 [
 135     read-request-test-4 lf>crlf [ read-request ] with-string-reader
 136     "host" header
 137 ] unit-test
 138
 139 STRING: read-response-test-1
 140 HTTP/1.1 404 not found
 141 Content-Type: text/html; charset=UTF-8
 142
 143 blah
 144 ;
 145
 146 {
 147     T{ response
 148         { version "1.1" }
 149         { code 404 }
 150         { message "not found" }
 151         { header H{ { "content-type" "text/html; charset=UTF-8" } } }
 152         { cookies { } }
 153         { content-type "text/html" }
 154         { content-charset "UTF-8" }
 155         { content-encoding utf8 }
 156     }
 157 } [
 158     read-response-test-1 lf>crlf
 159     [ read-response ] with-string-reader
 160 ] unit-test
 161
 162
 163 STRING: read-response-test-1'
 164 HTTP/1.1 404 not found
 165 content-type: text/html; charset=UTF-8
 166
 167 ;
 168
 169 ${ read-response-test-1' } [
 170     URL" http://localhost/" url set
 171     read-response-test-1 lf>crlf
 172     [ read-response ] with-string-reader
 173     [ write-response ] with-string-writer
 174     ! normalize crlf
 175     split-lines join-lines
 176 ] unit-test
 177
 178 { t } [
 179     "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
 180     dup parse-set-cookie first unparse-set-cookie =
 181 ] unit-test
 182
 183 {
 184     {
 185         T{ cookie
 186             { name "lang" }
 187             { value "en-US" }
 188             { path "/" }
 189             { domain "example.com" }
 190         }
 191     }
 192 } [ "lang=en-US; Path=/; Domain=example.com" parse-set-cookie ] unit-test
 193
 194 { t } [
 195     "a="
 196     dup parse-set-cookie first unparse-set-cookie =
 197 ] unit-test
 198
 199 STRING: read-response-test-2
 200 HTTP/1.1 200 Content follows
 201 Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456
 202
 203
 204 ;
 205
 206 { 2 } [
 207     read-response-test-2 lf>crlf
 208     [ read-response ] with-string-reader
 209     cookies>> length
 210 ] unit-test
 211
 212 STRING: read-response-test-3
 213 HTTP/1.1 200 Content follows
 214 Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes
 215
 216
 217 ;
 218
 219 { 1 } [
 220     read-response-test-3 lf>crlf
 221     [ read-response ] with-string-reader
 222     cookies>> length
 223 ] unit-test
 224
 225 ! Live-fire exercise
 226
 227 : add-quit-action ( responder -- responder )
 228     <action>
 229         [ stop-this-server "Goodbye" "text/html" <content> ] >>display
 230     "quit" add-responder ;
 231
 232 : test-db-file ( -- path ) "test.db" temp-file ;
 233
 234 : test-db ( -- db ) test-db-file <sqlite-db> ;
 235
 236 : add-addr ( url -- url' )
 237     >url clone "addr" get set-url-addr ;
 238
 239 : stop-test-httpd ( -- )
 240     "http://localhost/quit" add-addr http-get nip
 241     "Goodbye" assert= ;
 242
 243 { } [
 244     test-db-file ?delete-file
 245
 246     test-db [
 247         init-furnace-tables
 248     ] with-db
 249 ] unit-test
 250
 251 : test-with-dispatcher ( dispatcher quot -- )
 252     [ main-responder ] dip '[
 253         <http-server> 0 >>insecure f >>secure
 254         [
 255             server-addrs random "addr" set @
 256         ] with-threaded-server
 257     ] with-variable ; inline
 258
 259 :: test-with-db-persistence ( db-persistence quot -- )
 260     db-persistence [
 261         quot test-with-dispatcher
 262     ] with-disposal ; inline
 263
 264 <dispatcher>
 265     add-quit-action
 266     <dispatcher>
 267         "vocab:http/test" <static> >>default
 268     "nested" add-responder
 269     <action>
 270         [ URL" redirect-loop" <temporary-redirect> ] >>display
 271     "redirect-loop" add-responder [
 272
 273     [ t ] [
 274         "vocab:http/test/foo.html" ascii file-contents
 275         "http://localhost/nested/foo.html" add-addr http-get nip =
 276     ] unit-test
 277
 278     [ "http://localhost/redirect-loop" add-addr http-get nip ]
 279     [ too-many-redirects? ] must-fail-with
 280
 281     [ "Goodbye" ] [
 282         "http://localhost/quit" add-addr http-get nip
 283     ] unit-test
 284
 285 ] test-with-dispatcher
 286
 287 ! HTTP client redirect bug
 288 <dispatcher>
 289     add-quit-action
 290     <action> [ "quit" <temporary-redirect> ] >>display
 291     "redirect" add-responder [
 292
 293     [ "Goodbye" ] [
 294         "http://localhost/redirect" add-addr http-get nip
 295     ] unit-test
 296
 297     [ ] [
 298         [ stop-test-httpd ] ignore-errors
 299     ] unit-test
 300
 301 ] test-with-dispatcher
 302
 303 ! Dispatcher bugs
 304 : 404? ( response -- ? )
 305     {
 306         [ download-failed? ]
 307         [ response>> response? ]
 308         [ response>> code>> 404 = ]
 309     } 1&& ;
 310
 311 <dispatcher>
 312     <action> <protected>
 313     "Test" <login-realm>
 314     <sessions>
 315     "" add-responder
 316     add-quit-action
 317     <dispatcher>
 318         <action> "" add-responder
 319     "d" add-responder
 320 test-db <db-persistence> [
 321
 322     ! This should give a 404 not an infinite redirect loop
 323     [ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with
 324
 325     ! This should give a 404 not an infinite redirect loop
 326     [ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with
 327
 328     [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
 329
 330 ] test-with-db-persistence
 331
 332 <dispatcher>
 333     <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
 334     "Test" <login-realm>
 335     <sessions>
 336     "" add-responder
 337     add-quit-action
 338 test-db <db-persistence> [
 339
 340         [ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test
 341
 342         [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
 343
 344 ] test-with-db-persistence
 345
 346 SYMBOL: a
 347
 348 : test-a ( xml -- value )
 349     string>xml body>> "input" deep-tag-named "value" attr ;
 350
 351 <dispatcher>
 352     <action>
 353         [ a get-global "a" set-value ] >>init
 354         [ [ "<!DOCTYPE html><html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display
 355         [ { { "a" [ v-integer ] } } validate-params ] >>validate
 356         [ "a" value a set-global URL" " <redirect> ] >>submit
 357     <conversations>
 358     <sessions>
 359     >>default
 360     add-quit-action
 361 test-db <db-persistence> [
 362
 363     3 a set-global
 364
 365     [ "3" ] [
 366         "http://localhost/" add-addr http-get
 367         swap dup cookies>> "cookies" set session-id-key get-cookie
 368         value>> "session-id" set test-a
 369     ] unit-test
 370
 371     [ "4" ] [
 372         [
 373             "4" "a" ,,
 374             "http://localhost" add-addr "__u" ,,
 375             "session-id" get session-id-key ,,
 376         ] H{ } make
 377         "http://localhost/" add-addr <post-request> "cookies" get >>cookies
 378         http-request nip test-a
 379     ] unit-test
 380
 381     [ 4 ] [ a get-global ] unit-test
 382
 383     ! Test flash scope
 384     [ "xyz" ] [
 385         [
 386             "xyz" "a" ,,
 387             "http://localhost" add-addr "__u" ,,
 388             "session-id" get session-id-key ,,
 389         ] H{ } make
 390         "http://localhost/" add-addr <post-request> "cookies" get >>cookies
 391         http-request nip test-a
 392     ] unit-test
 393
 394     [ 4 ] [ a get-global ] unit-test
 395
 396     [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
 397
 398 ] test-with-db-persistence
 399
 400 ! Test cloning
 401 { f } [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
 402 { f } [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
 403
 404 ! Test basic auth
 405 { "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" } [
 406     <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header
 407 ] unit-test
 408
 409 ! Test a corner case with static responder
 410 <dispatcher>
 411     add-quit-action
 412     "vocab:http/test/foo.html" <static> >>default [
 413     [ t ] [
 414         "http://localhost/" add-addr http-get nip
 415         "vocab:http/test/foo.html" ascii file-contents =
 416     ] unit-test
 417
 418     [ ] [ stop-test-httpd ] unit-test
 419
 420 ] test-with-dispatcher
 421
 422 ! Check behavior of 307 redirect (reported by Chris Double)
 423 <dispatcher>
 424     add-quit-action
 425     <action>
 426         [ "b" <temporary-redirect> ] >>submit
 427     "a" add-responder
 428     <action>
 429         [
 430             request get post-data>> data>> "data" =
 431             [ "OK" "text/plain" <content> ] [ "OOPS" throw ] if
 432         ] >>submit
 433     "b" add-responder [
 434
 435     [ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test
 436
 437     ! Check that download throws errors (reported by Chris Double)
 438     [
 439         [
 440             "http://localhost/tweet_my_twat" add-addr download drop
 441         ] with-temp-directory
 442     ] must-fail
 443
 444     [ ] [ stop-test-httpd ] unit-test
 445
 446 ] test-with-dispatcher
 447
 448 ! Check that index.fhtml works
 449 <dispatcher>
 450     "resource:basis/http/test/" <static> enable-fhtml >>default
 451     add-quit-action [
 452
 453     [ "OK\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test
 454
 455     [ ] [ stop-test-httpd ] unit-test
 456
 457 ] test-with-dispatcher
 458
 459 ! Check that just closing the socket without sending anything works
 460 <dispatcher>
 461     add-quit-action [
 462     [ ] [ "addr" get binary [ ] with-client ] unit-test
 463
 464     [ ] [ stop-test-httpd ] unit-test
 465
 466 ] test-with-dispatcher