cohttp-eio: add Header.undecoded and make Header.decode concurrency safe

cohttp-eio/src/header.ml

@@ -16,9 +16,22 @@ type 'a header +=
   | Transfer_encoding : [ `chunked | `compress | `deflate | `gzip ] list header
   | H : lname -> value header
 
-type 'a decoder = value -> 'a
 type 'a encoder = 'a -> value
-type 'a undecoded = 'a Lazy.t
+type 'a decoder = value -> 'a
+type 'a undecoded_state = Decoded of 'a | Undecoded of 'a Lazy.t
+type 'a undecoded = { v : 'a undecoded_state Atomic.t }
+
+let undecoded : type a. a Lazy.t -> a undecoded =
+ fun v -> { v = Atomic.make (Undecoded v) }
+
+let rec decode : type a. a undecoded -> a =
+ fun v ->
+  match Atomic.get v.v with
+  | Decoded x -> x
+  | Undecoded lz as v_old ->
+      let x = Lazy.force lz in
+      if Atomic.compare_and_set v.v v_old (Decoded x) then x else decode v
+
 type (_, _) eq = Eq : ('a, 'a) eq
 
 class codec =
@@ -98,7 +111,7 @@ class codec =
 
 let name (c : #codec) = c#name
 
-type v = V : 'a header * 'a Lazy.t -> v
+type v = V : 'a header * 'a undecoded -> v
 
 class virtual t =
   object
@@ -132,14 +145,15 @@ let of_name_values (c : #codec) l =
   List.map
     (fun (name, value) ->
       let h = c#header (lname name) in
-      let v = lazy (c#decoder h value) in
+      let v = undecoded (lazy (c#decoder h value)) in
       V (h, v))
     l
   |> make_n c
 
 let length (t : #t) = List.length t#to_list
 
 let add_lazy (type a) (t : t) (h : a header) v =
+  let v = undecoded v in
   t#modify (fun l -> V (h, v) :: l)
 
 let add (type a) (t : t) (h : a header) v = add_lazy t h (lazy v)
@@ -154,7 +168,6 @@ let add_name_value (t : t) ~name ~value =
   add_lazy t h v
 
 let encode : type a. t -> a header -> a -> string = fun t h v -> t#encoder h v
-let decode : type a. a undecoded -> a = Lazy.force
 
 let exists (t : #t) (f : < f : 'a. 'a header -> 'a undecoded -> bool >) =
   let rec aux = function
@@ -168,7 +181,7 @@ let find_opt (type a) (t : #t) (h : a header) =
     | [] -> None
     | V (h', v) :: tl -> (
         match t#equal h h' with
-        | Some Eq -> ( try Some (Lazy.force v :> a) with _ -> None)
+        | Some Eq -> ( try Some (decode v :> a) with _ -> None)
         | None -> aux tl)
   in
   aux t#to_list
@@ -177,9 +190,7 @@ let find (type a) (t : #t) (h : a header) =
   let rec aux = function
     | [] -> raise Not_found
     | V (h', v) :: tl -> (
-        match t#equal h h' with
-        | Some Eq -> (Lazy.force v :> a)
-        | None -> aux tl)
+        match t#equal h h' with Some Eq -> (decode v :> a) | None -> aux tl)
   in
   aux t#to_list
 
@@ -188,16 +199,17 @@ let find_all (type a) (t : #t) (h : a header) : a undecoded list =
     | [] -> []
     | V (h', v) :: tl -> (
         match t#equal h h' with
-        | Some Eq -> (v :> a undecoded) :: aux tl
+        | Some Eq -> (v : a undecoded) :: aux tl
         | None -> aux tl)
   in
   aux t#to_list
 
-let update (t : #t) (f : < f : 'a. 'a header -> 'a undecoded -> 'a option >) =
+let update (t : #t)
+    (f : < f : 'a. 'a header -> 'a undecoded -> 'a undecoded option >) =
   t#modify
     (List.filter_map (fun (V (h, v)) ->
          let v = f#f h v in
-         Option.map (fun v -> V (h, lazy v)) v))
+         Option.map (fun v -> V (h, v)) v))
 
 let remove (type a) ?(all = false) (t : #t) (h : a header) =
   t#modify (fun headers ->
@@ -229,6 +241,6 @@ let to_name_values (t : #t) =
   List.map
     (fun (V (h, v)) ->
       let name = t#name h in
-      let value = encode t h (Lazy.force v) in
+      let value = encode t h (decode v) in
       (name, value))
     t#to_list

cohttp-eio/src/header.mli

@@ -54,21 +54,33 @@ type 'a header +=
 
 (** {1 Codec - Header Encoder & Decoder} *)
 
+type 'a encoder = 'a -> value
+(** [encoder] converts a typed value ['a] to its string representation. *)
+
 type 'a decoder = value -> 'a
 (** [decoder] converts {!type:value} to type ['a]. To denote an error while
     decoding, an OCaml exception value is raised. *)
 
-type 'a encoder = 'a -> value
-(** [encoder] converts a typed value ['a] to its string representation. *)
-
 type 'a undecoded
 (** ['a undecoded] represents a lazy value that is as yet undecoded. See
     {!val:decode}. *)
 
+val undecoded : 'a Lazy.t -> 'a undecoded
+(** [undecoded lazy_val] creates an {!type:undecoded} value.
+
+    {[
+      Header.undecoded (lazy (int_of_string "20"))
+    ]} *)
+
+val decode : 'a undecoded -> 'a
+(** [decode codec v] decodes [v].
+
+    @raise exn if decoding results in an error. *)
+
 (** [eq] is OCaml GADT equality. *)
 type (_, _) eq = Eq : ('a, 'a) eq
 
-(** {2 codec}
+(** {1 codec}
 
     [codec] defines encoders, decoders and equality for the following HTTP
     headers:
@@ -163,7 +175,7 @@ type t = private < codec ; .. >
 (** [t] represents a collection of HTTP headers. {b Note} [t] is concurrency
     safe. *)
 
-(** {2 Create} *)
+(** {1 Create} *)
 
 val make : #codec -> t
 (** [make codec] is an empty [t]. *)
@@ -177,7 +189,7 @@ val of_name_values : #codec -> (string * string) list -> t
 val length : t -> int
 (** [length t] is total count of headers in [t]. *)
 
-(** {2 Add} *)
+(** {1 Add} *)
 
 val add_lazy : t -> 'a header -> 'a Lazy.t -> unit
 (** [add_lazy t h lazy_v] adds header [h] and its corresponding typed lazy value
@@ -194,24 +206,20 @@ val add_name_value : t -> name:lname -> value:value -> unit
 (** [add_name_value t ~name ~value] lazily (i.e. undecoded) add header with
     [name] and [value] to [t]. *)
 
-(** {2 Encode, Decode} *)
+(** {1 Encode} *)
 
 val encode : t -> 'a header -> 'a -> value
 (** [encode codec h v] encodes the value of header [h]. The encoder is used as
     defined in [codec]. *)
 
-val decode : 'a undecoded -> 'a
-(** [decode codec v] decodes [v].
-
-    @raise exn if decoding results in an error. *)
-
-(** {2 Find} *)
+(** {1 Find} *)
 
 val exists : t -> < f : 'a. 'a header -> 'a undecoded -> bool > -> bool
 (** [exists t f] iterates over [t] and applies [f#f h v] where [h] and [v] are
     respectively header and undecoded value as it exists in [t]. It returns
-    [true] if any of the items in [t] returns [true] for [f#f h v]. See
-    {!val:decode} to decode [v]. *)
+    [true] if any of the items in [t] returns [true] for [f#f h v].
+
+    See {!val:decode} to decode [v]. *)
 
 val find_opt : t -> 'a header -> 'a option
 (** [find_opt t h] is [Some v] if [h] exists in [t]. It is [None] if [h] doesn't
@@ -225,16 +233,20 @@ val find : t -> 'a header -> 'a
 
 val find_all : t -> 'a header -> 'a undecoded list
 (** [find_all t h] is a list of undecoded values [v] corresponding to header
-    [h]. It is an empty list if [h] doesn't exist in [t]. See {!val:decode} to
-    decode [v]. *)
+    [h]. It is an empty list if [h] doesn't exist in [t].
 
-(** {2 Update, Remove} *)
+    See {!val:decode} to decode [v]. *)
 
-val update : t -> < f : 'a. 'a header -> 'a undecoded -> 'a option > -> unit
-(** [update t f] iterates over [t] and applies [f#f h v] where [h] and [v] are
-    respectively header and undecoded value as it exists in [t]. If
+(** {1 Update, Remove} *)
+
+val update :
+  t -> < f : 'a. 'a header -> 'a undecoded -> 'a undecoded option > -> unit
+(** [update t f] iterates over [t] and applies [f#f h v] to each element. [h]
+    and [v] are respectively header and undecoded value as it exists in [t]. If
     [f#f h v = Some v'] then the value of [h] is updated to [v']. If [None] then
-    [h] is removed from [t]. See {!val:decode} to decode [v]. *)
+    [h] is removed from [t].
+
+    See {!val:decode} to decode [v]. *)
 
 val remove : ?all:bool -> t -> 'a header -> unit
 (** [remove t h] removes the last added header [h] from [t].
@@ -243,25 +255,30 @@ val remove : ?all:bool -> t -> 'a header -> unit
       if [true] then all headers equal to [h] are removed from [t]. Default
       value is [false]. *)
 
-(** {2 Iter, Fold, Seq} *)
+(** {1 Iter, Fold, Seq} *)
 
 (** [binding] represents a typed header and its corresponding undecoded value.
+
     See {!type:undecoded} and {!val:decode}. *)
 type binding = B : 'a header * 'a undecoded -> binding
 
 val iter : t -> < f : 'a. 'a header -> 'a undecoded -> unit > -> unit
 (** [iter t f] iterates over [t] and applies [f#f h v] where [h] and [v] are
-    respectively header and undecoded value as it exists in [t]. See
-    {!val:decode} to decode [v]. *)
+    respectively header and undecoded value as it exists in [t].
+
+    See {!val:decode} to decode [v]. *)
 
 val fold_left :
   t -> < f : 'a. 'a header -> 'a undecoded -> 'b -> 'b > -> 'b -> 'b
 (** [fold_left t f acc] folds over [t] and applies [f#f h v acc] where [h] and
-    [v] are respectively header and undecoded value as it exists in [t]. See
-    {!val:decode} to decode [v]. *)
+    [v] are respectively header and undecoded value as it exists in [t].
+
+    See {!val:decode} to decode [v]. *)
 
 val to_seq : t -> binding Seq.t
-(** [to_seq t] returns a sequence of {!type:binding}s. *)
+(** [to_seq t] returns a sequence of {!type:binding}s.
+
+    See {!val:decode} to decode [v]. *)
 
 val to_name_values : t -> (name * value) list
 (** [to_name_values t] a list of [(name,value)] tuple.

cohttp-eio/tests/header.md

@@ -245,16 +245,19 @@ Apply `update`.
 
 ```ocaml
 # let f = object
-  method f: type a. a Header.header -> a Header.undecoded -> a option =
+  method f: type a. a Header.header -> a Header.undecoded -> a Header.undecoded option =
     fun h v ->
-      let v = Header.decode v in
-      match h, v with
-      | Header.Content_length, 200 -> Some 2000
-      | Header.H nm, "20" when ((nm :> string) = "age") -> Some "40"
+      let v' = Header.decode v in
+      match h, v' with
+      | Header.Content_length, 200 -> Some (Header.undecoded (lazy 2000))
+      | Header.H nm, "20" when ((nm :> string) = "age") -> Some (Header.undecoded (lazy "40"))
       | Header.H nm, "blah2" when ((nm :> string) = "blah2") -> None
       | _ -> Some v
   end;;
-val f : < f : 'a. 'a Header.header -> 'a Header.undecoded -> 'a option > =
+val f :
+  < f : 'a.
+          'a Header.header ->
+          'a Header.undecoded -> 'a Header.undecoded option > =
   <obj>
 
 # Header.update t f ;;