Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Patch ocaml-uri to fix IPv6 uri parsing #1

Merged
merged 1 commit into from
Jul 18, 2023
Merged

Patch ocaml-uri to fix IPv6 uri parsing #1

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
381 changes: 381 additions & 0 deletions SOURCES/xs-opam-repo-6.66.0-fix-ipv6-uri.XCP-ng.patch
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,381 @@
Adaptation of https://github.com/mirage/ocaml-uri/pull/169 to this version of the code.

diff --git c/packages/upstream/uri.4.2.0/files/fix-ipv6-uri-parsing.XCP-ng.patch w/packages/upstream/uri.4.2.0/files/fix-ipv6-uri-parsing.XCP-ng.patch
benjamreis marked this conversation as resolved.
Show resolved Hide resolved
new file mode 100644
index 00000000..0cd95cca
--- /dev/null
+++ w/packages/upstream/uri.4.2.0/files/fix-ipv6-uri-parsing.XCP-ng.patch
@@ -0,0 +1,361 @@
+diff --git i/lib/uri.ml w/lib/uri.ml
+index 7b5af34..38b22e7 100644
+--- i/lib/uri.ml
++++ w/lib/uri.ml
+@@ -80,7 +80,7 @@ type safe_chars = bool array
+
+ module type Scheme = sig
+ val safe_chars_for_component : component -> safe_chars
+- val normalize_host : string option -> string option
++ val normalize_host : string -> string
+ val canonicalize_port : int option -> int option
+ val canonicalize_path : string list -> string list
+ end
+@@ -186,9 +186,7 @@ end
+ module Http : Scheme = struct
+ include Generic
+
+- let normalize_host = function
+- | Some hs -> Some (String.lowercase_ascii hs)
+- | None -> None
++ let normalize_host hs = String.lowercase_ascii hs
+
+ let canonicalize_port = function
+ | None -> None
+@@ -212,11 +210,9 @@ end
+ module File : Scheme = struct
+ include Generic
+
+- let normalize_host = function
+- | Some hs ->
+- let hs = String.lowercase_ascii hs in
+- if hs="localhost" then Some "" else Some hs
+- | None -> None
++ let normalize_host hs =
++ let hs = String.lowercase_ascii hs in
++ if hs="localhost" then "" else hs
+ end
+
+ module Urn : Scheme = struct
+@@ -542,7 +538,9 @@ let encoded_of_query ?scheme = Query.encoded_of_query ?scheme
+ type t = {
+ scheme: Pct.decoded option;
+ userinfo: Userinfo.t option;
+- host: Pct.decoded option;
++ host: [ `Ipv4_literal of string
++ | `Ipv6_literal of string
++ | `Host of Pct.decoded] option ;
+ port: int option;
+ path: Path.t;
+ query: Query.t;
+@@ -561,8 +559,16 @@ let empty = {
+
+ let compare_decoded = Pct.unlift_decoded2 String.compare
+ let compare_decoded_opt = compare_opt compare_decoded
++let compare_host h1 h2 =
++ match h1, h2 with
++ | `Ipv4_literal ip1, `Ipv4_literal ip2 -> String.compare ip1 ip2
++ | `Ipv6_literal ip1, `Ipv6_literal ip2 -> String.compare ip1 ip2
++ | `Host h1, `Host h2 -> compare_decoded h1 h2
++ | _ -> -1
++let compare_host_opt = compare_opt compare_host
++
+ let compare t t' =
+- (match compare_decoded_opt t.host t'.host with
++ (match compare_host_opt t.host t'.host with
+ | 0 -> (match compare_decoded_opt t.scheme t'.scheme with
+ | 0 -> (match compare_opt (fun p p' ->
+ if p < p' then -1 else if p > p' then 1 else 0
+@@ -584,9 +590,6 @@ let uncast_opt = function
+ | Some h -> Some (Pct.uncast_decoded h)
+ | None -> None
+
+-let cast_opt = function
+- | Some h -> Some (Pct.cast_decoded h)
+- | None -> None
+
+ let normalize schem uri =
+ let module Scheme =
+@@ -596,38 +599,16 @@ let normalize schem uri =
+ | None -> None
+ in {uri with
+ scheme=dob String.lowercase_ascii uri.scheme;
+- host=cast_opt (Scheme.normalize_host (uncast_opt uri.host))
++ host= match uri.host with
++ | Some (`Ipv4_literal host) ->
++ Some (`Ipv4_literal (Scheme.normalize_host host))
++ | Some (`Ipv6_literal host) ->
++ Some (`Ipv6_literal (Scheme.normalize_host host))
++ | Some (`Host host) ->
++ Some (`Host (Pct.cast_decoded (Scheme.normalize_host (Pct.uncast_decoded host))))
++ | None -> None
+ }
+
+-(* Make a URI record. This is a bit more inefficient than it needs to be due to the
+- * casting/uncasting (which isn't fully identity due to the option box), but it is
+- * no big deal for now.
+-*)
+-let make ?scheme ?userinfo ?host ?port ?path ?query ?fragment () =
+- let decode = function
+- |Some x -> Some (Pct.cast_decoded x) |None -> None in
+- let host = match userinfo, host, port with
+- | _, Some _, _ | None, None, None -> host
+- | Some _, None, _ | _, None, Some _ -> Some ""
+- in
+- let userinfo = match userinfo with
+- | None -> None | Some u -> Some (userinfo_of_encoded u) in
+- let path = match path with
+- |None -> [] | Some p ->
+- let path = path_of_encoded p in
+- match host, path with
+- | None, _ | Some _, "/"::_ | Some _, [] -> path
+- | Some _, _ -> "/"::path
+- in
+- let query = match query with
+- | None -> Query.KV []
+- | Some p -> Query.KV p
+- in
+- let scheme = decode scheme in
+- normalize scheme
+- { scheme; userinfo;
+- host=decode host; port; path; query; fragment=decode fragment }
+-
+ (** Convert a URI structure into a percent-encoded string
+ <http://tools.ietf.org/html/rfc3986#section-5.3>
+ *)
+@@ -659,8 +640,13 @@ let to_string ?(pct_encoder=pct_encoder ()) uri =
+ );
+ (match uri.host with
+ |None -> ()
+- |Some host ->
++ |Some (`Host host) ->
+ add_pct_string ~component:pct_encoder.host host;
++ |Some (`Ipv4_literal host) -> Buffer.add_string buf host
++ |Some (`Ipv6_literal host) ->
++ Buffer.add_char buf '[';
++ Buffer.add_string buf host;
++ Buffer.add_char buf ']'
+ );
+ (match uri.port with
+ |None -> ()
+@@ -707,11 +693,11 @@ let with_scheme uri =
+ |Some scheme -> { uri with scheme=Some (Pct.cast_decoded scheme) }
+ |None -> { uri with scheme=None }
+
+-let host uri = get_decoded_opt uri.host
+-let with_host uri =
+- function
+- |Some host -> { uri with host=Some (Pct.cast_decoded host) }
+- |None -> { uri with host=None }
++let host uri =
++ match uri.host with
++ | None -> None
++ | Some (`Ipv4_literal h | `Ipv6_literal h) -> Some h
++ | Some (`Host h) -> Some (Pct.uncast_decoded h)
+
+ let host_with_default ?(default="localhost") uri =
+ match host uri with
+@@ -729,7 +715,7 @@ let with_userinfo uri userinfo =
+ | None -> None
+ in
+ match host uri with
+- | None -> { uri with host=Some (Pct.cast_decoded ""); userinfo=userinfo }
++ | None -> { uri with host=Some (`Host (Pct.cast_decoded "")); userinfo=userinfo }
+ | Some _ -> { uri with userinfo=userinfo }
+
+ let user uri = match uri.userinfo with
+@@ -741,7 +727,7 @@ let password uri = match uri.userinfo with
+ | Some (_, Some pass) -> Some pass
+ let with_password uri password =
+ let result userinfo = match host uri with
+- | None -> { uri with host=Some (Pct.cast_decoded ""); userinfo=userinfo }
++ | None -> { uri with host=Some (`Host (Pct.cast_decoded "")); userinfo=userinfo }
+ | Some _ -> { uri with userinfo=userinfo }
+ in
+ match uri.userinfo, password with
+@@ -756,7 +742,7 @@ let with_port uri port =
+ | None -> begin
+ match port with
+ | None -> { uri with host=None; port=None }
+- | Some _ -> { uri with host=Some (Pct.cast_decoded ""); port=port }
++ | Some _ -> { uri with host=Some (`Host (Pct.cast_decoded "")); port=port }
+ end
+
+ (* Return the path component *)
+@@ -800,29 +786,6 @@ let remove_query_param uri k = Query.(
+ { uri with query=KV (List.filter (fun (k',_) -> k<>k') (kv uri.query)) }
+ )
+
+-let with_uri ?scheme ?userinfo ?host ?port ?path ?query ?fragment uri =
+- let with_path_opt u o =
+- match o with
+- | None -> with_path u ""
+- | Some p -> with_path u p
+- in
+- let with_query_opt u o =
+- match o with
+- | None -> with_query u []
+- | Some q -> with_query u q
+- in
+- let with_ f o u =
+- match o with
+- | None -> u
+- | Some x -> f u x
+- in
+- with_ with_scheme scheme uri
+- |> with_ with_userinfo userinfo
+- |> with_ with_host host
+- |> with_ with_port port
+- |> with_ with_path_opt path
+- |> with_ with_query_opt query
+- |> with_ with_fragment fragment
+
+ (* Construct encoded path and query components *)
+ let path_and_query uri =
+@@ -986,12 +949,7 @@ module Parser = struct
+ lift format_addr (c_colon *> c_colon *> double_colon 0 <|> part 0)
+
+ let ipv6_address =
+- lift3
+- (fun lb ip rb ->
+- String.concat "" [ string_of_char lb; ip; string_of_char rb ])
+- (char '[')
+- ipv6
+- (char ']')
++ (char '[') *> ipv6 <* (char ']')
+
+ let pct_encoded =
+ lift2
+@@ -1025,10 +983,12 @@ module Parser = struct
+ ]))
+
+ let host =
+- lift
+- (fun s -> Pct.decode (Pct.cast_encoded s))
+- (choice
+- [ reg_name; ipv4_address; ipv6_address (* | ipv4_literal TODO *) ])
++ choice
++ [ ipv4_address >>| (fun h -> `Ipv4_literal h)
++ ; ipv6_address >>| (fun h -> `Ipv6_literal h)
++ ; reg_name >>| (fun s -> `Host (Pct.decode (Pct.cast_encoded s)))
++ (* ipv4_literal TODO *)
++ ]
+
+ let userinfo =
+ lift
+@@ -1102,6 +1062,78 @@ module Parser = struct
+ empty
+ end
+
++let decode_host host =
++ match Angstrom.parse_string ~consume:All Parser.host host with
++ | Ok parsed -> parsed
++ | Error _ ->
++ match Angstrom.parse_string ~consume:All Parser.ipv6 host with
++ | Ok parsed -> (`Ipv6_literal parsed)
++ | Error _ -> (`Host (Pct.cast_decoded host))
++
++(* Make a URI record. This is a bit more inefficient than it needs to be due to the
++ * casting/uncasting (which isn't fully identity due to the option box), but it is
++ * no big deal for now.
++*)
++let make ?scheme ?userinfo ?host ?port ?path ?query ?fragment () =
++ let decode = function
++ |Some x -> Some (Pct.cast_decoded x) |None -> None in
++ let host = match userinfo, host, port with
++ | _, Some _, _ | None, None, None -> host
++ | Some _, None, _ | _, None, Some _ -> Some ""
++ in
++ let userinfo = match userinfo with
++ | None -> None | Some u -> Some (userinfo_of_encoded u) in
++ let path = match path with
++ |None -> [] | Some p ->
++ let path = path_of_encoded p in
++ match host, path with
++ | None, _ | Some _, "/"::_ | Some _, [] -> path
++ | Some _, _ -> "/"::path
++ in
++ let query = match query with
++ | None -> Query.KV []
++ | Some p -> Query.KV p
++ in
++ let scheme = decode scheme in
++ normalize scheme
++ { scheme; userinfo;
++ host =
++ (match host with
++ | Some host -> Some (decode_host host)
++ | None -> None);
++ port; path; query; fragment=decode fragment }
++
++let with_host uri host =
++ { uri with
++ host = (match host with
++ | Some host -> Some (decode_host host)
++ | None -> None)
++ }
++
++let with_uri ?scheme ?userinfo ?host ?port ?path ?query ?fragment uri =
++ let with_path_opt u o =
++ match o with
++ | None -> with_path u ""
++ | Some p -> with_path u p
++ in
++ let with_query_opt u o =
++ match o with
++ | None -> with_query u []
++ | Some q -> with_query u q
++ in
++ let with_ f o u =
++ match o with
++ | None -> u
++ | Some x -> f u x
++ in
++ with_ with_scheme scheme uri
++ |> with_ with_userinfo userinfo
++ |> with_ with_host host
++ |> with_ with_port port
++ |> with_ with_path_opt path
++ |> with_ with_query_opt query
++ |> with_ with_fragment fragment
++
+ let of_string s =
+ (* To preserve the old regex parser's behavior, we only parse a prefix, and
+ * stop whenever we can't parse more. *)
+diff --git i/lib_test/test_runner.ml w/lib_test/test_runner.ml
+index a8ed8e7..90ca5ad 100644
+--- i/lib_test/test_runner.ml
++++ w/lib_test/test_runner.ml
+@@ -59,9 +59,9 @@ let uri_encodes = [
+ "/wh/at/ev/er", (Uri.make ~path:"/wh/at/ev/er" ());
+ "/wh/at!/ev%20/er", (Uri.make ~path:"/wh/at!/ev /er" ());
+ (* IPv6 literal *)
+- "http://%5Bdead%3Abeef%3A%3Adead%3A0%3Abeaf%5D",
++ "http://[dead%3Abeef%3A%3Adead%3A0%3Abeaf]",
+ (Uri.make ~scheme:"http" ~host:"[dead:beef::dead:0:beaf]" ());
+- "http://user:pass@%5B2001%3A41d1%3Afe67%3A500%3A227%3Ac6ff%3Afe5a%3Aefa0%5D:6789/wh/at/ever?foo=1&bar=5#5",
++ "http://user:pass@[2001%3A41d1%3Afe67%3A500%3A227%3Ac6ff%3Afe5a%3Aefa0]:6789/wh/at/ever?foo=1&bar=5#5",
+ (Uri.make ~scheme:"http" ~userinfo:"user:pass" ~host:"[2001:41d1:fe67:500:227:c6ff:fe5a:efa0]"
+ ~port:6789 ~path:"/wh/at/ever" ~query:["foo",["1"];"bar",["5"]] ~fragment:"5" ());
+ (* IPv6 literal with zone id *)
+@@ -338,6 +338,7 @@ let generic_uri_norm = [
+ "//colon%[email protected]/",
+ "//colon%[email protected]/";
+ "foo+bar%3a", "./foo+bar:";
++ "http://[2001:DB8:1234:5678:90ab:cdef::0123]/%68%65%6c%6c%6f", "http://[2001:db8:1234:5678:90ab:cdef::0123]/hello";
+ (let p_q = "/foo%20bar/" in
+ p_q, Uri.(path_and_query (of_string p_q)));
+ ]
+@@ -646,8 +647,10 @@ let with_uri =
+ Uri.with_uri ~query:None base, "scheme://user:pass@host:0/path#fragment";
+ Uri.with_uri ~query:(Some ["new", ["a"]]) base, "scheme://user:pass@host:0/path?new=a#fragment";
+ Uri.with_uri ~fragment:None base, "scheme://user:pass@host:0/path?query=arg";
+- Uri.with_uri ~fragment:(Some "new") base, "scheme://user:pass@host:0/path?query=arg#new"]
+-
++ Uri.with_uri ~fragment:(Some "new") base, "scheme://user:pass@host:0/path?query=arg#new";
++ Uri.with_uri ~host:(Some "2001:DB8:1234:5678:90ab:cdef::0123") base,
++ "scheme://user:pass@[2001:DB8:1234:5678:90ab:cdef::0123]:0/path?query=arg#fragment"
++ ]
+ let test_with_uri =
+ List.map (fun (input, output) ->
+ input >:: (fun () ->
diff --git c/packages/upstream/uri.4.2.0/opam w/packages/upstream/uri.4.2.0/opam
index 196e5622..58140da6 100644
--- c/packages/upstream/uri.4.2.0/opam
+++ w/packages/upstream/uri.4.2.0/opam
@@ -25,6 +25,7 @@ build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
+patches: "fix-ipv6-uri-parsing.XCP-ng.patch"
dev-repo: "git+https://github.com/mirage/ocaml-uri.git"
url {
src:
Loading