#lang racket/base
;;; @Package     uri
;;; @Subtitle    Web Uniform Resource Identifiers (URI and URL) in Racket
;;; @HomePage    http://www.neilvandyke.org/racket-uri/
;;; @Author      Neil Van Dyke
;;; @Version     0.2
;;; @Date        2011-08-23
;;; @PLaneT      neil/uri:1:=0

;; TODO: !!! document this.  regarding test failures, according to
;; http://tools.ietf.org/html/rfc3986#section-3.5 , fragment identifiers can
;; contain "/" and "?", but that might break some other code, so we will encode
;; those.

;; $Id: uri.rkt,v 1.531 2011/08/23 06:37:30 neilpair Exp $

;;; @legal
;;; Copyright @copyright{} 2003--2011 Neil Van Dyke.  This program is Free
;;; Software; you can redistribute it and/or modify it under the terms of the
;;; GNU Lesser General Public License as published by the Free Software
;;; Foundation; either version 3 of the License (LGPL 3), or (at your option)
;;; any later version.  This program is distributed in the hope that it will be
;;; useful, but without any warranty; without even the implied warranty of
;;; merchantability or fitness for a particular purpose.  See
;;; @indicateurl{http://www.gnu.org/licenses/} for details.  For other licenses
;;; and consulting, please contact the author.
;;; @end legal

(require (planet neil/srfi-9-plus:1:1))

;;; @section Introduction

;;; @i{WARNING: This package is being actively developed.  A future version is
;;; expected to introduce some major non-backward-compatible changes.}
;;;
;;; @b{uri} is a Racket code library for parsing, representing, and
;;; transforming Web Uniform Resource Identifiers (URI) , which includes
;;; Uniform Resource Locators (URL) and Uniform Resource Names (URN).  It
;;; supports absolute and relative URIs and URI references.
;;; @uref{http://www.ietf.org/rfc/rfc3305.txt, RFC2396} is the principal
;;; reference used for this implementation.  Earlier versions were informed by
;;; other RFCs, including @uref{http://www.ietf.org/rfc/rfc2396.txt, RFC2396}
;;; and @uref{http://www.ietf.org/rfc/rfc2732.txt, RFC2732}.
;;;
;;; Goals of this package are correctness, efficiency, and power.

;; TODO: !!! update for IETF @uref{STD66,
;; ftp://ftp.rfc-editor.org/in-notes/std/std66.txt} (also RFC3986)

;; Character Portability and Utilities:

(define (%hex-char->integer c)
  (case c
    ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4)
    ((#\5) 5) ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9)
    ((#\A #\a) 10) ((#\B #\b) 11) ((#\C #\c) 12)
    ((#\D #\d) 13) ((#\E #\e) 14) ((#\F #\f) 15)
    (else #f)))

(define (%two-hex-char->ascii-char str k)
  (integer->char
   (+ (* 16 (%hex-char->integer (string-ref str k)))
      (%hex-char->integer (string-ref str (+ 1 k))))))

;; Immutability Portability:

;; TODO: The immutability stuff is old, and most of it is probably overkill for
;; Racket.

(define (%take-i lst i)
  (if (< i 1)
      '()
      (let loop ((lst lst)
                 (i   i))
        (if (null? lst)
            '()
            (cons (car lst)
                  (if (< i 2)
                      '()
                      (loop (cdr lst) (- i 1))))))))

;; TODO: We had this commented-out before moving the antiresolution code back
;; in...
(define (%take-i/append list-a copy-len tail-list)
  (if (< copy-len 1)
      tail-list
      (let loop ((copy-len (- copy-len 1))
                 (list-a   list-a))
        (if (null? list-a)
            tail-list
            (cons (car list-a)
                  (if (< copy-len 1)
                      tail-list
                      (loop (- copy-len 1) (cdr list-a))))))))

(define (%list->list-i lst)
  ;; Note: currently only works with proper, non-cyclic lists.
  (let loop ((rest lst))
    (cond ((null? rest) lst)
          ((pair? rest) (if (immutable? rest)
                            (loop (cdr rest))
                            (let loop ((rest lst))
                              (if (null? rest)
                                  '()
                                  (cons (car rest)
                                        (loop (cdr rest)))))))
          (else (error "not a proper list" lst)))))

(define %map-i map)
;; (define (%map-i proc . lsts)
;;   (%list->list-i (apply map proc lsts)))

(define (%reverse-i lst)
  (let loop ((new-head '())
             (old-rest lst))
    (if (null? old-rest)
        new-head
        (loop (cons (car old-rest) new-head)
              (cdr old-rest)))))

(define %string->string-i string->immutable-string)

(define (%append-i . args)
  (if (null? args)
      '()
      ;; TODO: make sure final arg is immutable?
      (let loop ((head (car args))
                 (rest (cdr args)))
        (cond ((null? rest) head)
              ((null? head) (loop (car rest) (cdr rest)))
              (else         (let loop2 ((head2 (car head))
                                        (rest2 (cdr head)))
                              (cons
                               head2
                               (if (null? rest2)
                                   (loop (car rest) (cdr rest))
                                   (loop2 (car rest2) (cdr rest2))))))))))

(define (%string-append-i . args)
  (%string->string-i (apply string-append args)))

(define (%string-i . args)
  (%string->string-i (apply string args)))

(define (%substring-i str start-k end-k)
  (%string->string-i
   (if (and (= start-k 0) (or (not end-k) (= end-k (string-length str))))
       str
       (if end-k
           (substring str start-k end-k)
           (substring str start-k)))))

(define (%get-output-string-i . args)
  (%string->string-i (apply get-output-string args)))

;; Regexp Portability and Utilities:

(define (%rxpos-str pos str)
  (and pos
       (substring str (car pos) (cdr pos))))

(define (%rxpos-lowstr pos str)
  (let ((s (%rxpos-str pos str)))
    (if s (string-downcase s) #f)))

(define (%rxpos-lowsym pos str)
  (let ((s (%rxpos-lowstr pos str)))
    (if s (string->symbol s) s)))

;; (define (%rxpos-num pos str)
;;   (let ((s (%rxpos-str pos str)))
;;     (if s (string->number s) #f)))

(define %rxpos-unescape-num
  (let ((rx "^[0-9]+$"))
    (lambda (pos str)
      (if pos
          (let ((s (uri-unescape/shared-ok str (car pos) (cdr pos))))
            (if (regexp-match rx s)
                (string->number s)
                #f))
          #f))))

;; (define (%rxpos-str-i pos str)
;;   (if pos (%substring-i str (car pos) (cdr pos)) #f))

(define (%rxpos-unescape-str-i pos str)
  (if pos (uri-unescape-i str (car pos) (cdr pos)) #f))

;; (define (%rxpos-lowstr-i pos str)
;;   (if pos
;;       (%string->string-i
;;        (string-downcase (substring str (car pos) (cdr pos))))
;;       #f))

(define (%rxpos-unescape-lowstr-i pos str)
  (if pos
      (%string->string-i
       (string-downcase (uri-unescape/shared-ok str (car pos) (cdr pos))))
      #f))

(define (%rxpos-subtract pos offset)
  (if (and pos offset (not (zero? offset)))
      (cons (- (car pos) offset)
            (- (cdr pos) offset))
      pos))

;; (define (%rxpos->rxpos-i pos)
;;   (if pos
;;       (cons (car pos) (cdr pos))
;;       #f))

(define (%make-rx-replace-map-posns
         empty-string
         os-result-proc
         substring-result-proc
         orig-result-proc)
  (let ((fixed
         (lambda (rx str proc start end)
           (let ((end (let ((len (string-length str)))
                        (if (and end (<= end len)) end len))))
             (if (>= start end)
                 empty-string
                 (let ((os #f))
                   (let loop ((beg start))
                     (let ((rxmatch (regexp-match-positions rx str beg end)))
                       (if rxmatch
                           (begin (or os
                                      (set! os (open-output-string)))
                                  (let ((skip-end (car (car rxmatch))))
                                    (and (> skip-end beg)
                                         (display (substring str beg skip-end)
                                                  os)))
                                  (display (apply proc rxmatch) os)
                                  (let ((new-beg (cdr (car rxmatch))))
                                    (and (< new-beg end)
                                         (loop new-beg))))
                           (and os
                                (display (substring str beg end) os)))))
                   (cond (os => os-result-proc)
                         ((or (not (zero? start)) end)
                          (substring-result-proc str start end))
                         (else           (orig-result-proc str)))))))))
    (case-lambda
      ((rx str proc start end) (fixed rx str proc start end))
      ((rx str proc start)     (fixed rx str proc start #f))
      ((rx str proc)           (fixed rx str proc 0     #f)))))

(define %rx-replace-map-posns/new-mutable
  (%make-rx-replace-map-posns ""
                              get-output-string
                              substring
                              string-copy))

(define %rx-replace-map-posns-i
  (%make-rx-replace-map-posns ""
                              %get-output-string-i
                              %substring-i
                              %string->string-i))

(define %rx-replace-map-posns/shared-ok
  (%make-rx-replace-map-posns ""
                              get-output-string
                              substring
                              (lambda (n) n)))

(define (%make-rx-replacers/nm-i-so rx proc)
  (let ((make-proc (lambda (rx-replace-map-posns)
                     (let ((fixed
                            (lambda (str start end)
                              (rx-replace-map-posns rx
                                                    str
                                                    (lambda args
                                                      (apply proc str args))
                                                    start
                                                    end))))
                       (case-lambda
                         ((str start end) (fixed str start end))
                         ((str start)     (fixed str start #f))
                         ((str)           (fixed str 0     #f)))))))
    (values (make-proc %rx-replace-map-posns-i)
            (make-proc %rx-replace-map-posns/new-mutable)
            (make-proc %rx-replace-map-posns/shared-ok))))

(define-syntax %with-rx-match-positions
  (syntax-rules (else)
    ((_ RMP MATCHED)
     (%with-rx-match-positions
      RMP MATCHED
      (else (error "regexp match failed"))))
    ((_ (RMP-ARGS ...) ((VARS ...) MATCHED-EXPS ...) (else ELSE-EXPS ...))
     (let ((rxmatch (regexp-match-positions RMP-ARGS ...)))
       (if rxmatch
           (apply (lambda (VARS ...) MATCHED-EXPS ...) rxmatch)
           (begin ELSE-EXPS ...))))))

(define %rxpos-tag (string->symbol "*%rxpos*"))

(define (%make-tagged-rxpos rxpos)
  (cons %rxpos-tag rxpos))

(define (%tagged-rxpos? v)
  (and (pair? v) (eq? (car v) %rxpos-tag)))

;; (define (%tagged-rxpos-values-or-value v proc)
;;   (if (%tagged-rxpos? v)
;;       (proc (cadr v) (cddr v))
;;       v))

(define (%rxpos-subtract-and-tag pos offset)
  (%make-tagged-rxpos (%rxpos-subtract pos offset)))

(define-syntax %uri-rxpos-field-proc
  (syntax-rules ()
    ((_ GET-PROC PARSE-PROC SET-PROC)
     (lambda (uri)
       (let ((v (GET-PROC uri)))
         (if (%tagged-rxpos? v)
             (let ((pos (cdr v)))
               ;; TODO: This is kinda weird to be setting the value to #f.  We
               ;; have to make sure that all the parsed value representations
               ;; are OK with that.  We should probably have a "/pos" form of
               ;; the procedures instead.
               (let ((o (if pos
                            (PARSE-PROC (uri->string uri)
                                        (car pos)
                                        (cdr pos))
                            #f)))
                 (SET-PROC uri o)
                 o))
             v))))))

;; Utilities:

(define (%string-or-f->string-i-or-f str)
  (and str (%string->string-i str)))

;;; @section Escaping and Unescaping

;;; Several procedures to support escaping and unescaping of URI component
;;; strings, as described in [RFC2396 sec. 2.4], are provided.  Also provided
;;; are escaping and unescaping procedures that also support @code{+} as an
;;; encoding of a space character, as is used in some HTTP encodings of HTML
;;; forms.

;;;
;;; These procedures have multiple variants, concerning mutability of the
;;; strings they yield, and following the naming convention:
;;;
;;; @table @asis
;;;
;;; @item @i{foo}@code{-i}
;;; Always yields an immutable string (or a new string, if the Scheme
;;; implementation does not support immutable string).
;;;
;;; @item @i{foo}@code{/new-mutable}
;;; Always yields a new, mutable string.
;;;
;;; @item @i{foo}@code{/shared-ok}
;;; If the output is equal to the input, might yield the input string rather
;;; than yielding a copy of it.
;;;
;;; @end table
;;;
;;; Many applications will not call these procedures directly, since most of
;;; this library's interface automatically escapes and unescapes strings as
;;; appropriate.

;; @defproc uri-escape       str [start [end]] @result{} string
;; @defprocx  uri-escape/new-mutable         str [start [end]] @result{} string
;; @defprocx uri-escape/shared-ok str [start [end]] @result{} string

;;; @defproc uri-escape       str [start [end]]
;;; @defprocx  uri-escape/new-mutable         str [start [end]]
;;; @defprocx uri-escape/shared-ok str [start [end]]
;;;
;;; Yields a URI-escaped encoding of string @var{str}.  If @var{start} and
;;; @var{end} are given, then they designate the substring of @var{str} to use.
;;; All characters are escaped, except alphanumerics, minus, underscore,
;;; period, and tilde.  For example.
;;;
;;; @lisp
;;; (uri-escape "a = b/c + d") @result{} "a%20%3D%20b%2Fc%20%2B%20d"
;;; @end lisp

(define-values (uri-escape-i
                uri-escape/new-mutable
                uri-escape/shared-ok)
  (%make-rx-replacers/nm-i-so
   #rx"[^-_.~a-zA-Z0-9]"
   (lambda (str pos)
     (char->uri-escaped-string (string-ref str (car pos))))))

;; @defproc  uri-plusescape-i       str [start [end]] @result{} string
;; @defprocx uri-plusescape/new-mutable         str [start [end]] @result{} string
;; @defprocx uri-plusescape/shared-ok str [start [end]] @result{} string

;;; @defproc  uri-plusescape-i       str [start [end]]
;;; @defprocx uri-plusescape/new-mutable         str [start [end]]
;;; @defprocx uri-plusescape/shared-ok str [start [end]]
;;;
;;; Like @code{uri-escape}, except encodes space characters as @code{"+"}
;;; instead of @code{"%20"}.  This should generally only be used to mimic the
;;; encoding some Web browsers do of HTML form values.  For example:
;;;
;;; @lisp
;;; (uri-plusescape "a = b/c + d") @result{} "a+%3D+b%2Fc+%2B+d"
;;; @end lisp

(define-values (uri-plusescape-i
                uri-plusescape/new-mutable
                uri-plusescape/shared-ok)
  (%make-rx-replacers/nm-i-so
   #rx"( )|[^-_.~a-zA-Z0-9 ]"
   (lambda (str pos space-pos)
     (if space-pos
         "+"
         (char->uri-escaped-string (string-ref str (car pos)))))))

;; @defproc  uri-unescape-i       str [start [end]] @result{} string
;; @defprocx uri-unescape/new-mutable         str [start [end]] @result{} string
;; @defprocx uri-unescape/shared-ok str [start [end]] @result{} string

;;; @defproc  uri-unescape-i       str [start [end]]
;;; @defprocx uri-unescape/new-mutable         str [start [end]]
;;; @defprocx uri-unescape/shared-ok str [start [end]]
;;;
;;; Yields an URI-unescaped string from the encoding in string @code{str}.  If
;;; @var{start} and @var{end} are given, then they designate the substring of
;;; @var{str} to use.  For example:
;;;
;;; @lisp
;;; (uri-unescape "a%20b+c%20d") @result{} "a b+c d"
;;; @end lisp

(define-values (uri-unescape-i
                uri-unescape/new-mutable
                uri-unescape/shared-ok)
  (%make-rx-replacers/nm-i-so
   #rx"%([0-9a-fA-F][0-9a-fA-F])?"
   (lambda (str pos hex-pos)
     (if hex-pos
         (%two-hex-char->ascii-char str (car hex-pos))
         ;; TODO: Benchmark above against:
         ;; (integer->char
         ;; (string->number (substring str (car hex-pos) (cdr hex-pos)) 16))
         "%"))))

;; @defproc  uri-unplusescape-i       str [start [end]] @result{} string
;; @defprocx uri-unplusescape/new-mutable         str [start [end]] @result{} string
;; @defprocx uri-unplusescape/shared-ok str [start [end]] @result{} string

;;; @defproc  uri-unplusescape-i       str [start [end]]
;;; @defprocx uri-unplusescape/new-mutable         str [start [end]]
;;; @defprocx uri-unplusescape/shared-ok str [start [end]]
;;;
;;; Like @code{uri-unescape}, but also decodes the plus (@code{+}) character as
;;; to space character.  For example:
;;;
;;; @lisp
;;; (uri-unplusescape "a%20b+c%20d") @result{} "a b c d"
;;; @end lisp

(define-values (uri-unplusescape-i
                uri-unplusescape/new-mutable
                uri-unplusescape/shared-ok)
  (%make-rx-replacers/nm-i-so
   #rx"(\\+)|%([0-9a-fA-F][0-9a-fA-F])?"
   (lambda (str pos plus-pos hex-pos)
     (cond (plus-pos " ")
           (hex-pos  (%two-hex-char->ascii-char str (car hex-pos)))
           ;; TODO: Benchmark above against:
           ;; (hex-pos
           ;; (integer->char
           ;; (string->number (substring str (car hex-pos) (cdr hex-pos)) 16)
           ;; 16))
           (else     "%")))))

;; @defproc  char->uri-escaped-string   chr @result{} string
;; @defprocx char->uri-escaped-string-i chr @result{} string

;;; @defproc  char->uri-escaped-string   chr
;;; @defprocx char->uri-escaped-string-i chr
;;;
;;; Yields a URI-escaped string of character @var{chr}.  For example:
;;;
;;; @lisp
;;; (char->uri-escaped-string #\/) @result{} "%2F"
;;; @end lisp

(define-values (char->uri-escaped-string
                char->uri-escaped-string-i)
  (let* ((hex #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
                #\A #\B #\C #\D #\E #\F))
         (make-proc
          (lambda (string)
            (lambda (chr)
              (let ((n (char->integer chr)))
                (string #\%
                        (vector-ref hex (quotient  n 16))
                        (vector-ref hex (remainder n 16))))))))
    (values (make-proc string)
            (make-proc %string-i))))

;; @section URI Objects and URI Strings

(define-record-type/write %uri
  (%make-uri string scheme opaque-k pound-k auth path query)
  uri?
  (lambda (record port write?)
    (if write?
        (begin (display "#uri" port)
               (write (uri->string record) port))
        (display (uri->string record) port)))
  (string   uri->string   %set-uri-string!)
  (scheme   %uri-scheme   %set-uri-scheme!)
  (opaque-k %uri-opaque-k %set-uri-opaque-k!)
  (pound-k  %uri-pound-k  %set-uri-pound-k!)
  (auth     %uri-auth     %set-uri-auth!)
  (path     %uri-path     %set-uri-path!)
  (query    %uri-query    %set-uri-query!))

;;; @section URI API

;;; This section describes the ``URI string'' API, while the next section
;;; describes the ``URI object,'' (@code{uri}) API.  All procedures in this
;;; section yield URIs using immutable strings, and accept URIs as strings
;;; (immutable or mutable) or as the opaque objects described in the next
;;; section.

;;; @subsection Predicate

;;; @defproc uri? v
;;;
;;; !!!

;;; @subsection Converting Strings to URI Objects

;; TODO: Add URI extraction from strings, and distinguish from string
;; conversion.  The normal *string*->uri* procedures maybe shouldn't strip
;; leading and trailing garbage.  Have "extract-uri" and "extract-uri"
;; procedures?

;; @defproc  string->uri               str               @result{} uri
;; @defprocx string/base->uri          str base-uri      @result{} uri
;; @defprocx string/base-uri->uri str base-uri @result{} uri

;;; @defproc  string->uri               str              
;;; @defprocx string/base->uri          str base-uri     
;;; @defprocx string/base-uri->uri str base-uri
;;;
;;; !!!

;;
;; Note: The value of @code{(uri->string (string->uri @var{S}))} will NOT
;; always be equal to @var{S}.

(define (string->uri str)
  (substring->uri str 0 #f))

(define (string/base-uri->uri str base-uri)
  (substring/base-uri->uri str 0 #f base-uri))

(define (string/base->uri str base-uri)
  (substring/base-uri->uri str 0 #f (if base-uri
                                        (uri-or-string->uri base-uri)
                                        #f)))

;; @defproc  substring->uri             str start end             @result{} uri
;; @defprocx substring/base-uri-or-string->uri        str start end base-uri-or-string    @result{} uri
;; @defprocx substring/base-uri->uri str start end base-uri @result{} uri

;;; @defproc  substring->uri             str start end            
;;; @defprocx substring/base-uri-or-string->uri        str start end base-uri-or-string   
;;; @defprocx substring/base-uri->uri str start end base-uri
;;;
;;; !!!

(define substring->uri
  (let ((rx (regexp
             (string-append
              "^[ \t<]*"
              "("                       ; <1 used
              "(?:"                     ; <: scheme-colon
              "([a-zA-Z][-+.a-zA-Z0-9]*)" ; =2 scheme
              ":)?"                     ; >: scheme-colon
              "(?://"                   ; <: slashslash-authority
              "([^<>?/#]*)"             ; =3 authority
              ")?"                      ; >: slashslash-authority
              "([^<>?#]*)"              ; =4 path
              "(?:\\?"                  ; <: question-query
              "([^<>#]*)"               ; =5 query
              ")?"                      ; >: question-query
              "(#[^>]*)?"               ; =6 pound-fragment
              ")"                       ; >1 used
              ))))
    (lambda (str start end)
      (%with-rx-match-positions
       (rx str start end)
       ((whole used scheme authority path query pound-fragment)
        (let ((used-start (car used)))
          (%make-uri
           ;; string
           (%substring-i str used-start (cdr used))
           ;; scheme
           (%rxpos-lowsym scheme str)
           ;; opaque-k
           (if scheme
               (+ 1 (cdr (%rxpos-subtract scheme used-start)))
               0)
           ;; pound-k
           (and pound-fragment
                (car (%rxpos-subtract pound-fragment used-start)))
           ;; auth, path, query
           (%rxpos-subtract-and-tag authority used-start)
           (%rxpos-subtract-and-tag path      used-start)
           (%rxpos-subtract-and-tag query     used-start))))))))

(define (substring/base-uri->uri str start end base-uri)
  ;; TODO: Make a version of this that doesn't call substring->uri,
  ;; which will save some allocations in a potentially much-called
  ;; procedure (for example, parsing an HTML Web page with 1000 URLs while
  ;; resolving against a known base URI).
  (and base-uri
       (let ((uri (substring->uri str start end)))
         (resolved-uri uri base-uri)
         uri)))

(define (substring/base-uri-or-string->uri str start end base-uri-or-string)
  (substring/base-uri->uri str start end (if base-uri-or-string
                                             (uri-or-string->uri base-uri-or-string)
                                             #f)))

;;; @defproc uri-or-string->uri uri-or-string @result{} uri
;;;
;;; !!! convenience

(define (uri-or-string->uri uri-or-string)
  (cond ((uri? uri-or-string) uri-or-string)
        ((string? uri-or-string) (string->uri uri-or-string))
        (else          (error "expected uri or string, got:" uri-or-string))))

;;; @subsection Writing URIs to Ports and Converting URIs to Strings

;; @defproc  display-uri            uri port @result{} undef
;; @defprocx display-uri/nofragment uri port @result{} undef

;;; @defproc  display-uri            uri port
;;; @defprocx display-uri/nofragment uri port
;;;
;;; Displays @var{uri} to output port @var{port}.  For example:
;;;
;;; @lisp
;;; (display-uri "http://s/foo#bar" (current-output-port))
;;; @print{} http://s/foo#bar
;;; (display-uri/nofragment "http://s/foo#bar" (current-output-port))
;;; @print{} http://s/foo
;;; @end lisp

(define (display-uri uri port)
  (display uri port))

(define (display-uri/nofragment uri port)
  ;; TODO: Do a faster and simpler version, using pound-k and substring?
  (display (uri->string/nofragment uri) port))

;; @defproc  uri->string uri @result{} string

;;; @defproc  uri->string uri
;;;
;;; Yields the full string representation of URI @var{uri}.  Of course this is
;;; not needed when using only the string representation of URI, but using this
;;; procedure in libraries permits the @code{uri} to also be used.  For
;;; example:
;;;
;;; @lisp
;;; (define my-uri (string->uri "http://www/"))
;;; my-uri                   @result{} <uri:"http://www/">
;;; (uri->string my-uri)     @result{} "http://www/"
;;; @end lisp

(define (uri->string/nofragment uri)
  (let ((pound-k (%uri-pound-k uri)))
    (if pound-k
        (%substring-i (uri->string uri) 0 pound-k)
        (uri->string uri))))

;;; @subsection URI Schemes

;;; URI schemes are currently represented as lowercase Racket symbols and
;;; associated data.

;; @defvar  ftp-uri-scheme    @result{} urischeme
;; @defvarx gopher-uri-scheme @result{} urischeme
;; @defvarx http-uri-scheme   @result{} urischeme
;; @defvarx https-uri-scheme  @result{} urischeme
;; @defvarx imap-uri-scheme   @result{} urischeme
;; @defvarx ipp-uri-scheme    @result{} urischeme
;; @defvarx news-uri-scheme   @result{} urischeme
;; @defvarx nfs-uri-scheme    @result{} urischeme
;; @defvarx telnet-uri-scheme @result{} urischeme

;;; @defvar  ftp-uri-scheme
;;; @defvarx gopher-uri-scheme
;;; @defvarx http-uri-scheme
;;; @defvarx https-uri-scheme
;;; @defvarx imap-uri-scheme
;;; @defvarx ipp-uri-scheme
;;; @defvarx news-uri-scheme
;;; @defvarx nfs-uri-scheme
;;; @defvarx telnet-uri-scheme
;;;
;;; Some common URI scheme symbols, as a convenience for Racket code that must
;;; be portable to Racket implementations with case-insensitive readers.  For
;;; example, in some Racket implementations:
;;;
;;; @lisp
;;; 'ftp           @result{} FTP
;;; ftp-uri-scheme @result{} ftp
;;; @end lisp

(define ftp-uri-scheme    (string->symbol "ftp"))
(define gopher-uri-scheme (string->symbol "gopher"))
(define http-uri-scheme   (string->symbol "http"))
(define https-uri-scheme  (string->symbol "https"))
(define imap-uri-scheme   (string->symbol "imap"))
(define ipp-uri-scheme    (string->symbol "ipp"))
(define news-uri-scheme   (string->symbol "news"))
(define nfs-uri-scheme    (string->symbol "nfs"))
(define telnet-uri-scheme (string->symbol "telnet"))

;;; @defproc uri-scheme uri
;;;
;;; Yields the URI scheme of @var{uri}, or @code{#f} if none can be determined.
;;; For example:
;;;
;;; @lisp
;;; (uri-scheme "Http://www") @result{} http
;;; @end lisp

(define (uri-scheme uri)
  (%uri-scheme uri))

;; ;;; @defproc uri-with-scheme uri urischeme @result{} string
;; ;;;
;; ;;; TODO: in the current version oo this library, just does a string
;; ;;; replacement of the uri scheme.  no sensitivity to default port numbers
;; ;;; of uri schemes (partly because we are getting into territory where we
;; ;;; need to know whether an authority is a server authority.
;;
;; (define (uri-with-scheme uri urischeme)
;;   ;; TODO: Just do a string operation here, if it's a string for which we
;;   ;; don't have a uri.
;;   ;;
;;   ;; TODO: Maybe force urischeme to a valid one, so that they can use quoted
;;   ;; symbols in a case-insensitive Racket implementation safely.
;;   (uri->string (uri-with-scheme (uri-or-string->uri uri) urischeme)))

(define %default-portnums
  (list (cons ftp-uri-scheme    21)
        (cons gopher-uri-scheme 70)
        (cons http-uri-scheme   80)
        (cons https-uri-scheme  443)
        (cons imap-uri-scheme   143)
        (cons ipp-uri-scheme    631)
        (cons news-uri-scheme   119)
        (cons nfs-uri-scheme    2049)
        (cons telnet-uri-scheme 23)))

;; TODO: Introduce a parameter for an ADT for default port numbers

;;; @defproc register-uri-scheme-default-portnum sym portnum
;;;
;;; Registers integer @var{portnum} as the default port number for the server
;;; authority component of URI scheme @var{sym}.
;;;
;;; @lisp
;;; (define x-foo-uri-scheme (string->symbol "x-foo"))
;;; (register-uri-scheme-default-portnum x-foo-uri-scheme 007)
;;; (register-uri-scheme-default-portnum x-foo-uri-scheme 666)
;;; @error{} cannot change uri scheme default portnum: x-foo 7 666
;;; @end lisp

(define (register-uri-scheme-default-portnum urischeme portnum)
  ;; TODO: Ideally, we would have a mutex lock around the list.
  ;; But wait til we make it a hashtable with other uri-scheme data.
  (let ((old-portnum (urischeme-default-portnum urischeme)))
    (if old-portnum
        (and (not (equal? portnum old-portnum))
             (error "cannot change uri scheme default portnum:"
                    urischeme
                    old-portnum
                    portnum))
        (set! %default-portnums
              (cons (cons urischeme portnum)
                    %default-portnums)))))

;;; @defproc register-uri-scheme-hierarchical sym
;;;
;;; Registers URI scheme @var{sym} as having a ``hierarchical'' form as
;;; described in [RFC2396 sec. 3].

(define (register-urischeme-hierarchical urischeme)
  ;; TODO: Mutex it, although pretty benign if we don't.
  (if (memq urischeme %hierarchical-schemes)
      (void)
      (begin (set! %hierarchical-schemes
                   (cons urischeme %hierarchical-schemes))
             (void))))

;;; @subsection URI Reference Fragment Identifiers

;;; @defproc  uri-fragment         uri
;;; @defprocx uri-fragment/escaped uri
;;;
;;; Yields the fragment identifier component of URI (or URI reference)
;;; @var{uri} as a string, or @code{#f} if there is no fragment.
;;; @code{uri-fragment} yields the fragment in unescaped form, and
;;; @code{uri-fragment/escaped} yields an escaped form in the unusual case that
;;; is desired.  For example:
;;;
;;; @lisp
;;; (uri-fragment         "foo#a%20b") @result{} "a b"
;;; (uri-fragment/escaped "foo#a%20b") @result{} "a%20b"
;;; @end lisp

(define (uri-fragment/escaped uri)
  ;; TODO: Do we want to escape better if the original fragment wasn't?
  (let ((pound-k (%uri-pound-k uri)))
    (if pound-k
        (%substring-i (uri->string uri)
                      (+ 1 pound-k)
                      #f)
        #f)))

(define (uri-fragment uri)
  ;; Note: We make this always immutable because some strings we yield will be
  ;; immutable, so we should be consistent.
  (let ((pound-k (%uri-pound-k uri)))
    (if pound-k
        (uri-unescape-i (uri->string uri) (+ 1 pound-k))
        #f)))

;;; @defproc uri-without-fragment uri
;;;
;;; Yields @var{uri} without the fragment component.  For example:
;;;
;;; @lisp
;;; (uri-without-fragment "http://w/#bar") @result{} "http://w/"
;;; @end lisp

(define (uri-without-fragment uri)
  (uri-with-fragment uri #f))

;;; @defproc  uri-with-fragment         uri fragment
;;; @defprocx uri-with-fragment/escaped uri fragment
;;;
;;; Yields a URI that is like @var{uri} except with the fragment @var{fragment}
;;; (or no fragment if @var{fragment} is @code{#f}).  For example:
;;;
;;; @lisp
;;; (uri-with-fragment "http://w/"     "foo") @result{} "http://w/#foo"
;;; (uri-with-fragment "http://w/#foo" "bar") @result{} "http://w/#bar"
;;; (uri-with-fragment "http://w/#bar" #f)    @result{} "http://w/"
;;; @end lisp
;;;
;;; The @code{uri-with-fragment/escaped} variant can be used when the desired
;;; fragment string is already in uri-escaped form:
;;;
;;; @lisp
;;; (uri-with-fragment         "foo" "a b")   @result{} "foo#a%20b"
;;; (uri-with-fragment/escaped "foo" "a%20b") @result{} "foo#a%20b"
;;; @end lisp

(define (uri-with-fragment uri fragment)
  (uri-with-fragment/escaped uri
                             (if fragment (uri-escape-i fragment) #f)))

(define (uri-with-fragment/escaped uri fragment)
  ;; TODO: Don't use string->uri and friends here.  Or at least copy over
  ;; any parsed server, path, and query info.
  (let ((old-pound-k (%uri-pound-k uri)))
    (if fragment
        (if old-pound-k
            (if (equal? (uri-fragment/escaped uri) fragment)
                uri
                (string->uri (%string-append-i
                              (uri->string/nofragment uri)
                              "#"
                              fragment)))
            (string->uri (%string-append-i
                          (uri->string uri)
                          "#"
                          fragment)))
        (if old-pound-k
            (string->uri (uri->string/nofragment uri))
            uri))))

;;; @subsection Hierarchical URIs

;;; This and some of the following subsections concern ``hierarchical'' generic
;;; URI syntax as described in @uref{http://www.ietf.org/rfc/rfc3305.txt,
;;; RFC2396} sec. 3.

;;; @defproc  uri-hierarchical? uri
;;;
;;; Yields a Boolean value for whether or not the URI scheme of URI @var{uri}
;;; is known to have a ``hierarchical'' generic URI layout.  For example:
;;;
;;; @lisp
;;; (uri-hierarchical? "http://www/")   @result{} #t
;;; (uri-hierarchical? "mailto://www/") @result{} #f
;;; (uri-hierarchical? "//www/")        @result{} #f
;;; @end lisp

(define (uri-hierarchical? uri)
  (urischeme-hierarchical? (%uri-scheme uri)))

;;; @subsection Server-Based Naming Authorities

;;; Several procedures extract the server authority values from URIs [RFC2396
;;; sec. 3.2.2].

;;; @defproc uri-server-userinfo+host+portnum uri
;;;
;;; Yields three values for the server authority of URI @var{uri}: the userinfo
;;; as a string (or @code{#f}), the host as a string (or @code{#f}), and the
;;; effective port number as an integer (or @code{#f}).  The effective port
;;; number of a server authority defaults to the default of the URI scheme
;;; unless overridden.  For example (note the effective port number is 21, the
;;; default for the @code{ftp} scheme):
;;;
;;; @lisp
;;; (uri-server-userinfo+host+portnum "ftp://anon@@ftp.foo.bar/")
;;; @result{} "anon" "ftp.foo.bar" 21
;;; @end lisp

(define (uri-server-userinfo+host+portnum uri)
  (uri-userinfo+host+portnum (uri-or-string->uri uri)))

;;; @defproc  uri-server-userinfo uri
;;; @defprocx uri-server-host     uri
;;; @defprocx uri-server-portnum  uri
;;;
;;; Yield the respective part of the server authority of @var{uri}.  See the
;;; discussion of @code{uri-server-userinfo+host+portnum}.

(define (uri-server-userinfo uri)
  (uriserver-userinfo (uri-uriserver (uri-or-string->uri uri))))

(define (uri-server-host uri)
  (uriserver-host (uri-uriserver (uri-or-string->uri uri))))

(define (uri-server-portnum uri)
  (uri-portnum (uri-or-string->uri uri)))

;;; @subsection Hierarchical Paths

;;; A parsed hierarchical path [RFC2396 sec. 3] is represented in
;;; @b{uri} as a tuple of a list of path segments and an @dfn{upcount}.
;;; The list of path segments does not contain any ``@code{.}'' or
;;; ``@code{..}'' relative components, as those are removed during parsing.
;;; The upcount is either @code{#f}, meaning an absolute path, or an integer 0
;;; or greater, meaning a relative path of that many levels ``up.''  A path
;;; segment without any parameters is represented as either a string or, if
;;; empty, @code{#f}.  For example:
;;;
;;; @lisp
;;; (uri-path-upcount+segments "/a/b/")       @result{} #f ("a" "b" #f)
;;; (uri-path-upcount+segments "/a/b/c")      @result{} #f ("a" "b" "c")
;;; (uri-path-upcount+segments "/a/../../../b/c") @result{} 2  ("b" "c")
;;; @end lisp
;;;
;;; @noindent
;;; and:
;;;
;;; @lisp
;;; (uri-path-upcount+segments "/.")  @result{} #f ()
;;; (uri-path-upcount+segments "/")   @result{} #f (#f)
;;; (uri-path-upcount+segments ".")   @result{} 0  (#f)
;;; (uri-path-upcount+segments "")    @result{} 0  ()
;;; (uri-path-upcount+segments "./")  @result{} 0  (#f)
;;; (uri-path-upcount+segments "..")  @result{} 1  ()
;;; (uri-path-upcount+segments "/..") @result{} 1  ()
;;; (uri-path-upcount+segments "../") @result{} 1  (#f)
;;; @end lisp
;;;
;;; A path segment with parameters is represented as a list, with the first
;;; element a string or @code{#f} for the path name, and the remaining elements
;;; strings for the parameters.  For example:
;;;
;;; @lisp
;;;  (uri-path-segments "../../a/b;p1/c/d;p2;p3/;p4")
;;; @result{} ("a" ("b" "p1") "c" ("d" "p2" "p3") (#f "p4"))
;;; @end lisp
;;;
;;; In the current version of @b{uri}, parsed paths are actually
;;; represented in reverse, which simplifies path resolution and permits list
;;; tails to be shared among potentially large numbers of long paths.  For
;;; example (@code{uripath} is a concept of the ``object URI'' API):
;;;
;;; @lisp
;;; (let ((base (string->uripath "/a/b/c/index.html")))
;;;   (map (lambda (n)
;;;          (resolved-uripath (string->uripath n) base))
;;;        '("x.html" "y/y.html" "../z/z.html")))
;;; @result{}
;;; @end lisp
;;; @example
;;; (("x.html" . #0=("c" . #1=("b" "a")))
;;;  ("y.html" "y" . #0#)
;;;  ("z.html" "z" . #1#))
;;; @end example

;;; @defproc  uri-path-upcount+segments         uri
;;; @defprocx uri-path-upcount+segments/reverse uri
;;;
;;; Yields the path upcount and the segments of @var{uri} as two values.  The
;;; segments list should be considered immutable, as it might be shared
;;; elsewhere.  @code{uri-path-upcount+segments/reverse} yields the segments
;;; list in reverse order, and is the more efficient of the two procedures.
;;;
;;; @lisp
;;; (uri-path-upcount+segments/reverse "../a/../../b/./c")
;;; @result{} 2 ("c" "b")
;;; (uri-path-upcount+segments         "../a/../../b/./c")
;;; @result{} 2 ("b" "c")
;;; @end lisp

(define (uri-path-upcount+segments uri)
  (uripath-upcount+segments (uri-uripath (uri-or-string->uri uri))))

(define (uri-path-upcount+segments/reverse uri)
  (uripath-upcount+segments/reverse (uri-uripath (uri-or-string->uri uri))))

;;; @defproc  uri-path-upcount          uri
;;; @defprocx uri-path-segments         uri
;;; @defprocx uri-path-segments/reverse uri
;;;
;;; See the documentation for @code{uri-path-upcount+segments}.
;;;
;;; @lisp
;;; (uri-path-upcount          "../a/../../b/./c") @result{} 2
;;; (uri-path-segments         "../a/../../b/./c") @result{} ("b" "c")
;;; (uri-path-segments/reverse "../a/../../b/./c") @result{} ("c" "b")
;;; @end lisp

(define (uri-path-upcount uri)
  (uripath-upcount (uri-uripath (uri-or-string->uri uri))))

(define (uri-path-segments uri)
  (uripath-segments (uri-uripath (uri-or-string->uri uri))))

(define (uri-path-segments/reverse uri)
  (uripath-segments/reverse (uri-uripath (uri-or-string->uri uri))))

;;; @defproc  urisegment-name        urisegment
;;; @defprocx urisegment-params      urisegment
;;; @defprocx urisegment-name+params urisegment
;;; @defprocx urisegment-has-params? urisegment
;;;
;;; Yield the components of a parsed URI segment.  The values should be
;;; considered immutable.  For example:
;;;
;;; @lisp
;;; (urisegment-name+params "foo")              @result{} "foo" ()
;;; (urisegment-name+params #f)                 @result{} #f    ()
;;; (urisegment-name+params '("foo" "p1" "p2")) @result{} "foo" ("p1" "p2")
;;; (urisegment-name+params '(#f    "p1" "p2")) @result{} #f    ("p1" "p2")
;;; @end lisp

(define (urisegment-name segment)
  (if (pair? segment) (car segment) segment))

(define (urisegment-params segment)
  (if (pair? segment) (cdr segment) '()))

(define (urisegment-name+params segment)
  (if (pair? segment)
      (values (car segment) (cdr segment))
      (values segment       '())))

(define (urisegment-has-params? segment)
  (pair? segment))

(define (%parse-uri-path-params str start end)
  (%with-rx-match-positions
   (#rx"^([^;]+)?(;)?" str start end)
   ((whole param semi)
    (cons (if param
              (uri-unescape-i str (car param) (cdr param))
              #f)
          (if semi
              (%parse-uri-path-params str (cdr whole) end)
              '())))))

;; ;;; @defproc uri-path-string uri @result{} string
;;
;; ;;; @defproc uri-without-scheme-and-authority uri @result{} string

;;; @subsection Attribute-Value Queries

;;; This library provides support for parsing the URI query component [RFC2396
;;; sec. 3.4], as attribute-value lists in the manner of @code{http} URI scheme
;;; queries.  Parsed queries are represented as association lists, in which the
;;; @dfn{car} of each pair is the attribute name as a string, and the @dfn{cdr}
;;; is either the attribute value as a string or @code{#t} if no value given.
;;; All strings are uri-unescaped.  For example:
;;;
;;; @lisp
;;; (uri-query "?q=fiendish+scheme&case&x=&y=1%2B2")
;;; @result{}
;;; (("q" . "fiendish scheme") ("case" . #t) ("x" . "") ("y" . "1+2"))
;;; @end lisp

;; Note: not so good for @code{imap} URI scheme [RFC2192].

;;; @defproc uri-query uri
;;;
;;; Yields the parsed attribute-value query of @var{uri}, or @code{#f} if no
;;; query.  For example:
;;;
;;; @lisp
;;; (uri-query "?x=42&y=1%2B2") @result{} (("x" . "42") ("y" . "1+2"))
;;; @end lisp

;; TODO: Rename this to distinguish from other kinds of queries.

(define (uri-query uri)
  (uri-uriquery (uri-or-string->uri uri)))

;;; @defproc uri-query-value uri attr
;;;
;;; Yields the value of attribute @var{attr} in @var{uri}'s query, or @code{#f}
;;; if @var{uri} has no query component or no @var{attr} attribute.  If the
;;; attribute appears multiple times in the query, the value of the first
;;; occurrence is used.  For example:
;;;
;;; @lisp
;;; (uri-query-value "?x=42&y=1%2B2" "y") @result{} "1+2"
;;; @end lisp

(define (uri-query-value uri attr)
  (let ((query (uri-query uri)))
    (if query
        (uriquery-value query attr)
        #f)))

;;; @defproc uriquery-value uriquery attr
;;;
;;; Yields the value of attribute @var{attr} in @var{uriquery}, or @code{#f} if
;;; there is no such attribute.  If the attribute appears multiple times in the
;;; query, the value of the first occurrence is used.

(define (uriquery-value uriquery attr)
  (let ((pair (assoc attr uriquery)))
    (and pair (cdr pair))))

;;; @subsection Resolving Relative URI

;;; This subsection concerns resolving relative URI.

;;; @defproc absolute-uri? uri
;;;
;;; Yields a Boolean value for whether or not URI @var{uri} is
;;; @emph{known} by the library's criteria to be absolute.

(define (absolute-uri? uri)
  (let ((urischeme (%uri-scheme uri)))
    (if urischeme
        (if (urischeme-hierarchical? urischeme)
            (let-values (((server path query) (uri-uriserver+path+query uri)))
              (and server
                   path
                   (not (uripath-upcount path))))
            #f)
        #f)))

;;; @defproc resolved-uri uri base-uri
;;;
;;; Yields a URI string that is URI @var{uri} possibly resolved with respect to
;;; URI @var{base-uri}, but not necessarily absolute.  As an extension to
;;; [RFC2396] rules for resolution, @var{base-uri} may be a relative URI.
;;;
;;; @lisp
;;; (resolved-uri "x.html" "http://w/a/b/c.html")
;;; @result{} "http://w/a/b/x.html"
;;; (resolved-uri "//www:80/" "http:")
;;; @result{} "http://www/"
;;; @end lisp

(define (resolved-uri uri base-uri)
  (cond
   ((not base-uri)  uri)
   ((uri? uri)      (resolved-uri/base-uri uri (uri-or-string->uri base-uri)))
   ((equal? uri "") base-uri)
   (else
    ;; TODO: If "uri" is a string URI for which we don't yet have a uri, we
    ;; could use "string/base->uri", which in the future might be more
    ;; efficient.
    (resolved-uri/base-uri (uri-or-string->uri uri)
                           (uri-or-string->uri base-uri)))))

(define (resolved-uri/base-uri uri base-uri)
  (cond ((equal? (uri->string uri) "") base-uri)
        ((absolute-uri? uri)           uri)
        (else
         (let ((old-urischeme  (%uri-scheme uri))
               (base-urischeme (%uri-scheme base-uri)))
           (if (or (and old-urischeme (eq? old-urischeme base-urischeme))
                   (and (not old-urischeme) base-urischeme))
               (let ((new-urischeme base-urischeme))
                 (if (urischeme-hierarchical? new-urischeme)
                     ;; TODO: Potentially reuse uri.
                     (%make-hierarchical-uri
                      new-urischeme
                      (resolved-uriserver/default-portnum
                       (uri-uriserver       uri)
                       (uri-uriserver       base-uri)
                       (urischeme-default-portnum new-urischeme))
                      (resolved-uripath   (uri-uripath  uri)
                                          (uri-uripath  base-uri))
                      ;; TODO: is this right, that query not inherited?
                      (uri-uriquery    uri)
                      (uri-fragment    uri))
                     ;; Note: We don't yet know how to resolve non-hierarchical
                     ;; URI, so just yield the original URI but possibly with
                     ;; the scheme of the base.
                     (uri-with-scheme uri new-urischeme)))
               uri)))))

;;; @defproc absolute-uri uri
;;;
;;; Yields a URI that may be a variation on @var{uri} that has been forced to
;;; absolute (by, e.g., dropping relative path components, or supplying a
;;; missing path).  The result might not be an absolute URI, however, due to
;;; limitations of the library or insufficient information in the URI.  For
;;; example:
;;;
;;; @lisp
;;; (absolute-uri "http://w/../a") @result{} "http://w/a"
;;; (absolute-uri "http://w")      @result{} "http://w/"
;;; @end lisp

(define (absolute-uri uri)
  (if (uri-hierarchical? uri)
      (let* ((old-uripath (uri-uripath uri))
             (new-uripath (absolute-uripath old-uripath)))
        (if (eq? new-uripath old-uripath)
            uri
            ;; TODO: Constructing a new uri like this is potentially a
            ;; problem, if uri is later made extensible and other fields can
            ;; be added to it.
            (%make-hierarchical-uri
             (%uri-scheme    uri)
             (uri-uriserver uri)
             new-uripath
             (uri-uriquery uri)
             (uri-fragment uri))))
      uri))

;; TODO: normalized-uri
;;
;; @defproc normalized-uri uri @result{} string
;;
;; Yields a possibly ``normalized'' variation on URI @var{uri}, such as by
;; consistent use of escaping, and by resolving relative elements in any path.
;; The exact behavior of this procedure will change in future versions of the
;; library.

;;; @section URI Schemes

;;; @defproc uri-scheme uri
;;;
;;; !!!

;;; @defproc uri-with-scheme uri urischeme
;;;
;;; !!!

;; TODO: Is that right, above?

(define (uri-with-scheme uri urischeme)
  ;; TODO: what about port numbers on URIs with server authorities?  we should
  ;; at least double check that if we have the default port number under old
  ;; scheme, we have the default under the new scheme (we currently do, but
  ;; errors, or a default scheme registered after parsing might break that).
  ;; we should also decide what it means when the server authority has a
  ;; non-default port number for the old scheme -- just keep it, probably.
  ;; Actually, this procedure mainly makes sense only for URIs that don't
  ;; already have schemes.
  (if (eq? urischeme (%uri-scheme uri))
      uri
      ;; TODO: Make this reuse parsed authority/path/query values, if the new
      ;; scheme has the same format as the old scheme.
      (string->uri
       (let ((old-str (uri->string uri))
             (opaque-k (%uri-opaque-k uri)))

         (if (zero? opaque-k)
             (%string-append-i (urischeme->string urischeme)
                               ":"
                               old-str)
             (%string-append-i
              (urischeme->string urischeme)
              (substring old-str (- opaque-k 1) (string-length old-str))))))))

;;; @defproc  string->urischeme str
;;; @defprocx symbol->urischeme sym
;;;
;;; !!!

;;
;; ensures is lowercase symbol

(define (string->urischeme str)
  (string->symbol (string-downcase str)))

(define (symbol->urischeme sym)
  (string->symbol (string-downcase (symbol->string sym))))

;;; @defproc urischeme->string
;;;
;;; !!!

(define (urischeme->string urischeme)
  (symbol->string urischeme))

;;; @defproc urischeme-hierarchical? urischeme
;;;
;;; !!!

(define (urischeme-hierarchical? urischeme)
  (and (memq urischeme %hierarchical-schemes) #t))

;;; @defproc urischeme-default-portnum urischeme
;;;
;;; !!!

(define (urischeme-default-portnum urischeme)
  (let ((pair (assq urischeme %default-portnums)))
    (if pair
        (cdr pair)
        #f)))

(define %hierarchical-schemes
  (list ftp-uri-scheme
        gopher-uri-scheme
        http-uri-scheme
        https-uri-scheme
        imap-uri-scheme
        ipp-uri-scheme
        nfs-uri-scheme))

;;; @section Hierarchical URIs

(define (%make-hierarchical-uri
         urischeme uriserver uripath uriquery fragment)
  (let-values (((string opaque-k pound-k)
                (%build-hierarchical-uri-string+opaque+pound
                 urischeme uriserver uripath uriquery fragment)))
    (%make-uri string
               urischeme
               opaque-k
               pound-k
               uriserver
               uripath
               uriquery)))

(define (%build-hierarchical-uri-string+opaque+pound
         urischeme uriserver uripath uriquery fragment)
  ;; Note: this procedure is currently only used when the uri scheme is known,
  ;; but will probably evolve into a procedure that works with unknown URI
  ;; schemes, so some code has been written to support that.
  ;;
  ;; TODO: fragment should already be *un*escaped
  (let ((str (let ((os (open-output-string)))
               (and urischeme
                    (begin (display urischeme os)
                           (write-char #\: os)))
               (if uriserver
                   (begin (display         "//"      os)
                          (write-uriserver uriserver os)
                          (and uripath
                               (write-uripath/leading-slash uripath os)))
                   (and uripath
                        (write-uripath uripath os)))
               (and uriquery
                    (not (null? uriquery))
                    (begin (write-char     #\?      os)
                           (write-uriquery uriquery os)))
               (and fragment
                    (begin (write-char #\#                           os)
                           (display    (uri-escape/shared-ok fragment) os)))
               (%get-output-string-i os))))
    (values str
            (if urischeme
                (+ 1 (string-length (symbol->string urischeme)))
                #f)
            (if fragment
                (- (string-length str) (string-length fragment) 1)
                #f))))

;; TODO: maybe make the hierarchical-uri parsing functions document that they
;; might only be meaningful on hierarchical uri.  maybe refuse to work with
;; known urischemes not known to be hierarchical.

;;; @defproc uri-uriserver uri
;;;
;;; !!!

(define (uri-uriserver uri)
  (if (uri? uri)

      (let ((substring->uriserver
             (lambda (str start end)
               (substring/default-portnum->uriserver
                str start end
                (urischeme-default-portnum (%uri-scheme uri))))))
        ((%uri-rxpos-field-proc %uri-auth
                                substring->uriserver
                                %set-uri-auth!)
         uri))
      (raise-type-error 'uri-uriserver "uriserver" uri)))

;;;@defproc uri-uriserver+path+query uri
;;;
;;; !!!

(define (uri-uriserver+path+query uri)
  (values (uri-uriserver uri)
          (uri-uripath   uri)
          (uri-uriquery  uri)))

;;; @defproc uri-uriserver uri @result{} uriserver
;;;
;;; !!!

;;;@defproc uri-uriserver+uripath+uriquery uri
;;;
;;; !!!

;;
;; for server authorities, not just any authority

(define (uri-uriserver+uripath+uriquery uri)
  (uri-uriserver+path+query (uri-or-string->uri uri)))

;;; @defproc uri-userinfo+host+portnum uri
;;;
;;; !!!

(define (uri-userinfo+host+portnum uri)
  (let-values (((userinfo host portnum)
                (uriserver-userinfo+host+portnum (uri-uriserver uri))))
    (values userinfo host (or portnum (uri-portnum uri)))))

;;; @defproc uri-portnum uri
;;;
;;; !!!

(define (uri-portnum uri)
  (or (uriserver-portnum (uri-uriserver uri))
      (let ((urischeme (%uri-scheme uri)))
        (and urischeme
             (urischeme-default-portnum urischeme)))))

;;; @defproc  make-uriserver                 userinfo host portnum
;;; @defprocx make-uriserver/default-portnum userinfo host portnum default-portnum
;;;
;;; !!!

;;
;; if uriserver is to have the default port number for a uri scheme, then
;; portnum should be #f.  (consider sharing the same uriserver for http and
;; https uri, for example.  also consider normal http uri do not show default
;; port number.)

(define (make-uriserver/default-portnum userinfo host portnum default-portnum)
  (let ((portnum (if (equal? portnum default-portnum) #f portnum)))
    (cond ((or userinfo portnum)
           (list (%string-or-f->string-i-or-f userinfo)
                 (%string-or-f->string-i-or-f host)
                 portnum))
          (host (%string-or-f->string-i-or-f host))
          (else #f))))

(define (make-uriserver userinfo host portnum)
  (make-uriserver/default-portnum userinfo host portnum #f))

;;; @defproc  make-or-reuse-uriserver userinfo host portnum base-uriserver
;;; @defprocx make-or-reuse-uriserver/default-portnum userinfo host portnum base-uriserver default-portnum
;;;
;;; !!!

;;
;; base-uriserver is of same scheme

(define (make-or-reuse-uriserver userinfo host portnum base-uriserver)
  (if (or userinfo host portnum)
      (if base-uriserver
          (let-values (((base-u base-h base-p)
                        (uriserver-userinfo+host+portnum base-uriserver)))
            (if (and (equal? userinfo base-u)
                     (equal? host     base-h)
                     (equal? portnum  base-p))
                base-uriserver
                (make-uriserver (or userinfo base-u)
                                (or host     base-h)
                                (or portnum  base-p))))
          (make-uriserver userinfo host portnum))
      base-uriserver))

(define (make-or-reuse-uriserver/default-portnum
         userinfo host portnum base-uriserver default-portnum)
  (make-or-reuse-uriserver userinfo
                           host
                           (if (equal? portnum default-portnum)
                               #f
                               portnum)
                           base-uriserver))

;;; @defproc  string->uriserver                         str
;;; @defprocx string/base->uriserver                    str base-uriserver
;;; @defprocx string/default-portnum->uriserver         str default-portnum
;;; @defprocx string/base/default-portnum->uriserver    str base-uriserver default-portnum
;;; @defprocx substring->uriserver                      str start end
;;; @defprocx substring/base->uriserver                 str start end base-uriserver
;;; @defprocx substring/default-portnum->uriserver      str start end default-portnum
;;; @defprocx substring/base/default-portnum->uriserver str start end base-uriserver default-portnum
;;;
;;; !!!

;; TODO: We sure do have a lot of these procedures...

(define (string->uriserver str)
  (substring/base/default-portnum->uriserver str 0 #f #f #f))

(define (string/base->uriserver str base-uriserver)
  (substring/base/default-portnum->uriserver str 0 #f base-uriserver #f))

(define (string/base/default-portnum->uriserver str base-uriserver default-portnum)
  (substring/base/default-portnum->uriserver str 0 #f base-uriserver default-portnum))

(define (string/default-portnum->uriserver str default-portnum)
  (substring/base/default-portnum->uriserver str 0 #f #f default-portnum))

(define (substring->uriserver str start end)
  (substring/base/default-portnum->uriserver str start end #f #f))

(define (substring/base->uriserver str start end base-uriserver)
  (substring/base/default-portnum->uriserver str start end base-uriserver #f))

(define (substring/default-portnum->uriserver str start end default-portnum)
  (substring/base/default-portnum->uriserver str start end #f default-portnum))

(define substring/base/default-portnum->uriserver
  (let ((rx (regexp
             "^(?:([^@:]+)@)?([^@:]+)?(?::([0-9%a-fA-F]+))?")))
    (lambda (str start end base-uriserver default-portnum)
      (%with-rx-match-positions
       (rx str start (or end (string-length str)))
       ((whole userinfo host portnum)
        (if (or userinfo host portnum)
            (make-or-reuse-uriserver/default-portnum
             (%rxpos-unescape-str-i    userinfo str)
             (%rxpos-unescape-lowstr-i host     str)
             (%rxpos-unescape-num      portnum  str)
             base-uriserver
             default-portnum)
            #f))))))

;;; @defproc  uriserver-userinfo              uriserver
;;; @defprocx uriserver-host                  uriserver
;;; @defprocx uriserver-portnum               uriserver
;;; @defprocx uriserver-userinfo+host+portnum uriserver
;;;
;;; !!!

(define (uriserver-userinfo uriserver)
  (if (pair? uriserver)
      (list-ref uriserver 0)
      #f))

(define (uriserver-host uriserver)
  (cond ((not     uriserver) #f)
        ((string? uriserver) uriserver)
        (else                (list-ref uriserver 1))))

(define (uriserver-portnum  uriserver)
  (if (pair? uriserver)
      (list-ref uriserver 2)
      #f))

(define (uriserver-userinfo+host+portnum uriserver)
  (cond ((not     uriserver) (values #f #f        #f))
        ((string? uriserver) (values #f uriserver #f))
        (else                (apply values uriserver))))

;;; @defproc write-uriserver uriserver port
;;;
;;; !!!

(define (write-uriserver uriserver port)
  (let-values (((userinfo host portnum) (uriserver-userinfo+host+portnum uriserver)))
    (and userinfo
         (begin (display    (uri-escape/shared-ok userinfo) port)
                (write-char #\@      port)))
    (and host
         (display (uri-escape/shared-ok host) port))
    (and portnum
         (begin (write-char #\:     port)
                (display    portnum port)))))

;;; @defproc uriserver-with-default-portnum uriserver default-portnum
;;;
;;; !!!

(define (uriserver-with-default-portnum uriserver default-portnum)
  (if (and default-portnum
           (equal? (uriserver-portnum uriserver) default-portnum))
      (let-values (((userinfo host portnum) (uriserver-userinfo+host+portnum uriserver)))
        (make-uriserver userinfo host #f))
      uriserver))

;;; @defproc  resolved-uriserver uriserver base-uriserver
;;; @defprocx resolved-uriserver/default-portnum uriserver base-uriserver default-portnum
;;;
;;; !!!

;; Note: base-uriserver must be from uri of the same scheme as uriserver

(define (resolved-uriserver uriserver base-uriserver)
  (or uriserver base-uriserver))

(define (resolved-uriserver/default-portnum
         uriserver base-uriserver default-portnum)
  (uriserver-with-default-portnum (or uriserver base-uriserver)
                                  default-portnum))

;;; @subsection Hierarchical Paths

;;; @defproc  uri-path                uri
;;; @defprocx uri-path/noparams       uri
;;; @defprocx uri-uripath          uri
;;; @defprocx uri-uripath/noparams uri
;;;
;;; !!!

;; TODO: "path/noparams" might be be an unusual case.  Maybe better to have the
;; "/noparams" be on "uripath-segments/noparams" and
;; "uripath-upcount+segments/noparams".  Or maybe we should add
;; "uri-path-upcount", "uri-path-segments", "uri-path-segments/noparams", etc.

(define (uri-path uri)
  (uri-uripath (uri-or-string->uri uri)))

(define (uri-path/noparams uri)
  (uri-uripath/noparams (uri-or-string->uri uri)))

(define uri-uripath
  (%uri-rxpos-field-proc %uri-path
                         substring->uripath
                         %set-uri-path!))

(define (uri-uripath/noparams uri)
  (let*-values (((uripath)  (uri-uripath uri))
                ((ups segs) (uripath-upcount+segments/reverse uripath)))
    (let loop ((rest segs))
      (cond ((null? rest) uripath)
            ((urisegment-has-params? (car rest))
             (make-uripath/reverse/shared-ok
              ups
              (%map-i urisegment-name segs)))
            (else (loop (cdr rest)))))))

;;; @defproc  make-uripath                   upcount segments
;;; @defprocx make-uripath/reverse           upcount segments
;;; @defprocx make-uripath/reverse/shared-ok upcount segments
;;;
;;; !!!

(define (make-uripath/reverse/shared-ok upcount segments)
  (if upcount ;; (and upcount (not (null? segments)))
      (cons upcount segments)
      segments))

(define (make-uripath/reverse upcount segments)
  (make-uripath/reverse/shared-ok upcount (%list->list-i segments)))

(define (make-uripath upcount segments)
  (make-uripath/reverse/shared-ok upcount (%reverse-i segments)))

;;; @defproc uripath-with-upcount uripath upcount
;;;
;;; !!!

;;
;; possibly new, possibly original

(define (uripath-with-upcount uripath upcount)
  (let-values (((old-uc old-segs) (uripath-upcount+segments/reverse uripath)))
    (if (equal? upcount old-uc)
        uripath
        (make-uripath/reverse/shared-ok upcount old-segs))))

;;; @defproc  string->uripath         str
;;; @defprocx string/base->uripath    str base-uripath
;;; @defprocx substring->uripath      str start end
;;; @defprocx substring/base->uripath str start end base-uripath
;;;
;;; !!!
;;;
;;; Note: Contrary to [RFC2396], we don't require base to be absolute.

(define (string->uripath str)
  (substring->uripath str 0 #f))

(define (string/base->uripath str base-uripath)
  (substring/base->uripath str 0 #f base-uripath))

;; TODO: URI parsing code should ignore whitespace when parsing a
;; "<([Uu][Rr][Ll]:)?[^>]*>" one.  Distinguish "extract-uri" or "parse-uri"
;; from "string->uri".

(define substring->uripath
  ;; TODO: We can drop the second match-position from "path-rx".
  (let ((path-rx    #rx"^(/)?(.+)?$")
        (segment-rx #rx"^([^/;]+)?(;[^/]*)?(/)?"))
    (lambda (str start end)
      (let ((end (or end (string-length str))))
        (%with-rx-match-positions
         (path-rx str start end)
         ((whole leading-slash path-pos)
          (if path-pos
              (let loop ((start (car path-pos))
                         (uc   (if leading-slash #f 0))
                         (segs  '()))
                (%with-rx-match-positions
                 (segment-rx str start end)
                 ((whole name-pos params slash)
                  (let ((name (if name-pos
                                  (uri-unescape-i str
                                                  (car name-pos)
                                                  (cdr name-pos))
                                  #f)))
                    (cond
                     ((and name (string=? name ".."))
                      (let-values (((new-uc new-segs)
                                    (if (null? segs)
                                        (values (+ 1 (or uc 0)) segs)
                                        (values uc              (cdr segs)))))
                        (if slash
                            (loop (cdr whole) new-uc new-segs)
                            (make-uripath/reverse/shared-ok new-uc new-segs))))
                     ((and name (string=? name "."))
                      (if slash
                          (loop (cdr whole) uc segs)
                          (make-uripath/reverse/shared-ok uc (cons #f segs))))
                     (else
                      (let ((new-segs (cons
                                       (if params
                                           (cons
                                            name
                                            (%parse-uri-path-params
                                             str
                                             (+ 1 (car params))
                                             (cdr params)))
                                           name)
                                       segs)))
                        (if slash
                            (loop (cdr whole) uc new-segs)
                            (make-uripath/reverse/shared-ok uc new-segs)))))))))
              (if leading-slash
                  (make-uripath/reverse/shared-ok #f
                                                  (cons #f '()))
                  (make-uripath/reverse/shared-ok 0 '())))))))))

(define (substring/base->uripath str start end base-uripath)
  (let ((uripath (substring->uripath str start end)))
    (if base-uripath
        (resolved-uripath uripath base-uripath)
        uripath)))

;; TODO: maybe add /noparams variants of uripath accessors, and *maybe* remove
;; the uri-path/noparams

;;; @defproc  uripath-upcount                  uripath
;;; @defprocx uripath-segments                 uripath
;;; @defprocx uripath-segments/reverse         uripath
;;; @defprocx uripath-upcount+segments         uripath
;;; @defprocx uripath-upcount+segments/reverse uripath
;;;
;;; !!!

(define (uripath-upcount+segments/reverse path)
  ;;!!! shouldn't the null path be (values 0 '()) ?
  (cond ((null? path)          (values #f         '()))
        ((integer? (car path)) (values (car path) (cdr path)))
        (else                  (values #f         path))))

(define (uripath-upcount+segments uripath)
  (let-values (((uc segs) (uripath-upcount+segments/reverse uripath)))
    (values uc (%reverse-i segs))))

(define (uripath-upcount uripath)
  (and (not (null? uripath))
       (integer? (car uripath))
       (car uripath)))

(define (uripath-segments/reverse path)
  (cond ((null? path)          '())
        ((integer? (car path)) (cdr path))
        (else                  path)))

(define (uripath-segments uripath)
  (%reverse-i (uripath-segments/reverse uripath)))

;;; @defproc uripath-has-params? uripath
;;;
;;; !!!

(define (uripath-has-params? uripath)
  (let ((segs (uripath-segments/reverse uripath)))
    (let loop ((segs segs))
      (cond ((null? segs)                        #f)
            ((urisegment-has-params? (car segs)) #t)
            (else                                (loop (cdr segs)))))))

;;; @defproc  write-uripath               uripath port
;;; @defprocx write-uripath/leading-slash uripath port
;;;
;;; !!!

(define (%write-uripath/leading-slash-arg
         uripath port leading-slash?)
  (let-values (((uc segs) (uripath-upcount+segments uripath)))
    (cond (uc
           (and leading-slash?
                (if (zero? uc)
                    ;; TODO: This isn't right.  Look at what the parsing
                    ;; procedure produces, and special-case if need be.
                    (display "/." port)
                    (write-char #\/ port)))
           (let loop ((i uc))
             (and (> i 0)
                  (begin (display "../" port)
                         (loop (- i 1))))))
          ((or (not leading-slash?)
               (null? segs)
               (car segs)
               (null? (cdr segs)))
           (write-char #\/ port))
          (else (display "/./" port)))
    ;; TODO: Make this use segments/reverse, use non-tail recursion on
    ;; segments, and eliminate use of %for-each/between.
    (and segs
         (%for-each/between
          (lambda (seg)
            (let ((name (urisegment-name seg)))
              (and name
                   (display (uri-escape/shared-ok (urisegment-name seg))
                            port))
              (for-each (lambda (param)
                          (write-char #\; port)
                          (display (uri-escape/shared-ok param) port))
                        (urisegment-params seg))))
          (lambda () (write-char #\/ port))
          segs))))

(define (%for-each/between each-proc between-proc lst)
  ;; TODO: Lose this procedure.
  (and (not (null? lst))
       (let loop ((head (car lst))
                  (rest (cdr lst)))
         (each-proc head)
         (if (null? rest)
             (void)
             (begin (between-proc)
                    (loop (car rest) (cdr rest)))))))

(define (write-uripath uripath port)
  (%write-uripath/leading-slash-arg uripath port #f))

(define (write-uripath/leading-slash uripath port)
  (%write-uripath/leading-slash-arg uripath port #t))

;;; @defproc  uripath->string               uripath
;;; @defprocx uripath->string/leading-slash uripath
;;;
;;; !!!
;;;
;;; @lisp
;;; (uri-path-segments "//a/b")   @result{} ("b")
;;; (uri-path-segments "/.//a/b") @result{} (#f "a" "b")
;;; @end lisp
;;;
;;; !!!
;;;
;;; @lisp
;;; (uripath->string               (string->uripath "//b"))
;;; @result{} "//b"
;;; (uripath->string/leading-slash (string->uripath "//b"))
;;; @result{} "/.//b"
;;; (uripath->string/leading-slash (string->uripath "/a/b"))
;;; @result{} "/a/b"
;;; (uripath->string/leading-slash (string->uripath "/;p1/b"))
;;; @result{} "/;p1/b"
;;; @end lisp

(define (uripath->string uripath)
  (let ((os (open-output-string)))
    (write-uripath uripath os)
    (get-output-string os)))

(define (uripath->string/leading-slash uripath)
  (let ((os (open-output-string)))
    (write-uripath/leading-slash uripath os)
    (get-output-string os)))

;;; @defproc resolved-uripath uripath base-uripath
;;;
;;; !!!

(define (resolved-uripath uripath base-uripath)
  (let-values (((old-upcount old-segs) (uripath-upcount+segments/reverse uripath)))
    (cond
     ((and (not old-upcount) (null? old-segs))
      (let-values (((base-upcount base-segs)
                    (uripath-upcount+segments/reverse base-uripath)))
        ;; TODO: unify this with below.
        ;;
        ;; TODO: check for base-upcount #f below.
        (make-uripath/reverse/shared-ok (if old-upcount
                                            (max old-upcount
                                                 (or base-upcount 0))
                                            base-upcount)
                                        base-segs)))
     (old-upcount
      (let-values (((base-upcount base-segs)
                    (uripath-upcount+segments/reverse base-uripath)))
        (cond
         ((not (null? base-segs))
          ;; "base-segs" is not null, so...
          ;;
          ;; TODO: We can simplify these "usable-base-segs" things once we've
          ;; tested all the oddball cases.
          (let-values (((usable-base-segs usable-base-segs-len)
                        (let ((base-segs-len (length base-segs)))
                          ;; (if (urisegment-name (car base-segs))
                          (if (null? old-segs)
                              (values base-segs       base-segs-len)
                              (values (cdr base-segs) (- base-segs-len 1))))))
            (let ((base-segs-to-skip (min old-upcount
                                          usable-base-segs-len)))
              (if (< base-segs-to-skip 0)
                  (make-uripath/reverse/shared-ok
                   (if base-upcount
                       (max (+ old-upcount base-segs-to-skip) base-upcount)
                       (+ old-upcount base-segs-to-skip))
                   (%append-i old-segs usable-base-segs))
                  (make-uripath/reverse/shared-ok
                   base-upcount
                   (%append-i old-segs
                              (list-tail usable-base-segs
                                         base-segs-to-skip)))))))
         (base-upcount
          ;; "base-segs" is null, but "base-upcount" is not #f, so...
          ;;
          ;; TODO: do we take #f in base-segs into account?
          (if (> base-upcount old-upcount)
              (uripath-with-upcount uripath base-upcount)
              uripath))
         (else uripath))))
     (else uripath))))

;;; @defproc absolute-uripath uripath
;;;
;;; !!!

(define (absolute-uripath uripath)
  (let-values (((upc segs) (uripath-upcount+segments/reverse uripath)))
    (cond ((null? segs) (make-uripath/reverse/shared-ok #f '(#f)))
          (upc          (make-uripath/reverse/shared-ok #f segs))
          (else         uripath))))

;;; @subsection Attribute-Value Queries

;;; @defproc uri-uriquery uri
;;;
;;; !!!

(define uri-uriquery
  (%uri-rxpos-field-proc %uri-query
                         substring->uriquery
                         %set-uri-query!))

;;; @defproc  string->uriquery    str
;;; @defprocx substring->uriquery str start end
;;;
;;; !!!

(define (substring->uriquery str start end)
  (let loop ((start start)
             (end   (or end (string-length str))))
    (%with-rx-match-positions
     (#rx"^([^&=]+)?(?:=([^&]*))?(&)?" str start end)
     ((whole name-pos val-pos amp-pos)
      (if name-pos
          (cons (cons
                 (uri-unescape-i str
                                 (car name-pos)
                                 (cdr name-pos))
                 (if val-pos
                     (uri-unplusescape-i str
                                         (car val-pos)
                                         (cdr val-pos))
                     #t))
                (if amp-pos
                    (loop (cdr amp-pos) end)
                    '()))
          (if amp-pos
              (loop (cdr amp-pos) end)
              '()))))))

(define (string->uriquery str) (substring->uriquery str 0 #f))

;;; @defproc write-uriquery uriquery port
;;;
;;; !!!

(define (write-uriquery uriquery port)
  (or (null? uriquery)
      (let loop ((head (car uriquery))
                 (rest (cdr uriquery)))
        (let ((attr (car head))
              (val  (cdr head)))
          (and attr
               (display (uri-escape/shared-ok attr) port))
          (and (string? val)
               (begin (write-char #\= port)
                      (display (uri-escape/shared-ok val) port)))
          (if (null? rest)
              (void)
              (begin (write-char #\& port)
                     (loop (car rest) (cdr rest))))))))

;; TODO: add uriquery-string

;;; @section Antiresolution (In-Progress)

;; TODO: !!! Implement the W3C way of doing this, and then try to reconcile
;; that with the arguably better semantics.

;; @defproc antiresolved-uri uri base-uri @result{} string
;;
;; !!!

;; (define (antiresolved-uri uri base-uri)
;;   '!!!
;;   )

;; (define (resolved-uri/base-uri uri base-uri)
;;   (cond ((equal? (uri->string uri) "") base-uri)
;;         ((absolute-uri? uri)           uri)
;;         (else
;;          (let ((old-urischeme  (uri-scheme uri))
;;                (base-urischeme (uri-scheme base-uri)))
;;            (if (or (and old-urischeme (eq? old-urischeme base-urischeme))
;;                    (and (not old-urischeme) base-urischeme))
;;                (let ((new-urischeme base-urischeme))
;;                  (if (urischeme-hierarchical? new-urischeme)
;;                      ;; TODO: Potentially reuse uri.
;;                      (%make-hierarchical-uri
;;                       new-urischeme
;;                       (resolved-uriserver/default-portnum
;;                        (uri-uriserver       uri)
;;                        (uri-uriserver       base-uri)
;;                        (urischeme-default-portnum new-urischeme))
;;                       (resolved-uripath   (uri-uripath  uri)
;;                                           (uri-uripath  base-uri))
;;                       ;; TODO: is this right, that query not inherited?
;;                       (uri-uriquery    uri)
;;                       (uri-fragment    uri))
;;                      ;; Note: We don't yet know how to resolve non-hierarchical
;;                      ;; URI, so just yield the original URI but possibly with
;;                      ;; the scheme of the base.
;;                      (uri-with-scheme uri new-urischeme)))
;;                uri)))))

;;; @defproc antiresolved-uripath uripath base-uripath
;;;
;;; !!!

(define (antiresolved-uripath a-uripath b-uripath)
  (let-values (((a-u a-s) (uripath-upcount+segments/reverse a-uripath))
               ((b-u b-s) (uripath-upcount+segments/reverse b-uripath)))
    (if (or a-u b-u)
        (error "!!! can't handle relative uripaths")
        (let-values (((u s) (%antiresolve-uripath/u+s a-s b-s)))
          (make-uripath/reverse/shared-ok u s)))))

;; TODO: Offer alternative modes for anti-resolve.  The following would be
;; "always-relative" mode.  Other likely modes include "minimize-string-length"
;; and "(max-upcount N)".  Maybe "minimize-segment-count".

(define (%antiresolve-uripath/u+s a-segs b-segs)
  ;; TODO: We could do one loop while no differences found, and a separate loop
  ;; for once differences found.  That might be a mess, though.
  (let loop ((depth          0)
             (a-segs-tail    a-segs)
             (b-segs-tail    b-segs)
             (differ-upcount #f)
             ;;(differ-b-tail  #f)
             )
    (if (null? a-segs-tail)
        ;; No more a-segs, so check if we're also out of b-segs...
        (if (null? b-segs-tail)
            ;; We simultaneously reached the ends of a-segs and b-segs, which
            ;; means they're the same length, so see when we had our last
            ;; difference...
            (cond ((not differ-upcount)
                   ;; No differences were found, so the two are equivalent.
                   (values 0 '()))
                  ((equal? (+ 1 differ-upcount) depth)
                   ;; Same lengths, everything was different, so...
                   (values differ-upcount a-segs))
                  (else
                   ;; Same lengths, differences were found, but not everything
                   ;; was different, so...
                   (values differ-upcount
                           (%take-i a-segs (+ 1 differ-upcount)))))
            ;; a-segs is null, but b-segs is not, so...
            (let ((extra-b-len (length b-segs-tail)))
              (let-values (((ups segs) (%antiresolve-uripath/u+s
                                        a-segs
                                        (list-tail b-segs extra-b-len))))
                ;; TODO: See if (and (zero? ups) (null? segs)) affects the ups.
                (values (+ extra-b-len (or ups 0)) segs))))
        ;; a-segs is *not* null, so see if b-segs is...
        (if (null? b-segs-tail)
            ;; a-segs is *not* null, but b-segs *is* null, so...
            (let loop-a-segs-longer ((len          0)
                                     (extra-a-segs a-segs-tail)
                                     (a-segs-tail  a-segs))
              (if (null? extra-a-segs)
                  (let*-values
                      (((ups segs)      (%antiresolve-uripath/u+s
                                         a-segs-tail b-segs))
                       ((null-uripath?) (and (zero? ups) (null? segs))))
                    ;; Note: We could cons the front a-segs as we go through
                    ;; this loop, but that makes us not be tail-recursive, and
                    ;; there's the problem of consing to the result uripath
                    ;; segments without the upcount.
                    (values ups (%take-i/append a-segs
                                                (if null-uripath?
                                                    (+ 1 len)
                                                    len)
                                                segs)))
                  (loop-a-segs-longer (+ 1 len)
                                      (cdr extra-a-segs)
                                      (cdr a-segs-tail))))
            ;; Neither a-segs nor b-segs is null, so...
            (if (eq? a-segs-tail b-segs-tail)
                ;; The remainder of a-segs-tail and b-segs-tail are
                ;; identical, so...
                (values differ-upcount
                        (%take-i a-segs (+ 1 differ-upcount)))
                ;; The remainder of a-segs-tail and b-segs-tail are *not*
                ;; identical, so...
                (if (equal? (car a-segs-tail) (car b-segs-tail))
                    ;; The heads *are* equal, so recurse *without* updating the
                    ;; differs.
                    (loop (+ 1 depth)
                          (cdr a-segs-tail)
                          (cdr b-segs-tail)
                          differ-upcount)
                    ;; The heads are *not* equal, so recurse *while* updating
                    ;; the differs.
                    (loop (+ 1 depth)
                          (cdr a-segs-tail)
                          (cdr b-segs-tail)
                          depth)))))))

;;; @defproc  antiresolved-uriserver uriserver base-uriserver
;;; @defprocx antiresolved-uriserver/default-portnum uriserver base-uriserver default-portnum
;;;
;;; !!!

;; Note: base-uriserver must be from uri of the same scheme as uriserver

(define (antiresolved-uriserver uriserver base-uriserver)
  (if (equal? uriserver base-uriserver)
      #f
      uriserver))

(define (antiresolved-uriserver/default-portnum
         uriserver base-uriserver default-portnum)
  ;; TODO: !!! what is this?
  (uriserver-with-default-portnum (or uriserver base-uriserver)
                                  default-portnum))

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.2 --- 2011-08-23 --- PLaneT @code{(1 0)}
;;; This is a release of some code-in-progress that has been sitting around
;;; unreleased for years.  It has been changed heavily since the 2004,
;;; non-PLaneT release, including getting rid of the "uriobj"-specific
;;; operations, so that all operations work on both string and object forms.  A
;;; few tests fail.  Non-backward-compatible API changes are expected.
;;;
;;; @item Version 0.1 --- 2004-08-18
;;; Initial release.  Incorporates some code from UriFrame.
;;;
;;; @end table

;; TODO: Change this to enumerate specific symbols to export,
(provide (all-defined-out))