basis/urls/urls-tests.factor

   1 USING: accessors arrays assocs io.sockets io.sockets.secure kernel
   2 linked-assocs present prettyprint sequences tools.test urls ;
   3 IN: urls.tests
   4
   5 { "localhost" f } [ "localhost" parse-host ] unit-test
   6 { "localhost" 8888 } [ "localhost:8888" parse-host ] unit-test
   7
   8 CONSTANT: urls {
   9     {
  10         T{ url
  11            { protocol "http" }
  12            { host "www.apple.com" }
  13            { port 1234 }
  14            { path "/a/path" }
  15            { query LH{ { "a" "b" } } }
  16            { anchor "foo" }
  17          }
  18         "http://www.apple.com:1234/a/path?a=b#foo"
  19     }
  20     {
  21         T{ url
  22            { protocol "http" }
  23            { host "www.apple.com" }
  24            { path "/a/path" }
  25            { query LH{ { "a" "b" } } }
  26            { anchor "foo" }
  27          }
  28         "http://www.apple.com/a/path?a=b#foo"
  29     }
  30     {
  31         T{ url
  32            { protocol "http" }
  33            { host "www.apple.com" }
  34            { port 1234 }
  35            { path "/another/fine/path" }
  36            { anchor "foo" }
  37          }
  38         "http://www.apple.com:1234/another/fine/path#foo"
  39     }
  40     {
  41         T{ url
  42            { path "/a/relative/path" }
  43            { anchor "foo" }
  44          }
  45         "/a/relative/path#foo"
  46     }
  47     {
  48         T{ url
  49            { path "/a/relative/path" }
  50          }
  51         "/a/relative/path"
  52     }
  53     {
  54         T{ url
  55            { path "a/relative/path" }
  56          }
  57         "a/relative/path"
  58     }
  59     {
  60         T{ url
  61            { path "bar" }
  62            { query LH{ { "a" "b" } } }
  63          }
  64         "bar?a=b"
  65     }
  66     {
  67         T{ url
  68            { protocol "ftp" }
  69            { host "ftp.kernel.org" }
  70            { username "slava" }
  71            { path "/" }
  72          }
  73         "ftp://slava@ftp.kernel.org/"
  74     }
  75     {
  76         T{ url
  77            { protocol "ftp" }
  78            { host "ftp.kernel.org" }
  79            { username "slava" }
  80            { password "secret" }
  81            { path "/" }
  82          }
  83         "ftp://slava:secret@ftp.kernel.org/"
  84     }
  85     {
  86         T{ url
  87            { protocol "http" }
  88            { host "foo.com" }
  89            { path "/" }
  90            { query LH{ { "a" f } } }
  91          }
  92         "http://foo.com/?a"
  93     }
  94     ! Capital letters, digits, hyphen, plus and period are allowed
  95     ! characters in the scheme
  96     ! part. https://tools.ietf.org/html/rfc1738#section-5
  97     {
  98         T{ url
  99            { protocol "foo.bar" }
 100            { host "www.google.com" }
 101            { path "/" }
 102          }
 103         "foo.bar://www.google.com/"
 104     }
 105     {
 106         T{ url
 107            { protocol "foo.-bar" }
 108            { host "www.google.com" }
 109            { path "/" }
 110          }
 111         "foo.-bar://www.google.com/"
 112     }
 113     {
 114         T{ url
 115            { protocol "t1000" }
 116            { host "www.google.com" }
 117            { path "/" }
 118          }
 119         "t1000://www.google.com/"
 120     }
 121     {
 122         T{ url
 123             { protocol "no-auth" }
 124             { path "/some/random/path" }
 125         }
 126         "no-auth:/some/random/path"
 127     }
 128     {
 129         T{ url
 130             { protocol "http" }
 131             { host "example.org" }
 132             { path "/" }
 133             { username "user" }
 134             { password "" }
 135         }
 136         "http://user:@example.org/"
 137     }
 138     {
 139         T{ url
 140             { protocol "http" }
 141             { host "example.org" }
 142             { path "/" }
 143             { username "" }
 144             { password "pass" }
 145         }
 146         "http://:pass@example.org/"
 147     }
 148     {
 149         T{ url
 150             { protocol "http" }
 151             { host "example.org" }
 152             { path "/%2F/" }
 153         }
 154         "http://example.org/%2F/"
 155     }
 156 }
 157
 158 urls [
 159     [ 1array ] [ [ >url ] curry ] bi* unit-test
 160 ] assoc-each
 161
 162 urls [
 163     swap [ 1array ] [ [ present ] curry ] bi* unit-test
 164 ] assoc-each
 165
 166 { T{ url
 167     { protocol "http" }
 168     { username "ш" }
 169     { password "ш" }
 170     { host "ш.com" }
 171     { port 1234 }
 172     { path "/ш" }
 173     { query LH{ { "ш" "ш" } } }
 174     { anchor "ш" }
 175   } }
 176 [ "http://ш:ш@ш.com:1234/ш?ш=ш#ш" >url ] unit-test
 177
 178 {
 179     T{ url
 180         { protocol "http" }
 181         { username f }
 182         { password f }
 183         { host "März.com" }
 184         { port f }
 185         { path "/päth" }
 186         { query LH{ { "query" "Dürst" } } }
 187         { anchor "☃" }
 188     }
 189 } [ "http://März.com/päth?query=Dürst#☃" >url ] unit-test
 190
 191 { T{ url
 192     { protocol "https" }
 193     { host "www.google.com" }
 194     { path "/" }
 195    } }
 196 [ "https://www.google.com:/" >url ] unit-test
 197
 198 { "https://www.google.com/" }
 199 [ T{ url
 200     { protocol "https" }
 201     { host "www.google.com" }
 202     { path "/" }
 203 } present ] unit-test
 204
 205 { "b" } [ "a" "b" url-append-path ] unit-test
 206
 207 { "a/b" } [ "a/c" "b" url-append-path ] unit-test
 208
 209 { "a/b" } [ "a/" "b" url-append-path ] unit-test
 210
 211 { "/b" } [ "a" "/b" url-append-path ] unit-test
 212
 213 { "/b" } [ "a/b/" "/b" url-append-path ] unit-test
 214
 215 { "/xxx/bar" } [ "/xxx/baz" "bar" url-append-path ] unit-test
 216
 217 {
 218     T{ url
 219         { protocol "http" }
 220         { host "www.apple.com" }
 221         { port 1234 }
 222         { path "/a/path" }
 223     }
 224 } [
 225     T{ url
 226         { protocol "http" }
 227         { host "www.apple.com" }
 228         { port 1234 }
 229         { path "/foo" }
 230     }
 231
 232     T{ url
 233         { path "/a/path" }
 234     }
 235
 236     derive-url
 237 ] unit-test
 238
 239 {
 240     T{ url
 241         { protocol "http" }
 242         { host "www.apple.com" }
 243         { port 1234 }
 244         { path "/a/path/relative/path" }
 245         { query LH{ { "a" "b" } } }
 246         { anchor "foo" }
 247     }
 248 } [
 249     T{ url
 250         { protocol "http" }
 251         { host "www.apple.com" }
 252         { port 1234 }
 253         { path "/a/path/" }
 254     }
 255
 256     T{ url
 257         { path "relative/path" }
 258         { query LH{ { "a" "b" } } }
 259         { anchor "foo" }
 260     }
 261
 262     derive-url
 263 ] unit-test
 264
 265 {
 266     T{ url
 267         { protocol "http" }
 268         { host "www.apple.com" }
 269         { port 1234 }
 270         { path "/a/path/relative/path" }
 271         { query LH{ { "a" "b" } } }
 272         { anchor "foo" }
 273     }
 274 } [
 275     T{ url
 276         { protocol "http" }
 277         { host "www.apple.com" }
 278         { port 1234 }
 279         { path "/a/path/" }
 280     }
 281
 282     T{ url
 283         { path "relative/path" }
 284         { query LH{ { "a" "b" } } }
 285         { anchor "foo" }
 286     }
 287
 288     derive-url
 289 ] unit-test
 290
 291 {
 292     T{ url
 293         { protocol "http" }
 294         { host "www.apple.com" }
 295         { path "/xxx/baz" }
 296     }
 297 } [
 298     T{ url
 299         { protocol "http" }
 300         { host "www.apple.com" }
 301         { path "/xxx/bar" }
 302     }
 303
 304     T{ url
 305         { path "baz" }
 306     }
 307
 308     derive-url
 309 ] unit-test
 310
 311 {
 312     T{ url
 313         { protocol "https" }
 314         { host "www.apple.com" }
 315         { path "/" }
 316     }
 317 } [
 318     T{ url
 319         { protocol "http" }
 320         { host "www.apple.com" }
 321         { port 80 }
 322         { path "/" }
 323     }
 324
 325     T{ url
 326         { protocol "https" }
 327         { host "www.apple.com" }
 328         { path "/" }
 329     }
 330
 331     derive-url
 332 ] unit-test
 333
 334 ! Support //foo.com, which has the same protocol as the url we derive from
 335 { URL" http://foo.com" }
 336 [ URL" http://google.com" URL" //foo.com" derive-url ] unit-test
 337
 338 { URL" https://foo.com" }
 339 [ URL" https://google.com" URL" //foo.com" derive-url ] unit-test
 340
 341 { "a" } [
 342     <url> "a" "b" set-query-param "b" query-param
 343 ] unit-test
 344
 345 { t } [
 346     URL" http://www.google.com" "foo" "bar" set-query-param
 347     query>> linked-assoc?
 348 ] unit-test
 349
 350 { "foo#3" } [ URL" foo" clone 3 >>anchor present ] unit-test
 351
 352 { "http://www.foo.com/" } [ "http://www.foo.com:80" >url present ] unit-test
 353
 354 { f } [ URL" /gp/redirect.html/002-7009742-0004012?location=http://advantage.amazon.com/gp/vendor/public/join%26token%3d77E3769AB3A5B6CF611699E150DC33010761CE12" protocol>> ] unit-test
 355
 356 {
 357     T{ url
 358         { protocol "http" }
 359         { host "localhost" }
 360         { query LH{ { "foo" "bar" } } }
 361         { path "/" }
 362     }
 363 }
 364 [ "http://localhost?foo=bar" >url ] unit-test
 365
 366 {
 367     T{ url
 368         { protocol "http" }
 369         { host "localhost" }
 370         { query LH{ { "foo" "bar" } } }
 371         { path "/" }
 372     }
 373 }
 374 [ "http://localhost/?foo=bar" >url ] unit-test
 375
 376 { "/" } [ "http://www.jedit.org" >url path>> ] unit-test
 377
 378 { "USING: urls ;\nURL\" foo\"" } [ URL" foo" unparse-use ] unit-test
 379
 380 { T{ inet { host "google.com" } { port 80 } } }
 381 [ URL" http://google.com/" url-addr ] unit-test
 382
 383 {
 384     T{ secure
 385         { addrspec T{ inet { host "google.com" } { port 443 } } }
 386         { hostname "google.com" }
 387     }
 388 }
 389 [ URL" https://google.com/" url-addr ] unit-test
 390
 391 { "git+https" }
 392 [ URL" git+https://google.com/git/factor.git" >url protocol>> ] unit-test
 393
 394 ! Params should be rendered in the order in which they are added.
 395 { "/?foo=foo&bar=bar&baz=baz" } [
 396     URL" /"
 397     "foo" "foo" set-query-param
 398     "bar" "bar" set-query-param
 399     "baz" "baz" set-query-param
 400     present
 401 ] unit-test
 402
 403 ! Scheme characters are
 404 ! case-insensitive. https://tools.ietf.org/html/rfc3986#section-3.1
 405 { URL" http://www.google.com/" } [
 406     URL" HTTP://www.google.com/"
 407 ] unit-test
 408
 409 { URL" https://host:1234/path" } [ URL" https://host:1234/path" redacted-url ] unit-test
 410 { URL" https://user@host:1234/path" } [ URL" https://user@host:1234/path" redacted-url ] unit-test
 411 { URL" https://user:xxxxx@host:1234/path" } [ URL" https://user:password@host:1234/path" redacted-url ] unit-test
 412
 413 {
 414     { "/a/b/c"    "./////d"     "/a/b/d"    }
 415     { "/a/b/c"    "./././././d" "/a/b/d"    }
 416     { "/a/b/c"    "/d"          "/d"        }
 417     { "/a/b/c"    "/./d"        "/d"        }
 418     { "/a/b/c"    "/../d"       "/d"        }
 419     { "/a/b/c"    "/d"          "/d"        }
 420     { "/a/b/c"    "d"           "/a/b/d"    }
 421     { "/a/b/c"    "./d"         "/a/b/d"    }
 422     { "/a/b/c"    "d/"          "/a/b/d/"   }
 423     { "/a/b/c"    "."           "/a/b/"     }
 424     { "/a/b/c"    "./"          "/a/b/"     }
 425     { "/a/b/c"    ".."          "/a/"       }
 426     { "/a/b/c"    "../"         "/a/"       }
 427     { "/a/b/c"    "../d"        "/a/d"      }
 428     { "/a/b/c"    "../.."       "/"         }
 429     { "/a/b/c"    "../../"      "/"         }
 430     { "/a/b/c"    "../../d"     "/d"        }
 431     { "/a/b/c"    "../../../d"  "/d"        }
 432     { "/a/b/c"    "d."          "/a/b/d."   }
 433     { "/a/b/c"    ".d"          "/a/b/.d"   }
 434     { "/a/b/c"    "d.."         "/a/b/d.."  }
 435     { "/a/b/c"    "..d"         "/a/b/..d"  }
 436     { "/a/b/c"    "./../d"      "/a/d"      }
 437     { "/a/b/c"    "./d/."       "/a/b/d/"   }
 438     { "/a/b/c"    "d/./e"       "/a/b/d/e"  }
 439     { "/a/b/c"    "d/../e"      "/a/b/e"    }
 440     { "/a/b/c/d/" "../../e/f"   "/a/b/e/f"  }
 441     { "/a/b/c/d"  "../../e/f"   "/a/e/f"    }
 442     { "/a/b/c/d/" "../../e/f/"  "/a/b/e/f/" }
 443     { "/a/b/c/d"  "../../e/f/"  "/a/e/f/"   }
 444     { "/a/b/c/d/" "/../../e/f/" "/e/f/"     }
 445     { "/a/b/c/d"  "/../../e/f/" "/e/f/"     }
 446 } [
 447     1 cut* swap first2 '[ _ _ url-append-path ] unit-test
 448 ] each
 449
 450 ! RFC 3986 1.1.2.  Examples
 451
 452 {
 453     T{ url
 454         { protocol "ftp" }
 455         { host "ftp.is.co.za" }
 456         { path "/rfc/rfc1808.txt" }
 457     }
 458 } [ "ftp://ftp.is.co.za/rfc/rfc1808.txt" >url ] unit-test
 459
 460 {
 461     T{ url
 462         { protocol "http" }
 463         { host "www.ietf.org" }
 464         { path "/rfc/rfc2396.txt" }
 465     }
 466 } [ "http://www.ietf.org/rfc/rfc2396.txt" >url ] unit-test
 467
 468
 469 {
 470     T{ url
 471         { protocol "ldap" }
 472         { host "[2001:db8::7]" }
 473         { path "/c=GB" }
 474         { query LH{ { "objectClass?one" f } } }
 475     }
 476 } [ "ldap://[2001:db8::7]/c=GB?objectClass?one" >url ] unit-test
 477
 478 {
 479     T{ url
 480         { protocol "mailto" }
 481         { path "John.Doe@example.com" }
 482     }
 483 } [ "mailto:John.Doe@example.com" >url ] unit-test
 484
 485
 486 {
 487     T{ url
 488         { protocol "news" }
 489         { path "comp.infosystems.www.servers.unix" }
 490     }
 491 } [ "news:comp.infosystems.www.servers.unix" >url ] unit-test
 492
 493
 494 {
 495     T{ url
 496         { protocol "tel" }
 497         { path "+1-816-555-1212" }
 498     }
 499 } [ "tel:+1-816-555-1212" >url ] unit-test
 500
 501 {
 502     T{ url
 503         { protocol "telnet" }
 504         { host "192.0.2.16" }
 505         { port 80 }
 506         { path "/" }
 507     }
 508 } [ "telnet://192.0.2.16:80/" >url ] unit-test
 509
 510 {
 511     T{ url
 512         { protocol "urn" }
 513         { path "oasis:names:specification:docbook:dtd:xml:4.1.2" }
 514     }
 515 } [ "urn:oasis:names:specification:docbook:dtd:xml:4.1.2" >url ] unit-test
 516
 517 ! RFC 3986 6.2.2.  Syntax Normalization
 518 { URL" example://a/b/c/%7Bfoo%7D" } [
 519     URL" eXAMPLE://a/./b/../b/%63/%7bfoo%7d"
 520 ] unit-test
 521
 522 ! RFC 3986 6.2.3. Scheme-Based Normalization
 523 { t } [
 524     {
 525       "http://example.com"
 526       "http://example.com/"
 527       "http://example.com:/"
 528       "http://example.com:80/"
 529     } [ >url present "http://example.com/" = ] all?
 530 ] unit-test
 531