Skip to content

Commit

Permalink
cohttp-eio: subsume Header.Codec.t and Header.Codec.v into Header.codec
Browse files Browse the repository at this point in the history
  • Loading branch information
@bikallem
bikallem committed Feb 6, 2023
1 parent 3fc8fdc commit bec3ecf
Show file tree
Hide file tree
Showing 3 changed files with 119 additions and 126 deletions.
121 changes: 54 additions & 67 deletions cohttp-eio/src/header.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,18 +21,9 @@ type 'a encoder = 'a -> value
type 'a undecoded = 'a Lazy.t
type (_, _) eq = Eq : ('a, 'a) eq

module Codec = struct
class type t =
object
method header : 'a. lname -> 'a header
method equal : 'a 'b. 'a header -> 'b header -> ('a, 'b) eq option
method decoder : 'a. 'a header -> 'a decoder
method encoder : 'a. 'a header -> 'a encoder
method name : 'a. 'a header -> name
end

let int_decoder v = int_of_string v
let int_encoder v = string_of_int v
class codec =
let int_decoder v = int_of_string v in
let int_encoder v = string_of_int v in

(* Transfer-Encoding decoder. *)
let te_decoder v =
Expand All @@ -46,7 +37,7 @@ module Codec = struct
| "deflate" -> `deflate
| "gzip" -> `gzip
| v -> failwith @@ "Invalid 'Transfer-Encoding' value " ^ v)

in
(* Transfer-Encoding encoder. *)
let te_encoder v =
List.map
Expand All @@ -57,69 +48,67 @@ module Codec = struct
| `gzip -> "gzip")
v
|> String.concat ", "

in
let constructor_name hdr =
let nm = Obj.Extension_constructor.of_val hdr in
Obj.Extension_constructor.name nm
in
object
method header : 'a. lname -> 'a header =
function
| "content-length" -> Obj.magic Content_length
| "transfer-encoding" -> Obj.magic Transfer_encoding
| h -> Obj.magic (H h)

method equal : type a b. a header -> b header -> (a, b) eq option =
fun a b ->
match (a, b) with
| Content_length, Content_length -> Some Eq
| Transfer_encoding, Transfer_encoding -> Some Eq
| H a, H b -> if String.equal a b then Some Eq else None
| _ -> None

method decoder : type a. a header -> a decoder =
function
| Content_length -> int_decoder
| Transfer_encoding -> te_decoder
| H _ -> Fun.id
| hdr ->
let err = "decoder undefined for header " ^ constructor_name hdr in
raise @@ Invalid_argument err

method encoder : type a. a header -> a encoder =
function
| Content_length -> int_encoder
| Transfer_encoding -> te_encoder
| H _ -> Fun.id
| hdr ->
let err = "encoder undefined for header " ^ constructor_name hdr in
raise @@ Invalid_argument err

method name : type a. a header -> name =
function
| Content_length -> "Content-Length"
| Transfer_encoding -> "Transfer-Encoding"
| H name -> canonical_name name
| hdr ->
let err = "name undefined for header " ^ constructor_name hdr in
raise @@ Invalid_argument err
end

let v : t =
object
method header : 'a. lname -> 'a header =
function
| "content-length" -> Obj.magic Content_length
| "transfer-encoding" -> Obj.magic Transfer_encoding
| h -> Obj.magic (H h)

method equal : type a b. a header -> b header -> (a, b) eq option =
fun a b ->
match (a, b) with
| Content_length, Content_length -> Some Eq
| Transfer_encoding, Transfer_encoding -> Some Eq
| H a, H b -> if String.equal a b then Some Eq else None
| _ -> None

method decoder : type a. a header -> a decoder =
function
| Content_length -> int_decoder
| Transfer_encoding -> te_decoder
| H _ -> Fun.id
| hdr ->
let err = "decoder undefined for header " ^ constructor_name hdr in
raise @@ Invalid_argument err

method encoder : type a. a header -> a encoder =
function
| Content_length -> int_encoder
| Transfer_encoding -> te_encoder
| H _ -> Fun.id
| hdr ->
let err = "encoder undefined for header " ^ constructor_name hdr in
raise @@ Invalid_argument err

method name : type a. a header -> name =
function
| Content_length -> "Content-Length"
| Transfer_encoding -> "Transfer-Encoding"
| H name -> canonical_name name
| hdr ->
let err = "name undefined for header " ^ constructor_name hdr in
raise @@ Invalid_argument err
end
end

let name (c : #Codec.t) = c#name
let name (c : #codec) = c#name

type v = V : 'a header * 'a Lazy.t -> v

class type virtual t =
class virtual t =
object
inherit Codec.t
inherit codec
method virtual headers : v list Atomic.t
method virtual to_list : v list
method virtual modify : (v list -> v list) -> unit
end

let make_n (c : #Codec.t) values : t =
let make_n (c : #codec) values : t =
let headers = Atomic.make values in
let rec modify f r =
let v_old = Atomic.get r in
Expand All @@ -139,7 +128,7 @@ let make_n (c : #Codec.t) values : t =

let make code = make_n code []

let of_name_values (c : #Codec.t) l =
let of_name_values (c : #codec) l =
List.map
(fun (name, value) ->
let h = c#header (lname name) in
Expand All @@ -164,9 +153,7 @@ let add_name_value (t : t) ~name ~value =
let v = lazy (t#decoder h value) in
add_lazy t h v

let encode : type a. #Codec.t -> a header -> a -> string =
fun codec h v -> codec#encoder 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 >) =
Expand Down
96 changes: 50 additions & 46 deletions cohttp-eio/src/header.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,9 +43,9 @@ type 'a header = ..
or found.
Users should extend this type to define custom headers along with a custom
{!class:Codec.t} instance.
{!class:codec} instance.
See {!class:Codec.t}. *)
See {!class:codec}. *)

type 'a header +=
| Content_length : int header
Expand All @@ -65,15 +65,20 @@ type 'a undecoded
(** ['a undecoded] represents a lazy value that is as yet undecoded. See
{!val:decode}. *)

(** [eq] is the OCaml GADT equality. *)
(** [eq] is OCaml GADT equality. *)
type (_, _) eq = Eq : ('a, 'a) eq

(** {1 Codec}
(** {2 codec}
[Codec] defines encoders, decoders and equality for {!type:header}.
[codec] defines encoders, decoders and equality for the following HTTP
headers:
- {!val:Content_Length}
- {!val:Transfer_encoding}
- {!val:H}
Users looking to combine both custom headers and headers defined in this
module should implement {!type:Codec.t} and use {!val:Codec.v}.
module are recommended to inherit this class.
{i Example} Here we define two custom headers [Header1] and [Header2] and
implement codec for it in object [custom_codec].
Expand All @@ -83,88 +88,87 @@ type (_, _) eq = Eq : ('a, 'a) eq
| Header1 : string Header.header
| Header2 : int Header.header
let custom_codec : Header.Codec.t =
let custom_codec : Header.codec =
object
method header : type a. Header.lname -> a Header.header =
inherit Header.codec as super
method! header : type a. Header.lname -> a Header.header =
fun nm ->
match (nm :> string) with
| "header1" -> Obj.magic Header1
| "header2" -> Obj.magic Header2
| _ -> Header.Codec.v#header nm
| _ -> super#header nm
method equal : type a b.
method! equal : type a b.
a Header.header -> b Header.header -> (a, b) Header.eq option =
fun a b ->
match (a, b) with
| Header1, Header1 -> Some Eq
| Header2, Header2 -> Some Eq
| _ -> Header.Codec.v#equal a b
| _ -> super#equal a b
method decoder : type a. a Header.header -> a Header.decoder =
method! decoder : type a. a Header.header -> a Header.decoder =
function
| Header1 -> int_of_string
| Header2 -> float_of_string
| hdr -> Header.Codec.v#decoder hdr
| hdr -> super#decoder hdr
method encoder : type a. a Header.header -> a Header.encoder =
method! encoder : type a. a Header.header -> a Header.encoder =
function
| Header1 -> string_of_int
| Header2 -> string_of_float
| hdr -> Header.Codec.v#encoder hdr
| hdr -> super#encoder hdr
method name : type a. a Header.header -> Header.name =
method! name : type a. a Header.header -> Header.name =
fun hdr ->
match hdr with
| Header1 -> Header.canonical_name "header1"
| Header2 -> Header.canonical_name "header2"
| hdr -> Header.Codec.v#name hdr
| hdr -> super#name hdr
end
]} *)
]}
module Codec : sig
(** [t] defines the class type that all codecs has to implement. *)
class type t =
object
method header : 'a. lname -> 'a header
(** [header lname] converts [lname] to {!type:header}. *)
The headers can then used used as such:
method equal : 'a 'b. 'a header -> 'b header -> ('a, 'b) eq option
(** [equal h1 h2] if [Some Eq] if [h1] and [h2] are equal. It is [None]
otherwise. *)

method decoder : 'a. 'a header -> 'a decoder
(** [decoder h] is decoder for header [h]. *)
{[
let h = Header.make custom_codec in
Header.add c Header1 1000;
Header.add c Header2 100.222
]} *)
class codec :
object
method header : 'a. lname -> 'a header
(** [header lname] converts [lname] to {!type:header}. *)

method encoder : 'a. 'a header -> 'a encoder
(** [encoder h] is encoder for header [h]. *)
method equal : 'a 'b. 'a header -> 'b header -> ('a, 'b) eq option
(** [equal h1 h2] if [Some Eq] if [h1] and [h2] are equal. It is [None]
otherwise. *)

method name : 'a. 'a header -> name
(** [name h] is the canonical name for header [h]. *)
end
method decoder : 'a. 'a header -> 'a decoder
(** [decoder h] is decoder for header [h]. *)

val v : t
(** [v] defines [codec]s for the following HTTP headers:
method encoder : 'a. 'a header -> 'a encoder
(** [encoder h] is encoder for header [h]. *)

- {!val:Content_Length}
- {!val:Transfer_encoding}
- {!val:H} *)
end
method name : 'a. 'a header -> name
(** [name h] is the canonical name for header [h]. *)
end

val name : #Codec.t -> 'a header -> name
val name : #codec -> 'a header -> name
(** [name codec h] is the canonical name for header [h]. *)

(** {1 Collection of Headers} *)

type t = private < Codec.t ; .. >
type t = private < codec ; .. >
(** [t] represents a collection of HTTP headers. {b Note} [t] is concurrency
safe. *)

(** {2 Create} *)

val make : #Codec.t -> t
val make : #codec -> t
(** [make codec] is an empty [t]. *)

val of_name_values : #Codec.t -> (string * string) list -> t
val of_name_values : #codec -> (string * string) list -> t
(** [of_name_values codec l] is [t] with header items initialized to [l] such
that [List.length seq = Header.length t]. *)

Expand Down Expand Up @@ -192,7 +196,7 @@ val add_name_value : t -> name:lname -> value:value -> unit

(** {2 Encode, Decode} *)

val encode : #Codec.t -> 'a header -> 'a -> value
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]. *)

Expand Down
Loading

0 comments on commit bec3ecf

Please sign in to comment.