CA-406403: Do not return HTTP 500 when Accept header can't be parsed

/update_rrds returned a 500 HTTP code in some cases where the accept header was
invalid. Now these cases are treated in the same way as a lack of Accept
header.

Signed-off-by: Pau Ruiz Safont <[email protected]>

Author: psafont

ocaml/libs/http-lib/http.mli

@@ -55,6 +55,9 @@ module Accept : sig
   val equal : t -> t -> bool
 
   val of_string : string -> t list
+  (** [of_string accept_hdr] Returns a list of weighted media types represented
+      by [accept_hdr]. If [accept_hdr can't be parsed, raises [Parse_failure]].
+      *)
 
   val to_string : t -> string
 

ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml

@@ -18,20 +18,17 @@ let content_xml = content_hdr_of_mime mime_xml
 
 let client_prefers_json req =
   let module Accept = Http.Accept in
-  match req.Http.Request.accept with
-  | None ->
-      List.mem_assoc "json" req.Http.Request.query
-  | Some accept -> (
-      let accepted = Accept.of_string accept in
-      let negotiated = Accept.preferred ~from:[mime_json; mime_xml] accepted in
-      match negotiated with
-      | x :: _ when String.equal x mime_json ->
-          true
-      | [] ->
-          List.mem_assoc "json" req.Http.Request.query
-      | _ ->
-          false
-    )
+  let ( let* ) = Option.bind in
+  let map_head f lst = List.nth_opt lst 0 |> Option.map f in
+  let prefers =
+    let* accept = req.Http.Request.accept in
+    let* accepted =
+      try Some (Accept.of_string accept) with Accept.Parse_failure _ -> None
+    in
+    let negotiated = Accept.preferred ~from:[mime_json; mime_xml] accepted in
+    map_head (fun x -> String.equal x mime_json) negotiated
+  in
+  Option.value ~default:(List.mem_assoc "json" req.Http.Request.query) prefers
 
 let content_type json = if json then content_json else content_xml