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