Add ppx_deriving_router.cohttp_lwt (#8)

Author: davesnx

.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 --yes
+      - run: opam install dream http cohttp cohttp-lwt cohttp-lwt-unix --yes
       - run: opam exec -- dune build -p ppx_deriving_router
       # run tests
       - run: opam install . --deps-only --with-test

cohttp-lwt/dune

@@ -0,0 +1,8 @@
+(library
+ (name ppx_deriving_router_cohttp_lwt)
+ (public_name ppx_deriving_router.cohttp_lwt)
+ (virtual_deps http cohttp cohttp-lwt cohttp-lwt-unix)
+ (optional)
+ (libraries ppx_deriving_router)
+ (ppx_runtime_libraries ppx_deriving_router.cohttp_lwt_runtime)
+ (kind ppx_deriver))

cohttp-lwt/runtime/dune

@@ -0,0 +1,13 @@
+(library
+ (name ppx_deriving_router_runtime_cohttp_lwt_runtime)
+ (public_name ppx_deriving_router.cohttp_lwt_runtime)
+ (virtual_deps http cohttp cohttp-lwt cohttp-lwt-unix)
+ (optional)
+ (wrapped false)
+ (libraries
+  http
+  cohttp
+  cohttp-lwt
+  cohttp-lwt-unix
+  ppx_deriving_router.runtime_lib
+  melange-json-native.ppx-runtime))

cohttp-lwt/runtime/ppx_deriving_router_runtime.ml

@@ -0,0 +1,80 @@
+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 = Cohttp_lwt_unix.Request.t * Cohttp_lwt.Body.t
+       and type 'a IO.t = 'a IO.t = struct
+    module IO = IO
+
+    type t = Cohttp_lwt_unix.Request.t * Cohttp_lwt.Body.t
+
+    let queries (request, _body) =
+      let uri = Cohttp_lwt_unix.Request.uri request in
+      Uri.query uri
+      |> List.map (fun (k, vs) -> List.map (fun v -> k, v) vs)
+      |> List.flatten
+
+    let body ((_request, body) : t) = Cohttp_lwt.Body.to_string body
+
+    let path (request, _body) =
+      let uri = Cohttp_lwt_unix.Request.uri request in
+      Uri.path uri
+
+    let method_ (request, _body) =
+      match Cohttp_lwt_unix.Request.meth request with
+      | `GET -> `GET
+      | `POST -> `POST
+      | `PUT -> `PUT
+      | `DELETE -> `DELETE
+      | `HEAD -> failwith "HEAD is not supported"
+      | `PATCH -> failwith "PATCH is not supported"
+      | `OPTIONS -> failwith "OPTIONS is not supported"
+      | `TRACE -> failwith "TRACE is not supported"
+      | `CONNECT -> failwith "CONNECT is not supported"
+      | `Other other ->
+          failwith (Printf.sprintf "%s is not supported" other)
+  end
+
+  module Response :
+    Ppx_deriving_router_runtime_lib.RESPONSE
+      with type t = Cohttp_lwt_unix.Response.t * Cohttp_lwt.Body.t
+       and type status = Cohttp.Code.status_code
+       and type 'a IO.t = 'a IO.t = struct
+    module IO = IO
+
+    type t = Cohttp_lwt_unix.Response.t * Cohttp_lwt.Body.t
+    type status = Cohttp.Code.status_code
+
+    let status_ok : status = `OK
+    let status_not_found : status = `Not_found
+    let status_bad_request : status = `Bad_request
+    let status_method_not_allowed : status = `Method_not_allowed
+
+    let respond ~status ~headers body : t Lwt.t =
+      let headers = Cohttp.Header.of_list headers in
+      Cohttp_lwt_unix.Server.respond_string ~body ~status ~headers ()
+  end
+
+  module Return :
+    Ppx_deriving_router_runtime_lib.RETURN
+      with type status = Cohttp.Code.status_code
+       and type 'a t = 'a = struct
+    type 'a t = 'a
+    type status = Cohttp.Code.status_code
+
+    let data x = Some x
+    let status _ = None
+    let headers _ = []
+  end
+end
+
+include Ppx_deriving_router_runtime_lib.Make (Request) (Response) (Return)

cohttp-lwt/runtime/ppx_deriving_router_runtime.mli

@@ -0,0 +1,7 @@
+include
+  Ppx_deriving_router_runtime_lib.S
+    with type 'a IO.t = 'a Lwt.t
+     and type Request.t = Cohttp_lwt_unix.Request.t * Cohttp_lwt.Body.t
+     and type Response.t = Cohttp_lwt_unix.Response.t * Cohttp_lwt.Body.t
+     and type Response.status = Cohttp.Code.status_code
+     and type 'a Return.t = 'a

cohttp-lwt/test/dune

@@ -0,0 +1,9 @@
+(executable
+ (name test)
+ (preprocess
+  (pps ppx_deriving_router.cohttp_lwt melange-json-native.ppx)))
+
+(cram
+ (deps
+  ./test.exe
+  (package ppx_deriving_router)))

cohttp-lwt/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