Add support for cohttp-eio

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

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

cohttp-eio/dune

@@ -0,0 +1,8 @@
+(library
+ (name ppx_deriving_router_cohttp_eio)
+ (public_name ppx_deriving_router.cohttp_eio)
+ (virtual_deps 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,11 @@
+(library
+ (name ppx_deriving_router_runtime_cohttp_eio_runtime)
+ (public_name ppx_deriving_router.cohttp_eio_runtime)
+ (virtual_deps cohttp-eio)
+ (optional)
+ (wrapped false)
+ (libraries
+  uri
+  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 = Uri.of_string req.Http.Request.resource 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 = Uri.of_string req.Http.Request.resource 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)
+ (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

cohttp-eio/test/test.ml

@@ -0,0 +1,95 @@
+open Routing
+open! Cohttp
+open! Cohttp_eio
+
+let pages_handle route _req =
+  match route with
+  | Pages.Home -> Server.respond_string ~status:`OK ~body:"HOME PAGE" ()
+  | Route_with_implicit_path { param } ->
+      let param = Option.value ~default:"-" param in
+      Server.respond_string ~status:`OK
+        ~body:("works as well, param is: " ^ param)
+        ()
+  | Route_with_implicit_path_post ->
+      Server.respond_string ~status:`OK ~body:"posted" ()
+  | Echo_options { options } ->
+      let json = Options.to_json options in
+      let json = Yojson.Basic.to_string json in
+      Server.respond_string ~status:`OK ~body:json
+        ~headers:
+          (Http.Header.of_list [ "Content-Type", "application/json" ])
+        ()
+  | List_users { user_ids } ->
+      let ids =
+        match user_ids with
+        | user_ids ->
+            Printf.sprintf "[%s]"
+              (user_ids |> List.map User_id.project |> String.concat ", ")
+      in
+      Server.respond_string ~status:`OK
+        ~body:(Printf.sprintf "User ids = %s" ids)
+        ()
+  | User_info { user_id } | User_info_via_path { user_id } ->
+      Server.respond_string ~status:`OK
+        ~body:
+          (Printf.sprintf "User info for %S" (User_id.project user_id))
+        ()
+  | Signal { level } ->
+      Server.respond_string ~status:`OK
+        ~body:(Printf.sprintf "Signal: %d" (Level.to_int level))
+        ()
+  | Hello { name; modifier; greeting } ->
+      let greeting = Option.value greeting ~default:"Hello" in
+      let name =
+        match modifier with
+        | None -> name
+        | Some Uppercase -> String.uppercase_ascii name
+        | Some Lowercase -> String.lowercase_ascii name
+      in
+      let greeting = Printf.sprintf "%s, %s!" greeting name in
+      Server.respond_string ~status:`OK ~body:greeting ()
+
+let api_handle :
+    type a.
+    a Api.t -> Cohttp.Request.t * Eio.Flow.source_ty Eio.Flow.source -> a
+    =
+ fun x _req ->
+  match x with
+  | Raw_response ->
+      Server.respond_string ~status:`OK ~body:"RAW RESPONSE" ()
+  | List_users -> []
+  | Create_user { id } -> { Api.id }
+  | Get_user { id } -> { Api.id }
+
+let all_handler =
+  let f :
+      type a.
+      a All.t ->
+      Cohttp.Request.t * Eio.Flow.source_ty Eio.Flow.source ->
+      a =
+   fun x req ->
+    match x with
+    | Pages p -> pages_handle p req
+    | Api e -> api_handle e req
+    | Static { path } ->
+        Server.respond_string ~status:`OK
+          ~body:(Printf.sprintf "path=%S" path)
+          ()
+  in
+  All.handle { f }
+
+let log_warning ex = Logs.warn (fun f -> f "%a" Eio.Exn.pp ex)
+
+let () =
+  let port = ref 8888 in
+  Arg.parse
+    [ "-p", Arg.Set_int port, " Listening port number (8888 by default)" ]
+    ignore "An HTTP/1.1 server";
+  Eio_main.run @@ fun env ->
+  Eio.Switch.run @@ fun sw ->
+  let handler _conn req body = all_handler (req, body) in
+  let socket =
+    Eio.Net.listen env#net ~sw ~backlog:128 ~reuse_addr:true
+      (`Tcp (Eio.Net.Ipaddr.V4.loopback, !port))
+  and server = Cohttp_eio.Server.make ~callback:handler () in
+  Cohttp_eio.Server.run socket server ~on_error:log_warning

dream/runtime/ppx_deriving_router_runtime.ml

@@ -1,7 +1,20 @@
 open struct
+  module IO :
+    Ppx_deriving_router_runtime_lib.IO with type 'a t = 'a Lwt.t = struct
+    type 'a t = 'a Lwt.t
+
+    let return = Lwt.return
+    let fail = Lwt.fail
+    let bind = Lwt.bind
+    let catch = Lwt_result.catch
+  end
+
   module Request :
-    Ppx_deriving_router_runtime_lib.REQUEST with type t = Dream.request =
-  struct
+    Ppx_deriving_router_runtime_lib.REQUEST
+      with type 'a IO.t = 'a IO.t
+       and type t = Dream.request = struct
+    module IO = IO
+
     type t = Dream.request
 
     let queries = Dream.all_queries
@@ -19,8 +32,11 @@ open struct
 
   module Response :
     Ppx_deriving_router_runtime_lib.RESPONSE
-      with type status = Dream.status
+      with type 'a IO.t = 'a IO.t
+       and type status = Dream.status
        and type t = Dream.response = struct
+    module IO = IO
+
     type status = Dream.status
 
     let status_ok : status = `OK

dream/runtime/ppx_deriving_router_runtime.mli

@@ -1,6 +1,7 @@
 include
   Ppx_deriving_router_runtime_lib.S
-    with type Request.t = Dream.request
+    with type 'a IO.t = 'a Lwt.t
+     and type Request.t = Dream.request
      and type Response.t = Dream.response
      and type Response.status = Dream.status
      and type 'a Return.t = 'a

dune-project

@@ -18,7 +18,7 @@
 (package
  (name ppx_deriving_router)
  (synopsis "Derive typesafe router from type declarations")
- (depopts dream)
+ (depopts dream cohttp-eio)
  (depends
   (ocaml
    (>= 4.14))