basis/http/http-tests.factor

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