basis/http/http-tests.factor

   1 USING: http http.server http.client http.client.private tools.test multiline
   2 io.streams.string io.encodings.utf8 io.encodings.8-bit
   3 io.encodings.binary io.encodings.string kernel arrays splitting
   4 sequences assocs io.sockets db db.sqlite continuations urls
   5 hashtables accessors namespaces ;
   6 IN: http.tests
   7
   8 [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
   9
  10 [ "text/html" utf8 ] [ "text/html;  charset=UTF-8" parse-content-type ] unit-test
  11
  12 [ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
  13
  14 [ { } ] [ "" parse-cookie ] unit-test
  15 [ { } ] [ "" parse-set-cookie ] unit-test
  16
  17 ! Make sure that totally invalid cookies don't confuse us
  18 [ { } ] [ "hello world; how are you" parse-cookie ] unit-test
  19
  20 : lf>crlf "\n" split "\r\n" join ;
  21
  22 STRING: read-request-test-1
  23 POST /bar HTTP/1.1
  24 Some-Header: 1
  25 Some-Header: 2
  26 Content-Length: 4
  27 Content-type: application/octet-stream
  28
  29 blah
  30 ;
  31
  32 [
  33     T{ request
  34         { url T{ url { path "/bar" } } }
  35         { method "POST" }
  36         { version "1.1" }
  37         { header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
  38         { post-data T{ post-data { data "blah" } { content-type "application/octet-stream" } } }
  39         { cookies V{ } }
  40     }
  41 ] [
  42     read-request-test-1 lf>crlf [
  43         read-request
  44     ] with-string-reader
  45 ] unit-test
  46
  47 STRING: read-request-test-1'
  48 POST /bar HTTP/1.1
  49 content-length: 4
  50 content-type: application/octet-stream
  51 some-header: 1; 2
  52
  53 blah
  54 ;
  55
  56 read-request-test-1' 1array [
  57     read-request-test-1 lf>crlf
  58     [ read-request ] with-string-reader
  59     [ write-request ] with-string-writer
  60     ! normalize crlf
  61     string-lines "\n" join
  62 ] unit-test
  63
  64 STRING: read-request-test-2
  65 HEAD  /bar   HTTP/1.1
  66 Host: www.sex.com
  67
  68 ;
  69
  70 [
  71     T{ request
  72         { url T{ url { host "www.sex.com" } { path "/bar" } } }
  73         { method "HEAD" }
  74         { version "1.1" }
  75         { header H{ { "host" "www.sex.com" } } }
  76         { cookies V{ } }
  77     }
  78 ] [
  79     read-request-test-2 lf>crlf [
  80         read-request
  81     ] with-string-reader
  82 ] unit-test
  83
  84 STRING: read-request-test-3
  85 GET nested HTTP/1.0
  86
  87 ;
  88
  89 [ read-request-test-3 lf>crlf [ read-request ] with-string-reader ]
  90 [ "Bad request: URL" = ]
  91 must-fail-with
  92
  93 STRING: read-request-test-4
  94 GET /blah HTTP/1.0
  95 Host: "www.amazon.com"
  96 ;
  97
  98 [ "www.amazon.com" ]
  99 [
 100     read-request-test-4 lf>crlf [ read-request ] with-string-reader
 101     "host" header
 102 ] unit-test
 103
 104 STRING: read-response-test-1
 105 HTTP/1.1 404 not found
 106 Content-Type: text/html; charset=UTF-8
 107
 108 blah
 109 ;
 110
 111 [
 112     T{ response
 113         { version "1.1" }
 114         { code 404 }
 115         { message "not found" }
 116         { header H{ { "content-type" "text/html; charset=UTF-8" } } }
 117         { cookies { } }
 118         { content-type "text/html" }
 119         { content-charset utf8 }
 120     }
 121 ] [
 122     read-response-test-1 lf>crlf
 123     [ read-response ] with-string-reader
 124 ] unit-test
 125
 126
 127 STRING: read-response-test-1'
 128 HTTP/1.1 404 not found
 129 content-type: text/html; charset=UTF-8
 130
 131
 132 ;
 133
 134 read-response-test-1' 1array [
 135     URL" http://localhost/" url set
 136     read-response-test-1 lf>crlf
 137     [ read-response ] with-string-reader
 138     [ write-response ] with-string-writer
 139     ! normalize crlf
 140     string-lines "\n" join
 141 ] unit-test
 142
 143 [ t ] [
 144     "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
 145     dup parse-set-cookie first unparse-set-cookie =
 146 ] unit-test
 147
 148 [ t ] [
 149     "a="
 150     dup parse-set-cookie first unparse-set-cookie =
 151 ] unit-test
 152
 153 STRING: read-response-test-2
 154 HTTP/1.1 200 Content follows
 155 Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456
 156
 157
 158 ;
 159
 160 [ 2 ] [
 161     read-response-test-2 lf>crlf
 162     [ read-response ] with-string-reader
 163     cookies>> length
 164 ] unit-test
 165
 166 STRING: read-response-test-3
 167 HTTP/1.1 200 Content follows
 168 Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes
 169
 170
 171 ;
 172
 173 [ 1 ] [
 174     read-response-test-3 lf>crlf
 175     [ read-response ] with-string-reader
 176     cookies>> length
 177 ] unit-test
 178
 179 ! Live-fire exercise
 180 USING: http.server http.server.static furnace.sessions furnace.alloy
 181 furnace.actions furnace.auth furnace.auth.login furnace.db http.client
 182 io.servers.connection io.files io.files.temp io.directories io io.encodings.ascii
 183 accessors namespaces threads
 184 http.server.responses http.server.redirection furnace.redirection
 185 http.server.dispatchers db.tuples ;
 186
 187 : add-quit-action
 188     <action>
 189         [ stop-this-server "Goodbye" "text/html" <content> ] >>display
 190     "quit" add-responder ;
 191
 192 : test-db-file "test.db" temp-file ;
 193
 194 : test-db test-db-file <sqlite-db> ;
 195
 196 [ test-db-file delete-file ] ignore-errors
 197
 198 test-db [
 199     init-furnace-tables
 200 ] with-db
 201
 202 : test-httpd ( responder -- )
 203     [
 204         main-responder set
 205         <http-server>
 206             0 >>insecure
 207             f >>secure
 208         dup start-server*
 209         sockets>> first addr>> port>>
 210     ] with-scope "port" set ;
 211
 212 [ ] [
 213     <dispatcher>
 214         add-quit-action
 215         <dispatcher>
 216             "resource:basis/http/test" <static> >>default
 217         "nested" add-responder
 218         <action>
 219             [ URL" redirect-loop" <temporary-redirect> ] >>display
 220         "redirect-loop" add-responder
 221
 222     test-httpd
 223 ] unit-test
 224
 225 : add-port ( url -- url' )
 226     >url clone "port" get >>port ;
 227
 228 [ t ] [
 229     "resource:basis/http/test/foo.html" ascii file-contents
 230     "http://localhost/nested/foo.html" add-port http-get nip =
 231 ] unit-test
 232
 233 [ "http://localhost/redirect-loop" add-port http-get nip ]
 234 [ too-many-redirects? ] must-fail-with
 235
 236 [ "Goodbye" ] [
 237     "http://localhost/quit" add-port http-get nip
 238 ] unit-test
 239
 240 ! HTTP client redirect bug
 241 [ ] [
 242     <dispatcher>
 243         add-quit-action
 244         <action> [ "quit" <temporary-redirect> ] >>display
 245         "redirect" add-responder
 246
 247     test-httpd
 248 ] unit-test
 249
 250 [ "Goodbye" ] [
 251     "http://localhost/redirect" add-port http-get nip
 252 ] unit-test
 253
 254
 255 [ ] [
 256     [ "http://localhost/quit" add-port http-get 2drop ] ignore-errors
 257 ] unit-test
 258
 259 ! Dispatcher bugs
 260 [ ] [
 261     <dispatcher>
 262         <action> <protected>
 263         "Test" <login-realm>
 264         <sessions>
 265         "" add-responder
 266         add-quit-action
 267         <dispatcher>
 268             <action> "" add-responder
 269         "d" add-responder
 270     test-db <db-persistence>
 271
 272     test-httpd
 273 ] unit-test
 274
 275 : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
 276
 277 ! This should give a 404 not an infinite redirect loop
 278 [ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with
 279
 280 ! This should give a 404 not an infinite redirect loop
 281 [ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with
 282
 283 [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
 284
 285 [ ] [
 286     <dispatcher>
 287         <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
 288         "Test" <login-realm>
 289         <sessions>
 290         "" add-responder
 291         add-quit-action
 292     test-db <db-persistence>
 293
 294     test-httpd
 295 ] unit-test
 296
 297 [ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test
 298
 299 [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
 300
 301 USING: html.components html.elements html.forms
 302 xml xml.utilities validators
 303 furnace furnace.conversations ;
 304
 305 SYMBOL: a
 306
 307 [ ] [
 308     <dispatcher>
 309         <action>
 310             [ a get-global "a" set-value ] >>init
 311             [ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
 312             [ { { "a" [ v-integer ] } } validate-params ] >>validate
 313             [ "a" value a set-global URL" " <redirect> ] >>submit
 314         <conversations>
 315         <sessions>
 316         >>default
 317         add-quit-action
 318     test-db <db-persistence>
 319
 320     test-httpd
 321 ] unit-test
 322
 323 3 a set-global
 324
 325 : test-a string>xml "input" tag-named "value" swap at ;
 326
 327 [ "3" ] [
 328     "http://localhost/" add-port http-get
 329     swap dup cookies>> "cookies" set session-id-key get-cookie
 330     value>> "session-id" set test-a
 331 ] unit-test
 332
 333 [ "4" ] [
 334     [
 335         "4" "a" set
 336         "http://localhost" add-port "__u" set
 337         "session-id" get session-id-key set
 338     ] H{ } make-assoc
 339     "http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
 340 ] unit-test
 341
 342 [ 4 ] [ a get-global ] unit-test
 343
 344 ! Test flash scope
 345 [ "xyz" ] [
 346     [
 347         "xyz" "a" set
 348         "http://localhost" add-port "__u" set
 349         "session-id" get session-id-key set
 350     ] H{ } make-assoc
 351     "http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
 352 ] unit-test
 353
 354 [ 4 ] [ a get-global ] unit-test
 355
 356 [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
 357
 358 ! Test cloning
 359 [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
 360 [ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test