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

/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.

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/libs/http-lib/http_test.ml

@@ -24,6 +24,15 @@ module Accept = struct
     let actual = Accept.of_string data in
     Alcotest.(check @@ list accept) data expected actual
 
+  let test_invalid () =
+    let data = "text/html, image/gif, image/jpeg, ; q=.2, */; q=.2" in
+    let expected = Accept.Parse_failure " " in
+    let actual () =
+      let _ = Accept.of_string data in
+      ()
+    in
+    Alcotest.check_raises "Raises Parse failure" expected actual
+
   let test_accept_complex () =
     let data =
       "application/xml;q=0.9,text/html,application/xhtml+xml,*/*;q=0.8"
@@ -81,6 +90,7 @@ module Accept = struct
         [
           ("Simple", `Quick, test_accept_simple)
         ; ("Complex", `Quick, test_accept_complex)
+        ; ("Invalid", `Quick, test_invalid)
         ]
       ; preferred_tests
       ]

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

@@ -18,20 +18,19 @@ 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_json =
+    let* accept = req.Http.Request.accept in
+    let* accepted =
+      try Some (Accept.of_string accept) with Accept.Parse_failure _ -> None
+    in
+    Accept.preferred ~from:[mime_json; mime_xml] accepted
+    |> map_head (fun x -> String.equal x mime_json)
+  in
+  Option.value
+    ~default:(List.mem_assoc "json" req.Http.Request.query)
+    prefers_json
 
 let content_type json = if json then content_json else content_xml