main.carp

(deftype URI
  [scheme (Maybe String)
   host (Maybe String)
   port (Maybe Int)
   path (Maybe String)
   query (Maybe String)
   user (Maybe String)
   password (Maybe String)
   fragment (Maybe String)
   opaque (Maybe String)])

(defmodule URI
  (use-all Int Maybe Result)

  (doc zero "Creates an empty URI, i.e. one that has only `Nothing` in it.")
  (implements zero zero)
  (defn zero []
    (URI.init (Nothing)
              (Nothing)
              (Nothing)
              (Nothing)
              (Nothing)
              (Nothing)
              (Nothing)
              (Nothing)
              (Nothing)))

  (doc default-ports
    "is a map of all the services that have default ports—that
we know of—and their port values.")
  (def default-ports
    {@"acap" 674
     @"afp" 548
     @"dict" 2628
     @"dns" 53
     @"ftp" 21
     @"ftps" 990
     @"git" 9418
     @"gopher" 70
     @"http" 80
     @"https" 443
     @"imap" 143
     @"ipp" 631
     @"ipps" 631
     @"irc" 194
     @"ircs" 6697
     @"ldap" 389
     @"ldaps" 636
     @"mms" 1755
     @"msrp" 2855
     @"mtqp" 1038
     @"nfs" 111
     @"nntp" 119
     @"nntps" 563
     @"pop" 110
     @"prospero" 1525
     @"redis" 6379
     @"rsync" 873
     @"rtsp" 554
     @"rtsps" 322
     @"rtspu" 5005
     @"scp" 22
     @"sftp" 22
     @"smb" 445
     @"snmp" 161
     @"ssh" 22
     @"svn" 3690
     @"telnet" 23
     @"ventrilo" 3784
     @"vnc" 5900
     @"wais" 210
     @"ws" 80
     @"wss" 443})

  (doc default-port "gets the default `port` for the `scheme` of the URI `u`.
Returns 0 if it’s unknown.")
  (defn default-port [s]
    (from (apply s &(fn [s] (Map.get &default-ports &s))) 0))

  (doc default-port? "checks whether the `port` of the URI `u` is the default
port for its `scheme`.")
  (defn default-port? [u]
    (from (apply @(port u) &(fn [p] (= p (default-port @(scheme u))))) false))

  (private starts-with-byte?)
  (hidden starts-with-byte?)
  (defn starts-with-byte? [s c]
    (and (not (String.empty? s)) (= (char-at s 0) c)))

  (doc hostname "returns the host part of a URI `u`, unwrapping brackets for
IPv6 addresses.

```
(URI.hostname &(URI.parse \"http://[::1]/bar\"))   ; => ::1
(URI.hostname &(URI.parse \"http://foo.com/bar\")) ; => foo.com
```
")
  (defn hostname [u]
    (apply @(host u)
           &(fn [h]
             (let [n (length &h)]
               (if (and (> n 1)
                        (= (char-at &h 0) \[)
                        (= (char-at &h (Int.dec n)) \]))
                 (byte-slice &h 1 (Int.dec n))
                 h)))))

  (doc full-path "returns the full path of a URI `u`, i.e. the origin-form
request target: the path followed by `?` and the query when one is present.

The result always begins with `/`; a URI with no path (or an empty path)
yields `/`.

```
(def uri (URI.parse \"http://foo.com/posts?id=30&limit=5#time=1305298413\"))
(URI.full-path &uri) ; => /posts?id=30&limit=5
```
")
  (defn full-path [u]
    (let [q (from @(query u) @"")
          pth (from @(path u) @"")]
      (concat
        &[@(if (starts-with-byte? &pth \/) "" "/")
          pth
          (if (String.empty? &q) @"" @"?")
          q])))

  (doc absolute? "checks whether a URI `u` is absolute.")
  (defn absolute? [u] (just? (scheme u)))
  (doc relative? "checks whether a URI `u` is relative.")
  (defn relative? [u] (nothing? (scheme u)))

  (doc userinfo "returns the user-information component for a URI `u`, which
contains the provided username and password.

```
(def uri (URI.parse \"http://admin:password@foo.com\"))
(URI.userinfo &uri) ; => admin:password
```
")
  (defn userinfo [u]
    (concat
      &[(from @(user u) @"")
        @(if (just? (password u)) ":" "")
        (from @(password u) @"")]))

  (doc str "prints the URL `u` as idempotently as possible, i.e. as the parsed
string.

```
(def uri (URI.parse \"http://admin:password@foo.com\"))
(URI.str &uri) ; => \"http://admin:password@foo.com\"
```
")
  (defn str [u]
    (let [s @(scheme u)
          authority? (or (just? (host u)) (or (just? (user u)) (just? (port u))))
          usr @(user u)
          q @(query u)
          h @(host u)
          p @(port u)
          pth (from @(path u) @"")
          f @(fragment u)]
      (concat
        &[(from (apply s &(fn [s] (concat &[s @":"]))) @"")
          (from @(opaque u) @"")
          @(if authority? "//" "")
          (from (apply usr &(fn [usr] (concat &[(userinfo u) @"@"]))) @"")
          (from h @"")
          (from
            (apply p
                   &(fn [p] (if (default-port? u) @"" (concat &[@":" (str p)]))))
            @"")
          pth
          (from (apply q &(fn [q] (concat &[@"?" q]))) @"")
          (from (apply f &(fn [f] (concat &[@"#" f]))) @"")])))

  (doc = "is defined as the equality of all members of URIs `u1` and `u2`.")
  (sig = (Fn [(Ref URI) (Ref URI)] Bool))
  (implements = =)
  (defn = [u1 u2]
    (and (= (scheme u1) (scheme u2))
         (and (= (host u1) (host u2))
              (and (= (port u1) (port u2))
                   (and (= (path u1) (path u2))
                        (and (= (query u1) (query u2))
                             (and (= (user u1) (user u2))
                                  (and (= (password u1) (password u2))
                                       (and (= (fragment u1) (fragment u2))
                                            (= (opaque u1) (opaque u2)))))))))))

  ; the escape mechanisms are inspired by janet’s uri library, written by
  ; Andrew Chambers.

  (private decode-nibble)
  (hidden decode-nibble)
  (defn decode-nibble [c]
    (let [b (to-int c)]
      (cond
        (and (>= c \0) (<= c \9)) (- b 48)
        (and (>= c \a) (<= c \f)) (+ 10 (- b 97))
        (and (>= c \A) (<= c \F)) (+ 10 (- b 65))
        0)))

  (private unreserved?)
  (hidden unreserved?)
  (defn unreserved? [c]
    (or (and (>= c \a) (<= c \z))
        (or (and (>= c \A) (<= c \Z))
            (or (and (>= c \0) (<= c \9))
                (or (= c \-) (or (= c \_) (or (= c \.) (= c \~))))))))

  (private chartab)
  (hidden chartab)
  (def chartab [\0 \1 \2 \3 \4 \5 \6 \7 \8 \9 \A \B \C \D \E \F])

  (doc escape "URI escapes the string `s`, percent-encoding every byte that is
not an unreserved ASCII character. Multi-byte UTF-8 characters are encoded one
byte at a time, so the output is standard, interoperable percent-encoding.")
  (defn escape [s]
    (let-do [a []
             bs (String.to-bytes s)]
      (for [i 0 (Array.length &bs)]
        (let [n (Byte.to-int @(Array.unsafe-nth &bs i))
              c (from-int n)]
          (if (unreserved? c)
            (Array.push-back! &a c)
            (do
              (Array.push-back! &a \%)
              (Array.push-back! &a
                                @(Array.unsafe-nth &chartab
                                                   (bit-shift-right (bit-and n
                                                                             240)
                                                                    4)))
              (Array.push-back! &a @(Array.unsafe-nth &chartab (bit-and n 15)))))))
      (from-chars &a)))

  (private nibble-at)
  (hidden nibble-at)
  (defn nibble-at [bs i]
    (decode-nibble (from-int (Byte.to-int @(Array.unsafe-nth bs i)))))

  (private hex-byte?)
  (hidden hex-byte?)
  (defn hex-byte? [bs i]
    (let [c (from-int (Byte.to-int @(Array.unsafe-nth bs i)))]
      (or (and (>= c \0) (<= c \9))
          (or (and (>= c \a) (<= c \f)) (and (>= c \A) (<= c \F))))))

  (doc unescape
    "URI unescapes the string `s`, decoding each percent-triplet into
a single byte and copying all other bytes through verbatim. UTF-8 characters
that were percent-encoded byte by byte are therefore reassembled correctly.")
  (defn unescape [s]
    (let-do [a []
             bs (String.to-bytes s)
             n (Array.length &bs)]
      (for [i 0 n]
        (let [b @(Array.unsafe-nth &bs i)]
          ; 37b is the byte value of `%`; only decode a triplet when both
          ; following bytes are hex, otherwise copy the `%` through verbatim
          (if (and (= b 37b)
                   (and (< (+ i 2) n)
                        (and (hex-byte? &bs (inc i)) (hex-byte? &bs (+ i 2)))))
            (do
              (Array.push-back! &a
                                (Byte.from-int
                                  (bit-or
                                    (bit-shift-left (nibble-at &bs (inc i)) 4)
                                    (nibble-at &bs (+ i 2)))))
              (set! i (+ i 2)))
            (Array.push-back! &a b))))
      (String.from-bytes &a)))

  (defn- first-eq-index [s]
    (let-do [len (length s)
             i 0]
      (while (and (< i len) (/= (char-at s i) \=)) (set! i (inc i)))
      (if (= i len) (Nothing) (Just i))))

  (doc query-map-from-str "parses the querystring as a `Map` and returns it,
percent-decoding keys and values.

A parameter without a value, such as `flag` in `?flag`, is stored with an empty
string as its value. Empty segments, such as a trailing or doubled `&`, are
skipped. The result is wrapped in a `Result` for API compatibility.")
  (defn query-map-from-str [s]
    (if (= s "")
      (Success {})
      (Array.reduce
        &(fn [a x]
          (match a
            (Error err) (Error err)
            (Success m)
              (match (first-eq-index x)
                (Nothing)
                  (if (String.empty? x)
                    (Success m)
                    (let [k (unescape x)
                          v @""] (Success (Map.put m &k &v))))
                (Just i)
                  (let [k (unescape &(byte-slice x 0 i))
                        v (unescape &(byte-slice x (inc i) (length x)))]
                    (Success (Map.put m &k &v))))))
        (the (Result (Map String String) String) (Success {}))
        &(split-by s &[\&]))))

  (doc query-map "parses the querystring as a `Map` and returns it,
percent-decoding keys and values.

A parameter without a value, such as `flag` in `?flag`, is stored with an empty
string as its value. Empty segments, such as a trailing or doubled `&`, are
skipped. The result is wrapped in a `Result` for API compatibility.")
  (defn query-map [u]
    (match @(query u) (Nothing) (Success {}) (Just s) (query-map-from-str &s)))

  (defn- multimap-append [m k v]
    (match (Map.get-maybe &m &k)
      (Just existing) (Map.put m &k &(Array.push-back existing v))
      (Nothing) (Map.put m &k &[v])))

  (doc query-multimap-from-str "parses the querystring, collecting every value
for a key into an `Array` in encounter order, and returns the result,
percent-decoding keys and values.

Unlike `query-map-from-str`, repeated keys such as `a` in `a=1&a=2` are all kept
instead of overwritten. A parameter without a value, such as `flag` in `?flag`,
contributes a single empty-string value. Empty segments, such as a trailing or
doubled `&`, are skipped. The result is wrapped in a `Result` for API
compatibility.")
  (defn query-multimap-from-str [s]
    (if (= s "")
      (Success {})
      (Array.reduce
        &(fn [a x]
          (match a
            (Error err) (Error err)
            (Success m)
              (match (first-eq-index x)
                (Nothing)
                  (if (String.empty? x)
                    (Success m)
                    (Success (multimap-append m (unescape x) @"")))
                (Just i)
                  (Success
                    (multimap-append m
                                     (unescape &(byte-slice x 0 i))
                                     (unescape &(byte-slice x (inc i) (length x))))))))
        (the (Result (Map String (Array String)) String) (Success {}))
        &(split-by s &[\&]))))

  (doc query-multimap "parses the querystring, collecting every value for a key
into an `Array` in encounter order, and returns the result, percent-decoding
keys and values.

This mirrors `query-map` but preserves repeated keys; see
`query-multimap-from-str` for the exact edge-case semantics.")
  (defn query-multimap [u]
    (match @(query u)
      (Nothing) (Success {})
      (Just s) (query-multimap-from-str &s)))

  (doc query-values "returns every value supplied for the query parameter `k` in
URI `u`, in encounter order and percent-decoded. A key that is absent yields an
empty `Array`.")
  (defn query-values [u k]
    (match (query-multimap u)
      (Error _) []
      (Success m) (from (Map.get-maybe &m k) [])))

  (doc query-string-from-map "converts a `Map` of query parameters back into a
querystring, percent-encoding keys and values.

This is the inverse of `query-map-from-str`.")
  (defn query-string-from-map [m]
    (Map.kv-reduce
      &(fn [acc k v]
        (let [pair (concat &[(escape k) @"=" (escape v)])]
          (if (String.empty? &acc) pair (concat &[acc @"&" pair]))))
      @""
      m)))

(deftype URIParser [source String
                    offset Int])

(defmodule URIParser
  (use-all Char URI)

  (defn from-string [s] (init @s 0))
  (implements from-string URIParser.from-string)

  (defn c [p] (char-at (source p) @(offset p)))
  (defn nxt [p] (char-at (source p) (inc @(offset p))))
  (defn alpha? [p] (Char.alpha? (c p)))
  (defn num? [p] (Char.num? (c p)))
  (defn end? [p] (= (length (source p)) @(offset p)))
  (defn end-of-host? [p] (or (= (c p) \/) (= (c p) \?) (= (c p) \#)))
  (defn adv [p] (update-offset @p &inc))
  (defn bck [p] (update-offset @p &dec))
  (defn from [p frm] (byte-slice (source p) frm @(offset p)))

  ; f is taken by value: a borrowed closure's deleter is emitted after `break`
  (defn map-uri [res f]
    (match res (Result.Error e) (Error e) (Result.Success u) (Success (f u))))

  (defn parse-authority [p res] res)
  (defn parse-path [p res] res)

  (defn parse-fragment [po res]
    (let-do [p (adv &po)
             pref &p
             st @(offset &p)]
      (while true
        (if (end? &p)
          (do
            (set! res
                  (map-uri res
                           (fn [res] (set-fragment res (Just (from pref st))))))
            (break))
          (set! p (adv &p))))
      res))

  (defn parse-query [po res]
    (let-do [p (adv &po)
             pref &p
             st @(offset &p)]
      (while true
        (cond
          (end? &p)
            (do
              (set! res
                    (map-uri res
                             (fn [res] (set-query res (Just (from pref st))))))
              (break))
          (= (c &p) \#)
            (do
              (set! res
                    (parse-fragment @pref
                                    (map-uri res
                                             (fn [res]
                                               (set-query res
                                                          (Just (from pref st)))))))
              (break))
          (set! p (adv &p))))
      res))

  (defn parse-path [p res]
    (let-do [st @(offset &p)
             pref &p]
      (while true
        (if (end? &p)
          (do
            (set! res
                  (map-uri res (fn [res] (set-path res (Just (from pref st))))))
            (break))
          (case (c &p)
                \?
                (do
                  (set! res
                        (parse-query @&p
                                     (map-uri res
                                              (fn [res]
                                                (set-path res
                                                          (Just (from pref st)))))))
                  (break))
                \#
                (do
                  (set! res
                        (parse-fragment @&p
                                        (map-uri res
                                                 (fn [res]
                                                   (set-path res
                                                             (Just (from pref st)))))))
                  (break))
                (set! p (adv &p)))))
      res))

  (defn parse-opaque [po res]
    (let-do [p (adv &po)
             pref &p
             st @(offset &p)]
      (while true
        (cond
          (end? &p)
            (do
              (set! res
                    (map-uri res
                             (fn [res] (set-opaque res (Just (from pref st))))))
              (break))
          (or (= (c &p) \?) (= (c &p) \#))
            (do
              (set! res
                    (let [r (map-uri res
                                     (fn [res]
                                       (set-opaque res (Just (from pref st)))))]
                      (if (= (c &p) \?)
                        (parse-query @&p r)
                        (parse-fragment @&p r))))
              (break))
          (set! p (adv &p))))
      res))

  (defn parse-relative-slash [p res]
    (cond
      (end? &p) res
      (= (nxt &p) \/) (parse-authority (adv &p) res)
      (parse-path p res)))

  (defn parse-relative [p res]
    (if (end? &p)
      res
      (case (c &p)
            \/
            (parse-relative-slash p res)
            \?
            (parse-query p res)
            \#
            (parse-fragment p res)
            (parse-path p res))))

  (defn significant-digits [digits]
    (let-do [i 0
             n (length digits)
             stop (dec n)]
      (while (and (< i stop) (= (char-at digits i) \0)) (set! i (inc i)))
      (byte-slice digits i n)))

  (defn set-parsed-port [res digits off]
    (match res
      (Result.Error e) (Error e)
      (Result.Success u)
        (if (String.empty? digits)
          (Success (set-port u (Nothing)))
          (let [n (Maybe.from (Int.from-string digits) 0)]
            ; strtol overflows silently, so require a round-trip
            (if (= &(Int.str n) &(significant-digits digits))
              (Success (set-port u (Just n)))
              (Error (fmt "Invalid URI: bad port at character %d" off)))))))

  (defn parse-port [p res]
    (let-do [st @(offset &p)
             pref &p]
      ; `break` jumps over its own block’s cleanup, so bind strings before it.
      (while true
        (cond
          (end? &p)
            (do
              (set! res
                    (let [digits (from pref st)]
                      (set-parsed-port res &digits @(offset &p))))
              (break))
          (num? &p) (set! p (adv &p))
          (end-of-host? &p)
            (do
              ; like `parse-host`: only `/` introduces a path; `?`/`#` go to the
              ; query/fragment parsers so they are not swallowed as the path.
              (set! res
                    (let [r (set-parsed-port res &(from pref st) @(offset &p))]
                      (case (c &p)
                            \?
                            (parse-query @&p r)
                            \#
                            (parse-fragment @&p r)
                            (parse-path @&p r))))
              (break))
          (do
            (set! res
                  (let [msg (fmt "Invalid URI: bad port at character %d"
                                 @(offset &p))]
                    (Error msg)))
            (break))))
      res))

  (defn parse-host [p res]
    (if (= (c &p) \/)
      (parse-path p (map-uri res (fn [res] (set-host res (Just @"")))))
      (let-do [bracket-flag false
               st @(offset &p)
               pref &p]
        (while true
          (cond
            (end? &p)
              (do
                (set! res
                      (map-uri res
                               (fn [res] (set-host res (Just (from pref st))))))
                (break))
            (and (= (c &p) \:) (not bracket-flag))
              (do
                (set! res
                      (parse-port (adv &p)
                                  (map-uri res
                                           (fn [res]
                                             (set-host res (Just (from pref st)))))))
                (break))
            (end-of-host? &p)
              (do
                ; a `/`, `?`, or `#` ends the host, but only `/` introduces a
                ; path. `?` and `#` must go to the query/fragment parsers (which
                ; consume their own delimiter), mirroring `parse-relative`;
                ; routing them all to `parse-path` swallowed the query/fragment.
                (set! res
                      (let [r (map-uri res
                                       (fn [res]
                                         (set-host res (Just (from pref st)))))]
                        (case (c &p)
                              \?
                              (parse-query @&p r)
                              \#
                              (parse-fragment @&p r)
                              (parse-path @&p r))))
                (break))
            (do
              (when (= (c &p) \[) (set! bracket-flag true))
              (when (= (c &p) \]) (set! bracket-flag false))
              (set! p (adv &p)))))
        res)))

  (defn parse-userinfo [p res]
    (let-do [pw-flag false
             st @(offset &p)
             pref &p]
      (while true
        (cond
          (= (c &p) \@)
            (do
              (set! res
                    (parse-host (adv &p)
                                (map-uri res
                                         (fn [res]
                                           (if pw-flag
                                             (set-password res
                                                           (Just (from pref st)))
                                             (set-user res (Just (from pref st))))))))
              (break))
          (= (c &p) \:)
            (do
              (set! res
                    (map-uri res (fn [res] (set-user res (Just (from pref st))))))
              (set! pw-flag true)
              (set! p (adv &p))
              (set! st @(offset &p)))
          (set! p (adv &p))))
      res))

  (defn parse-authority [po res]
    (let-do [p (adv &po)
             st @(offset &p)]
      (while true
        (cond
          (end? &p) (do (set! res (parse-host (set-offset @&p st) res)) (break))
          (= (c &p) \@)
            (do (set! res (parse-userinfo (set-offset @&p st) res)) (break))
          (end-of-host? &p)
            (do (set! res (parse-host (set-offset @&p st) res)) (break))
          (set! p (adv &p))))
      res))

  (defn parse-path-or-authority [p res]
    (if (= (c &p) \/) (parse-authority p res) (parse-path (bck &p) res)))

  (defn parse-no-scheme [p res]
    (if (= (c &p) \#) (parse-fragment p res) (parse-relative p res)))

  (defn parse-scheme [p res]
    (let-do [st @(offset &p)
             pref &p]
      (while true
        (cond
          (or (alpha? &p) (num? &p) (= (c &p) \-) (= (c &p) \.) (= (c &p) \+))
            (set! p (adv &p))
          (= (c &p) \:)
            (do
              (set! res
                    (map-uri res
                             (fn [res] (set-scheme res (Just (from pref st))))))
              (if (= (nxt &p) \/)
                (do
                  (set! res
                        (parse-path-or-authority (update-offset @&p
                                                                &(fn [x] (+ x 2)))
                                                 res))
                  (break))
                (do (set! res (parse-opaque @&p res)) (break))))
          (do (set! res (parse-no-scheme (set-offset @&p 0) res)) (break))))
      res))

  (defn parse [p]
    (let [res (Success (zero))]
      (if (alpha? &p) (parse-scheme p res) (parse-no-scheme p res)))))

(defmodule URI
  (doc parse "Parses a URI from a string `s`.")
  (defn parse [s] (URIParser.parse (URIParser.from-string s))))

(defmodule URI
  (private pop-last)
  (hidden pop-last)
  (defn pop-last [output]
    (unless (Array.empty? output) (ignore (Array.pop-back! output))))

  (doc remove-dot-segments "normalizes a path by resolving `.` and `..` segments
following RFC 3986 section 5.2.4.

Runs in a single linear pass: a byte cursor walks the input once and output
segments are collected on a stack, so an `n`-segment path costs `O(n)` instead
of the quadratic slicing a literal transcription of the RFC would incur.")
  (defn remove-dot-segments [path]
    (let-do [n (length path)
             i 0
             output (the (Array String) [])]
      (while (< i n)
        (let [c0 (char-at path i)
              rem (- n i)]
          (cond
            ; A: leading "../" or "./" — drop
            (and (>= rem 3)
                 (= c0 \.)
                 (= (char-at path (+ i 1)) \.)
                 (= (char-at path (+ i 2)) \/))
            (set! i (+ i 3))
            (and (>= rem 2) (= c0 \.) (= (char-at path (+ i 1)) \/))
            (set! i (+ i 2))
            ; B: "/./" — collapse onto the leading "/"
            (and (>= rem 3)
                 (= c0 \/)
                 (= (char-at path (+ i 1)) \.)
                 (= (char-at path (+ i 2)) \/))
            (set! i (+ i 2))
            ; a trailing "/." contributes a lone "/"
            (and (= rem 2) (= c0 \/) (= (char-at path (+ i 1)) \.))
            (do (Array.push-back! &output @"/") (set! i n))
            ; C: "/../" — collapse to "/" and pop the last output segment
            (and (>= rem 4)
                 (= c0 \/)
                 (= (char-at path (+ i 1)) \.)
                 (= (char-at path (+ i 2)) \.)
                 (= (char-at path (+ i 3)) \/))
            (do (pop-last &output) (set! i (+ i 3)))
            ; a trailing "/.." pops the last segment, then contributes a "/"
            (and (= rem 3)
                 (= c0 \/)
                 (= (char-at path (+ i 1)) \.)
                 (= (char-at path (+ i 2)) \.))
            (do (pop-last &output) (Array.push-back! &output @"/") (set! i n))
            ; D: a bare "." or ".." — drop
            (or (and (= rem 1) (= c0 \.))
                (and (= rem 2) (= c0 \.) (= (char-at path (+ i 1)) \.)))
            (set! i n)
            ; E: move the next segment, with its leading "/" if any, to output
            (let-do [start (if (= c0 \/) (+ i 1) i)
                     j start]
              (while (and (< j n) (/= (char-at path j) \/)) (set! j (inc j)))
              (Array.push-back! &output (byte-slice path i j))
              (set! i j)))))
      (concat &output)))

  (private merge-paths)
  (hidden merge-paths)
  (defn merge-paths [base ref-path]
    (if (and (just? (host base)) (empty? &(from @(path base) @"")))
      (concat &[@"/" @ref-path])
      (let-do [base-path (from @(path base) (from @(opaque base) @""))
               prefix-len 0]
        (for [i 0 (length &base-path)]
          (when (= (char-at &base-path i) \/) (set! prefix-len (inc i))))
        (concat &[(byte-slice &base-path 0 prefix-len) @ref-path]))))

  (doc resolve "resolves a URI reference string `ref-str` against a base URI
`base`, following RFC 3986 section 5. Returns the resolved absolute URI, or an
error if the reference string cannot be parsed.

```
(def base (Result.unsafe-from-success (URI.parse \"http://a/b/c/d?q\")))
(URI.resolve &base \"../g\")   ; => http://a/b/g
(URI.resolve &base \"/g\")     ; => http://a/g
(URI.resolve &base \"?y\")     ; => http://a/b/c/d?y
```
")
  (sig resolve (Fn [(Ref URI) (Ref String)] (Result URI String)))
  (defn resolve [base ref-str]
    (match (URI.parse ref-str)
      (Error e) (Error e)
      (Success r)
        (let [ref-path-abs (starts-with-byte? ref-str \/)]
          (Success
            (cond
              (just? (scheme &r))
                (init @(scheme &r)
                      @(host &r)
                      @(port &r)
                      (apply @(path &r) &(fn [p] (remove-dot-segments &p)))
                      @(query &r)
                      @(user &r)
                      @(password &r)
                      @(fragment &r)
                      @(opaque &r))
              (just? (host &r))
                (init @(scheme base)
                      @(host &r)
                      @(port &r)
                      (apply @(path &r) &(fn [p] (remove-dot-segments &p)))
                      @(query &r)
                      @(user &r)
                      @(password &r)
                      @(fragment &r)
                      (Nothing))
              (and (empty? &(from @(path &r) @"")) (not ref-path-abs))
                (init @(scheme base)
                      @(host base)
                      @(port base)
                      @(path base)
                      (if (just? (query &r)) @(query &r) @(query base))
                      @(user base)
                      @(password base)
                      @(fragment &r)
                      @(opaque base))
              (let [r-path (from @(path &r) @"")
                    target-path (remove-dot-segments
                      &(if ref-path-abs @&r-path (merge-paths base &r-path)))]
                (init @(scheme base)
                      @(host base)
                      @(port base)
                      (Just target-path)
                      @(query &r)
                      @(user base)
                      @(password base)
                      @(fragment &r)
                      (Nothing)))))))))

(defmodule URI
  (private lower-byte)
  (hidden lower-byte)
  (defn lower-byte [b]
    (if (Char.upper-case? (from-int (Byte.to-int b))) (+ b 32b) b))

  (private upper-hex-byte)
  (hidden upper-hex-byte)
  (defn upper-hex-byte [b]
    (let [c (from-int (Byte.to-int b))]
      (if (and (>= c \a) (<= c \f)) (- b 32b) b)))

  (private lower-str)
  (hidden lower-str)
  (defn lower-str [s]
    (let-do [bs (String.to-bytes s)
             a []]
      (for [i 0 (Array.length &bs)]
        (Array.push-back! &a (lower-byte @(Array.unsafe-nth &bs i))))
      (String.from-bytes &a)))

  (doc normalize-pct "normalizes the percent-encoding in `s` per RFC 3986
section 6.2.2: percent-encoded octets of unreserved characters are decoded to
their literal form, and the hexadecimal digits of the remaining triplets are
upper-cased. When `lower?` is set, unencoded letters (and decoded unreserved
letters) are lower-cased, as required for the host component.")
  (private normalize-pct)
  (hidden normalize-pct)
  (defn normalize-pct [s lower?]
    (let-do [bs (String.to-bytes s)
             n (Array.length &bs)
             a []
             i 0]
      (while (< i n)
        (let [b @(Array.unsafe-nth &bs i)]
          (if (and (= b 37b)
                   (< (+ i 2) n)
                   (hex-byte? &bs (inc i))
                   (hex-byte? &bs (+ i 2)))
            (let-do [hi @(Array.unsafe-nth &bs (inc i))
                     lo @(Array.unsafe-nth &bs (+ i 2))
                     d (Byte.from-int
                       (bit-or
                         (bit-shift-left (nibble-at &bs (inc i)) 4)
                         (nibble-at &bs (+ i 2))))]
              (if (unreserved? (from-int (Byte.to-int d)))
                (Array.push-back! &a (if lower? (lower-byte d) d))
                (do
                  (Array.push-back! &a b)
                  (Array.push-back! &a (upper-hex-byte hi))
                  (Array.push-back! &a (upper-hex-byte lo))))
              (set! i (+ i 3)))
            (do
              (Array.push-back! &a (if lower? (lower-byte b) b))
              (set! i (inc i))))))
      (String.from-bytes &a)))

  (private normalized-port)
  (hidden normalized-port)
  (defn normalized-port [sch prt]
    (match-ref prt
      (Maybe.Nothing) (Maybe.Nothing)
      (Maybe.Just p)
        (match-ref sch
          (Maybe.Nothing) (Maybe.Just @p)
          (Maybe.Just s)
            (match (Map.get-maybe &default-ports s)
              (Maybe.Just dp) (if (= @p dp) (Maybe.Nothing) (Maybe.Just @p))
              (Maybe.Nothing) (Maybe.Just @p)))))

  (doc normalize "normalizes a URI `u` following RFC 3986 section 6.2, returning
an equivalent URI in a canonical form. This makes two URIs that denote the same
resource compare equal under `URI.=`.

The following transformations are applied:

- **Case normalization** (§6.2.2.1): the scheme and host are lower-cased, and
  the hexadecimal digits of percent-encoded triplets are upper-cased.
- **Percent-encoding normalization** (§6.2.2.2): percent-encoded octets that
  correspond to unreserved characters (`ALPHA` / `DIGIT` / `-` / `.` / `_` /
  `~`) are decoded to their literal form.
- **Path segment normalization** (§6.2.2.3): `.` and `..` segments are removed
  from the path.
- **Default-port removal** (§6.2.3): a port equal to the scheme’s default is
  dropped.

Case-sensitive components (userinfo, path, query, and fragment) keep their
case; only their percent-encoding is normalized.

Note: because `.` is unreserved, a percent-encoded dot (`%2E`) is decoded
(§6.2.2.2) and then resolved by dot-segment removal (§6.2.2.3), so
`/a/%2E%2E/b` normalizes to `/b`. An encoded `..` therefore collapses just
like a literal one, which callers using `normalize` for path-prefix
security checks should account for.

```
(URI.str &(URI.normalize &(Result.unsafe-from-success
  (URI.parse \"HTTP://User@Example.COM:80/%7Ejoe/./index.html\"))))
; => “http://User@example.com/~joe/index.html”
```
")
  (defn normalize [u]
    (let [sch (apply @(scheme u) &(fn [s] (lower-str &s)))
          prt (normalized-port &sch (port u))
          hst (apply @(host u) &(fn [h] (normalize-pct &h true)))
          usr (apply @(user u) &(fn [x] (normalize-pct &x false)))
          pwd (apply @(password u) &(fn [x] (normalize-pct &x false)))
          pth (apply @(path u)
                     &(fn [p] (remove-dot-segments &(normalize-pct &p false))))
          qry (apply @(query u) &(fn [x] (normalize-pct &x false)))
          frg (apply @(fragment u) &(fn [x] (normalize-pct &x false)))
          opq (apply @(opaque u) &(fn [x] (normalize-pct &x false)))]
      (init sch hst prt pth qry usr pwd frg opq))))

(defmodule URICopy (defn = [u1 u2] (URI.= &u1 &u2)))
(doc URI "is a `URI` datatype and parser for Carp.

## Installation

```clojure
(load \"git@github.com:carpentry-org/uri@0.5.1\")
```

## Usage

To get started, you’ll most probably want to parse a `URI` from a string. To do
so, you use `URI.parse`. This function will return a `URI` datatype for you to
work with, or an error type if the URI string was invalid.

If you have a URI value the simplest operation is probably converting the URI
back to a string using the `str` interface, which should be idempotent—i.e.
you’ll get the original URI back. Components are stored exactly as they were
written, so `path` keeps its leading `/`.

You can also ask the `URI` for its properties, like the scheme, the port, or the
URI parameters.

A more complete documentation can be found under [https://veitheller.de/uri/](https://veitheller.de/uri)!

## Acknowledgements

This datatype and parser was heavily inspired by the one in [the Crystal
standard library](https://github.com/crystal-lang/crystal/blob/master/src/uri.cr).
I cannot thank the people who worked on it enough; they saved me from going
through a lot of pain and suffering!")