tests.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;; copyright (c) 1999-2001 Franz Inc, Berkeley, CA  - All rights reserved.
   3 ;; copyright (c) 2003 Kevin Rosenberg (significant fixes for using
   4 ;; tester package)
   5 ;;
   6 ;; The software, data and information contained herein are proprietary
   7 ;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
   8 ;; given in confidence by Franz, Inc. pursuant to a written license
   9 ;; agreement, and may be stored and used only in accordance with the terms
  10 ;; of such license.
  11 ;;
  12 ;; Restricted Rights Legend
  13 ;; ------------------------
  14 ;; Use, duplication, and disclosure of the software, data and information
  15 ;; contained herein by any agency, department or entity of the U.S.
  16 ;; Government are subject to restrictions of Restricted Rights for
  17 ;; Commercial Software developed at private expense as specified in
  18 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
  19 ;;
  20 ;; Original version from ACL 6.1:
  21 ;; t-uri.cl,v 1.3.6.3.2.1 2001/08/09 17:42:43 layer
  22 ;;
  23 ;; $Id$
  24
  25
  26 (defpackage #:puri-tests (:use #:puri #:cl #:ptester))
  27 (in-package #:puri-tests)
  28
  29 (unintern-uri t)
  30
  31 (defmacro gen-test-forms ()
  32   (let ((res '())
  33         (base-uri "http://a/b/c/d;p?q"))
  34
  35     (dolist (x `(;; (relative-uri result base-uri compare-function)
  36 ;;;; RFC Appendix C.1 (normal examples)
  37                  ("g:h" "g:h" ,base-uri)
  38                  ("g" "http://a/b/c/g" ,base-uri)
  39                  ("./g" "http://a/b/c/g" ,base-uri)
  40                  ("g/" "http://a/b/c/g/" ,base-uri)
  41                  ("/g" "http://a/g" ,base-uri)
  42                  ("//g" "http://g" ,base-uri)
  43                  ;; Following was changed from appendix C of RFC 2396
  44                  ;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query
  45                  #-ignore ("?y" "http://a/b/c/d;p?y" ,base-uri)
  46                  #+ignore ("?y" "http://a/b/c/?y" ,base-uri)
  47                  ("g?y" "http://a/b/c/g?y" ,base-uri)
  48                  ("#s" "http://a/b/c/d;p?q#s" ,base-uri)
  49                  ("g#s" "http://a/b/c/g#s" ,base-uri)
  50                  ("g?y#s" "http://a/b/c/g?y#s" ,base-uri)
  51                  (";x" "http://a/b/c/;x" ,base-uri)
  52                  ("g;x" "http://a/b/c/g;x" ,base-uri)
  53                  ("g;x?y#s" "http://a/b/c/g;x?y#s" ,base-uri)
  54                  ("." "http://a/b/c/" ,base-uri)
  55                  ("./" "http://a/b/c/" ,base-uri)
  56                  (".." "http://a/b/" ,base-uri)
  57                  ("../" "http://a/b/" ,base-uri)
  58                  ("../g" "http://a/b/g" ,base-uri)
  59                  ("../.." "http://a/" ,base-uri)
  60                  ("../../" "http://a/" ,base-uri)
  61                  ("../../g" "http://a/g" ,base-uri)
  62 ;;;; RFC Appendix C.2 (abnormal examples)
  63                  ("" "http://a/b/c/d;p?q" ,base-uri)
  64                  ("../../../g" "http://a/../g" ,base-uri)
  65                  ("../../../../g" "http://a/../../g" ,base-uri)
  66                  ("/./g" "http://a/./g" ,base-uri)
  67                  ("/../g" "http://a/../g" ,base-uri)
  68                  ("g." "http://a/b/c/g." ,base-uri)
  69                  (".g" "http://a/b/c/.g" ,base-uri)
  70                  ("g.." "http://a/b/c/g.." ,base-uri)
  71                  ("..g" "http://a/b/c/..g" ,base-uri)
  72                  ("./../g" "http://a/b/g" ,base-uri)
  73                  ("./g/." "http://a/b/c/g/" ,base-uri)
  74                  ("g/./h" "http://a/b/c/g/h" ,base-uri)
  75                  ("g/../h" "http://a/b/c/h" ,base-uri)
  76                  ("g;x=1/./y" "http://a/b/c/g;x=1/y" ,base-uri)
  77                  ("g;x=1/../y" "http://a/b/c/y" ,base-uri)
  78                  ("g?y/./x" "http://a/b/c/g?y/./x" ,base-uri)
  79                  ("g?y/../x" "http://a/b/c/g?y/../x" ,base-uri)
  80                  ("g#s/./x" "http://a/b/c/g#s/./x" ,base-uri)
  81                  ("g#s/../x" "http://a/b/c/g#s/../x" ,base-uri)
  82                  ("http:g" "http:g" ,base-uri)
  83
  84                  ("foo/bar/baz.htm#foo"
  85                   "http://a/b/foo/bar/baz.htm#foo"
  86                   "http://a/b/c.htm")
  87                  ("foo/bar/baz.htm#foo"
  88                   "http://a/b/foo/bar/baz.htm#foo"
  89                   "http://a/b/")
  90                  ("foo/bar/baz.htm#foo"
  91                   "http://a/foo/bar/baz.htm#foo"
  92                   "http://a/b")
  93                  ("foo/bar;x;y/bam.htm"
  94                   "http://a/b/c/foo/bar;x;y/bam.htm"
  95                   "http://a/b/c/")))
  96       (push `(test (intern-uri ,(second x))
  97                              (intern-uri (merge-uris (intern-uri ,(first x))
  98                                                      (intern-uri ,(third x))))
  99                              :test 'uri=)
 100             res))
 101
 102 ;;;; intern tests
 103     (dolist (x '(;; default port and specifying the default port are
 104                  ;; supposed to compare the same:
 105                  ("http://www.franz.com:80" "http://www.franz.com")
 106                  ("http://www.franz.com:80" "http://www.franz.com" eq)
 107                  ;; make sure they're `eq':
 108                  ("http://www.franz.com:80" "http://www.franz.com" eq)
 109                  ("http://www.franz.com" "http://www.franz.com" eq)
 110                  ("http://www.franz.com/foo" "http://www.franz.com/foo" eq)
 111                  ("http://www.franz.com/foo?bar"
 112                   "http://www.franz.com/foo?bar" eq)
 113                  ("http://www.franz.com/foo?bar#baz"
 114                   "http://www.franz.com/foo?bar#baz" eq)
 115                  ("http://WWW.FRANZ.COM" "http://www.franz.com" eq)
 116                  ("http://www.FRANZ.com" "http://www.franz.com" eq)
 117                  ("http://www.franz.com" "http://www.franz.com/" eq)
 118                  (;; %72 is "r", %2f is "/", %3b is ";"
 119                   "http://www.franz.com/ba%72%2f%3b;x;y;z/baz/"
 120                   "http://www.franz.com/bar%2f%3b;x;y;z/baz/" eq)))
 121       (push `(test (intern-uri ,(second x))
 122                              (intern-uri ,(first x))
 123               :test ',(if (third x)
 124                           (third x)
 125                           'uri=))
 126             res))
 127
 128 ;;;; parsing and equivalence tests
 129     (push `(test
 130             (parse-uri "http://foo+bar?baz=b%26lob+bof")
 131             (parse-uri (parse-uri "http://foo+bar?baz=b%26lob+bof"))
 132             :test 'uri=)
 133           res)
 134     (push '(test
 135             (parse-uri "http://www.foo.com")
 136             (parse-uri (parse-uri "http://www.foo.com?")) ; allow ? at end
 137             :test 'uri=)
 138           res)
 139     (push `(test
 140             "baz=b%26lob+bof"
 141             (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof"))
 142             :test 'string=)
 143           res)
 144     (push `(test
 145             "baz=b%26lob+bof%3d"
 146             (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof%3d"))
 147             :test 'string=)
 148           res)
 149     (push
 150      `(test (parse-uri "xxx?%41") (parse-uri "xxx?A") :test 'uri=)
 151      res)
 152     (push
 153      `(test "A" (uri-query (parse-uri "xxx?%41")) :test 'string=)
 154      res)
 155
 156     (push `(test-error (parse-uri " ")
 157                                  :condition-type 'uri-parse-error)
 158           res)
 159     (push `(test-error (parse-uri "foo ")
 160                                  :condition-type 'uri-parse-error)
 161           res)
 162     (push `(test-error (parse-uri " foo ")
 163                                  :condition-type 'uri-parse-error)
 164           res)
 165     (push `(test-error (parse-uri "<foo")
 166                                  :condition-type 'uri-parse-error)
 167           res)
 168     (push `(test-error (parse-uri "foo>")
 169                                  :condition-type 'uri-parse-error)
 170           res)
 171     (push `(test-error (parse-uri "<foo>")
 172                                  :condition-type 'uri-parse-error)
 173           res)
 174     (push `(test-error (parse-uri "%")
 175                                  :condition-type 'uri-parse-error)
 176           res)
 177     (push `(test-error (parse-uri "foo%xyr")
 178                                  :condition-type 'uri-parse-error)
 179           res)
 180     (push `(test-error (parse-uri "\"foo\"")
 181                                  :condition-type 'uri-parse-error)
 182           res)
 183     (push `(test "%20" (format nil "~a" (parse-uri "%20"))
 184                            :test 'string=)
 185           res)
 186     (push `(test "&" (format nil "~a" (parse-uri "%26"))
 187                            :test 'string=)
 188           res)
 189     (push
 190      `(test "foo%23bar" (format nil "~a" (parse-uri "foo%23bar"))
 191                       :test 'string=)
 192      res)
 193     (push
 194      `(test "foo%23bar#foobar"
 195                       (format nil "~a" (parse-uri "foo%23bar#foobar"))
 196                       :test 'string=)
 197      res)
 198     (push
 199      `(test "foo%23bar#foobar#baz"
 200                       (format nil "~a" (parse-uri "foo%23bar#foobar#baz"))
 201                       :test 'string=)
 202      res)
 203     (push
 204      `(test "foo%23bar#foobar#baz"
 205                       (format nil "~a" (parse-uri "foo%23bar#foobar%23baz"))
 206                       :test 'string=)
 207      res)
 208     (push
 209      `(test "foo%23bar#foobar/baz"
 210                       (format nil "~a" (parse-uri "foo%23bar#foobar%2fbaz"))
 211                       :test 'string=)
 212      res)
 213     (push `(test-error (parse-uri "foobar??")
 214                                  :condition-type 'uri-parse-error)
 215           res)
 216     (push `(test-error (parse-uri "foobar?foo?")
 217                                  :condition-type 'uri-parse-error)
 218           res)
 219     (push `(test "foobar?%3f"
 220                            (format nil "~a" (parse-uri "foobar?%3f"))
 221                            :test 'string=)
 222           res)
 223     (push `(test
 224             "http://foo/bAr;3/baz?baf=3"
 225             (format nil "~a" (parse-uri "http://foo/b%41r;3/baz?baf=3"))
 226             :test 'string=)
 227           res)
 228     (push `(test
 229             '(:absolute ("/bAr" "3") "baz")
 230             (uri-parsed-path (parse-uri "http://foo/%2fb%41r;3/baz?baf=3"))
 231             :test 'equal)
 232           res)
 233     (push `(test
 234             "/%2fbAr;3/baz"
 235             (let ((u (parse-uri "http://foo/%2fb%41r;3/baz?baf=3")))
 236               (setf (uri-parsed-path u) '(:absolute ("/bAr" "3") "baz"))
 237               (uri-path u))
 238             :test 'string=)
 239           res)
 240     (push `(test
 241             "http://www.verada.com:8010/kapow?name=foo%3Dbar%25"
 242             (format nil "~a"
 243                     (parse-uri
 244                      "http://www.verada.com:8010/kapow?name=foo%3Dbar%25"))
 245             :test 'string=)
 246           res)
 247     (push `(test
 248             "ftp://parcftp.xerox.com/pub/pcl/mop/"
 249             (format nil "~a"
 250                     (parse-uri "ftp://parcftp.xerox.com:/pub/pcl/mop/"))
 251             :test 'string=)
 252           res)
 253     (push `(test
 254             "http://xn--mller-kva.example.com/"
 255             (format nil "~a"
 256                     (parse-uri "http://xn--mller-kva.example.com/"))
 257             :test 'string=)
 258           res)
 259     (push `(test
 260             "http://xn--mller-kva.example.com/"
 261             (format nil "~a"
 262                     (parse-uri "http://müller.example.com/"))
 263             :test 'string=)
 264           res)
 265     (push `(test
 266             "http://example.xn--fiqz9s/"
 267             (format nil "~a"
 268                     (parse-uri "http://example.中國/"))
 269             :test 'string=)
 270           res)
 271
 272 ;;;; enough-uri tests
 273     (dolist (x `(("http://www.franz.com/foo/bar/baz.htm"
 274                   "http://www.franz.com/foo/bar/"
 275                   "baz.htm")
 276                  ("http://www.franz.com/foo/bar/baz.htm"
 277                   "http://www.franz.com/foo/bar"
 278                   "baz.htm")
 279                  ("http://www.franz.com:80/foo/bar/baz.htm"
 280                   "http://www.franz.com:80/foo/bar"
 281                   "baz.htm")
 282                  ("http:/foo/bar/baz.htm" "http:/foo/bar"  "baz.htm")
 283                  ("http:/foo/bar/baz.htm" "http:/foo/bar/" "baz.htm")
 284                  ("/foo/bar/baz.htm" "/foo/bar"  "baz.htm")
 285                  ("/foo/bar/baz.htm" "/foo/bar/" "baz.htm")
 286                  ("/foo/bar/baz.htm#foo" "/foo/bar/" "baz.htm#foo")
 287                  ("/foo/bar/baz.htm?bar#foo" "/foo/bar/" "baz.htm?bar#foo")
 288
 289                  ("http://www.dnai.com/~layer/foo.htm"
 290                   "http://www.known.net"
 291                   "http://www.dnai.com/~layer/foo.htm")
 292                  ("http://www.dnai.com/~layer/foo.htm"
 293                   "http://www.dnai.com:8000/~layer/"
 294                   "http://www.dnai.com/~layer/foo.htm")
 295                  ("http://www.dnai.com:8000/~layer/foo.htm"
 296                   "http://www.dnai.com/~layer/"
 297                   "http://www.dnai.com:8000/~layer/foo.htm")
 298                  ("http://www.franz.com"
 299                   "http://www.franz.com"
 300                   "/")))
 301       (push `(test (parse-uri ,(third x))
 302                              (enough-uri (parse-uri ,(first x))
 303                                          (parse-uri ,(second x)))
 304                              :test 'uri=)
 305             res))
 306
 307 ;;;; urn tests, ideas of which are from rfc2141
 308     (let ((urn "urn:com:foo-the-bar"))
 309       (push `(test "com" (urn-nid (parse-uri ,urn))
 310                              :test #'string=)
 311             res)
 312       (push `(test "foo-the-bar" (urn-nss (parse-uri ,urn))
 313                              :test #'string=)
 314             res))
 315     (push `(test-error (parse-uri "urn:")
 316                                  :condition-type 'uri-parse-error)
 317           res)
 318     (push `(test-error (parse-uri "urn:foo")
 319                                  :condition-type 'uri-parse-error)
 320           res)
 321     (push `(test-error (parse-uri "urn:foo$")
 322                                  :condition-type 'uri-parse-error)
 323           res)
 324     (push `(test-error (parse-uri "urn:foo_")
 325                                  :condition-type 'uri-parse-error)
 326           res)
 327     (push `(test-error (parse-uri "urn:foo:foo&bar")
 328                                  :condition-type 'uri-parse-error)
 329           res)
 330     (push `(test (parse-uri "URN:foo:a123,456")
 331                            (parse-uri "urn:foo:a123,456")
 332                            :test #'uri=)
 333           res)
 334     (push `(test (parse-uri "URN:foo:a123,456")
 335                            (parse-uri "urn:FOO:a123,456")
 336                            :test #'uri=)
 337           res)
 338     (push `(test (parse-uri "urn:foo:a123,456")
 339                            (parse-uri "urn:FOO:a123,456")
 340                            :test #'uri=)
 341           res)
 342     (push `(test (parse-uri "URN:FOO:a123%2c456")
 343                            (parse-uri "urn:foo:a123%2C456")
 344                            :test #'uri=)
 345           res)
 346     (push `(test
 347             nil
 348             (uri= (parse-uri "urn:foo:A123,456")
 349                   (parse-uri "urn:FOO:a123,456")))
 350           res)
 351     (push `(test
 352             nil
 353             (uri= (parse-uri "urn:foo:A123,456")
 354                   (parse-uri "urn:foo:a123,456")))
 355           res)
 356     (push `(test
 357             nil
 358             (uri= (parse-uri "urn:foo:A123,456")
 359                   (parse-uri "URN:foo:a123,456")))
 360           res)
 361     (push `(test
 362             nil
 363             (uri= (parse-uri "urn:foo:a123%2C456")
 364                   (parse-uri "urn:FOO:a123,456")))
 365           res)
 366     (push `(test
 367             nil
 368             (uri= (parse-uri "urn:foo:a123%2C456")
 369                   (parse-uri "urn:foo:a123,456")))
 370           res)
 371     (push `(test
 372             nil
 373             (uri= (parse-uri "URN:FOO:a123%2c456")
 374                   (parse-uri "urn:foo:a123,456")))
 375           res)
 376     (push `(test
 377             nil
 378             (uri= (parse-uri "urn:FOO:a123%2c456")
 379                   (parse-uri "urn:foo:a123,456")))
 380           res)
 381     (push `(test
 382             nil
 383             (uri= (parse-uri "urn:foo:a123%2c456")
 384                   (parse-uri "urn:foo:a123,456")))
 385           res)
 386
 387     (push `(test t
 388                            (uri= (parse-uri "foo") (parse-uri "foo#")))
 389           res)
 390
 391     (push
 392      '(let ((puri::*strict-parse* nil))
 393        (test-no-error
 394         (puri:parse-uri
 395          "http://foo.com/bar?a=zip|zop")))
 396      res)
 397     (push
 398      '(test-error
 399        (puri:parse-uri "http://foo.com/bar?a=zip|zop")
 400        :condition-type 'uri-parse-error)
 401      res)
 402
 403     (push
 404      '(let ((puri::*strict-parse* nil))
 405        (test-no-error
 406         (puri:parse-uri
 407          "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041")))
 408      res)
 409     (push
 410      '(test-error
 411        (puri:parse-uri
 412         "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041")
 413        :condition-type 'uri-parse-error)
 414      res)
 415
 416     (push
 417      '(let ((puri::*strict-parse* nil))
 418        (test-no-error
 419         (puri:parse-uri
 420          "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843")))
 421      res)
 422     (push
 423      '(test-error
 424        (puri:parse-uri
 425         "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843")
 426        :condition-type 'uri-parse-error)
 427      res)
 428
 429     ;;; tests for weird control characters
 430     ;; http://www.ietf.org/rfc/rfc2396.txt 2.4.3
 431     (dolist (x '("https://example.com/q?foo%0abar%20baz" ;;an escaped newline
 432                  "https://example.com/q?%7f" ;; 7f, 127
 433                  ))
 434       (push
 435        `(let ((weird-uri ,x))
 436           (test weird-uri
 437                 (puri:render-uri (puri:parse-uri weird-uri) nil)
 438                 :test #'string=)
 439           ) res))
 440
 441     `(progn ,@(nreverse res))))
 442
 443 (defun do-tests ()
 444   (let ((*break-on-test-failures* t))
 445     (with-tests (:name "puri")
 446       (gen-test-forms)))
 447   t)
 448
 449