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.latin1 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 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     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     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 {
 177     {
 178         T{ cookie
 179             { name "lang" }
 180             { value "en-US" }
 181             { path "/" }
 182             { domain "example.com" }
 183         }
 184     }
 185 } [ "lang=en-US; Path=/; Domain=example.com" parse-set-cookie ] unit-test
 186
 187 { t } [
 188     "a="
 189     dup parse-set-cookie first unparse-set-cookie =
 190 ] unit-test
 191
 192 STRING: read-response-test-2
 193 HTTP/1.1 200 Content follows
 194 Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456
 195
 196
 197 ;
 198
 199 { 2 } [
 200     read-response-test-2 lf>crlf
 201     [ read-response ] with-string-reader
 202     cookies>> length
 203 ] unit-test
 204
 205 STRING: read-response-test-3
 206 HTTP/1.1 200 Content follows
 207 Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes
 208
 209
 210 ;
 211
 212 { 1 } [
 213     read-response-test-3 lf>crlf
 214     [ read-response ] with-string-reader
 215     cookies>> length
 216 ] unit-test
 217
 218 ! Live-fire exercise
 219 USING: http.server.static furnace.sessions furnace.alloy
 220 furnace.actions furnace.auth furnace.auth.login furnace.db
 221 io.servers io.files io.files.temp io.directories io
 222 threads
 223 http.server.responses http.server.redirection furnace.redirection
 224 http.server.dispatchers db.tuples ;
 225
 226 : add-quit-action ( responder -- responder )
 227     <action>
 228         [ stop-this-server "Goodbye" "text/html" <content> ] >>display
 229     "quit" add-responder ;
 230
 231 : test-db-file ( -- path ) "test.db" temp-file ;
 232
 233 : test-db ( -- db ) test-db-file <sqlite-db> ;
 234
 235 : add-addr ( url -- url' )
 236     >url clone "addr" get set-url-addr ;
 237
 238 : stop-test-httpd ( -- )
 239     "http://localhost/quit" add-addr http-get nip
 240     "Goodbye" assert= ;
 241
 242 { } [
 243     test-db-file ?delete-file
 244
 245     test-db [
 246         init-furnace-tables
 247     ] with-db
 248 ] unit-test
 249
 250 : test-with-dispatcher ( dispatcher quot -- )
 251     [ main-responder ] dip '[
 252         <http-server> 0 >>insecure f >>secure
 253         [
 254             server-addrs random "addr" set @
 255         ] with-threaded-server
 256     ] with-variable ; inline
 257
 258 USING: locals ;
 259
 260 :: test-with-db-persistence ( db-persistence quot -- )
 261     db-persistence [
 262         quot test-with-dispatcher
 263     ] with-disposal ; inline
 264
 265 <dispatcher>
 266     add-quit-action
 267     <dispatcher>
 268         "vocab:http/test" <static> >>default
 269     "nested" add-responder
 270     <action>
 271         [ URL" redirect-loop" <temporary-redirect> ] >>display
 272     "redirect-loop" add-responder [
 273
 274     [ t ] [
 275         "vocab:http/test/foo.html" ascii file-contents
 276         "http://localhost/nested/foo.html" add-addr http-get nip =
 277     ] unit-test
 278
 279     [ "http://localhost/redirect-loop" add-addr http-get nip ]
 280     [ too-many-redirects? ] must-fail-with
 281
 282     [ "Goodbye" ] [
 283         "http://localhost/quit" add-addr http-get nip
 284     ] unit-test
 285
 286 ] test-with-dispatcher
 287
 288 ! HTTP client redirect bug
 289 <dispatcher>
 290     add-quit-action
 291     <action> [ "quit" <temporary-redirect> ] >>display
 292     "redirect" add-responder [
 293
 294     [ "Goodbye" ] [
 295         "http://localhost/redirect" add-addr http-get nip
 296     ] unit-test
 297
 298     [ ] [
 299         [ stop-test-httpd ] ignore-errors
 300     ] unit-test
 301
 302 ] test-with-dispatcher
 303
 304 ! Dispatcher bugs
 305 : 404? ( response -- ? )
 306     {
 307         [ download-failed? ]
 308         [ response>> response? ]
 309         [ response>> code>> 404 = ]
 310     } 1&& ;
 311
 312 <dispatcher>
 313     <action> <protected>
 314     "Test" <login-realm>
 315     <sessions>
 316     "" add-responder
 317     add-quit-action
 318     <dispatcher>
 319         <action> "" add-responder
 320     "d" add-responder
 321 test-db <db-persistence> [
 322
 323     ! This should give a 404 not an infinite redirect loop
 324     [ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with
 325
 326     ! This should give a 404 not an infinite redirect loop
 327     [ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with
 328
 329     [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
 330
 331 ] test-with-db-persistence
 332
 333 <dispatcher>
 334     <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
 335     "Test" <login-realm>
 336     <sessions>
 337     "" add-responder
 338     add-quit-action
 339 test-db <db-persistence> [
 340
 341         [ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test
 342
 343         [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
 344
 345 ] test-with-db-persistence
 346
 347 USING: html.components html.forms
 348 xml xml.traversal validators
 349 furnace furnace.conversations ;
 350
 351 SYMBOL: a
 352
 353 : test-a ( xml -- value )
 354     string>xml body>> "input" deep-tag-named "value" attr ;
 355
 356 <dispatcher>
 357     <action>
 358         [ a get-global "a" set-value ] >>init
 359         [ [ "<!DOCTYPE html><html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display
 360         [ { { "a" [ v-integer ] } } validate-params ] >>validate
 361         [ "a" value a set-global URL" " <redirect> ] >>submit
 362     <conversations>
 363     <sessions>
 364     >>default
 365     add-quit-action
 366 test-db <db-persistence> [
 367
 368     3 a set-global
 369
 370     [ "3" ] [
 371         "http://localhost/" add-addr http-get
 372         swap dup cookies>> "cookies" set session-id-key get-cookie
 373         value>> "session-id" set test-a
 374     ] unit-test
 375
 376     [ "4" ] [
 377         [
 378             "4" "a" ,,
 379             "http://localhost" add-addr "__u" ,,
 380             "session-id" get session-id-key ,,
 381         ] H{ } make
 382         "http://localhost/" add-addr <post-request> "cookies" get >>cookies
 383         http-request nip test-a
 384     ] unit-test
 385
 386     [ 4 ] [ a get-global ] unit-test
 387
 388     ! Test flash scope
 389     [ "xyz" ] [
 390         [
 391             "xyz" "a" ,,
 392             "http://localhost" add-addr "__u" ,,
 393             "session-id" get session-id-key ,,
 394         ] H{ } make
 395         "http://localhost/" add-addr <post-request> "cookies" get >>cookies
 396         http-request nip test-a
 397     ] unit-test
 398
 399     [ 4 ] [ a get-global ] unit-test
 400
 401     [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
 402
 403 ] test-with-db-persistence
 404
 405 ! Test cloning
 406 { f } [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
 407 { f } [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
 408
 409 ! Test basic auth
 410 { "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" } [
 411     <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header
 412 ] unit-test
 413
 414 ! Test a corner case with static responder
 415 <dispatcher>
 416     add-quit-action
 417     "vocab:http/test/foo.html" <static> >>default [
 418     [ t ] [
 419         "http://localhost/" add-addr http-get nip
 420         "vocab:http/test/foo.html" ascii file-contents =
 421     ] unit-test
 422
 423     [ ] [ stop-test-httpd ] unit-test
 424
 425 ] test-with-dispatcher
 426
 427 ! Check behavior of 307 redirect (reported by Chris Double)
 428 <dispatcher>
 429     add-quit-action
 430     <action>
 431         [ "b" <temporary-redirect> ] >>submit
 432     "a" add-responder
 433     <action>
 434         [
 435             request get post-data>> data>> "data" =
 436             [ "OK" "text/plain" <content> ] [ "OOPS" throw ] if
 437         ] >>submit
 438     "b" add-responder [
 439
 440     [ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test
 441
 442     ! Check that download throws errors (reported by Chris Double)
 443     [
 444         [
 445             "http://localhost/tweet_my_twat" add-addr download
 446         ] with-temp-directory
 447     ] must-fail
 448
 449     [ ] [ stop-test-httpd ] unit-test
 450
 451 ] test-with-dispatcher
 452
 453 ! Check that index.fhtml works
 454 <dispatcher>
 455     "resource:basis/http/test/" <static> enable-fhtml >>default
 456     add-quit-action [
 457
 458     [ "OK\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test
 459
 460     [ ] [ stop-test-httpd ] unit-test
 461
 462 ] test-with-dispatcher
 463
 464 ! Check that just closing the socket without sending anything works
 465 <dispatcher>
 466     add-quit-action [
 467     [ ] [ "addr" get binary [ ] with-client ] unit-test
 468
 469     [ ] [ stop-test-httpd ] unit-test
 470
 471 ] test-with-dispatcher