Add ppx_deriving_router.cohttp_eio

To try:
  $ dune exec ./cohttp-eio/test/test.exe

and then:
  $ curl http://127.0.0.1:8888/hello/World

.github/workflows/main.yml

@@ -45,7 +45,7 @@ jobs:
       - run: opam install . --deps-only
       - run: opam exec -- dune build -p ppx_deriving_router
       # build with dream (should make ppx_deriving_router.dream available)
-      - run: opam install dream http cohttp cohttp-lwt cohttp-lwt-unix --yes
+      - run: opam install dream http cohttp cohttp-lwt cohttp-lwt-unix eio cohttp-eio --yes
       - run: opam exec -- dune build -p ppx_deriving_router
       # run tests
       - run: opam install . --deps-only --with-test

cohttp-eio/dune

@@ -0,0 +1,8 @@
+(library
+ (name ppx_deriving_router_cohttp_eio)
+ (public_name ppx_deriving_router.cohttp_eio)
+ (virtual_deps http eio cohttp cohttp-eio)
+ (optional)
+ (libraries ppx_deriving_router)
+ (ppx_runtime_libraries ppx_deriving_router.cohttp_eio_runtime)
+ (kind ppx_deriver))

cohttp-eio/runtime/dune

@@ -0,0 +1,12 @@
+(library
+ (name ppx_deriving_router_runtime_cohttp_eio_runtime)
+ (public_name ppx_deriving_router.cohttp_eio_runtime)
+ (virtual_deps eio http cohttp cohttp-eio)
+ (optional)
+ (wrapped false)
+ (libraries
+  uri
+  cohttp
+  cohttp-eio
+  ppx_deriving_router.runtime_lib
+  melange-json-native.ppx-runtime))

cohttp-eio/runtime/ppx_deriving_router_runtime.ml

@@ -0,0 +1,76 @@
+open struct
+  module IO : Ppx_deriving_router_runtime_lib.IO with type 'a t = 'a =
+  struct
+    type 'a t = 'a
+
+    let return = Fun.id
+    let fail exn = raise exn
+    let bind x f = f x
+    let catch f = try Ok (f ()) with exn -> Error exn
+  end
+
+  module Request :
+    Ppx_deriving_router_runtime_lib.REQUEST
+      with type 'a IO.t = 'a IO.t
+       and type t = Http.Request.t * Eio.Flow.source_ty Eio.Flow.source =
+  struct
+    module IO = IO
+
+    type t = Http.Request.t * Eio.Flow.source_ty Eio.Flow.source
+
+    let queries (req, _body) =
+      let uri = Cohttp.Request.uri req in
+      Uri.query uri
+      |> List.map (fun (k, vs) -> List.map (fun v -> k, v) vs)
+      |> List.flatten
+
+    let body ((_req, body) : t) = Eio.Flow.read_all body
+
+    let path (req, _body) =
+      let uri = Cohttp.Request.uri req in
+      Uri.path uri
+
+    let method_ (req, _body) =
+      match req.Http.Request.meth with
+      | `GET -> `GET
+      | `POST -> `POST
+      | `PUT -> `PUT
+      | `DELETE -> `DELETE
+      | _ -> failwith "Unsupported method"
+  end
+
+  module Response :
+    Ppx_deriving_router_runtime_lib.RESPONSE
+      with type 'a IO.t = 'a IO.t
+       and type status = Http.Status.t
+       and type t = Http.Response.t * Cohttp_eio.Body.t = struct
+    module IO = IO
+
+    type status = Http.Status.t
+
+    let status_ok : status = `OK
+    let status_bad_request : status = `Bad_request
+    let status_method_not_allowed : status = `Method_not_allowed
+    let status_not_found : status = `Not_found
+
+    type t = Http.Response.t * Cohttp_eio.Body.t
+
+    let respond ~status ~headers body =
+      let headers = Http.Header.of_list headers in
+      Cohttp_eio.Server.respond_string ~headers ~status ~body ()
+  end
+
+  module Return :
+    Ppx_deriving_router_runtime_lib.RETURN
+      with type status = Http.Status.t
+       and type 'a t = 'a = struct
+    type status = Http.Status.t
+    type 'a t = 'a
+
+    let data x = Some x
+    let status _ = None
+    let headers _ = []
+  end
+end
+
+include Ppx_deriving_router_runtime_lib.Make (Request) (Response) (Return)

cohttp-eio/runtime/ppx_deriving_router_runtime.mli

@@ -0,0 +1,8 @@
+include
+  Ppx_deriving_router_runtime_lib.S
+    with type Request.t =
+      Http.Request.t * Eio.Flow.source_ty Eio.Flow.source
+     and type Response.t = Http.Response.t * Cohttp_eio.Body.t
+     and type Response.status = Http.Status.t
+     and type 'a Return.t = 'a
+     and type 'a IO.t = 'a

cohttp-eio/test/dune

@@ -0,0 +1,10 @@
+(executable
+ (name test)
+ (libraries eio eio.unix eio_main cohttp-eio)
+ (preprocess
+  (pps ppx_deriving_router.cohttp_eio melange-json-native.ppx)))
+
+(cram
+ (deps
+  ./test.exe
+  (package ppx_deriving_router)))

cohttp-eio/test/routing.ml

@@ -0,0 +1,97 @@
+type modifier =
+  | Uppercase
+  | Lowercase
+      (** this a custom type which we want to be able to serialize/deserialize
+          from/to the URL query *)
+
+let modifier_of_url_query k xs =
+  match List.assoc_opt k xs with
+  | Some "uppercase" -> Ok Uppercase
+  | Some "lowercase" -> Ok Lowercase
+  | Some _ -> Error "invalid modifier"
+  | None -> Error "missing modifier"
+
+let modifier_to_url_query k = function
+  | Uppercase -> [ k, "uppercase" ]
+  | Lowercase -> [ k, "lowercase" ]
+
+module Options = struct
+  open Ppx_deriving_json_runtime.Primitives
+
+  type t = { a : int option } [@@deriving json, url_query_via_json]
+end
+
+module User_id : sig
+  type t
+
+  val inject : string -> t
+  val project : t -> string
+end = struct
+  type t = string
+
+  let inject x = x
+  let project x = x
+end
+
+module Level = struct
+  type t = Alert | Warning
+
+  let to_int = function Alert -> 2 | Warning -> 1
+
+  let of_int = function
+    | 2 -> Alert
+    | 1 -> Warning
+    | _ -> failwith "invalid level"
+end
+
+module Pages = struct
+  open Ppx_deriving_router_runtime.Primitives
+
+  type user_id = User_id.t
+  [@@deriving url_query_via_iso, url_path_via_iso]
+
+  type level = Level.t
+  [@@deriving
+    url_query_via_iso { t = int; inject = of_int; project = to_int }]
+
+  type t =
+    | Home [@GET "/"]
+    | Hello of {
+        name : string;
+        modifier : modifier option;
+        greeting : string option;
+      } [@GET "/hello/:name"]
+    | Echo_options of { options : Options.t }
+    | List_users of { user_ids : user_id list }
+    | User_info of { user_id : user_id }
+    | User_info_via_path of { user_id : user_id } [@GET "/user/:user_id"]
+    | Signal of { level : level }
+    | Route_with_implicit_path of { param : string option }
+    | Route_with_implicit_path_post [@POST]
+  [@@deriving router]
+end
+
+module Api = struct
+  open Ppx_deriving_router_runtime.Primitives
+  open Ppx_deriving_json_runtime.Primitives
+
+  type user = { id : int } [@@deriving json]
+
+  type _ t =
+    | List_users : user list t [@GET "/"]
+    | Create_user : { id : int [@body] } -> user t [@POST "/"]
+    | Get_user : { id : int } -> user t [@GET "/:id"]
+    | Raw_response : Ppx_deriving_router_runtime.response t
+        [@GET "/raw-response"]
+  [@@deriving router]
+end
+
+module All = struct
+  type _ t =
+    | Pages : Pages.t -> Ppx_deriving_router_runtime.response t
+        [@prefix "/"]
+    | Api : 'a Api.t -> 'a t [@prefix "/nested/api"]
+    | Static : { path : string } -> Ppx_deriving_router_runtime.response t
+        [@GET "/static/...path"]
+  [@@deriving router]
+end