Merge pull request #5877 from last-genius/private/asultanov/uri-path

CP-50181: Percent decode all Uri paths before using them

ocaml/libs/http-lib/http.ml

@@ -923,7 +923,7 @@ module Url = struct
       in
       let data =
         {
-          uri= (match Uri.path uri with "" -> "/" | path -> path)
+          uri= (match Uri.path_unencoded uri with "" -> "/" | path -> path)
         ; query_params= Uri.query uri |> List.map query
         }
       in
@@ -936,7 +936,7 @@ module Url = struct
       | Some "https" ->
           (scheme ~ssl:true, data)
       | Some "file" ->
-          let scheme = File {path= Uri.path uri} in
+          let scheme = File {path= Uri.path_unencoded uri} in
           (scheme, {data with uri= "/"})
       | _ ->
           failwith "unsupported URI scheme"

ocaml/libs/http-lib/http_svr.ml

@@ -374,7 +374,7 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio
                  (* Request-Line   = Method SP Request-URI SP HTTP-Version CRLF *)
                  let uri_t = Uri.of_string uri in
                  if uri_t = Uri.empty then raise Http_parse_failure ;
-                 let uri = Uri.path uri_t |> Uri.pct_decode in
+                 let uri = Uri.path_unencoded uri_t in
                  let query = Uri.query uri_t |> kvlist_flatten in
                  let m = Http.method_t_of_string meth in
                  let version =

ocaml/libs/open-uri/open_uri.ml

@@ -74,7 +74,7 @@ let with_open_uri ?verify_cert uri f =
             )
     )
   | Some "file" ->
-      let filename = Uri.path_and_query uri in
+      let filename = Uri.path_and_query uri |> Uri.pct_decode in
       let sockaddr = Unix.ADDR_UNIX filename in
       let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
       finally

ocaml/message-switch/switch/switch_main.ml

@@ -222,7 +222,7 @@ let make_server config trace_config =
     let open Message_switch_core.Protocol in
     Cohttp_lwt.Body.to_string body >>= fun body ->
     let uri = Cohttp.Request.uri req in
-    let path = Uri.path uri in
+    let path = Uri.path_unencoded uri in
     match In.of_request body (Cohttp.Request.meth req) path with
     | None ->
         error "<- [unparsable request; path = %s; body = %s]" path

ocaml/nbd/src/main.ml

@@ -59,7 +59,7 @@ let handle_connection fd tls_role =
     >>= fun session_id -> f uri rpc session_id
   in
   let serve t uri rpc session_id =
-    let path = Uri.path uri in
+    let path = Uri.path_unencoded uri in
     (* note preceeding / *)
     let vdi_uuid =
       if path <> "" then String.sub path 1 (String.length path - 1) else path

ocaml/vhd-tool/src/impl.ml

@@ -787,9 +787,9 @@ let endpoint_of_string = function
           if he = [] then raise Not_found ;
           return (Sockaddr (List.hd he).Unix.ai_addr)
       | Some "unix", _ ->
-          return (Sockaddr (Lwt_unix.ADDR_UNIX (Uri.path uri')))
+          return (Sockaddr (Lwt_unix.ADDR_UNIX (Uri.path_unencoded uri')))
       | Some "file", _ ->
-          return (File (Uri.path uri'))
+          return (File (Uri.path_unencoded uri'))
       | Some "http", _ ->
           return (Http uri')
       | Some "https", _ ->

ocaml/xapi-guard/lib/server_interface.ml

@@ -77,9 +77,8 @@ let serve_forever_lwt path callback =
   Lwt.return cleanup
 
 let serve_forever_lwt_callback rpc_fn path _ req body =
-  let uri = Cohttp.Request.uri req in
-  match (Cohttp.Request.meth req, Uri.path uri) with
-  | `POST, _ ->
+  match Cohttp.Request.meth req with
+  | `POST ->
       let* body = Cohttp_lwt.Body.to_string body in
       let* response =
         Xapi_guard.Dorpc.wrap_rpc err (fun () ->
@@ -91,7 +90,7 @@ let serve_forever_lwt_callback rpc_fn path _ req body =
       in
       let body = response |> Xmlrpc.string_of_response in
       Cohttp_lwt_unix.Server.respond_string ~status:`OK ~body ()
-  | _, _ ->
+  | _ ->
       let body =
         "Not allowed"
         |> Rpc.rpc_of_string
@@ -142,7 +141,7 @@ let serve_forever_lwt_callback_vtpm ~cache mutex (read, persist) vm_uuid _ req
   *)
   Lwt_mutex.with_lock mutex @@ fun () ->
   (* TODO: some logging *)
-  match (Cohttp.Request.meth req, Uri.path uri) with
+  match (Cohttp.Request.meth req, Uri.path_unencoded uri) with
   | `GET, path when path <> "/" ->
       let key = Tpm.key_of_swtpm path in
       let* body = read (vm_uuid, timestamp, key) in

ocaml/xapi-idl/lib/xcp_service.ml

@@ -501,8 +501,8 @@ let http_handler call_of_string string_of_response process s =
   | `Invalid x ->
       debug "Failed to read HTTP request. Got: '%s'" x
   | `Ok req -> (
-    match (Cohttp.Request.meth req, Uri.path (Cohttp.Request.uri req)) with
-    | `POST, _ -> (
+    match Cohttp.Request.meth req with
+    | `POST -> (
         let headers = Cohttp.Request.headers req in
         match Cohttp.Header.get headers "content-length" with
         | None ->
@@ -535,7 +535,7 @@ let http_handler call_of_string string_of_response process s =
               (fun t -> Response.write_body t response_txt)
               response oc
       )
-    | _, _ ->
+    | _ ->
         let content_length = 0 in
         let headers =
           Cohttp.Header.of_list

ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml

@@ -333,7 +333,7 @@ let vg_of_uri uri =
   let uri' = Uri.of_string uri in
   match Uri.scheme uri' with
   | Some "vg" ->
-      let vg = Uri.path uri' in
+      let vg = Uri.path_unencoded uri' in
       if vg <> "" && vg.[0] = '/' then
         String.sub vg 1 (String.length vg - 1)
       else

ocaml/xapi-storage-script/main.ml

@@ -977,7 +977,7 @@ let bind ~volume_script_dir =
             let uri = Uri.of_string datasource in
             match Uri.scheme uri with
             | Some "xeno+shm" -> (
-                let uid = Uri.path uri in
+                let uid = Uri.path_unencoded uri in
                 let uid =
                   if String.length uid > 1 then
                     String.sub uid ~pos:1 ~len:(String.length uid - 1)
@@ -1024,7 +1024,7 @@ let bind ~volume_script_dir =
                 let uri = Uri.of_string datasource in
                 match Uri.scheme uri with
                 | Some "xeno+shm" -> (
-                    let uid = Uri.path uri in
+                    let uid = Uri.path_unencoded uri in
                     let uid =
                       if String.length uid > 1 then
                         String.sub uid ~pos:1 ~len:(String.length uid - 1)

ocaml/xe-cli/newcli.ml

@@ -135,7 +135,7 @@ let parse_url url =
     let ( let* ) = Option.bind in
     let* scheme = Uri.scheme uri in
     let* host = Uri.host uri in
-    let path = Uri.path_and_query uri in
+    let path = Uri.path_and_query uri |> Uri.pct_decode in
     Some (scheme, host, path)
   in
   match parse (Uri.of_string url) with

ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml

@@ -66,7 +66,7 @@ module Lwt_unix_IO = struct
   let open_connection uri =
     ( match Uri.scheme uri with
     | Some "file" ->
-        return (Unix.PF_UNIX, Unix.ADDR_UNIX (Uri.path uri), false)
+        return (Unix.PF_UNIX, Unix.ADDR_UNIX (Uri.path_unencoded uri), false)
     | Some "http+unix" ->
         return (Unix.PF_UNIX, Unix.ADDR_UNIX (Uri.host_with_default uri), false)
     | Some "http" | Some "https" ->

ocaml/xenopsd/lib/xenops_server.ml

@@ -2629,7 +2629,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle)
       let make_url snippet id_str =
         Uri.make ?scheme:(Uri.scheme url) ?host:(Uri.host url)
           ?port:(Uri.port url)
-          ~path:(Uri.path url ^ snippet ^ id_str)
+          ~path:(Uri.path_unencoded url ^ snippet ^ id_str)
           ~query:(Uri.query url) ()
       in
       (* CA-78365: set the memory dynamic range to a single value to stop
@@ -3630,7 +3630,7 @@ module VM = struct
         debug "traceparent: %s" (Option.value ~default:"(none)" traceparent) ;
         let id, final_id =
           (* The URI is /service/xenops/memory/id *)
-          let bits = Astring.String.cuts ~sep:"/" (Uri.path uri) in
+          let bits = Astring.String.cuts ~sep:"/" (Uri.path_unencoded uri) in
           let id = bits |> List.rev |> List.hd in
           let final_id =
             match List.assoc_opt "final_id" cookies with
@@ -3673,7 +3673,7 @@ module VM = struct
       (fun () ->
         let vgpu_id =
           (* The URI is /service/xenops/migrate-vgpu/id *)
-          let path = Uri.path uri in
+          let path = Uri.path_unencoded uri in
           let bits = Astring.String.cut ~sep:"/" ~rev:true path in
           let vgpu_id_str =
             match bits with
@@ -3736,7 +3736,7 @@ module VM = struct
     let dbg = List.assoc "dbg" cookies in
     Debug.with_thread_associated dbg
       (fun () ->
-        let vm = basename (Uri.path uri) in
+        let vm = basename (Uri.path_unencoded uri) in
         match context.transferred_fd with
         | Some fd ->
             debug "VM.receive_mem: passed fd %d" (Obj.magic fd) ;