;; uri-generic version based on packrat

(provide 'uri-generic)

(module uri-generic
  (uri-reference update-uri update-authority
   uri-reference? uri-auth uri-authority uri-scheme uri-path uri-query
   uri-fragment uri-host uri-port uri-username uri-password
   authority? authority-host authority-port
   authority-username authority-password
   
   uri? absolute-uri absolute-uri? uri->string uri->list
   relative-ref? uri-relative-to uri-relative-from 
   uri-decode-string uri-encode-string 
   uri-normalize-case uri-normalize-path-segments
   uri-path-absolute? uri-path-relative?

   char-set:gen-delims char-set:sub-delims
   char-set:uri-reserved char-set:uri-unreserved)

(import chicken scheme extras data-structures ports)

(require-library regex)
(import irregex)
(require-extension defstruct srfi-1 srfi-4 srfi-13 srfi-14 packrat)

;; What to do with these?
#;(cond-expand
   (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
   (else (use srfi-13 srfi-14)))

(defstruct URI      scheme authority path query fragment)
(defstruct 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-reference? 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))))

(define authority? URIAuth?)
(define authority-host URIAuth-host)
(define authority-port URIAuth-port)
(define authority-username URIAuth-username)
(define authority-password URIAuth-password)

(define update-authority update-URIAuth)

(define update-uri
  (let ((unset (list 'unset)))
   (lambda (uri . key/values)
     (apply
      (lambda (#!key
               (scheme (URI-scheme uri)) (path (URI-path uri))
               (query (URI-query uri)) (fragment (URI-fragment uri))
               (auth unset) (authority unset))
        (let* ((base-auth (or
                           (cond
                            ((not (eq? unset auth)) auth)
                            ((not (eq? unset authority)) authority)
                            (else (URI-authority uri)))
                           (make-URIAuth)))
               (updated-auth (apply update-authority base-auth key/values))
               (final-auth (if (equal? (make-URIAuth) updated-auth)
                               #f
                               updated-auth)))
          (make-URI scheme: scheme path: path query: query fragment: fragment
                    authority: final-auth))) key/values))))


(define (uri? u)
  (and (uri-reference? u) (uri-scheme u) #t))

(define (relative-ref? u)
  (and (uri-reference? u) (not (uri-scheme u))))

(define (absolute-uri? u)
  (and (uri-reference? u) (not (relative-ref? u)) (not (uri-fragment u))))


;; 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:uri-reserved (char-set-union char-set:gen-delims char-set:sub-delims))

(define (char-set-parser char-set)
  (lambda (results)
    (let ((ch (parse-results-token-value results)))
      (if (and ch (char-set-contains? char-set ch))
          (make-result ch (parse-results-next results))
          (make-expected-result (parse-results-position results) char-set)))))

(define sub-delims (char-set-parser char-set:sub-delims))

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

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

(define unreserved (char-set-parser char-set:uri-unreserved))

(define alpha (char-set-parser char-set:letter))

;; 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 ":******" ))))
    (with-output-to-string
      (lambda ()
        (display-fragments
         `(,(and-let* ((scheme (uri-scheme uri))) (list scheme ":"))
           ,(and-let* ((auth (URI-authority uri))
                       (host (URIAuth-host auth)))
              (let ((username (URIAuth-username auth)))
                (list "//" (and username (list (userinfomap username (URIAuth-password auth)) "@"))
                      host (and (URIAuth-port auth)
                                (list ":" (URIAuth-port auth))))))
           ,(path->string (uri-path uri))
           ,(and-let* ((query (uri-query uri))) (list "?" query))
           ,(and-let* ((fragment (uri-fragment uri))) (list  "#" fragment))))))))


;; RFC3986, section 2.2
;;
;; Percent encoding
;;

(define uri-decode-string
  (let ((re (irregex `(seq #\% hex-digit hex-digit))))
    (lambda (str #!optional (char-set char-set:full))
      (irregex-replace/all
       re str
       (lambda (match)
         (let* ((encoded (irregex-match-substring match))
                (decoded (integer->char (string->number (string-drop encoded 1) 16))))
           (if (char-set-contains? char-set decoded) (string decoded) encoded)))))))

(define (display-fragments b)
  (let loop ((fragments b))
    (cond
      ((null? fragments) (begin))
      ((not (car fragments)) 
       (loop (cdr fragments) ))
      ((null? (car fragments)) 
       (loop (cdr fragments) ))
      ((pair? (car fragments))
       (begin (loop (car fragments))
	      (loop (cdr fragments) )))
      (else
       (display (car fragments))
       (loop (cdr fragments) )))))

			 
(define (path->string path)
  (cond
   ((null? path) "")
   ((eq? '/ (car path)) (string-append "/" (join-segments (cdr path))))
   ((protect? (car path)) (join-segments (cons "." path)))
   (else (join-segments path))))

(define (join-segments segments)
  (string-intersperse
   (map (lambda (segment) (list)
                (uri-encode-string segment (char-set #\/)))
        segments) "/"))

;; Section 4.2; if the first segment contains a colon, it must be prefixed "./"
(define (protect? sa) (string-index sa #\:))

; 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 ":******" ))))
    `(,(URI-scheme uri) (,(uri-auth->list (URI-authority uri) userinfomap)
                         ,(URI-path uri) ,(URI-query uri))
      ,(URI-fragment uri))))

(define (uri-auth->list uri-auth userinfomap)
  (and uri-auth
       `(,(and-let* ((user (URIAuth-username uri-auth))
                     (pass (URIAuth-password uri-auth)))
            (userinfomap user pass))
         ,(URIAuth-host uri-auth) ,(URIAuth-port uri-auth))))
			 

(define (uri-normalize-case uri)
  (let* ((normalized-uri (uri-reference 
			  (normalize-pct-encoding (uri->string uri (lambda (user pass) (conc user ":" pass))))))
         (scheme         (string->symbol (string-downcase (->string (uri-scheme uri)))))
         (host           (normalize-pct-encoding (string-downcase (uri-host uri)))))
    (update-uri normalized-uri scheme: scheme host: host)))

;; RFC 3986, section 2.1
;;
;; Returns a 'pct-encoded' sequence of octets.
;;
(define (uri-encode-string str #!optional (char-set (char-set-complement
                                                     char-set:uri-unreserved)))
  (define (hex-digit i)
    (and (>= i 0) (< i 16)
         (car (string->list (string-upcase (number->string i 16))))))
  (define (pct-encode c)
    (let ((i (char->integer c)))
     `(#\% ,(hex-digit (quotient i 16)) ,(hex-digit (remainder i 16)))))
  (list->string
   (string-fold-right (lambda (c res)
                        (if (char-set-contains? char-set c)
                            (append (pct-encode c) res)
                            (cons c res)))
                      '() str)))

(define normalize-pct-encoding
  (let ((re (irregex `(seq #\% hex-digit hex-digit)))
        (char-set char-set:uri-unreserved))
    (lambda (str)
      (irregex-replace/all
       re str
       (lambda (match)
         (let* ((encoded (irregex-match-substring match))
                (decoded (integer->char (string->number (string-drop encoded 1) 16))))
           (if (char-set-contains? char-set decoded)
               (string decoded)
               (string-upcase encoded))))))))

(define path-safe-chars (char-set-union char-set:uri-unreserved (char-set #\/ #\?)))

(define (match->uri m)
  (let* ((ap (or (irregex-match-substring m 'abspath1)
                 (irregex-match-substring m 'abspath2)))
         (rp (or (irregex-match-substring m 'relpath1)
                 (irregex-match-substring m 'relpath2)))
         (path (if ap
                   (if (string-null? ap)
                       '()
                       (cons '/ (map (lambda (s)
                                       (uri-decode-string s path-safe-chars))
                                     (cdr (string-split ap "/" #t)))))
                   (if (string-null? rp)
                       '()
                       (map (lambda (s)
                              (uri-decode-string s path-safe-chars))
                            (string-split rp "/" #t))))))
   (make-URI scheme: (handle-exceptions
                         exn #f
                         (and-let* ((s (irregex-match-substring m 'scheme)))
                           (string->symbol s)))
             authority: (let ((user (irregex-match-substring m 'username))
                              (pass (irregex-match-substring m 'password))
                              (host (irregex-match-substring m 'host))
                              (port (irregex-match-substring m 'port)))
                          (and (or user pass host port)
                               (make-URIAuth
                                username: user password: pass
                                host: host
                                port: (and port (string->number port)))))
             path: path
             query: (irregex-match-substring m 'query)
             fragment: (irregex-match-substring m 'fragment))))

;; RFC3986, section 3.2.2
;;
;; host        = IP-literal / IPv4address / reg-name
;;

;; IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet
;; dec-octet   = DIGIT                 ; 0-9
;;               / %x31-39 DIGIT       ; 10-99
;;               / "1" 2DIGIT          ; 100-199
;;               / "2" %x30-34 DIGIT   ; 200-249
;;               / "25" %x30-35        ; 250-255

(define numeric (char-set-parser char-set:digit))
(define hex-digit (char-set-parser char-set:hex-digit))

(define x31-39
  (char-set-parser (char-set (integer->char #x31) (integer->char #x39))))
(define x30-34
  (char-set-parser (char-set (integer->char #x30) (integer->char #x34))))
(define x30-35
  (char-set-parser (char-set (integer->char #x30) (integer->char #x35))))

(define scheme-chars (char-set-parser (char-set-union char-set:letter+digit
                                                      (char-set #\+ #\- #\.))))

(define (eof results)
  (if (parse-results-token-value results)
      (make-expected-result (parse-results-position results) 'EOF)
      (make-result #t (parse-results-next results))))

(define (pct-decode pct-list char-set)
  (let ((dc (integer->char (string->number (apply string (cdr pct-list)) 16))))
    (if (char-set-contains? char-set dc) (list dc) pct-list)))

(define uri-parser
  (packrat-parser
   uri
   
   (pct-encoded (('#\% h1 <- hex-digit h2 <- hex-digit) `(#\% ,h1 ,h2)))

   (dec-octet ((n <- numeric) n)
              ((n1 <- x31-39 n2 <- numeric) `(,n1 ,n2))
              (('#\1 n1 <- numeric n2 <- numeric) `(#\1 ,n1 ,n2))
              (('#\2 n1 <- x30-34 n2 <- numeric) `(#\2 ,n1 ,n2))
              (('#\2 '#\5 n <- x30-35) `(#\2 #\5 ,n)))

   (ipv4-address ((n1 <- dec-octet '#\. n2 <- dec-octet '#\. n3 <- dec-octet '#\.)
                  (append! n1 '(#\.) n2 '(#\.) n3)))

   ;; IPv6address =                                  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

   (h16  ((n1 <- hex-digit n2 <- hex-digit n3 <- hex-digit n4 <- hex-digit)
          `(,n1 ,n2 ,n3 ,n4)))
   (ls32 ((n1 <- h16 '#\: n2 <- h16) (append! n1 '(#\:) n2))
         ((a <- ipv4-address) a))

   (h16:x6 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16 '#\:
             n4 <- h16 '#\: n5 <- h16 '#\: n6 <- h16 '#\:)
            `(,n1 #\: ,n2 #\: ,n3 #\: ,n4 #\: n5 #\: n6 #\:)))

   (h16:x5 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16 '#\:
             n4 <- h16 '#\: n5 <- h16 '#\:)
            `(,n1 #\: ,n2 #\: ,n3 #\: ,n4 #\: n5 #\:)))

   (h16:x4 ((n1 <- h16 '#\: n2 <- h16 #\: n3 <- h16 #\: n4 <- h16 #\:)
            `(,n1 #\: ,n2 #\: ,n3 #\: ,n4 #\:)))

   (h16:x3 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16 '#\:)
            `(,n1 #\: ,n2 #\: ,n3 #\:)))

   (h16:x2 ((n1 <- h16 '#\: n2 <- h16 '#\:) `(,n1 #\: ,n2 #\:)))

   (h16:x1 ((n1 <- h16 '#\:) `(,n1 #\:)))

   (h16? ((n <- h16) n) (() '()))
   (h16:x1-h16? ((n1 <- h16:x1 n2 <- h16) (append! n1 n2)) (() '()))
   (h16:x2-h16? ((n1 <- h16:x2 n2 <- h16) (append! n1 n2)) (() '()))
   (h16:x3-h16? ((n1 <- h16:x3 n2 <- h16) (append! n1 n2)) (() '()))
   (h16:x4-h16? ((n1 <- h16:x4 n2 <- h16) (append! n1 n2)) (() '()))
   (h16:x5-h16? ((n1 <- h16:x5 n2 <- h16) (append! n1 n2)) (() '()))
   (h16:x6-h16? ((n1 <- h16:x6 n2 <- h16) (append! n1 n2)) (() '()))
   
   (ipv6-address ((n1 <- h16 n2 <- ls32)
                  (append! n1 n2))
                 (('#\: '#\: n1 <- h16:x5 n2 <- ls32)
                  `(#\: #\: ,@n1 ,@n2))
                 ((n1 <- h16? '#\: '#\: n2 <- h16:x4 n3 <- ls32)
                  `(,@n1 #\: #\: ,@n2 ,@n3))
                 ((n1 <- h16:x1-h16? '#\: '#\: n2 <- h16:x3 n3 <- ls32)
                  `(,@n1 #\: #\: ,@n2 ,@n3))
                 ((n1 <- h16:x2-h16? '#\: '#\: n2 <- h16:x2 n3 <- ls32)
                  `(,@n1 #\: #\: ,@n2 ,@n3))
                 ((n1 <- h16:x3-h16? '#\: '#\: n2 <- h16:x1 n3 <- ls32)
                  `(,@n1 #\: #\: ,@n2 ,@n3))
                 ((n1 <- h16:x4-h16? '#\: '#\: n2 <- ls32)
                  `(,@n1 #\: #\: ,@n2))
                 ((n1 <- h16:x5-h16? '#\: '#\: n2 <- h16)
                  `(,@n1 #\: #\: ,@n2))
                 ((n1 <- h16:x6-h16? '#\: '#\:)
                  `(,@n1 #\: #\:)))

   ;; IPvFuture  = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )
   (ipv-future (('#\v n1 <- hex-digits '#\. n2 <- ipv-future-rest)
                `(#\v ,@n1 #\. ,@n2)))
   (hex-digits ((n1 <- hex-digit n2 <- hex-digit n3 <- hex-digits)
                (cons n1 (cons n2 n3)))
               ((n1 <- hex-digit) `(,n1)))
   (ipv-future-rest ((n1 <- unres-sub-: n2 <- unres-sub: n3 <- ipv-future-rest)
                     (cons n1 (cons n2 n3)))
                    ((n1 <- unres-sub-:) `(,n1)))
   (unres-sub-: ((n1 <- unreserved) n1) ((n2 <- sub-delims) n2) ((#\:) #\:))

   ;; IP-literal = "[" ( IPv6address / IPvFuture  ) "]"
   (ip-literal (('#\[ a <- ipv6-address '#\]) `(#\[ ,@a #\]))
               (('#\[ a <- ipv-future   '#\]) `(#\[ ,@a #\])))

   (reg-name ((r1 <- unreserved  r2 <- reg-name) (cons r1 r2))
             ((r1 <- pct-encoded r2 <- reg-name)
              (append! (pct-decode r1 char-set:uri-unreserved) r2))
             ((r1 <- sub-delims  r2 <- reg-name) (cons r1 r2))
             (() '()))

   (host ((ip <- ip-literal)     (list->string ip))
         ((ipv4 <- ipv4-address) (list->string ipv4))
         ((rn <- reg-name)       (list->string rn)))

   (port ((n <- portnum) (string->number (list->string n)))
         (() #f))
   (portnum ((n1 <- numeric n2 <- portnum) (cons n1 n2))
            (() '()))

   ;; RFC3986, section 3.2
   ;;
   ;; userinfo    = *( unreserved / pct-encoded / sub-delims / ":" )
   ;;
   ;; We split this up in the leading part without colons ("username") and
   ;; everything after that ("password"), including extra colons.
   ;;
   ;; The RFC is not very clear, but it does mention this:
   ;;   "The userinfo subcomponent may consist of a user name and,
   ;;    optionally, scheme-specific information about how to gain
   ;;    authorization to access the resource."
   ;;
   ;; The grammar allows multiple colons, and the RFC then continues:
   ;;   "Applications should not render as clear text any data after
   ;;    the first colon (":") character found within a userinfo
   ;;    subcomponent unless the data after the colon is the empty
   ;;    string (indicating no password)."

   (userinfo0 ((u <- unreserved ur <- userinfo0)  (cons u ur))
              ((u <- pct-encoded ur <- userinfo0)
               (append! (pct-decode u char-set:uri-unreserved) ur))
              ((u <- sub-delims ur <- userinfo0)  (cons u ur))
              (() '()))

   (userinfo1 ((u <- unreserved ur <- userinfo1)  (cons u ur))
              ((u <- pct-encoded ur <- userinfo1)
               (append! (pct-decode u char-set:uri-unreserved) ur))
              ((u <- sub-delims ur <- userinfo1)  (cons u ur))
              (('#\: ur <- userinfo1) (cons #\: ur))
              (() '()))

   (userinfo ((u0 <- userinfo0 '#\: u1 <- userinfo1)
              (cons (list->string u0) (list->string u1)))
             ((u0 <- userinfo0) (cons (list->string u0) #f)))

   ;; authority   = [ userinfo "@" ] host [ ":" port ]

   (userinfo@? ((ui <- userinfo '#\@) ui)
                    (() '(#f . #f)))
   (:port? (('#\: p <- port) p)
                (() #f))
   (authority ((ui <- userinfo@? h <- host p <- :port?)
               (make-URIAuth
                port: p host: h username: (car ui) password: (cdr ui))))

   ;; RFC3986, section 3
   ;;
   (scheme-rest ((c <- scheme-chars r <- scheme-rest) (cons c r))
                (() '()))
   (scheme ((a <- alpha r <- scheme-rest)
            (string->symbol (list->string (cons a r)))))

   ;;   hier-part   = "//" authority path-abempty
   ;;               / path-absolute
   ;;               / path-rootless
   ;;               / path-empty
   ;;
   ;;
   ;; path-abempty  = *( "/" segment )
   ;; path-absolute = "/" [ segment-nz *( "/" segment ) ]
   ;; path-noscheme = segment-nz-nc *( "/" segment )
   ;; path-rootless = segment-nz *( "/" segment )
   ;; path-empty    = 0<pchar>
   ;;
   ;; segment       = *pchar
   ;; segment-nz    = 1*pchar
   ;; segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" )
   ;; ; non-zero-length segment without any colon ":"
   ;; pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"

   (pchar ((u <- unreserved) `(,u))
          ((p <- pct-encoded) (pct-decode p path-safe-chars))
          ((s <- sub-delims) `(,s))
          (('#\:) `(#\:))
          (('#\@) `(#\@)))

   ;; Our own invention, not in ABNF of RFC 3986
   (pchar-nc ((u <- unreserved) `(,u))
             ((p <- pct-encoded) (pct-decode p path-safe-chars))
             ((s <- sub-delims) `(,s))
             (('#\@) `(#\@)))

   (segment ((p <- pchar s <- segment) (append! p s))
            (() '()))
   (segment-nz ((p <- pchar s <- segment-nz) (append! p s))
               ((p <- pchar) p))
   (segment-nz-nc ((p <- pchar-nc s <- segment-nz-nc) (append! p s))
                  ((p <- pchar-nc) p))

   (path-empty (() '())) ;; Always succeeds. "0<pchar>" in the ABNF

   ;; slash-segments is our own invention
   (slash-segments (('#\/ s <- segment rest <- slash-segments)
                    (cons (list->string s) rest))
                   (() '()))
   (path-noscheme ((s <- segment-nz-nc rest <- slash-segments)
                   (cons (list->string s) rest)))

   (path-abempty ((s <- slash-segments) (if (null? s) s (cons '/ s))))

   (path-rootless ((s <- segment-nz rest <- slash-segments)
                   (cons (list->string s) rest)))

   (path-absolute (('#\/ s <- segment-nz rest <- slash-segments)
                   (cons '/ (cons (list->string s) rest)))
                  (('#\/) `(/ . (""))))

   (hier-part (('#\/ '#\/ a <- authority p <- path-abempty)
               `((auth . ,a) (path . ,p)))
              ((p <- path-absolute) `((path . ,p)))
              ((p <- path-rootless) `((path . ,p)))
              ((p <- path-empty) `((path . ,p))))

   ;; RFC3986 section 3.4
   ;;
   ;; query       = *( pchar / "/" / "?" )

   ;; A qchar is identical to pchar, with different pct decoding rules
   (qchar ((u <- unreserved) `(,u))
          ((p <- pct-encoded) (pct-decode p char-set:uri-unreserved))
          ((s <- sub-delims) `(,s))
          (('#\:) `(#\:))
          (('#\@) `(#\@)))
   
   (query ((c <- qchar r <- query) (append c r))
          (('#\/ r <- query) (cons #\/ r))
          (('#\? r <- query) (cons #\? r))
          (() '()))

   ;; RFC3986 section 3.5
   ;;
   ;; fragment       = *( pchar / "/" / "?" )
   (fragment ((c <- qchar r <- fragment) (append! c r))
             (('#\/ r <- fragment) (cons #\/ r))
             (('#\? r <- fragment) (cons #\? r))
             (() '()))

   ;; RFC3986 section 3
   ;;
   ;;   URI         = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
   ;;
   (?-query? (('#\? q <- query) (list->string q))
            (() #f))
   (hash-fragment? (('#\# f <- fragment) (list->string f))
               (() #f))
   (uri ((s <- scheme '#\: h <- hier-part q <- ?-query? f <- hash-fragment? eof)
         (make-URI scheme: s authority: (alist-ref 'auth h)
                   path: (alist-ref 'path h) query: q fragment: f)))))

;;  RFC3986, section 4.2
;;
;;   relative-ref  = relative-part [ "?" query ] [ "#" fragment ]
;;
;;   relative-part = "//" authority path-abempty
;;                 / path-absolute
;;                 / path-noscheme
;;                 / path-empty
(define relative-ref-parser
  (packrat-parser
   relative-ref
   (relative-part (('#\/ '#\/ a <- authority p <- path-abempty) `(,a . ,p))
                  ((p <- path-absolute) `(#f . ,p))
                  ((p <- path-noscheme) `(#f . ,p))
                  ((p <- path-empty) `(#f . ,p)))
   (relative-ref ((rp <- relative-part q <- ?-query? f <- hash-fragment? eof)
                  (make-URI scheme: #f authority: (car rp) path: (cdr rp)
                            query: q fragment: f)))))

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

(define (generator s)
  (let ((chars (string->list s))
        (pos (top-parse-position #f)))
    (lambda ()
      (if (null? chars)
          (values pos #f)
          (let ((c (car chars))
                (old-pos pos))
            (set! chars (cdr chars))
            (set! pos (update-parse-position pos c))
            (values old-pos (cons c c)))))))

(define (parse-string parser s)
  (and-let* ((res (parser (base-generator->results (generator s))))
             ((parse-result-successful? res)))
    (parse-result-semantic-value res)))

(define (uri-reference s)
  (or (parse-string uri-parser s)
      (parse-string relative-ref-parser s)))

;; RFC3986, section 4.3

;; absolute-URI  = scheme ":" hier-part [ "?" query ]

(define (absolute-uri s)
  (let ((ref (uri-reference s)))
    (when (uri-fragment ref)
      (error 'absolute-uri "fragments are not permitted in absolute URI"))
    (unless (uri-scheme ref)
      (error 'absolute-uri "no scheme found in URI string"))
    ref))

;;
;;  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"
;;
;;  Algorithm from RFC3986, section 5.2.2
;;

(define (uri-relative-to ref base)
  (and (uri-reference? ref) (uri-reference? base)
       (cond ((uri-scheme ref)      (update-URI ref
						path: (just-segments ref)))
	     ((uri-authority ref)   (update-URI ref
						path: (just-segments ref)
						scheme: (uri-scheme base)))
	     ((let ((p (uri-path ref))) (and (not (null? p)) p)) =>
	      (lambda (ref-path)
		(if (and (pair? ref-path) (eq? '/ (car ref-path)))
		    (update-URI ref
				scheme: (uri-scheme base)
				authority: (uri-auth base)
				path: (just-segments ref))
		    (update-URI ref
				scheme: (uri-scheme base)
				authority: (uri-auth base)
				path: (merge-paths base ref-path)))))
	     ((uri-query ref) (update-URI ref
					  scheme: (uri-scheme base)
					  authority: (uri-auth base)
					  path: (merge-paths base (list ""))))
	     (else (update-URI ref
			       path: (URI-path base)
			       scheme: (URI-scheme base)
			       authority: (URI-authority base)
			       query: (URI-query base))))))

;;
;; 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)      (update-URI uabs))
	((ucdiff? uri-authority uabs base)   (update-URI uabs scheme: #f))
        ;; Special case: no relative representation for http://a/ -> http://a
        ;; ....unless that should be a path of ("..")
        ((null? (uri-path uabs))             (update-URI uabs scheme: #f))
	((ucdiff? uri-path uabs base)
	 (update-URI uabs
		     scheme: #f
		     authority: #f
		     path: (rel-path-from
			    (remove-dot-segments (uri-path uabs))
			    (remove-dot-segments (uri-path base)))))
	((ucdiff? uri-query uabs base)
	 (update-URI uabs
		     scheme: #f
		     authority: #f
		     path: (list)))
	(else
	 (update-URI uabs
		     scheme: #f
		     authority: #f
		     query: #f
		     path: (list)))))

(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))       (equal? s1 s2))
	       ((and (string? s1) (string? s2))   (string=? s1 s2))
	       (else                              (eq? s1 s2))))))

(define (rel-path-from pabs base)
  (cond
   ((or (null? base) (null? pabs)) pabs)
   ;; Construct a relative path segment if the paths share a
   ;; leading segment other than a leading '/'
   ((and (eq? (car pabs) '/) (eq? (car base) '/))
    (make-rel-path
     (if (string=? (cadr pabs) (cadr base))
         (rel-path-from1 (cdr pabs) (cdr base))
         pabs)))
   (else (error 'rel-path-from "Both URI paths must be absolute" pabs base))))

(define (make-rel-path x)
  (if (or (eq? (car x) '/) (string=? (car x) ".") (string=? (car x) ".."))
      x
      (cons "." x)))

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

(define (rel-path-from1 pabs base)
  (let* ((rpabs (reverse pabs))
         (rbase (reverse base))
         (rp (rel-segs-from (reverse (cdr rpabs)) (reverse (cdr rbase)))))
    (if (null? rp)
        (if (string=? (car rpabs) (car rbase))
            (list)
            (list (car rpabs)))
        (append rp (list (car rpabs))))))

;;  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 (if (string=? (car sabs) (car base))
                  (rel-segs-from (cdr sabs) (cdr base))
                  (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))))

;;  Path segment normalization; cf. RFC3986 section 6.2.2.4

(define (uri-normalize-path-segments uri)
  (update-URI uri path: (just-segments uri)))

(define (merge0 pb pr)
  (let* ((rpb  (reverse pb))
         (pb1  (reverse (if (pair? rpb) ; RFC3986, section 5.2.3, second bullet
                            (cdr rpb) rpb))))
    (append pb1 pr))) ; It is assumed we never get here if pr is empty!

(define (merge-paths b pr)  ; pr is a relative path, *not* a URI object
  (let ((ba (uri-authority b))
	(pb (uri-path b)))
    (let ((mp (if (and ba (null? pb))
                  (cons '/ pr)  ; RFC3986, section 5.2.3, first bullet
                  (merge0 pb pr))))
      (remove-dot-segments mp))))

(define (just-segments u)
  (remove-dot-segments (uri-path u)))

;;  Remove dot segments, but protect leading '/' symbol
(define (remove-dot-segments ps)
  (if (and (pair? ps) (eq? (car ps) '/))
      (cons '/ (elim-dots (cdr ps)))
      (elim-dots ps)))

(define (elim-dots ps)
  (let loop ((ps ps) (trailing-slash? #f) (lst (list)))
    (cond
     ((null? ps) (reverse (if trailing-slash? (cons "" lst) lst)))
     ((equal? (car ps) ".")
      (loop (cdr ps) #t lst))
     ((equal? (car ps) "..")
      (loop (cdr ps) #t (if (pair? lst) (cdr lst) lst)))
     (else
      (loop (cdr ps) #f (cons (car ps) lst))))))

(define (uri-path-absolute? uri)
  (let ((path (uri-path uri)))
   (and (pair? path) (eq? '/ (car path)))))

(define (uri-path-relative? uri)
  (not (uri-path-absolute? uri)))
)