basis/http/http-tests.factor

   1 USING: http http.server http.client http.client.private tools.test
   2 multiline io.streams.string io.encodings.utf8 io.encodings.8-bit
   3 io.encodings.binary io.encodings.string io.encodings.ascii kernel
   4 arrays splitting sequences assocs io.sockets db db.sqlite
   5 continuations urls hashtables accessors namespaces xml.data
   6 io.encodings.8-bit.latin1 random ;
   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
  20 [ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } } unparse-host ] unit-test
  21 [ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } { port 80 } } unparse-host ] unit-test
  22 [ "localhost" ] [ T{ url { protocol "https" } { host "localhost" } { port 443 } } unparse-host ] unit-test
  23 [ "localhost:8080" ] [ T{ url { protocol "http" } { host "localhost" } { port 8080 } } unparse-host ] unit-test
  24 [ "localhost:8443" ] [ T{ url { protocol "https" } { host "localhost" } { port 8443 } } unparse-host ] unit-test
  25
  26 : lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
  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 [ test-db-file delete-file ] ignore-errors
 223
 224 test-db [
 225     init-furnace-tables
 226 ] with-db
 227
 228 : test-httpd ( responder -- )
 229     [
 230         main-responder set
 231         <http-server>
 232             0 >>insecure
 233             f >>secure
 234         start-server
 235         servers>> random addr>> port>>
 236     ] with-scope "port" set ;
 237
 238 [ ] [
 239     <dispatcher>
 240         add-quit-action
 241         <dispatcher>
 242             "vocab:http/test" <static> >>default
 243         "nested" add-responder
 244         <action>
 245             [ URL" redirect-loop" <temporary-redirect> ] >>display
 246         "redirect-loop" add-responder
 247
 248     test-httpd
 249 ] unit-test
 250
 251 : add-port ( url -- url' )
 252     >url clone "port" get >>port ;
 253
 254 [ t ] [
 255     "vocab:http/test/foo.html" ascii file-contents
 256     "http://localhost/nested/foo.html" add-port http-get nip =
 257 ] unit-test
 258
 259 [ "http://localhost/redirect-loop" add-port http-get nip ]
 260 [ too-many-redirects? ] must-fail-with
 261
 262 [ "Goodbye" ] [
 263     "http://localhost/quit" add-port http-get nip
 264 ] unit-test
 265
 266 ! HTTP client redirect bug
 267 [ ] [
 268     <dispatcher>
 269         add-quit-action
 270         <action> [ "quit" <temporary-redirect> ] >>display
 271         "redirect" add-responder
 272
 273     test-httpd
 274 ] unit-test
 275
 276 [ "Goodbye" ] [
 277     "http://localhost/redirect" add-port http-get nip
 278 ] unit-test
 279
 280
 281 [ ] [
 282     [ "http://localhost/quit" add-port http-get 2drop ] ignore-errors
 283 ] unit-test
 284
 285 ! Dispatcher bugs
 286 [ ] [
 287     <dispatcher>
 288         <action> <protected>
 289         "Test" <login-realm>
 290         <sessions>
 291         "" add-responder
 292         add-quit-action
 293         <dispatcher>
 294             <action> "" add-responder
 295         "d" add-responder
 296     test-db <db-persistence>
 297
 298     test-httpd
 299 ] unit-test
 300
 301 : 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ;
 302
 303 ! This should give a 404 not an infinite redirect loop
 304 [ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with
 305
 306 ! This should give a 404 not an infinite redirect loop
 307 [ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with
 308
 309 [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
 310
 311 [ ] [
 312     <dispatcher>
 313         <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
 314         "Test" <login-realm>
 315         <sessions>
 316         "" add-responder
 317         add-quit-action
 318     test-db <db-persistence>
 319
 320     test-httpd
 321 ] unit-test
 322
 323 [ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test
 324
 325 [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
 326
 327 USING: html.components html.forms
 328 xml xml.traversal validators
 329 furnace furnace.conversations ;
 330
 331 SYMBOL: a
 332
 333 [ ] [
 334     <dispatcher>
 335         <action>
 336             [ a get-global "a" set-value ] >>init
 337             [ [ "<html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display
 338             [ { { "a" [ v-integer ] } } validate-params ] >>validate
 339             [ "a" value a set-global URL" " <redirect> ] >>submit
 340         <conversations>
 341         <sessions>
 342         >>default
 343         add-quit-action
 344     test-db <db-persistence>
 345
 346     test-httpd
 347 ] unit-test
 348
 349 3 a set-global
 350
 351 : test-a ( xml -- value )
 352     string>xml body>> "input" deep-tag-named "value" attr ;
 353
 354 [ "3" ] [
 355     "http://localhost/" add-port http-get
 356     swap dup cookies>> "cookies" set session-id-key get-cookie
 357     value>> "session-id" set test-a
 358 ] unit-test
 359
 360 [ "4" ] [
 361     [
 362         "4" "a" set
 363         "http://localhost" add-port "__u" set
 364         "session-id" get session-id-key set
 365     ] H{ } make-assoc
 366     "http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
 367 ] unit-test
 368
 369 [ 4 ] [ a get-global ] unit-test
 370
 371 ! Test flash scope
 372 [ "xyz" ] [
 373     [
 374         "xyz" "a" set
 375         "http://localhost" add-port "__u" set
 376         "session-id" get session-id-key set
 377     ] H{ } make-assoc
 378     "http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
 379 ] unit-test
 380
 381 [ 4 ] [ a get-global ] unit-test
 382
 383 [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
 384
 385 ! Test cloning
 386 [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
 387 [ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
 388
 389 ! Test basic auth
 390 [ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
 391
 392 ! Test a corner case with static responder
 393 [ ] [
 394     <dispatcher>
 395         add-quit-action
 396         "vocab:http/test/foo.html" <static> >>default
 397     test-httpd
 398 ] unit-test
 399
 400 [ t ] [
 401     "http://localhost/" add-port http-get nip
 402     "vocab:http/test/foo.html" ascii file-contents =
 403 ] unit-test
 404
 405 [ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
 406
 407 ! Check behavior of 307 redirect (reported by Chris Double)
 408 [ ] [
 409     <dispatcher>
 410         add-quit-action
 411         <action>
 412             [ "b" <temporary-redirect> ] >>submit
 413         "a" add-responder
 414         <action>
 415             [
 416                 request get post-data>> data>> "data" =
 417                 [ "OK" "text/plain" <content> ] [ "OOPS" throw ] if
 418             ] >>submit
 419         "b" add-responder
 420     test-httpd
 421 ] unit-test
 422
 423 [ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test
 424
 425 ! Check that download throws errors (reported by Chris Double)
 426 [
 427     "resource:temp" [
 428         "http://localhost/tweet_my_twat" add-port download
 429     ] with-directory
 430 ] must-fail
 431
 432 [ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test