Skip to content

Commit

Permalink
Add verbatim_query for extracting literal query string. Fixes mirage#57.
Browse files Browse the repository at this point in the history
  • Loading branch information
@dsheets
dsheets committed May 15, 2015
1 parent af31d7e commit aba103c
Show file tree
Hide file tree
Showing 4 changed files with 106 additions and 42 deletions.
2 changes: 2 additions & 0 deletions CHANGES
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,8 @@
* Uri_services now includes service aliases (e.g. www, www-http, http)
* Uri_services now includes chargen and git
* Add `Uri.canonicalize` for scheme-specific normalization (#70)
* Add `Uri.verbatim_query` to extract literal query string (#57)
* Add `Uri.equal`
* Add `Uri.user` and `Uri.password` accessors for subcomponents of userinfo (#62)
* Add `Uri.with_password` functional setter for password subcomponent of userinfo
* Fix file scheme host normalization bug which introduced empty host (#59)
Expand Down
98 changes: 67 additions & 31 deletions lib/uri.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -422,19 +422,28 @@ let encoded_of_path ?scheme = Path.encoded_of_path ?scheme
(* Query string handling, to and from an assoc list of key/values *)
module Query = struct

type t = (string * string list) list with sexp

let compare = compare_list (fun (k,vl) (k',vl') ->
match String.compare k k' with
| 0 -> compare_list String.compare vl vl'
| c -> c
)
type kv = (string * string list) list with sexp

type t =
| KV of kv
| Raw of string option * kv Lazy.t

let t_of_sexp sexp = KV (kv_of_sexp sexp)
let sexp_of_t = function Raw (_,lazy kv) | KV kv -> sexp_of_kv kv

let compare x y = match x, y with
| KV kvl, KV kvl'
| Raw (_, lazy kvl), KV kvl'
| KV kvl, Raw (_, lazy kvl') ->
compare_list (fun (k,vl) (k',vl') ->
match String.compare k k' with
| 0 -> compare_list String.compare vl vl'
| c -> c
) kvl kvl'
| Raw (raw,_), Raw (raw',_) -> compare_opt String.compare raw raw'

let find q k = try Some (List.assoc k q) with Not_found -> None

(* TODO: only make the query tuple parsing lazy and an additional
* record in Url.t ? *)

let split_query qs =
let els = Stringext.split ~on:'&' qs in
(** Replace a + in a query string with a space in-place *)
Expand Down Expand Up @@ -487,6 +496,12 @@ module Query = struct
) "," buf v)
) "&" buf l;
Buffer.contents buf

let of_raw qs =
let lazy_query = Lazy.from_fun (fun () -> query_of_encoded qs) in
Raw (Some qs, lazy_query)

let kv = function Raw (_, lazy kv) | KV kv -> kv
end

let query_of_encoded = Query.query_of_encoded
Expand All @@ -509,7 +524,7 @@ let empty = {
host = None;
port = None;
path = [];
query = [];
query = Query.Raw (None, Lazy.from_val []);
fragment = None;
}

Expand All @@ -532,6 +547,8 @@ let compare t t' =
| c -> c)
| c -> c)

let equal t t' = compare t t' = 0

let uncast_opt = function
| Some h -> Some (Pct.uncast_decoded h)
| None -> None
Expand Down Expand Up @@ -571,7 +588,10 @@ let make ?scheme ?userinfo ?host ?port ?path ?query ?fragment () =
| None, _ | Some _, "/"::_ | Some _, [] -> path
| Some _, _ -> "/"::path
in
let query = match query with |None -> [] |Some p -> p in
let query = match query with
| None -> Query.KV []
| Some p -> Query.KV p
in
let scheme = decode scheme in
normalize scheme
{ scheme; userinfo;
Expand Down Expand Up @@ -621,8 +641,8 @@ let of_string s =
in
let query =
match get_opt_encoded subs 7 with
| Some x -> Query.query_of_encoded (Pct.uncast_encoded x)
| None -> []
| Some x -> Query.of_raw (Pct.uncast_encoded x)
| None -> Query.Raw (None, Lazy.from_val [])
in
let fragment = get_opt subs 9 in
normalize scheme { scheme; userinfo; host; port; path; query; fragment }
Expand Down Expand Up @@ -685,11 +705,11 @@ let to_string uri =
Buffer.add_string buf
(Pct.uncast_encoded (encoded_of_path ?scheme uri.path))
);
(match uri.query with
|[] -> ()
|q ->
Buffer.add_char buf '?';
Buffer.add_string buf (encoded_of_query ?scheme q)
Query.(match uri.query with
| Raw (None,_) | KV [] -> ()
| Raw (_,lazy q) | KV q -> (* normalize e.g. percent capitalization *)
Buffer.add_char buf '?';
Buffer.add_string buf (encoded_of_query ?scheme q)
);
(match uri.fragment with
|None -> ()
Expand Down Expand Up @@ -772,30 +792,42 @@ let with_fragment uri =
|None -> { uri with fragment=None }
|Some frag -> { uri with fragment=Some (Pct.cast_decoded frag) }

let query uri = uri.query
let get_query_param' uri k = Query.find uri.query k
let query uri = Query.kv uri.query
let verbatim_query uri = Query.(match uri.query with
| Raw (qs,_) -> qs
| KV [] -> None
| KV kv -> Some (encoded_of_query ?scheme:(scheme uri) kv)
)
let get_query_param' uri k = Query.(find (kv uri.query) k)
let get_query_param uri k =
match get_query_param' uri k with
|None -> None
|Some v -> Some (String.concat "," v)

let with_query uri query = { uri with query=query }
let with_query uri query = { uri with query=Query.KV query }
let q_s q = List.map (fun (k,v) -> k,[v]) q
let with_query' uri query = with_query uri (q_s query)
let add_query_param uri p = { uri with query=p::uri.query }
let add_query_param' uri (k,v) = { uri with query=(k,[v])::uri.query }
let add_query_params uri ps = { uri with query=ps@uri.query }
let add_query_params' uri ps = { uri with query=(q_s ps)@uri.query }
let remove_query_param uri k = { uri with query=(List.filter (fun (k',_) -> k<>k') uri.query) }
let add_query_param uri p = Query.({ uri with query=KV (p::(kv uri.query)) })
let add_query_param' uri (k,v) =
Query.({ uri with query=KV ((k,[v])::(kv uri.query)) })
let add_query_params uri ps = Query.({ uri with query=KV (ps@(kv uri.query)) })
let add_query_params' uri ps =
Query.({ uri with query=KV ((q_s ps)@(kv uri.query)) })
let remove_query_param uri k = Query.(
{ uri with query=KV (List.filter (fun (k',_) -> k<>k') (kv uri.query)) }
)

(* Construct encoded path and query components *)
let path_and_query uri =
match (path uri), (query uri) with
|"", [] -> "/" (* TODO: What about same document? (/) *)
|"", q -> (* TODO: What about same document? (/) *)
Printf.sprintf "/?%s" (encoded_of_query q)
let scheme = uncast_opt uri.scheme in
Printf.sprintf "/?%s" (encoded_of_query ?scheme q)
|p, [] -> p
|p, q -> Printf.sprintf "%s?%s" p (encoded_of_query q)
|p, q ->
let scheme = uncast_opt uri.scheme in
Printf.sprintf "%s?%s" p (encoded_of_query ?scheme q)

(* TODO: functions to add and remove from a URI *)

Expand All @@ -815,8 +847,12 @@ let resolve schem base uri =
let uri = {uri with scheme=base.scheme; host=base.host; port=base.port} in
let path_str = path uri in
if path_str=""
then {uri with path=base.path;
query=if uri.query=[] then base.query else uri.query}
then { uri with
path=base.path;
query=match uri.query with
| Query.Raw (None,_) | Query.KV [] -> base.query
| _ -> uri.query
}
else if path_str.[0]='/'
then {uri with path=remove_dot_segments uri.path}
else {uri with
Expand Down
9 changes: 9 additions & 0 deletions lib/uri.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,9 @@ val empty : t
and finally fragment. Designed to produce a reasonable sort order. *)
val compare : t -> t -> int

(** [equal a b] is [compare a b = 0]. *)
val equal : t -> t -> bool

(** Percent-encode a string. The [scheme] argument defaults to 'http' and
the [component] argument defaults to `Path *)
val pct_encode : ?scheme:string -> ?component:component -> string -> string
Expand Down Expand Up @@ -100,6 +103,12 @@ val make : ?scheme:string -> ?userinfo:string -> ?host:string ->
(** Get a query string from a URI *)
val query : t -> (string * string list) list

(** Get a verbatim query string from a URI. If the provenance of the
URI is a string and its query component has not been updated, this
is the literal query string as parsed. Otherwise, this is the
composition of {!query} and {!encoded_of_query} *)
val verbatim_query : t -> string option

(** Make a percent-encoded query string from percent-decoded query tuple *)
val encoded_of_query : ?scheme:string -> (string * string list) list -> string

Expand Down
39 changes: 28 additions & 11 deletions lib_test/test_runner.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -382,10 +382,11 @@ let test_sexping =

let test_with_change = [
"test_with_scheme" >:: (fun () ->
let printer = Uri.to_string in
let uri = Uri.of_string "https://foo.bar/a/b/c" in
let uri2 = Uri.with_scheme uri (Some "https") in
let uri3 = Uri.with_scheme uri (Some "f o o") in
assert_equal uri uri2;
assert_equal ~printer uri uri2;
let exp = "f%20o%20o://foo.bar/a/b/c" in
let msg = sprintf "%s <> %s" (Uri.to_string uri3) exp in
assert_equal ~msg (Uri.to_string uri3) exp;
Expand All @@ -398,13 +399,13 @@ let test_with_change = [

let urn = Uri.of_string "urn:uuid:f81d4fae-7dec-11d0-a765-00a0c91e6bf6" in
let urn2= Uri.with_scheme urn (Some "urn") in
assert_equal urn urn2;
assert_equal ~printer urn urn2;

let urn_path =
Uri.with_path Uri.empty "uuid:f81d4fae-7dec-11d0-a765-00a0c91e6bf6"
in
let urn2 = Uri.with_scheme urn_path (Some "urn") in
assert_equal urn urn2
assert_equal ~printer urn urn2
);

"test_with_userinfo" >:: (fun () ->
Expand Down Expand Up @@ -503,43 +504,59 @@ let test_with_change = [
);

"test_with_query" >:: (fun () ->
let cmp = Uri.equal in
let test_with_query prefix =
let uri = Uri.of_string prefix in
let uri_empty = Uri.with_query uri [] in
let msg = prefix ^ " empty" in
assert_equal ~msg (Uri.of_string prefix) uri_empty;
assert_equal ~cmp ~msg (Uri.of_string prefix) uri_empty;
let uri_quest = Uri.with_query uri ["",[]] in
let uri_exp_s = prefix ^ "?" in
let uri_exp = Uri.of_string uri_exp_s in
let uri_exp_sexp = Sexplib.Sexp.to_string (Uri.sexp_of_t uri_exp) in
let uri_quest_sexp = Sexplib.Sexp.to_string (Uri.sexp_of_t uri_quest) in
let msg = sprintf "'%s' quest (%s <> %s)"
prefix uri_exp_sexp uri_quest_sexp in
assert_equal ~msg uri_exp uri_quest;
assert_equal ~cmp ~msg uri_exp uri_quest;
let uri_equal = Uri.with_query uri ["",[""]] in
let msg = prefix ^ " equal" in
assert_equal ~msg (Uri.of_string (prefix^"?=")) uri_equal;
assert_equal ~cmp ~msg (Uri.of_string (prefix^"?=")) uri_equal;
let uri_comma = Uri.with_query uri ["",["";""]] in
let msg = prefix ^ " comma" in
assert_equal ~msg (Uri.of_string (prefix^"?=,")) uri_comma;
assert_equal ~cmp ~msg (Uri.of_string (prefix^"?=,")) uri_comma;
let uri_empty = Uri.with_query' uri [] in
let msg = prefix ^ " empty'" in
assert_equal ~msg (Uri.of_string prefix) uri_empty;
assert_equal ~cmp ~msg (Uri.of_string prefix) uri_empty;
let uri_equal = Uri.with_query' uri ["",""] in
let msg = prefix ^" equal'" in
assert_equal ~msg (Uri.of_string (prefix^"?=")) uri_equal;
assert_equal ~cmp ~msg (Uri.of_string (prefix^"?=")) uri_equal;
in
test_with_query "";
test_with_query "//";
test_with_query "///";
let uri = Uri.of_string "//#" in
let uri_quest = Uri.with_query uri ["",[]] in
let msg = "?#" in
assert_equal ~msg (Uri.of_string "//?#") uri_quest;
assert_equal ~cmp ~msg (Uri.of_string "//?#") uri_quest;
let uri_equal = Uri.with_query' uri ["",""] in
let uri_exp_s = "//?=#" in
let msg = sprintf "%s <> %s" uri_exp_s (Uri.to_string uri_equal) in
assert_equal ~msg (Uri.of_string "//?=#") uri_equal;
assert_equal ~cmp ~msg (Uri.of_string "//?=#") uri_equal;

let printer x = x in
let uri_exp_s = "?name=3+4%20+%3a|" in
let uri = Uri.of_string uri_exp_s in
(match Uri.verbatim_query uri with
| None -> assert_failure "no query string! (1)"
| Some qs -> assert_equal uri_exp_s ("?"^qs)
);
assert_equal ~printer "?name=3%204%20%20:%7C" (Uri.to_string uri);
let uri_plus = Uri.add_query_param' uri ("time","now") in
let uri_exp_s = "?time=now&name=3%204%20%20:%7C" in
(match Uri.verbatim_query uri_plus with
| None -> assert_failure "no query string! (2)"
| Some qs -> assert_equal ~printer uri_exp_s ("?"^qs)
);
);

"test_with_fragment" >:: (fun () ->
Expand Down

0 comments on commit aba103c

Please sign in to comment.