;; uri-generic version based on prcc

(provide 'uri-generic)

(module uri-generic
  (uri-reference make-uri 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)

(use extras data-structures ports prcc
     srfi-1 srfi-4 srfi-13 srfi-14)

(define uri-error error)

(cond-expand
 (chicken)
 (else
  (define (->string obj)
    (let ((s (open-output-string)))
      (display obj s)
      (let ((result (get-output-string s)))
        (close-output-port s)
        result)))
  ))

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

(define-record-type <URI>
  (make-URI scheme authority path query fragment)
  URI?
  (scheme URI-scheme URI-scheme-set!)
  (authority URI-authority URI-authority-set!)
  (path URI-path URI-path-set!)
  (query URI-query URI-query-set!)
  (fragment URI-fragment URI-fragment-set!))

(define-record-type <URIAuth>
  (make-URIAuth username password host port)
  URIAuth?
  (username URIAuth-username URIAuth-username-set!)
  (password URIAuth-password URIAuth-password-set!)
  (host URIAuth-host URIAuth-host-set!)
  (port URIAuth-port URIAuth-port-set!))

(cond-expand
 (chicken
  (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))))
 (else))

(define (update-URI uri . args)
  (let loop ((args args)
             (new-scheme (URI-scheme uri))
             (new-authority (URI-authority uri))
             (new-path (URI-path uri))
             (new-query (URI-query uri))
             (new-fragment (URI-fragment uri)))
    (cond ((null? args)
           (make-URI new-scheme new-authority new-path new-query new-fragment))
          ((null? (cdr args))
           (uri-error "malformed arguments to update-URI"))
          (else
           (let ((key (car args))
                 (value (cadr args)))
             (loop (cddr args)
                   (if (eq? key 'scheme) value new-scheme)
                   (if (eq? key 'authority) value new-authority)
                   (if (eq? key 'path) value new-path)
                   (if (eq? key 'query) value new-query)
                   (if (eq? key 'fragment) value new-fragment)))))))


(define (update-URIAuth uri-auth . args)
  (let loop ((args args)
             (new-username (URIAuth-username uri-auth))
             (new-password (URIAuth-password uri-auth))
             (new-host (URIAuth-host uri-auth))
             (new-port (URIAuth-port uri-auth)))
    (cond ((null? args)
           (make-URIAuth new-username new-password new-host new-port))
          ((null? (cdr args))
           (uri-error "malformed arguments to update-URIAuth"))
          (else
           (let ((key (car args))
                 (value (cadr args)))
             (loop (cddr args)
                   (if (eq? key 'username) value new-username)
                   (if (eq? key 'password) value new-password)
                   (if (eq? key 'host) value new-host)
                   (if (eq? key 'port) value new-port)))))))


(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 . args)
      (let loop ((key/values args)
                 (scheme (URI-scheme uri))
                 (path (URI-path uri))
                 (query (URI-query uri))
                 (fragment (URI-fragment uri))
                 (auth unset)
                 (authority unset))
        (cond
         ((null? key/values)
        (let* ((base-auth (or
                           (cond
                            ((not (eq? unset auth)) auth)
                            ((not (eq? unset authority)) authority)
                            (else (URI-authority uri)))
                             (make-URIAuth #f #f #f #f)))
                 (updated-auth (apply update-authority base-auth args))
                 (final-auth (if (uri-auth-equal? (make-URIAuth #f #f #f #f)
                                                  updated-auth)
                               #f
                               updated-auth)))
            (make-URI scheme final-auth path query fragment)))
         ((null? (cdr key/values))
          (uri-error "malformed arguments to update-uri"))
         ((not (memq (car key/values)
                     '(scheme authority path query fragment
                              username password host port)))
          (uri-error "unknown argument to update-uri" (car key/values)))
         (else
          (let ((key (car key/values))
                (value (cadr key/values)))
            (loop (cddr key/values)
                  (if (eq? key 'scheme) value scheme)
                  (if (eq? key 'path) value path)
                  (if (eq? key 'query) value query)
                  (if (eq? key 'fragment) value fragment)
                  (if (eq? key 'auth) value auth)
                  (if (eq? key 'authority) value authority)))))))))


(cond-expand

 (chicken
  (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)
                  (username unset) (password unset)
                  (host unset) (port unset))
           (let* ((args (list 'scheme scheme
                              'path path
                              'query query
                              'fragment fragment))
                  (args (if (not (eq? auth unset))
                            (append args (list 'auth auth)) args))
                  (args (if (not (eq? authority unset))
                            (append args (list 'authority authority)) args))
                  (args (if (not (eq? username unset))
                            (append args (list 'username username)) args))
                  (args (if (not (eq? password unset))
                            (append args (list 'password password)) args))
                  (args (if (not (eq? host unset))
                            (append args (list 'host host)) args))
                  (args (if (not (eq? port unset))
                            (append args (list 'port port)) args))
                  )
             (apply update-uri* uri args)))
         key/values)))))

 (else
  (define update-uri update-uri*)))

(define (make-uri* . key/values)
  (apply update-uri* (make-URI #f #f '() #f #f) key/values))

(cond-expand

 (chicken
  (define (make-uri . key/values)
    (apply update-uri (make-URI #f #f '() #f #f) key/values)))
 
 (else
  (define make-uri make-uri*)))

(define (uri-equal? a b)
  (or (and (not a) (not b))
      (and (equal? (URI-scheme a) (URI-scheme b))
           (uri-auth-equal? (URI-authority a) (URI-authority b))
           (equal? (URI-path a) (URI-path b))
           (equal? (URI-query a) (URI-query b))
           (equal? (URI-fragment a) (URI-fragment b)))))


(define (uri-auth-equal? a b)
  (or (and (not a) (not b))
      (and
       (equal? (URIAuth-username a) (URIAuth-username b))
       (equal? (URIAuth-password a) (URIAuth-password b))
       (equal? (URIAuth-host a) (URIAuth-host b))
       (equal? (URIAuth-port a) (URIAuth-port b)))))


(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 sub-delims (one-of (char-set->string char-set:sub-delims)))

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

;; The SRFI-14 library uses Latin1, and its definition of "letter"
;; includes accented letters with high bit. This wreaks havoc with
;; UTF-8 URIs.  Besides, the RFC only discusses ASCII letters anyway.
(define char-set:ascii-letter
  (string->char-set
   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))

(define char-set:ascii-letter+digit
  (char-set-union char-set:ascii-letter char-set:digit))

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

(define unreserved (one-of (char-set->string char-set:uri-unreserved)))

(define alpha (one-of (char-set->string char-set:ascii-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))))))))

(define (as-string parser)
  (act parser (lambda (x)
                (if (or (null? x) (pair? x))
                    (string-concatenate (map ->string x))
                    (->string x)))))

;; This "list" trick is required because returning #f will cause prcc
;; to believe the parser failed (which it did, but we pretend it
;; didn't).  Unfortunately, any code that uses this trick needs to
;; unpack the data from the list again later.
(define (maybe/list parser)
  (act parser list (constantly '(#f))))

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

(define hex-char (one-of (char-set->string char-set:hex-digit)))
(define pct-encoded (as-string (seq (char #\%) hex-char hex-char)))

(define (preceded-by ignore-parser use-parser)
  (ind (seq ignore-parser use-parser) 1))

(define (repeated parser n)
  (if (zero? n)
      (str "")
      (apply seq (list-tabulate n (constantly parser)))))

(define (uri-decode-string str #!optional (char-set char-set:full))
  (parse-string
   str
   (as-string
    (rep
     (sel
      (preceded-by
       (char #\%)
       (act (as-string (repeated hex-char 2))
            (lambda (encoded)
              (let ((decoded (integer->char (string->number encoded 16))))
                (and (char-set-contains? char-set decoded)
                     decoded)))))
      ;; This sucks; we really want an "any char" parser without
      ;; having to fall back to (expensive?) regex parsing.
      (regexp-parser "."))))))

(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 str)
  (parse-string
   str
   (as-string
    (rep
     (sel
      (act (seq (as-string (char #\%)) (as-string (repeated hex-char 2)))
           (lambda (res)
             (let* ((pct (car res))
                    (encoded (cadr res))
                    (decoded (integer->char (string->number encoded 16))))
               (if (char-set-contains? char-set:uri-unreserved decoded)
                   (string decoded)
                   (string-upcase (string-append pct encoded))))))
      ;; This sucks, see above
      (regexp-parser "."))))))

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

;; 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 (one-of (char-set->string char-set:digit)))

(define dec-octet
  (sel numeric
       ;; ucs-range->char-set is inclusive lower, exclusive upper bound!
       (seq (one-of (char-set->string (ucs-range->char-set #x31 #x40))) numeric)
       (seq (char #\1) numeric numeric)
       (seq (char #\2) (one-of (char-set->string (ucs-range->char-set #x30 #x35))) numeric)
       (seq (str "25") (one-of (char-set->string (ucs-range->char-set #x30 #x36))) numeric)))

(define ipv4-address
  (seq dec-octet (char #\.) dec-octet (char #\.) dec-octet (char #\.)))

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

(define  h16 (repeated hex-char 4))
(define ls32 (sel (seq h16 (char #\:) h16) ipv4-address))

(define ipv6-address
  (sel
   (seq (repeated (seq h16 (char #\:)) 6) ls32)
   (seq (str "::") (repeated (seq h16 (char #\:)) 5) ls32)
   (seq (one? h16)
        (str "::") (repeated (seq h16 (char #\:)) 4) ls32)
   (seq (one? (seq (repeated (seq h16 (char #\:)) 1) h16))
        (str "::") (repeated (seq h16 (char #\:)) 3) ls32)
   (seq (one? (seq (repeated (seq h16 (char #\:)) 2) h16))
        (str "::") (repeated (seq h16 (char #\:)) 2) ls32)
   (seq (one? (seq (repeated (seq h16 (char #\:)) 3) h16))
        (str "::") (repeated (seq h16 (char #\:)) 1) ls32)
   (seq (one? (seq (repeated (seq h16 (char #\:)) 4) h16))
        (str "::") ls32)
   (seq (one? (seq (repeated (seq h16 (char #\:)) 4) h16))
        (str "::") h16)
   (seq (one? (seq (repeated (seq h16 (char #\:)) 4) h16))
        (str "::"))))

;; IPvFuture  = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )
(define ipv-future
  (seq (char #\v) (rep+ hex-char) (char #\.)
       (rep+ (sel unreserved sub-delims (char #\:)))))

;; IP-literal = "[" ( IPv6address / IPvFuture  ) "]"
(define ip-literal
  (seq (char #\[) (sel ipv6-address ipv-future) (char #\])))

(define reg-name
  (rep (sel unreserved pct-encoded sub-delims)))

(define host (as-string (sel ip-literal ipv4-address reg-name)))

(define (as-number p) (act (as-string p) string->number))
(define port (as-number (rep numeric)))

;; 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)."

(define userinfo0
  (rep (sel unreserved pct-encoded sub-delims)))

(define userinfo1
  (rep (sel unreserved pct-encoded sub-delims (char #\:))))

(define userinfo
  (act (seq (as-string userinfo0)
            (one? (preceded-by (char #\:) (as-string userinfo1))))
       (lambda (result)
         (let ((user (car result))
               (pass (cadr result)))
           `((user . ,user)
             (pass . ,(and (not (string=? pass "")) pass)))))))

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

(define authority
  (act (seq (one? (ind (seq userinfo (char #\@)) 0))
            host
            (one? (preceded-by (char #\:) port)))
       (lambda (res)
         (let ((ui (and (not (string? (car res))) (car res)))
               (host (cadr res))
               (port (caddr res)))
           (make-URIAuth (and ui (alist-ref 'user ui))
                         (and ui (alist-ref 'pass ui))
                         host
                         ;; Port is "" if the parser failed
                         ;; It will be a number if it succeeded
                         (and (not (string? port)) port))))))

;; RFC3986, section 3
;;
(define (as-symbol p) (act (as-string p) string->symbol))
(define scheme
  (as-symbol (act (seq alpha (rep (sel alpha numeric (one-of "+-."))))
                  ;; Unwrap secondary list
                  (lambda (result) (cons (car result) (cadr result))))))

;;   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 / ":" / "@"

(define pchar (sel unreserved pct-encoded sub-delims (char #\:) (char #\@)))

(define pchar-nc ;; Our own invention, not in ABNF of RFC 3986
  (sel unreserved pct-encoded sub-delims (char #\@)))

(define (as-path-segment parser)
  (act (as-string parser)
       (lambda (s) (uri-decode-string s path-safe-chars))))

(define segment (as-path-segment (rep pchar)))
(define segment-nz (as-path-segment (rep+ pchar)))
(define segment-nz-nc (as-path-segment (rep+ pchar-nc)))

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

(define path-noscheme
  (act (seq segment-nz-nc (rep (preceded-by (char #\/) segment)))
       (lambda (res) (cons (car res) (cadr res)))))

(define path-abempty
  (act (rep (preceded-by (char #\/) segment))
       (lambda (p) (if (null? p) p (cons '/ p)))))

(define path-rootless
  (act (seq segment-nz (rep (preceded-by (char #\/) segment)))
       (lambda (r) (cons (car r) (cadr r)))))

(define path-absolute
  (preceded-by (char #\/)
               (sel
                (act (seq segment-nz
                          (rep (preceded-by (char #\/) segment)))
                     (lambda (r) (cons '/ (cons (car r) (cadr r)))))
                (act (sel (str "") (eof)) (constantly '(/ ""))))))

(define hier-part
  (sel (preceded-by
        (str "//")
        (act (seq authority path-abempty)
             (lambda (r)
               (let ((auth (and (not (string? (car r))) (car r)))
                     (path (and (not (string? (cadr r))) (cadr r))))
                 `((auth . ,auth) (path . ,path))))))
       (act (sel path-absolute
                 path-rootless
                 path-empty)
            (lambda (path) `((path . ,path))))))

;; RFC3986 section 3.4
;;
;; query       = *( pchar / "/" / "?" )
(define query
  (as-string (rep (sel pchar (char #\/) (char #\?)))))

;; RFC3986 section 3.5
;;
;; fragment       = *( pchar / "/" / "?" )
(define fragment
  (as-string (rep (sel pchar (char #\/) (char #\?)))))

;; RFC3986 section 3
;;
;;   URI         = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
;;
(define uri
  (act (seq scheme
            (preceded-by (char #\:) hier-part)
            (maybe/list (preceded-by (char #\?) query))
            (maybe/list (preceded-by (char #\#) fragment)))
       (lambda (r)
         (let* ((scheme (car r))
                (hier (cadr r))
                (query (caddr r))
                (query (car query))
                (fragment (cadddr r))
                (fragment (car fragment)))
          (make-URI scheme (alist-ref 'auth hier)
                    (alist-ref 'path hier) query fragment)))))

;;  RFC3986, section 4.2
;;
;;   relative-ref  = relative-part [ "?" query ] [ "#" fragment ]
;;
;;   relative-part = "//" authority path-abempty
;;                 / path-absolute
;;                 / path-noscheme
;;                 / path-empty
(define relative-part
  (sel (act (seq (preceded-by (str "//") authority) path-abempty)
            (lambda (res)
              (let ((auth (car res)) (path (cadr res)))
                (make-URI #f auth path #f #f))))
       (act (sel path-absolute path-noscheme path-empty)
            (lambda (path) (make-URI #f #f path #f #f)))))

(define relative-ref
  (act (seq relative-part
            (maybe/list (preceded-by (char #\?) query))
            (maybe/list (preceded-by (char #\#) fragment)))
       (lambda (res)
         (let ((base (car res))
               (query (car (cadr res)))
               (fragment (car (caddr res))))
           (update-URI base 'query query 'fragment fragment)))))

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

(define uri-reference
  (lambda (s)
    (and-let* ((decoded (uri-decode-string s char-set:uri-unreserved)))
      (parse-string decoded (pred (sel uri relative-ref) (eof))))))

;; RFC3986, section 4.3

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

;; (define abs-uri
;;   (seq scheme (preceded-by (char #\:) hier-part)
;;        (maybe/list (preceded-by (char #\?) 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)))
)