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.

The parser has been changed to use Result.t, with precise errors about the part
that failed to be parsed.

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

Author: psafont

ocaml/libs/http-lib/http.ml

@@ -463,43 +463,133 @@ module Accept = struct
     in
     loop (List.sort compare_user_preference types)
 
-  exception Parse_failure of string
+  (* {|
+     RFC 9110 defines a grammar for the Accept header:
+
+     Accept          = #( media-range [ weight ] )
+
+     media-range     = ( "*/*"
+                         / ( type "/" "*" )
+                         / ( type "/" subtype )
+                       ) parameters
+
+     media-type      = type "/" subtype parameters
+     type            = token
+     subtype         = token
+
+     parameters      = *( OWS ";" OWS [ parameter ] )
+     parameter       = parameter-name "=" parameter-value
+     parameter-name  = token
+     parameter-value = ( token / quoted-string )
+
+     weight          = OWS ";" OWS "q=" qvalue
+     qvalue          = ( "0" [ "." 0*3DIGIT ] )
+                     / ( "1" [ "." 0*3("0") ] )
+
+     OWS             = *( SP / HTAB )
+
+     token           = 1*tchar
+
+     tchar           = "!" / "#" / "$" / "%" / "&" / "'" / "*"
+                     / "+" / "-" / "." / "^" / "_" / "`" / "|" / "~"
+                     / DIGIT / ALPHA
+                     ; any VCHAR, except delimiters
+
+     quoted-string   = DQUOTE *( qdtext / quoted-pair ) DQUOTE
+     qdtext          = HTAB / SP / %x21 / %x23-5B / %x5D-7E / obs-text
+     quoted-pair     = "\" ( HTAB / SP / VCHAR / obs-text )
+
+     obs-text        = %x80-FF
+
+  |} *)
+
+  type parse_error =
+    | MediaRange of string
+    | MediaType of string
+    | Parameter of string
+    | Qvalue of string
+
+  let ( let* ) = Result.bind
+
+  (* transpose a list of results to Result of (list, err) *)
+  let transpose_list_result list_result =
+    list_result
+    |> List.partition_map (function Ok x -> Left x | Error x -> Right x)
+    |> function
+    | [], [] ->
+        Ok []
+    | _, err :: _ ->
+        Error err
+    | oks, _ ->
+        Ok oks
 
   let of_string_single x =
     match Astring.String.cuts ~sep:";" x with
     | ty_subty :: params ->
         let ty_of_string = function "*" -> None | x -> Some x in
-        let ty =
+        let* ty =
           match Astring.String.cuts ~sep:"/" ty_subty with
           | [ty; subty] ->
-              Option.map (fun ty -> (ty, ty_of_string subty)) (ty_of_string ty)
+              Ok
+                (Option.map
+                   (fun ty -> (ty, ty_of_string subty))
+                   (ty_of_string ty)
+                )
           | _ ->
-              raise (Parse_failure ty_subty)
+              Error (MediaType ty_subty)
         in
-        let params =
+        let* params =
           List.map
             (fun x ->
               match Astring.String.cut ~sep:"=" x with
               | Some (k, v) ->
-                  (k, v)
+                  Ok (k, v)
               | _ ->
-                  raise (Parse_failure x)
+                  Error (Parameter x)
             )
             params
+          |> transpose_list_result
         in
-        let q =
+
+        let* q =
           match List.assoc_opt "q" params with
-          | Some q ->
-              int_of_float (1000. *. float_of_string q)
+          | Some q -> (
+            match Float.of_string_opt q with
+            | None ->
+                Error (Qvalue q)
+            | Some q ->
+                Ok (Float.to_int (1000. *. q))
+          )
           | None ->
-              1000
+              Ok 1000
         in
-        {ty; q}
+        Ok {ty; q}
     | _ ->
-        raise (Parse_failure x)
+        Error (MediaRange x)
 
   let of_string x =
     List.map of_string_single (Astring.String.cuts ~empty:false ~sep:"," x)
+    |> transpose_list_result
+
+  let parse_error_equal a b =
+    match (a, b) with
+    | MediaRange a, MediaRange b
+    | MediaType a, MediaType b
+    | Parameter a, Parameter b
+    | Qvalue a, Qvalue b ->
+        String.equal a b
+    | _ ->
+        false
+
+  let parse_error_to_string = function
+    | MediaRange a ->
+        Printf.sprintf "MediaRange (%s)" a
+    | MediaType a ->
+        Printf.sprintf "Mimetype (%s)" a
+    | Parameter a ->
+        Printf.sprintf "Parameter (%s)" a
+    | Qvalue a ->
+        Printf.sprintf "Qvalue (%s)" a
 end
 
 module Request = struct

ocaml/libs/http-lib/http.mli

@@ -50,11 +50,15 @@ val read_http_response_header : bytes -> Unix.file_descr -> int
 module Accept : sig
   type t = {ty: (string * string option) option  (** None means '*' *); q: int}
 
-  exception Parse_failure of string
+  type parse_error =
+    | MediaRange of string
+    | Mimetype of string
+    | Parameter of string
+    | Qvalue of string
 
   val equal : t -> t -> bool
 
-  val of_string : string -> t list
+  val of_string : string -> (t list, parse_error) Result.t
 
   val to_string : t -> string
 
@@ -63,6 +67,10 @@ module Accept : sig
   val preferred : from:string list -> t list -> string list
   (** [preferred ~from accepted] returns the content types in [~from]
       that are accepted by elements of [accepted] in priority order *)
+
+  val parse_error_equal : parse_error -> parse_error -> bool
+
+  val parse_error_to_string : parse_error -> string
 end
 
 (** Parsed form of the HTTP request line plus cookie info *)

ocaml/libs/http-lib/http_test.ml

@@ -18,24 +18,32 @@ module Accept = struct
   let accept =
     Alcotest.testable (Fmt.of_to_string Accept.to_string) Accept.equal
 
+  let parse_error =
+    Alcotest.testable
+      (Fmt.of_to_string Accept.parse_error_to_string)
+      Accept.parse_error_equal
+
   let test_accept_simple () =
     let data = "application/json" in
-    let expected = [Accept.{ty= Some ("application", Some "json"); q= 1000}] in
+    let expected =
+      Ok [Accept.{ty= Some ("application", Some "json"); q= 1000}]
+    in
     let actual = Accept.of_string data in
-    Alcotest.(check @@ list accept) data expected actual
+    Alcotest.(check @@ result (list accept) parse_error) 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 expected = Error (Accept.Mimetype " ") in
+    let actual = Accept.of_string data in
+    Alcotest.(check @@ result (list accept) parse_error) data expected actual
 
   let test_accept_complex () =
     let data =
       "application/xml;q=0.9,text/html,application/xhtml+xml,*/*;q=0.8"
     in
+    let content_types = Accept.of_string data |> Result.get_ok in
+
     let expected = ["text/html"] in
-    let content_types = Accept.of_string data in
     let actual = Accept.preferred ~from:["text/html"] content_types in
     Alcotest.(check @@ list string) data expected actual ;
 
@@ -73,7 +81,7 @@ module Accept = struct
     in
     let test (name, data, from, expected) =
       let test () =
-        let content_types = Accept.of_string data in
+        let content_types = Accept.of_string data |> Result.get_ok in
         let actual = Accept.preferred ~from content_types in
         Alcotest.(check @@ list string) data expected actual
       in

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

@@ -18,20 +18,20 @@ 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 preferred_of accept =
+    let ( let* ) = Option.bind in
+    let* accepted = Accept.of_string accept |> Result.to_option in
+    let negotiated = Accept.preferred ~from:[mime_json; mime_xml] accepted in
+    match negotiated with
+    | x :: _ when String.equal x mime_json ->
+        Some true
+    | [] ->
+        None
+    | _ ->
+        Some false
+  in
+  Option.bind req.Http.Request.accept preferred_of
+  |> Option.value ~default:(List.mem_assoc "json" req.Http.Request.query)
 
 let content_type json = if json then content_json else content_xml