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