1: ;;
    2: ;; testing rfc.* module
    3: ;;
    4: 
    5: (use gauche.test)
    6: (use gauche.sequence)
    7: (test-start "rfc")
    8: 
    9: ;;--------------------------------------------------------------------
   10: (test-section "rfc.822")
   11: (use rfc.822)
   12: (test-module 'rfc.822)
   13: 
   14: (define rfc822-header1
   15:   "Received: by foo.bar.com id ZZZ55555; Thu, 31 May 2001 16:38:04 -1000 (HST)
   16: Received: from ooo.ooo.com (ooo.ooo.com [1.2.3.4])
   17:         by foo.bar.com (9.9.9+3.2W/3.7W-) with ESMTP id ZZZ55555
   18:         for <yoo@bar.com>; Thu, 31 May 2001 16:38:02 -1000 (HST)
   19: Received: from zzz ([1.2.3.5]) by ooo.ooo.com  with Maccrosoft SMTPSVC(5.5.1877.197.19);
   20:          Thu, 31 May 2001 22:33:16 -0400
   21: Message-ID: <beefbeefbeefbeef@ooo.ooo.com>
   22: Subject: Bogus Tester
   23: From: Bogus Sender <bogus@ooo.com>
   24: To: You <you@bar.com>, Another <another@ooo.com>
   25: Date: Fri, 01 Jun 2001 02:37:31 (GMT)
   26: Mime-Version: 1.0
   27: Content-Type: text/html
   28: Content-Transfer-Encoding: quoted-printable
   29: X-MSMail-Priority: Normal
   30: X-mailer: FooMail 4.0 4.03 (SMT460B92F)
   31: Content-Length: 4349
   32: 
   33: ")
   34: 
   35: (define rfc822-header1-list
   36:   '(("received" "by foo.bar.com id ZZZ55555; Thu, 31 May 2001 16:38:04 -1000 (HST)")
   37:     ("received" "from ooo.ooo.com (ooo.ooo.com [1.2.3.4])       by foo.bar.com (9.9.9+3.2W/3.7W-) with ESMTP id ZZZ55555      for <yoo@bar.com>; Thu, 31 May 2001 16:38:02 -1000 (HST)")
   38:     ("received" "from zzz ([1.2.3.5]) by ooo.ooo.com  with Maccrosoft SMTPSVC(5.5.1877.197.19);  Thu, 31 May 2001 22:33:16 -0400")
   39:     ("message-id" "<beefbeefbeefbeef@ooo.ooo.com>")
   40:     ("subject" "Bogus Tester")
   41:     ("from" "Bogus Sender <bogus@ooo.com>")
   42:     ("to" "You <you@bar.com>, Another <another@ooo.com>")
   43:     ("date" "Fri, 01 Jun 2001 02:37:31 (GMT)")
   44:     ("mime-version" "1.0")
   45:     ("content-type" "text/html")
   46:     ("content-transfer-encoding" "quoted-printable")
   47:     ("x-msmail-priority" "Normal")
   48:     ("x-mailer" "FooMail 4.0 4.03 (SMT460B92F)")
   49:     ("content-length" "4349")
   50:     ))
   51: 
   52: (test* "rfc822-header->list" #t
   53:        (equal? rfc822-header1-list
   54:                (rfc822-header->list (open-input-string rfc822-header1))))
   55: 
   56: ;; token parsers
   57: (test* "rfc822-field->tokens (basic)"
   58:        '(("aa") ("bb") ("cc") ("dd") ("ee") (" a\"aa\\aa (a)"))
   59:        (map rfc822-field->tokens
   60:             '("aa"
   61:               "  bb   "
   62:               " (comment) cc(comment)"
   63:               " (co\\mm$$*##&$%ent) dd(com (me) nt)"
   64:               "\"ee\""
   65:               "  \" a\\\"aa\\\\aa (a)\" (comment\\))")))
   66: 
   67: (test* "rfc822-field->tokens"
   68:        '("from" "aaaaa.aaa.org" "by" "ggg.gggg.net" "with" "ESMTP" "id" "24D50175C8")
   69:        (rfc822-field->tokens
   70:         "from aaaaa.aaa.org (aaaaa.aaa.org [192.168.0.9]) by ggg.gggg.net (Postfix) with ESMTP id 24D50175C8"))
   71: 
   72: 
   73: (test* "rfc822-parse-date" '(2003 3 4 12 34 56 -3600 2)
   74:        (receive r (rfc822-parse-date "Tue,  4 Mar 2003 12:34:56 -3600") r))
   75: 
   76: (test* "rfc822-parse-date" '(2003 3 4 12 34 56 0 2)
   77:        (receive r (rfc822-parse-date "Tue,  4 Mar 2003 12:34:56 UT") r))
   78: 
   79: (test* "rfc822-parse-date (no weekday)" '(2003 3 4 12 34 56 -3600 #f)
   80:        (receive r (rfc822-parse-date "4 Mar 2003 12:34:56 -3600") r))
   81: 
   82: (test* "rfc822-parse-date (no timezone)" '(2003 3 4 12 34 56 #f #f)
   83:        (receive r (rfc822-parse-date "4 Mar 2003 12:34:56") r))
   84: 
   85: (test* "rfc822-parse-date (old tz)" '(2003 3 4 12 34 56 #f #f)
   86:        (receive r (rfc822-parse-date "4 Mar 2003 12:34:56 jst") r))
   87: 
   88: (test* "rfc822-parse-date (no seconds)" '(2003 3 4 12 34 #f 900 #f)
   89:        (receive r (rfc822-parse-date "4 Mar 2003 12:34 +0900") r))
   90: 
   91: (test* "rfc822-parse-date (no seconds)" '(2003 3 4 12 34 #f 900 2)
   92:        (receive r (rfc822-parse-date "Tue, 04 Mar 2003 12:34 +0900") r))
   93: 
   94: (test* "rfc822-parse-date (2digit year)" '(2003 3 4 12 34 56 -3600 2)
   95:        (receive r (rfc822-parse-date "Tue,  4 Mar 03 12:34:56 -3600") r))
   96: 
   97: (test* "rfc822-parse-date (2digit year)" '(1987 3 4 12 34 56 -3600 2)
   98:        (receive r (rfc822-parse-date "Tue,  4 Mar 87 12:34:56 -3600") r))
   99: 
  100: (test* "rfc822-parse-date (Weekday, exhausive)" '(0 1 2 3 4 5 6 #f)
  101:        (map-with-index
  102:         (lambda (ind wday)
  103:           (receive (y m d H M S tz wd)
  104:               (rfc822-parse-date
  105:                #`",|wday|, ,(+ 2 ind) Jan 2000 00:00:00 +0000")
  106:             wd))
  107:         '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Znn")))
  108: 
  109: (test* "rfc822-parse-date (Months, exhausive)"
  110:        '(1 2 3 4 5 6 7 8 9 10 11 12 #f)
  111:        (map (lambda (mon)
  112:               (receive (y m d H M S tz wd)
  113:                   (rfc822-parse-date
  114:                    #`"1 ,mon 1999 00:00:00 +0000")
  115:                 m))
  116:             '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
  117:               "Sep" "Oct" "Nov" "Dec" "Zzz")))
  118: 
  119: (test* "rfc822-parse-date (invalid)" '(#f #f #f #f #f #f #f #f)
  120:        (receive r (rfc822-parse-date "Sun 2 Mar 2002") r))
  121: 
  122: ;;--------------------------------------------------------------------
  123: (test-section "rfc.base64")
  124: (use rfc.base64)
  125: (test-module 'rfc.base64)
  126: 
  127: (test* "encode" "" (base64-encode-string ""))
  128: (test* "encode" "YQ==" (base64-encode-string "a"))
  129: (test* "encode" "MA==" (base64-encode-string "0"))
  130: (test* "encode" "Cg==" (base64-encode-string "\n"))
  131: (test* "encode" "YTA=" (base64-encode-string "a0"))
  132: (test* "encode" "YTAK" (base64-encode-string "a0\n"))
  133: (test* "encode" "PQk0" (base64-encode-string "=\t4"))
  134: (test* "encode" "eTQ5YQ==" (base64-encode-string "y49a"))
  135: (test* "encode" "RWdqYWk=" (base64-encode-string "Egjai"))
  136: (test* "encode" "OTNiamFl" (base64-encode-string "93bjae"))
  137: (test* "encode" "QkFSMGVyOQ==" (base64-encode-string "BAR0er9"))
  138: 
  139: (test* "decode" "" (base64-decode-string ""))
  140: (test* "decode" "a" (base64-decode-string "YQ=="))
  141: (test* "decode" "a" (base64-decode-string "YQ="))
  142: (test* "decode" "a" (base64-decode-string "YQ"))
  143: (test* "decode" "a0" (base64-decode-string "YTA="))
  144: (test* "decode" "a0" (base64-decode-string "YTA"))
  145: (test* "decode" "a0\n" (base64-decode-string "YTAK"))
  146: (test* "decode" "y49a" (base64-decode-string "eTQ5YQ=="))
  147: (test* "decode" "Egjai" (base64-decode-string "RWdqYWk="))
  148: (test* "decode" "93bjae" (base64-decode-string "OTNiamFl"))
  149: (test* "decode" "BAR0er9" (base64-decode-string "QkFSMGVyOQ=="))
  150: (test* "decode" "BAR0er9" (base64-decode-string "QkFS\r\nMGVyOQ\r\n=="))
  151: 
  152: ;;--------------------------------------------------------------------
  153: (test-section "rfc.quoted-printable")
  154: (use rfc.quoted-printable)
  155: (test-module 'rfc.quoted-printable)
  156: 
  157: (test* "encode" "abcd=0Cefg"
  158:        (quoted-printable-encode-string "abcd\x0cefg"))
  159: (test* "encode"
  160:        "abcd\r\nefg"
  161:        (quoted-printable-encode-string "abcd\r\nefg"))
  162: (test* "encode (tab/space at eol)"
  163:        "abcd=09\r\nefg=20\r\n"
  164:        (quoted-printable-encode-string "abcd\t\r\nefg \r\n"))
  165: (test* "encode (soft line break)"
  166:        "0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abc=\r\ndefghij0123456789abcdefghij"
  167:        (quoted-printable-encode-string "0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij"))
  168: 
  169: (test* "decode" "\x01\x08abcde=\r\n"
  170:        (quoted-printable-decode-string "=01=08abc=64=65=3D\r\n"))
  171: (test* "decode (soft line break)"
  172:        "Now's the time for all folk to come to the aid of their country."
  173:        (quoted-printable-decode-string "Now's the time =\r\nfor all folk to come=   \r\n to the aid of their country."))
  174: (test* "decode (robustness)"
  175:        "foo=1qr =  j\r\n"
  176:        (quoted-printable-decode-string "foo=1qr =  j\r\n="))
  177: 
  178: 
  179: ;;--------------------------------------------------------------------
  180: (test-section "rfc.cookie")
  181: (use rfc.cookie)
  182: (use srfi-19)
  183: (test-module 'rfc.cookie)
  184: 
  185: (test* "parse, old" '(("foo" "bar")
  186:                       ("aaa" "bbb" :path "/a/b" :domain "a.b.com")
  187:                       ("x12" "Yy \"yY\" ;; Zz" :port "100, 200, 300")
  188:                       ("zzz" #f)
  189:                       ("_n_" "")
  190:                       ("mmm" "ppp"))
  191:        (parse-cookie-string " foo=bar; aaa = bbb ; $Path=/a/b;$Domain =a.b.com;x12=\"Yy \\\"yY\\\" ;; Zz\"; $Port=\"100, 200, 300\";zzz ;_n_=;mmm=ppp"))
  192: 
  193: (test* "parse, new" '(("$Version" "1")
  194:                       ("foo" "bar")
  195:                       ("aaa" "bbb" :path "/a/b" :domain "a.b.com")
  196:                       ("x12" "Yy \"yY\" ;; Zz" :port "100, 200, 300")
  197:                       ("zzz" #f)
  198:                       ("_n_" "")
  199:                       ("mmm" "ppp"))
  200:        (parse-cookie-string "$Version=1; foo=bar, aaa = bbb ; $Path=/a/b;$Domain =a.b.com,x12=\"Yy \\\"yY\\\" ;; Zz\"; $Port=\"100, 200, 300\",zzz ,_n_=,mmm=ppp"))
  201: 
  202: (test* "parse, new" '(("foo" "bar")
  203:                       ("aaa" "bbb" :path "/a/b" :domain "a.b.com")
  204:                       ("x12" "Yy \"yY\" ;; Zz" :port "100, 200, 300")
  205:                       ("zzz" #f)
  206:                       ("_n_" "")
  207:                       ("mmm" "ppp"))
  208:        (parse-cookie-string " foo=bar, aaa = bbb ; $Path=/a/b;$Domain =a.b.com,x12=\"Yy \\\"yY\\\" ;; Zz\"; $Port=\"100, 200, 300\",zzz ,_n_=,mmm=ppp"
  209:                             1))
  210: 
  211: (define *cookie-spec*
  212:   '(("guest-id" "foo123"
  213:      :domain "foo.com" :path "/abc"
  214:      :expires 1000000000 :max-age 864000
  215:      :discard #t :comment "hogehoge"
  216:      :comment-url "http://foo.com/hogehoge"
  217:      :port "80, 8080" :version 1)
  218:     ("guest-account" "87975348"
  219:      :domain "zzz.com" :path "/zzz"
  220:      :discard #f :secure #t :comment "ZzzZzz, OooOoo"
  221:      :comment-url "http://foo.com/hogehoge")))
  222: 
  223: (test* "cookie, old"
  224:        '("guest-id=foo123;Domain=foo.com;Path=/abc;Expires=Sun, 09-Sep-2001 01:46:40 GMT"
  225:          "guest-account=87975348;Domain=zzz.com;Path=/zzz;Secure")
  226:        (construct-cookie-string *cookie-spec* 0))
  227: 
  228: (test* "cookie, new"
  229:        '("guest-id=foo123;Domain=foo.com;Path=/abc;Max-Age=864000;Discard;Comment=hogehoge;CommentURL=\"http://foo.com/hogehoge\";Port=\"80, 8080\";Version=1"
  230:          "guest-account=87975348;Domain=zzz.com;Path=/zzz;Secure;Comment=\"ZzzZzz, OooOoo\";CommentURL=\"http://foo.com/hogehoge\"")
  231:        (construct-cookie-string *cookie-spec* 1))
  232: 
  233: ;; test for formatting srfi-19 time/date
  234: (test* "cookie, old, srfi-19 date"
  235:        '("foo=bar;Expires=Sun, 09-Sep-2001 01:46:40 GMT"
  236:          "foo=baz;Expires=Sun, 09-Sep-2001 01:46:40 GMT")
  237:        (construct-cookie-string
  238:         `(("foo" "bar" :expires ,(make-time time-utc 0 1000000000))
  239:           ("foo" "baz" :expires ,(make-date 0 40 46 1 9 9 2001 0)))
  240:         0))
  241: 
  242: ;;--------------------------------------------------------------------
  243: (test-section "rfc.ftp")
  244: (use rfc.ftp)
  245: (test-module 'rfc.ftp)
  246: 
  247: ;;--------------------------------------------------------------------
  248: (test-section "rfc.icmp")
  249: (use rfc.icmp)
  250: (use gauche.uvector)
  251: (test-module 'rfc.icmp)
  252: 
  253: ;; WRITEME
  254: 
  255: ;;--------------------------------------------------------------------
  256: (test-section "rfc.ip")
  257: (use rfc.ip)
  258: (use gauche.uvector)
  259: (test-module 'rfc.ip)
  260: 
  261: (test* "ip-version" 4
  262:        (ip-version '#u8(69 0 0 36 139 12 0 0 64 1 241 202
  263:                         127 0 0 1 127 0 0 1 0 0 205 245 50 10 0 0)))
  264: (test* "ip-version" 6
  265:        (ip-version '#u8(#x60 0 0 0 0 0 17 0
  266:                         0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1
  267:                         0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)))
  268: 
  269: (test* "ip-protocol" 1
  270:        (ip-protocol '#u8(69 0 0 36 139 12 0 0 64 1 241 202
  271:                          127 0 0 1 127 0 0 1 0 0 205 245 50 10 0 0)))
  272: (test* "ip-protocol" 17
  273:        (ip-protocol '#u8(#x60 0 0 0 0 0 17 0
  274:                          0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1
  275:                          0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)))
  276: (test* "ip-protocol" 17
  277:        (ip-protocol '#u8(#x60 0 0 0 0 0 0 0
  278:                          0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1
  279:                          0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1
  280:                          60 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0
  281:                          43 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
  282:                          17 0 0 0 0 0 0 0)))
  283: 
  284: ;;--------------------------------------------------------------------
  285: (test-section "rfc.mime")
  286: (use rfc.mime)
  287: (test-module 'rfc.mime)
  288: 
  289: (test* "mime-parse-version" '((1 0) (1 0) (1 0) (1 0) #f)
  290:        (map mime-parse-version
  291:             '(" 1.0"
  292:               " 1.0 (produced by MetaSend Vx.x) "
  293:               " (produced by MetaSend Vx.x) 1.0"
  294:               " 1.(produced by MetaSend Vx.x (beta))0"
  295:               " none ")))
  296: 
  297: (test* "mime-parse-content-type" '("text" "plain")
  298:        (mime-parse-content-type " text/plain (client: foo bar)"))
  299: (test* "mime-parse-content-type" '("text" "plain" ("charset" . "us-ascii"))
  300:        (mime-parse-content-type " text/plain ;charset=\"us-ascii\""))
  301: (test* "mime-parse-content-type" '("text" "plain" ("charset" . "us-ascii"))
  302:        (mime-parse-content-type " text/plain; charset=us-ascii (Plain Text)"))
  303: (test* "mime-parse-content-type" '("text" "plain" ("charset" . "iso-2022-jp"))
  304:        (mime-parse-content-type " text/(Plain Text)plain ; (Japanese) charset=iso-2022-jp"))
  305: 
  306: (test* "mime-parse-content-type"
  307:        '("text" "plain" ("zzz" . "yyy") ("xxx" . "www"))
  308:        (mime-parse-content-type " text/plain ;zzz=\"yyy\"; xxx = www (AAA)"))
  309: 
  310: (test* "mime-parse-content-type"
  311:        '("multipart" "alternative"
  312:          ("boundary" . "=_alternative 006EBAA488256DF0_="))
  313:        (mime-parse-content-type
  314:         "multipart/alternative; boundary=\"=_alternative 006EBAA488256DF0_=\"")
  315:        )
  316: 
  317: (use gauche.charconv)
  318: (when (ces-conversion-supported? "iso-8859-1" #f)
  319:   (test* "mime-decode-word" "this is some text"
  320:          (mime-decode-word "=?iso-8859-1?q?this=20is=20some=20text?=")))
  321: (when (ces-conversion-supported? "us-ascii" #f)
  322:   (test* "mime-decode-word" "Keith_Moore"
  323:          (mime-decode-word "=?US-ASCII?Q?Keith_Moore?=")))
  324: (when (and (memq (gauche-character-encoding) '(euc-jp sjis utf8))
  325:            (ces-conversion-supported? "iso-2022-jp" #f))
  326:   (test* "mime-decode-word" "\u5ddd\u5408 \u53f2\u6717"
  327:          (mime-decode-word "=?ISO-2022-JP?B?GyRCQG45ZxsoQiAbJEI7S08vGyhC?="))
  328:   )
  329: ;; this tests whether illegal input sequence is handled gracefully
  330: (when (memq (gauche-character-encoding) '(euc-jp sjis utf8))
  331:   (test* "mime-decode-word" "=?ISO-2022-JP?B?GyRCJDkbKBsoQg==?="
  332:          (mime-decode-word "=?ISO-2022-JP?B?GyRCJDkbKBsoQg==?=")))
  333: 
  334: ;; NB: this assumes the test is run either under src/ or test/
  335: (define (mime-message-tester num headers)
  336:   (let ((src #`"../test/data/rfc-mime-,|num|.txt")
  337:         (res (call-with-input-file #`"../test/data/rfc-mime-,|num|.res.txt"
  338:                read)))
  339:     (call-with-input-file src
  340:       (lambda (inp)
  341:         (let* ((title (read-line inp)) ;; test title
  342:                (expl  (read-line inp)) ;; explanation (ignored)
  343:                (headers (or headers (rfc822-header->list inp))))
  344:           (test* #`"mime-parse-message (,|num| - ,|title|)"
  345:                  res
  346:                  (and (equal? (mime-parse-version
  347:                                (rfc822-header-ref headers "mime-version"))
  348:                               '(1 0))
  349:                       (mime-message-resolver
  350:                        (mime-parse-message inp headers
  351:                                            (cut mime-body->string <> <>))
  352:                        #f)
  353:                       )))))
  354:     ))
  355: 
  356: (define (mime-message-resolver mesg parent)
  357:   (unless (eqv? (ref mesg 'parent) parent) (error "parent link broken"))
  358:   (list* (string-append (ref mesg 'type) "/" (ref mesg 'subtype))
  359:          (ref mesg 'index)
  360:          (if (string? (ref mesg 'content))
  361:            (list (ref mesg 'content))
  362:            (map (cut mime-message-resolver <> mesg) (ref mesg 'content)))))
  363: 
  364: (dotimes (n 8)
  365:   (mime-message-tester
  366:    n
  367:    (and (= n 6)
  368:         '(("mime-version" " 1.0")
  369:           ("content-type" "multipart/form-data; boundary=\"---------------------------6578815652962098482130719379\"")))))
  370: 
  371: ;;--------------------------------------------------------------------
  372: (test-section "rfc.uri")
  373: (use rfc.uri)
  374: (test-module 'rfc.uri)
  375: 
  376: (test* "encode" "abc%3c%20%3e%20%22%20%23%25%7b%7c%7d%5c%5e"
  377:        (uri-encode-string "abc< > \" #%{|}\\^"))
  378: (test* "encode (noescape)" ".a%21%2ap"
  379:        (uri-encode-string ".a!*p" :noescape *rfc3986-unreserved-char-set*))
  380: (test* "decode" "abc< > \" #%?{|}\\^"
  381:        (uri-decode-string "abc%3c%20%3e%20%22%20%23%25%3f%7b%7c%7d%5c%5e"))
  382: (test* "decode" "abc<+>+\"+#%?{|}\\^"
  383:        (uri-decode-string "abc%3c+%3e+%22+%23%25%3f%7b%7c%7d%5c%5e"))
  384: (test* "decode" "abc< > \" #%?{|}\\^"
  385:        (uri-decode-string "abc%3c+%3e+%22+%23%25%3f%7b%7c%7d%5c%5e"
  386:                           :cgi-decode #t))
  387: (test* "decode" "%"    (uri-decode-string "%"))
  388: (test* "decode" "a%"   (uri-decode-string "a%"))
  389: (test* "decode" "a%y"  (uri-decode-string "a%y"))
  390: (test* "decode" "a%ay" (uri-decode-string "a%ay"))
  391: (test* "decode" ""     (uri-decode-string ""))
  392: 
  393: (test* "uri-scheme&specific" '("http" "//www.shiro.dreamhost.com/scheme/")
  394:        (receive r
  395:            (uri-scheme&specific "http://www.shiro.dreamhost.com/scheme/")
  396:          r))
  397: 
  398: (test* "uri-scheme&specific" '(#f "/dev/tty")
  399:        (receive r
  400:            (uri-scheme&specific "/dev/tty")
  401:          r))
  402: 
  403: (test* "uri-decompose-hierarchical" '("www.example.com:8080"
  404:                                       "/about/company"
  405:                                       "abc=def&ghi%20"
  406:                                       "zzz")
  407:        (receive r
  408:            (uri-decompose-hierarchical
  409:             "//www.example.com:8080/about/company?abc=def&ghi%20#zzz")
  410:          r))
  411: 
  412: (test* "uri-decompose-hierarchical" '("www.example.com:8080"
  413:                                       "/about/company"
  414:                                       #f
  415:                                       "zzz")
  416:        (receive r
  417:            (uri-decompose-hierarchical
  418:             "//www.example.com:8080/about/company#zzz")
  419:          r))
  420: 
  421: (test* "uri-decompose-hierarchical" '("www.example.com:8080"
  422:                                       "/"
  423:                                       "abc"
  424:                                       #f)
  425:        (receive r
  426:            (uri-decompose-hierarchical
  427:             "//www.example.com:8080/?abc")
  428:          r))
  429: 
  430: (test* "uri-decompose-authority" '(#f "www.example.com" #f)
  431:        (receive r (uri-decompose-authority "www.example.com") r))
  432: (test* "uri-decompose-authority" '(#f "www.example.com" "8080")
  433:        (receive r (uri-decompose-authority "www.example.com:8080") r))
  434: (test* "uri-decompose-authority" '("foo:bar" "www.example.com" #f)
  435:        (receive r (uri-decompose-authority "foo:bar@www.example.com") r))
  436: 
  437: (test* "uri-parse" '("https" "shiro" "www.example.com" 443 "/login" "abc" "def")
  438:        (receive r (uri-parse "https://shiro@www.example.com:443/login?abc#def")
  439:          r))
  440: (test* "uri-parse" '("ftp" "anonymous:anonymous" "ftp.example.com" #f
  441:                      "/pub/foo" #f #f)
  442:        (receive r (uri-parse "ftp://anonymous:anonymous@ftp.example.com/pub/foo")
  443:          r))
  444: (test* "uri-parse" '("file" #f #f #f "/usr/local/lib/abc" #f #f)
  445:        (receive r (uri-parse "file:/usr/local/lib/abc")
  446:          r))
  447: (test* "uri-parse" '(#f #f #f #f "/usr/local/lib" #f #f)
  448:        (receive r (uri-parse "/usr/local/lib") r))
  449: (test* "uri-parse" '("mailto" #f #f #f "shiro@example.com" #f #f)
  450:        (receive r (uri-parse "mailto:shiro@example.com") r))
  451: 
  452: ;;--------------------------------------------------------------------
  453: (test-section "rfc.http")
  454: (use rfc.http)
  455: (test-module 'rfc.http)
  456: 
  457: (use gauche.parameter)
  458: 
  459: (test* "http-user-agent" "gauche.http/0.1"
  460:        (and (is-a? http-user-agent <parameter>)
  461:             (http-user-agent)))
  462: 
  463: (use gauche.net)
  464: (use util.list)
  465: (define *http-port* 6726)
  466: 
  467: (define (alist-equal? alis1 alis2)
  468:   (define (%sort alis)
  469:     (sort alis (lambda (a b) (string<? (car a) (car b)))))
  470:   (equal? (%sort alis1) (%sort alis2)))
  471: 
  472: (define %predefined-contents
  473:   (let1 ht (make-hash-table 'string=?)
  474:     (hash-table-put! ht "/redirect01"
  475:                      `("HTTP/1.x 302 Moved Temporarily\n"
  476:                        ,#`"Location: http://localhost:,|*http-port*|/redirect02\n\n"))
  477:     (hash-table-put! ht "/redirect11"
  478:                      '("HTTP/1.x 302 Moved Temporarily\n"
  479:                        "Location: /redirect12\n\n"))
  480:     (hash-table-put! ht "/loop1"
  481:                      '("HTTP/1.x 302 Moved Temporarily\n"
  482:                        "Location: /loop2\n\n"))
  483:     (hash-table-put! ht "/loop2"
  484:                      '("HTTP/1.x 302 Moved Temporarily\n"
  485:                        "Location: /loop1\n\n"))
  486:     (hash-table-put! ht "/chunked"
  487:                      '("HTTP/1.x 200 OK\nTransfer-Encoding: chunked\n\n"
  488:                        "2\r\nOK\n0\r\n\r\n"))
  489:     ht))
  490: 
  491: (define (run-http-server socket)
  492:   (let loop ()
  493:     (let* ((client (socket-accept socket))
  494:            (in  (socket-input-port client))
  495:            (out (socket-output-port client))
  496:            (request-line (read-line in)))
  497:       (rxmatch-if (#/^(\S+) (\S+) HTTP\/1\.1$/ request-line)
  498:           (#f method request-uri)
  499:         (let* ((headers (rfc822-header->list in))
  500:                (bodylen
  501:                 (cond ((assoc-ref headers "content-length")
  502:                        => (lambda (e) (string->number (car e))))
  503:                       (else 0)))
  504:                (body (read-block bodylen in)))