do not rely on locale for printing qvalues

cohttp/src/accept.ml

@@ -47,8 +47,16 @@ let rec string_of_pl = function
   | (k,T v)::r -> sprintf ";%s=%s%s" k v (string_of_pl r)
   | (k,S v)::r -> sprintf ";%s=\"%s\"%s" k (Stringext.quote v) (string_of_pl r)
 
+let string_of_q = function
+  | q when q < 0 ->
+    invalid_arg (Printf.sprintf "qvalue %d must be positive" q)
+  | q when q > 1000 ->
+    invalid_arg (Printf.sprintf "qvalue %d must be less than 1000" q)
+  | 1000 -> "1"
+  | q -> Printf.sprintf "0.%03d" q
+
 let accept_el el pl q =
-  sprintf "%s;q=%.3f%s" el ((float q)/.1000.) (string_of_pl pl)
+  sprintf "%s;q=%s%s" el (string_of_q q) (string_of_pl pl)
 
 let string_of_media_range = function
   | (MediaType (t,st),pl) -> accept_el (sprintf "%s/%s" t st) pl

cohttp/test/test_accept.ml

@@ -21,12 +21,43 @@ let suite_of
     -> a Alcotest.testable
     -> (string * a) list
     -> _ list
-  = fun parser t ->
+  = fun pf t ->
     List.map (fun (s, expected) ->
         let test () =
-          Alcotest.(check t) s (parser (Some s)) expected in
+          Alcotest.check t s (pf (Some s)) expected in
         (s, `Quick, test))
 
+let suite_of_fail
+  : type a. (string option -> a)
+    -> a Alcotest.testable
+    -> (string * exn) list
+    -> _ list
+  = fun pf t ->
+    List.map (fun (s, e) ->
+        let test () =
+          Alcotest.check_raises s e (fun () -> ignore (pf (Some s))) in
+        (s, `Quick, test))
+
+let suite_to_string_of
+  : type a. (a -> string)
+    -> (a * string) list
+    -> _ list
+  = fun pf ->
+    List.map (fun (v, expected_str) ->
+        let test () =
+          Alcotest.(check string expected_str expected_str (pf v)) in
+        (expected_str, `Quick, test))
+
+let suite_to_string_of_fail
+  : type a. (a -> string)
+    -> (a * string * exn) list
+    -> _ list
+  = fun pf ->
+    List.map (fun (v, descr, e) ->
+        let test () =
+          Alcotest.(check_raises descr e (fun () -> ignore (pf v))) in
+        ("", `Quick, test))
+
 let valid_media_ranges = [
   "text/plain", [1000,(A.MediaType ("text","plain"),[])];
   "text/*", [1000,(A.AnyMediaSubtype "text",[])];
@@ -36,7 +67,6 @@ let valid_media_ranges = [
   "*/*;q=1.", [1000,(A.AnyMedia,[])];
   "*/*;q=1.0", [1000,(A.AnyMedia,[])];
   "*/*;q=.0", [0,(A.AnyMedia,[])];
-  (* TODO invalid test "*/*;q=.", [0,(A.AnyMedia,[])]; *)
   "*/*;q=0.", [0,(A.AnyMedia,[])];
   "*/*;q=0.1", [100,(A.AnyMedia,[])];
   "image/*,text/*", [
@@ -52,11 +82,41 @@ let valid_media_ranges = [
   "*/*;f=\";q=0,text/plain\"", [1000,(A.AnyMedia,["f",A.S";q=0,text/plain"])];
 ]
 
+let invalid_media_ranges = [
+  "*/*;q=.", Parsing.Parse_error;
+]
+
 let valid_media_ranges_suite =
   let t_media_ranges =
     Alcotest.testable (Fmt.of_to_string A.string_of_media_ranges) (=) in
   suite_of A.media_ranges t_media_ranges valid_media_ranges
 
+let invalid_media_ranges_suite =
+  let t_media_ranges =
+    Alcotest.testable (Fmt.of_to_string A.string_of_media_ranges) (=) in
+  suite_of_fail A.media_ranges t_media_ranges invalid_media_ranges
+
+let valid_qualities = [
+  (1000,(A.AnyMedia,[])), "*/*;q=1";
+  (0,(A.AnyMedia,[])), "*/*;q=0.000";
+  (353,(A.AnyMedia,[])), "*/*;q=0.353";
+  (25,(A.AnyMedia,[])), "*/*;q=0.025";
+  (1,(A.AnyMedia,[])), "*/*;q=0.001";
+]
+
+let invalid_qualities = [
+  (-3,(A.AnyMedia,[])), "negative", Invalid_argument "qvalue -3 must be positive";
+  (1001,(A.AnyMedia,[])), "bigger than 1000", Invalid_argument "qvalue 1001 must be less than 1000";
+]
+
+let valid_qualities_suite =
+  suite_to_string_of
+    (fun (q,a) -> A.string_of_media_range a q) valid_qualities
+
+let invalid_qualities_suite =
+  suite_to_string_of_fail
+    (fun (q, a) -> A.string_of_media_range a q) invalid_qualities
+
 let valid_charsets = [
   "utf-8", [1000,A.Charset "utf-8"];
   "UTF-8", [1000,A.Charset "utf-8"];
@@ -112,8 +172,11 @@ let () = Printexc.record_backtrace true
 
 let () =
   Alcotest.run "test_accept" [
-    "Valid Accept",valid_media_ranges_suite;
-    "Valid Accept-Charset", valid_charsets_suite;
-    "Valid Accept-Encoding", valid_encodings_suite;
-    "Valid Accept-Language", valid_languages_suite;
+    "valid string to media range", valid_media_ranges_suite;
+    "invalid string to media range", invalid_media_ranges_suite;
+    "valid media range to string", valid_qualities_suite;
+    "invalid media range to string", invalid_qualities_suite;
+    "valid string to charset", valid_charsets_suite;
+    "valid string to encoding", valid_encodings_suite;
+    "valid string to language", valid_languages_suite;
   ]