;; 
;; Definitions and parsing routines for Uniform Resource Identifiers (RFC 3986).
;; 
;; Based on the Haskell URI library by  Graham Klyne <gk@ninebynine.org>.
;;
;; Copyright 2008 Ivan Raikov.
;;
;; 
;;  Redistribution and use in source and binary forms, with or without
;;  modification, are permitted provided that the following conditions
;;  are met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;  notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above
;;  copyright notice, this list of conditions and the following
;;  disclaimer in the documentation and/or other materials provided
;;  with the distribution.
;; 
;;  - Neither name of the copyright holders nor the names of its
;;  contributors may be used to endorse or promote products derived
;;  from this software without specific prior written permission.
;; 
;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;  POSSIBILITY OF SUCH DAMAGE.
;;

(require-extension syntax-case)
(require-extension matchable)
(require-extension srfi-1)
(require-extension srfi-4)

(define-extension uri-generic)

(declare
 (not usual-integrations)
 (fixnum)
 (inline)
 (lambda-lift)
 (export uri-reference
	 uri? uri-auth uri-authority uri-scheme uri-path uri-query
	 uri-fragment uri-host uri-port uri-username uri-password
	 absolute-uri uri->string uri->list uri-char-list-escape
	 uri-char-list->string uri-string->char-list 
	 uri-relative-to uri-relative-from 
	 uri-normalize-case uri-normalize-path-segments))

(cond-expand
   (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
   (else (use srfi-13 srfi-14)))

(define-record URI      scheme authority path query fragment)
(define-record URIAuth  username password host port)

(define-record-printer (URI x out)
  (fprintf out "#(URI scheme=~S authority=~A path=~S query=~S fragment=~S)"
	   (URI-scheme x)
	   (URI-authority x)
	   (URI-path x)
	   (URI-query x)
	   (URI-fragment x)))

(define-record-printer (URIAuth x out)
  (fprintf out "#(URIAuth host=~S port=~A)"
	   (URIAuth-host x)
	   (URIAuth-port x)))

(define uri? URI?)

(define uri-auth       URI-authority )
(define uri-authority  URI-authority )
(define uri-scheme     URI-scheme )
(define uri-path       URI-path )
(define uri-query      URI-query )
(define uri-fragment   URI-fragment )

(define (uri-host x)
  (let ((auth (URI-authority x)))
    (and auth (URIAuth-host auth))))

(define (uri-port x)
  (let ((auth (URI-authority x)))
    (and auth (URIAuth-port auth))))

(define (uri-username x)
  (let ((auth (URI-authority x)))
    (and auth (URIAuth-username auth))))

(define (uri-password x)
  (let ((auth (URI-authority x)))
    (and auth (URIAuth-password auth))))

;; Character classes
 
(define (hexdigit-char? c)    (char-set-contains? char-set:hex-digit c))

(define (reserved-char? c)    (char-set-contains? char-set:reserved c))

(define (unreserved-char? c)  (char-set-contains? char-set:unreserved c))

(define (scheme-char? c)      (char-set-contains? char-set:scheme c))

(define (ipv-future-char? c)  (char-set-contains? char-set:ipv-future c))

(define (pct-escaped? c)      (match c ((#\% h1 h2) #t) (else #f)))


;; Helper functions for character parsing
  
(define (uchar extras)
  (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
    (lambda (c) (or (pct-escaped? c) (unreserved-char? c) 
		    (char-set-contains? char-set:sub-delims c) 
		    (char-set-contains? extras-set c) ))))
  
;; same as uchar, but without sub-delims
(define (schar extras)
  (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
    (lambda (c) (or (pct-escaped? c)  (unreserved-char? c) 
		    (char-set-contains? extras-set c) ))))
		  
(define (many pred?)
  (lambda (s)
    (let loop ((lst (list)) (rst s))
      (cond ((null? rst)        (list (reverse lst) rst))
	    ((pred? (car rst))  (loop (cons (car rst) lst) (cdr rst)))
	    (else               (list (reverse lst) rst))))))

(define (many1 pred?)
  (lambda (s)
    (let ((a1 (and (not (null? s)) (pred? (car s)) (car s))))
      (and a1 (match ((many pred?) (cdr s))
		     ((as rst)  (list (cons a1 as) rst))
		     (else #f))))))


(define (count-min-max m n pred?)
  (lambda (s) 
    (let loop ((m m) (n n) (lst (list)) (rst s))
      (cond ((and (pair? rst) (positive? m))
	     (if (pred? (car rst))
		 (loop (- m 1) (- n 1) (cons (car rst) lst) (cdr rst)) #f))
	    ((or (<= n 0) (null? rst))   (list (reverse lst) rst))
	    (else 
	     (if (pred? (car rst))
		 (loop 0 (- n 1) (cons (car rst) lst) (cdr rst))
		 (list (reverse lst) rst)))))))

;; Parser combinators

(define (consume f) 
  (lambda (s)
    (let loop ((lst (list)) (rst s))
      (match (f rst)
	     ((a rst)  (loop (cons a lst) rst))
	     (else  (list (reverse lst) rst))))))


(define (consume-count n f)
  (lambda (s)
    (let loop ((n n) (lst (list)) (rst s))
      (if (positive? n)
	  (match (or (f rst) (list #f s))
		 ((x rst)  (and x (loop (- n 1) (cons x lst) rst))))
	  (list (reverse lst) rst)))))


(define (consume-min-max m n f)
  (lambda (s) 
    (let loop ((m m) (n n) (lst (list)) (rst s))
      (cond ((positive? m)
	     (match (f rst)
		    ((a1 rst) (loop (- m 1) (- n 1) (cons a1 lst) rst))
		    (else #f)))
	    ((<= n 0)   (list (reverse lst) rst))
	    (else 
	     (match (f rst)
		    ((a1 rst) (loop 0 (- n 1) (cons a1 lst) rst))
		    (else #f)))))))

;; Helper function for malformed ip address error messages

(define (try-ip-literal->string s)
  (let loop ((lst (list))  (rst s))
    (match rst ((#\] . rst)  (uri-char-list->string (reverse lst)))
	   (()  (uri-char-list->string (reverse lst)))
	   (else (loop (cons (car rst) lst) (cdr rst))))))

;; RFC 3986, section 2.1
;;
;; Returns a 'pct-encoded' sequence of octets.
;;
(define (pct-escape lst)
  (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
  (reverse (fold (lambda (x ax)
		   (let ((h1 (hex-digit (quotient x 16)))
			 (h2 (hex-digit (remainder x 16))))
		     (cons `(#\% ,h1 ,h2)  ax)))
		 (list) lst)))
  
;; RFC3986, section 2.2 
;;
;; Reserved characters.
;;

(define char-set:gen-delims (string->char-set ":/?#[]@"))
(define char-set:sub-delims (string->char-set "!$&'()*+,;="))

(define char-set:reserved (char-set-union char-set:gen-delims char-set:sub-delims))

;;  RFC3986, section 2.3
;;
;;  "Unreserved" characters.
;;

(define char-set:unreserved 
  (char-set-union char-set:letter+digit (string->char-set "-_.~")))


;;  RFC3986, section 3
;;
;;   URI         = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
;;
;;   hier-part   = "//" authority path-abempty
;;               / path-abs
;;               / path-rootless
;;               / path-empty

(define (uri s)
  (let ((s (if (string? s) (uri-string->char-list s) s)))
    (match (scheme s)
	   ((us rst)
	    (match-let* (((ua up rst)   (hier-part rst))
			 ((uq rst)      (match rst ((#\? . rst) (query rst))
					       (else (list #f rst))))
			 ((uf rst)      (match rst ((#\# . rst) (fragment rst))
					       (else (list #f rst)))))
			(make-URI (string->symbol (list->string us)) ua 
				  (map uri-char-list->string up) (and uq (filter-map query->string uq))
				  (and uf (uri-char-list->string uf)))))
	 (else #f))))

(define (hier-part s)
  (match s ((#\/ #\/ . rst) 
	    (match-let* (((ua rst)  (authority rst))
			 ((up rst)  (path-abempty rst)))
			(list ua up rst)))
	 (else (match-let (((up rst) (or (path-abs s) (path-rootless s) (list (list) s))))
			  (list #f up rst)))))

;;  RFC3986, section 3.1

(define scheme0 (many scheme-char?))
(define (scheme s)
  (match (scheme0 s)
	 ((ss (#\: . rst))  (list ss rst))
	 (else #f)))

(define char-set:scheme
  (char-set-union char-set:letter+digit (string->char-set "+-.")))


;;  RFC3986, section 3.2

(define (authority s)
  (match-let* (((uu uw rst)   (or (userinfo s) (list #f #f s)))
	       ((uh rst)      (host rst))
	       ((up rst)      (or (port rst) (list #f rst))))
	      (list (make-URIAuth (and uu (uri-char-list->string uu)) (and uw (uri-char-list->string uw))
				  (uri-char-list->string uh) 
				  (and (pair? up) (string->number (list->string up))))
		    rst)))

;;  RFC3986, section 3.2.1

(define userinfo0  (many (uchar ";&=+$,")))

(define (userinfo s)
  (match (userinfo0 s)
	 ((uu ( #\: . rst))   (match (userinfo0 rst)
				     ((up ( #\@ . rst) ) (list uu up rst))
				     (else #f)))
	 ((uu ( #\@ . rst)) (list uu (list) rst))
	 (else #f)))



;;  RFC3986, section 3.2.2

(define (host s)  (or (ip-literal s) (ipv4-address s) (reg-name s)))

(define (ip-literal s)
  (match s ((#\[ . rst) 
	    (match (or (ipv6-address rst) (ipv-future rst))
		   ((ua (#\] . rst))  (list ua rst))
		   (else (error 'ip-literal "malformed ip literal" (try-ip-literal->string rst)))))
	 (else #f)))

(define ipv-future0  (many ipv-future-char?))

(define (ipv-future s)
  (match s ((#\v (? hexdigit-char?) #\. . rst)  (ipv-future0 rst))
	 (else #f)))

(define char-set:ipv-future 
  (char-set-union char-set:unreserved char-set:sub-delims (char-set #\;)))



;; Pv6address =                            6( h16 ":" ) ls32
;;                   /                       "::" 5( h16 ":" ) ls32
;;                   / [               h16 ] "::" 4( h16 ":" ) ls32
;;                   / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32
;;                   / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32
;;                   / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32
;;                   / [ *4( h16 ":" ) h16 ] "::"              ls32
;;                   / [ *5( h16 ":" ) h16 ] "::"              h16
;;                   / [ *6( h16 ":" ) h16 ] "::"

;;       ls32        = ( h16 ":" h16 ) / IPv4address
;;                   ; least-significant 32 bits of address

;;       h16         = 1*4HEXDIG
;;                   ; 16 bits of address represented in hexadecimal


(define (ipv6-address s)
  (or (match (u6-h4c s) ;; 6( h16 ":" ) ls32

	     ((a2 rst)  (match (ls32 rst)
			       ((a3 rst)  (list (append (concatenate a2) a3) rst))
			       (else #f)))
	     (else #f))
      (match s          ;; "::" 5( h16 ":" ) ls32
	     ((#\: #\: . rst)  
	      (match (u5-h4c rst)
		     ((a2 rst)  (match (ls32 rst)
				       ((a3 rst)  (list (append (list #\: #\:) (concatenate a2) a3) rst))
				       (else #f)))))
	     (else #f))
      (match (u_opt_n_h4c_h4 0 s)
	     ((a1 rst) (match rst
			      ((#\: #\: . rst)  
			       (match (u4-h4c rst)
				      ((a2 rst)  (match (ls32 rst)
							((a3 rst)  
							 (list (append (concatenate a1) (list #\: #\:) 
								       (concatenate a2) a3) rst))
							(else #f)))
				      (else #f)
				      ))
			      (else #f)))
	      (else #f))
      (match (u_opt_n_h4c_h4 1 s)
	     ((a1 rst) 
        	      (match rst       
			      ((#\: #\: . rst)  
			       (match (u3-h4c rst)
				      ((a2 rst)  (match (ls32 rst)
							((a3 rst)  
							 (list (append (concatenate a1) (list #\: #\:) 
								       (concatenate a2) a3) rst))
							(else #f)))
				      (else #f)
				      ))
			      (else #f)))
	      (else #f))
      (match (u_opt_n_h4c_h4 2 s)
	     ((a1 rst) (match rst       
			      ((#\: #\: . rst)  
			       (match (u2-h4c rst)
				      ((a2 rst)  (match (ls32 rst)
							((a3 rst)  (list (append (concatenate a1) (list #\: #\:) 
										 (concatenate a2) a3) rst))
							(else #f)))
				      (else #f)
				      ))
			      (else #f)))
	      (else #f))
      (match (u_opt_n_h4c_h4 3 s)
	     ((a1 rst) (match rst       
			      ((#\: #\: . rst)  
			       (match (h4c rst)
				      ((a2 rst)  (match (ls32 rst)
							((a3 rst)  (list (append (concatenate a1) (list #\: #\:) 
										 (concatenate a2) a3) rst))
							(else #f)))
				      (else #f)
				      ))
			      (else #f)))
	      (else #f))
      (match (u_opt_n_h4c_h4 4 s)
	     ((a1 rst) (match rst       
			      ((#\: #\: . rst)  
			       (match (ls32 rst)
				      ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) a3) rst))
				      (else #f)))
			      (else #f)))
	      (else #f))
      (match (u_opt_n_h4c_h4 5 s)
	     ((a1 rst) (match rst       
			      ((#\: #\: . rst)  
			       (match (h4 rst)
				      ((a3 rst)  (list (append (concatenate a1) (list #\: #\:) a3) rst))
				      (else #f)))
			      (else #f)))
	      (else #f))
      (match (u_opt_n_h4c_h4 6 s)
	     ((a1 rst) (match rst       
			      ((#\: #\: . rst)  
			       (list (append (concatenate a1) (list #\: #\:)) rst))
			      (else #f)))
	      (else #f))
      (error 'ipv6-address "malformed ipv6 address" (try-ip-literal->string s))))



(define (u_opt_n_h4c_h4 n s)
  (match ((consume-min-max 0 n h4c) s)
	 ((a1 rst)  (match (h4 rst)
			   ((a2 rst) (list (append a1 (list a2)) rst))
			   (else #f)))
	 (else #f)))

(define (ls32 s)
  (match (h4c s)
	 ((a1 rst) (match (h4 rst)
			  ((a2 rst)  (list (append a1 a2) rst))
			  (else (ipv4-address s))))
	 (else (ipv4-address s))))

(define (h4c s)
  (match (h4 s)
	 ((a1 (#\: (and r1 (not #\:)) . rst))
	  (list (append a1 (list #\:)) (cons r1 rst)))
	 (else #f)))

(define u6-h4c (consume-count 6 h4c))
(define u5-h4c (consume-count 5 h4c))
(define u4-h4c (consume-count 4 h4c))
(define u3-h4c (consume-count 3 h4c))
(define u2-h4c (consume-count 2 h4c))

(define h4 (count-min-max 1 4 hexdigit-char?))

(define (ipv4-address s)
  (match (dec-octet s)
	 ((a1 (#\. rst)) 
	  (match (dec-octet rst)
		 ((a2 (#\. rst))  
		  (match (dec-octet rst)
			 ((a3 (#\. rst))  
			  (match (dec-octet rst)
				 ((a4 rst)  (list (append a1 #\. a2 #\. a3 #\. a4) rst))
				 (else #f)))
			 (else #f)))
		 (else #f)))
	 (else #f)))

(define (dec-char->num c)
  (case c ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4) ((#\5) 5) 
	 ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9) (else #f)))
		  
(define (ipv4-octet? lst)
  (let loop ((n (reverse (map dec-char->num lst))) (i 1) (ax 0))
    (if (null? n) (and (>= ax 0) (<= ax 255))
	(loop (cdr n) (* i 10) (+ ax (* i (car n)))))))

(define (dec-octet s)
  (match ((count-min-max 1 3 char-numeric?) s)
	 (((and a1 (? ipv4-octet?)) rst)  (list a1 rst))
	 (else #f)))

(define reg-name
  (count-min-max 0 255 (lambda (c) (or (unreserved-char? c) 
				       (pct-escaped? c) 
				       (char-set-contains? char-set:sub-delims c) ))))

;;  RFC3986, section 3.2.3

(define port0 (many char-numeric?))

(define (port s)
  (match s ((#\: . rst)  (port0 rst))
	 (else #f)))


;;
;;  RFC3986, section 3.3
;;
;;   path          = path-abempty    ; begins with "/" or is empty
;;                 / path-abs        ; begins with "/" but not "//"
;;                 / path-noscheme   ; begins with a non-colon segment
;;                 / path-rootless   ; begins with a segment
;;                 / path-empty      ; zero characters
;;
;;   path-abempty  = *( "/" segment )
;;   path-abs      = "/" [ segment-nz *( "/" segment ) ]
;;   path-noscheme = segment-nzc *( "/" segment )
;;   path-rootless = segment-nz *( "/" segment )
;;   path-empty    = 0<pchar>
;;
;;   segment       = *pchar
;;   segment-nz    = 1*pchar
;;   segment-nzc   = 1*( unreserved / pct-encoded / sub-delims / "@" )
;;
;;   pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"

(define (path s)
  (or (path-abempty s)  (path-abs s) (path-noscheme s) 
      (path-rootless s) (list (list) s)))

  
(define (slash-segment s)
  (match s
	 ((#\/ . rst)  (match (segment rst)
			      ((ss rst)  (list (cons #\/ ss) rst))
			      (else #f)))
	 (else  #f)))

(define pchar (uchar ":@"))

(define segment (many pchar))

(define segment-nz (many1 pchar))

(define segment-nzc (many1 (uchar "@")))

(define path-abempty (consume slash-segment))

(define (path-abs s)
  (match s
	 ((#\/ . rst)  (match (path-rootless rst)
			      ((() rst)  (list  (list #\/)  rst))
			      ((lst rst) (list  (cons (cons #\/ (car lst)) (cdr lst)) rst))
			      (else #f)))
	 (else #f)))

(define (path-noscheme s)
  (match (segment-nzc s)
	 ((s1 rst)  (match (path-abempty rst)
			   ((ss rst) (list (cons s1 ss) rst))
			   (else (list (list s1) rst))))
	 (else #f)))

(define (path-rootless s)
  (match (segment-nz s)
	 ((s1 rst)  (match (path-abempty rst)
			   ((ss rst) (list (cons s1 ss) rst))
			   (else #f)))
	 (else #f)))

;;  RFC3986, section 3.4


(define query0  (many (schar ":@/?!$'()*+,;=")))
(define (query1 s)
  (match s ((#\& . rst) (query0 rst))
	 (else #f)))

(define (query s)
  (match (query0 s)
	 ((q1 rst)   
	             (match ((consume query1) rst)
			    ((qs rst)  (list (cons q1 qs) rst))
			    (else (list (list q1) rst))))
	 (else #f)))

(define query-part (many (schar ":@/?!$'()*+,;")))

(define (query->string s)
  (match (query-part s)
	 ((p1 (#\= . rst))  (match (query-part rst)
				   ((p2 _) `(,(uri-char-list->string p1) . ,(uri-char-list->string p2)))
				   (else #f)))
	 ((p1 ())   `(,(uri-char-list->string p1)))
	 (else #f)))
  

;;  RFC3986, section 3.5


(define fragment0  (many (uchar ":@/?")))
(define (fragment s)
  (match (fragment0 s)
	 ((ss rst)  (list ss rst))
	 (else #f)))

;;  Reference, Relative and Absolute URI forms
;;
;;  RFC3986, section 4.1

(define (uri-reference s)
  (let ((s (if (string? s) (uri-string->char-list s) s)))
    (or (uri s) (relative-ref s))))

;;  RFC3986, section 4.2
;;
;;   relative-URI  = relative-part [ "?" query ] [ "#" fragment ]
;;
;;   relative-part = "//" authority path-abempty
;;                 / path-abs
;;                 / path-noscheme
;;                 / path-empty

(define (relative-ref s)
  (and (not (scheme s))
       (match-let* (((ua up rst)  (relative-part s))
		    ((uq rst)     (match rst ((#\? . rst) (query rst))
					 (else (list #f rst))))
		    ((uf rst)     (match rst ((#\# . rst) (fragment rst))
					 (else (list #f rst)))))
		   (make-URI #f ua (map uri-char-list->string up) 
			     (and uq (filter-map query->string uq))
			     (and uf (uri-char-list->string uf))))))
(define (relative-part s)
  (match s
	 ((#\/ #\/ . rst)
	  (match-let* (((ua rst)  (authority rst))
		       ((up rst)  (path-abempty rst)))
		      (list ua up rst)))
	 (else (match-let* (((up rst)  (or (path-abs s) (path-noscheme s) (list (list) s))))
			   (list #f up rst))))) 



;;  RFC3986, section 4.3

(define (absolute-uri s)
  (match (scheme s)
	 ((us rst)  
	  (match-let (((ua up rst)  (hier-part rst))
		      ((uq rst)     (match rst ((#\? . rst)  (query rst))
					   (else (list (list) rst)))))
		     (make-URI us ua up uq #f)))))
		     

;; Turns a URI into a string.
;;
;; Uses a supplied function to map the userinfo part of the URI.
;;

(define (uri->string uri . rest)
   (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
    (match uri
	   (($ URI scheme authority path query fragment)
	    (string-append 
	     ((lambda (x) (or (and x (string-append (->string x) ":")) ""))  scheme)
	     (if authority (string-append (uri-auth->string authority userinfomap) "/") "")
	     (string-concatenate path)
	     (if query (string-concatenate (cons "?" (intersperse query "&"))) "")
	     (if fragment (string-append  "#" fragment) "")))
	   (else #f))))

(define (uri-auth->string uri-auth userinfomap)
  (match uri-auth
	 (($ URIAuth username password host port)
	  (string-append "//" (if (and username password)
				  ((lambda (x) (or (and x (string-append x "@")) ""))
				   (userinfomap username password)) "")
			 host ((lambda (x) (or (and x (string-append ":" (->string x))) ""))
			       port)))
	 (else #f)))
			 
; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).

(define (uri->list uri . rest)
  (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
    (match uri
	   (($ URI scheme authority path query fragment)
	    `(,scheme (,(uri-auth->list authority userinfomap) ,path ,query) ,fragment))
	   (else #f))))

(define (uri-auth->list uri-auth userinfomap)
  (match uri-auth
	 (($ URIAuth username password regname port)
	  `(,(if (and username password) (userinfomap username password) #f) ,regname ,port ))
	 (else #f)))
			 

;;  Escape sequence handling

(define (uri-char-list-escape p enc str)
  (reverse
   (fold (lambda (c ax) 
	   (if (not (p c)) (let* ((os (enc c))  (cs (map pct-escape os)))
			     (append (reverse cs) ax))
	       (cons c ax)))
	 (list) str)))

;; Convert a URI character list to a string

(define (uri-char-list->string s)
  (list->string 
   (reverse
    (fold (lambda (x ax)
		  (cond ((char? x) (cons x ax))
			((list? x) (append (reverse x) ax)))) (list) s))))
   
;; Convert a string to a URI character list 

(define (uri-string->char-list s)
  (let loop ((cs (list)) (lst (string->list s)))
    (if (null? lst) (reverse cs)
	(match lst
	       ((#\% h1 h2 . rst)  (loop (cons (list #\% h1 h2) cs) rst))
	       (((and c (? char?)) . rst)  (loop (cons c cs) rst))))))
   
;;
;;  Resolving a relative URI relative to a base URI
;;
;;  Returns a new URI which represents the value of the first URI
;;  interpreted as relative to the second URI.
;;
;;  For example:
;;
;;  (uri->string (relative-to (uri-reference "foo") (uri "http://bar.org/")) )
;;         => "http://bar.org/foo"
;;
;;  (uri->string (non-strict-relative-to (uri "http:foo") (uri "http://bar.org/")) )
;;         => "http://bar.org/foo" 
;;
;;  Algorithm from RFC3986, section 5.2.2
;;

(define (uri-relative-to ref base)
  (and (uri? ref) (uri? base)
       (cond ((uri-scheme ref)      (just-segments ref))
	     ((uri-authority ref)   (let ((x (just-segments ref)))
				      (URI-scheme-set! x (uri-scheme base))
				      x))

	     (((lambda (p) (and (not (null? p)) p))  (uri-path ref)) =>
	      (lambda (ref-path)
		(if (and (pair? ref-path) (string-prefix? "/" (car ref-path)))
		    (let ((x (just-segments ref)))
		      (URI-scheme-set! x (uri-scheme base))
		      (URI-authority-set! x (uri-auth base))
		      x)
		    (let ((x (udup ref)))
		      (URI-scheme-set! x (uri-scheme base))
		      (URI-authority-set! x (uri-auth base))
		      (URI-path-set! x (merge-paths base x))
		      (just-segments x)))))

	     ((uri-query ref)       (let ((x (udup ref)))
				      (URI-scheme-set! x (uri-scheme base))
				      (URI-authority-set! x (uri-auth base))
				      (URI-path-set! x (list "/"))
				      (URI-path-set! x (merge-paths base x))
				      (just-segments x)))

	     (else                  (let ((x (just-segments ref)))
				      (URI-scheme-set! x (uri-scheme base))
				      (URI-authority-set! x (uri-auth base))
				      (URI-path-set! x (uri-path base))
				      (URI-query-set! x (uri-query base))
				      x)))))

(define (just-segments u)
  (let ((p (remove-dot-segments (uri-path u))))
    (make-URI (uri-scheme u) (uri-auth u) p
	      (uri-query u) (uri-fragment u))))

(define (merge0 pb pr)
  (let* ((rpb  (reverse pb))
	 (pb1  (reverse (if (not (string=? (car rpb) "/")) (cdr rpb) rpb)))
	 (pr1  (or (and (pair? pr) (not (string-prefix? ".." (car pr))) (not (string-prefix? "." (car pr)))
			(not (string-prefix? "/" (car pr))) 
			(cons (string-append "/" (car pr)) (cdr pr)))
		   pr)))
    (append pb1 pr1)))

(define (merge-paths b r)
  (let ((ba (uri-authority b))
	(pb (uri-path b))
	(pr (uri-path r)))
    (let ((mp  (if (and ba (null? pb)) (cons "/" pr) (merge0 pb pr))))
      mp)))

(define (uri-non-strict-relative-to ref base)
  (let ((rs (uri-scheme ref))
	(rb (uri-scheme base)))
    (let ((ref1 (make-URI (if (eq? rs rb) #f (uri-scheme ref))
			  (uri-auth ref) (uri-path ref)
			  (uri-query ref) (uri-fragment ref))))
      (uri-relative-to ref1 base))))


;;  Remove dot segments, but protect leading '/' character

(define (remove-dot-segments ps)
  (match ps (("/" . rst)   (cons "/" (elim-dots rst)))
	 (else             (elim-dots ps))))

(define (elim-dots ps)
  (let loop ((ps ps) (lst (list)))
    (if (null? ps) (reverse lst)
	(match ps
	       (((or "." "/."))
		(loop (list) (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) (cons "/" lst))))
	       (((or "." "/.") . rst)
		(loop rst (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) lst)))
	       (((or ".." "/.."))          
		(loop (list) (if (pair? lst) (cons "/" (cdr lst)) lst)))
	       (((or ".." "/..") . rst)
		(loop rst (if (pair? lst) (cdr lst) lst)))
	       ((x . rst)       (loop rst (cons x lst)))))))

;;
;; Finding a URI relative to a base URI
;;
;; Returns a new URI which represents the relative location of the
;; first URI with respect to the second URI.  Thus, the values
;; supplied are expected to be absolute URIs, and the result returned
;; may be a relative URI.
;;
;; Example:
;;
;; (uri->string
;;  (uri-relative-from (uri "http://example.com/Root/sub1/name2#frag")
;;                     (uri "http://example.com/Root/sub2/name2#frag")))
;;    ==> "../sub1/name2#frag"
;;


(define (uri-relative-from uabs base)
  (cond ((ucdiff? uri-scheme uabs base)      (udup uabs))
	((ucdiff? uri-authority uabs base)   (let ((x (udup uabs)))
					       (URI-scheme-set! x #f)
					       x))
	((ucdiff? uri-path uabs base)        
	 (let ((x    (udup uabs))
	       (path (rel-path-from (remove-body-dot-segments (uri-path uabs))
				    (remove-body-dot-segments (uri-path base)))))
	   (URI-scheme-set! x #f)
	   (URI-authority-set! x #f)
	   (URI-path-set! x path)
	   x))
	((ucdiff? uri-query uabs base) 
	 (let ((x (udup uabs)))
	   (URI-scheme-set! x #f)
	   (URI-authority-set! x #f)
	   (URI-path-set! x (list))
	   x))
	(else                             
	 (let ((x (udup uabs)))
	   (URI-scheme-set! x #f)
	   (URI-authority-set! x #f)
	   (URI-query-set! x #f)
	   (URI-path-set! x (list))
	   x))))


(define (udup u)
  (make-URI (uri-scheme u) (uri-auth u) (uri-path u)
	    (uri-query u) (uri-fragment u)))

(define (ucdiff? sel u1 u2)
  (let ((s1 (sel u1))
	(s2 (sel u2)))
    (not (cond ((and (URIAuth? s1) (URIAuth? s2))
		(not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
	       ((and (list? s1) (list? s2))       (every string=? s1 s2))
	       ((and (string? s1) (string? s2))   (string=? s1 s2))
	       (else                              (eq? s1 s2))))))

(define (remove-body-dot-segments p)
  (or (and (pair? p)
	   (let ((r (reverse p)))
	     (reverse (cons (car r) (remove-dot-segments (cdr r))))))
      p))

(define (rel-path-from pabs base)
  (cond  ((null? pabs)  (list "/"))
	 ((null? base)  pabs)
	 ;; Construct a relative path segment if the paths share a
	 ;; leading segment other than a leading '/'
	 (else  (match (list pabs base)
		       (((sa1 . (and ra1 (sa2 . ra2))) (sb1 . (and rb1 (sb2 . rb2))))
			(if (string=? sa1 sb1)
			    (make-rel-path
			     (if (string=? "/" sa1)
				 (if (string=? sa2 sb2) (rel-path-from1 ra2 rb2) pabs)
				 (rel-path-from1 ra1 rb1)))
			    pabs))
		       (((sa1) (sb1 . rb1))
			(if (string=? sa1 sb1)  (rel-segs-from (list) rb1)
			    pabs))))))

(define (make-rel-path x)
  (if (pair? x) (if (string-prefix? "/" (car x)) (cons "." x) x) x))

;;  rel-path-from1 strips off trailing names from the supplied paths,

(define (rel-path-from1 pabs base)
  (match-let* (((na . sa)  (reverse pabs))  
	       ((nb . sb)  (reverse base)))
     (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
       (if (null? rp)  (cond ((string=? na nb)  (list))
			     ((protect? na)     (list (string-append "./" na)))
			     (else              (list na)))
	   (append rp (list na))))))

			  
(define (protect? sa) (or (string-null? sa) (string-contains sa ":")))
	      


;;  rel-segs-from discards any common leading segments from both paths,
;;  then invokes dif-segs-from to calculate a relative path from the end
;;  of the base path to the end of the target path.  The final name is
;;  handled separately, so this deals only with "directory" segments.

(define (rel-segs-from sabs base)
  (cond ((and (null? sabs) (null? base))  (list))
	((or (null? sabs) (null? base))   (dif-segs-from sabs base))
	(else (match-let (((sa1 . ra1) sabs)
			  ((sb1 . rb1) base))
			 (if (string=? sa1 sb1)
			     (rel-segs-from ra1 rb1)
			     (dif-segs-from sabs base))))))

;;  dif-segs-from calculates a path difference from base to target,
;;  not including the final name at the end of the path (i.e. results
;;  always ends with '/')
;;
;;  This function operates under the invariant that the supplied value
;;  of sabs is the desired path relative to the beginning of base.
;;  Thus, when base is empty, the desired path has been found.

(define (dif-segs-from sabs base)
  (if (null? base) sabs (dif-segs-from (cons ".." sabs)  (cdr base))))



;; Other normalization functions
;;
;; Case normalization; cf. RFC3986 section 6.2.2.1
;; NOTE:  authority case normalization is not performed

(define (uri-normalize-case uri)
  (let ((u1      (udup uri))
	(scheme  (string->symbol (string-downcase (->string (uri-scheme uri)))))
	(path    (map (lambda (c) (match c (('% h1 h2)  `(% ,(char-upcase h1) ,(char-upcase h2)))
					 (else c))) (uri-path uri))))
    (URI-scheme-set! u1 scheme)
    (URI-path-set! u1 path)
    u1))


;;  Path segment normalization; cf. RFC3986 section 6.2.2.4

(define (uri-normalize-path-segments uri)
  (let ((u1      (udup uri))
	(path    (remove-dot-segments (uri-path uri))))
    (URI-path-set! u1 path)
    u1))