allow to define typed response

Author: andreypopp

native/lib/ppx_deriving_router.ml

@@ -75,12 +75,14 @@ let td_to_ty_handler param td =
         [%type:
           [%t td_to_ty (Some param) td] ->
           Ppx_deriving_router_runtime.request ->
-          [%t param] Lwt.t]
+          [%t param] Ppx_deriving_router_runtime.return Lwt.t]
   | None ->
       [%type:
         [%t td_to_ty param td] ->
         Ppx_deriving_router_runtime.request ->
-        Ppx_deriving_router_runtime.response Lwt.t]
+        Ppx_deriving_router_runtime.response
+        Ppx_deriving_router_runtime.return
+        Lwt.t]
 
 let td_to_ty_enc param td =
   let loc = td.ptype_loc in

native/runtime/ppx_deriving_router_runtime_lib.ml

@@ -1,8 +1,5 @@
 type http_method = [ `DELETE | `GET | `POST | `PUT ]
 
-type http_status =
-  [ `Not_Found | `Bad_Request | `Method_Not_Allowed | `OK ]
-
 module type REQUEST = sig
   type t
 
@@ -13,13 +10,26 @@ module type REQUEST = sig
 end
 
 module type RESPONSE = sig
+  type status
+
+  val status_ok : status
+  val status_bad_request : status
+  val status_not_found : status
+  val status_method_not_allowed : status
+
   type t
 
   val respond :
-    status:http_status ->
-    headers:(string * string) list ->
-    string ->
-    t Lwt.t
+    status:status -> headers:(string * string) list -> string -> t Lwt.t
+end
+
+module type RETURN = sig
+  type status
+  type 'a t
+
+  val data : 'a t -> 'a option
+  val status : _ t -> status option
+  val headers : _ t -> (string * string) list
 end
 
 module type S = sig
@@ -33,6 +43,10 @@ module type S = sig
 
   type response = Response.t
 
+  module Return : RETURN
+
+  type 'a return = 'a Return.t
+
   module Encode : module type of Ppx_deriving_router_encode
   module Decode : module type of Ppx_deriving_router_decode
   module Primitives : module type of Ppx_deriving_router_primitives
@@ -47,7 +61,7 @@ module type S = sig
       | Encode_raw : response encode
       | Encode_json : ('a -> json) -> 'a encode
 
-    val encode : 'a encode -> 'a -> response Lwt.t
+    val encode : 'a encode -> 'a return -> response Lwt.t
 
     type 'v route =
       | Route : ('a, 'v) Routes.path * 'a * ('v -> 'w) -> 'w route
@@ -80,15 +94,23 @@ module type S = sig
   end
 end
 
-module Make (Request : REQUEST) (Response : RESPONSE) :
-  S with type Request.t = Request.t and type Response.t = Response.t =
-struct
+module Make
+    (Request : REQUEST)
+    (Response : RESPONSE)
+    (Return : RETURN with type status = Response.status) :
+  S
+    with type Request.t = Request.t
+     and type Response.t = Response.t
+     and type Response.status = Response.status
+     and type 'a Return.t = 'a Return.t = struct
   type json = Yojson.Basic.t
   type request = Request.t
   type response = Response.t
+  type 'a return = 'a Return.t
 
   module Request = Request
   module Response = Response
+  module Return = Return
   module Encode = Ppx_deriving_router_encode
   module Decode = Ppx_deriving_router_decode
   module Primitives = Ppx_deriving_router_primitives
@@ -103,14 +125,24 @@ struct
       | Encode_raw : response encode
       | Encode_json : ('a -> json) -> 'a encode
 
-    let encode : type a. a encode -> a -> response Lwt.t =
+    let encode : type a. a encode -> a Return.t -> response Lwt.t =
      fun enc x ->
+      let status =
+        Option.value ~default:Response.status_ok (Return.status x)
+      in
+      let headers = Return.headers x in
       match enc, x with
-      | Encode_raw, x -> Lwt.return x
-      | Encode_json to_json, x ->
-          Response.respond ~status:`OK
-            ~headers:[ "Content-Type", "application/json" ]
-            (Yojson.Basic.to_string (to_json x))
+      | Encode_raw, x -> (
+          match Return.data x with
+          | None -> Response.respond ~status ~headers ""
+          | Some x -> Lwt.return x)
+      | Encode_json to_json, x -> (
+          match Return.data x with
+          | None -> Response.respond ~status ~headers ""
+          | Some x ->
+              Response.respond ~status
+                ~headers:(("Content-Type", "application/json") :: headers)
+                (Yojson.Basic.to_string (to_json x)))
 
     type 'v route =
       | Route : ('a, 'v) Routes.path * 'a * ('v -> 'w) -> 'w route
@@ -151,16 +183,19 @@ struct
       Lwt.bind (dispatch router req) (function
         | `Ok v -> f v req
         | `Invalid_query_parameter (param, msg) ->
-            Response.respond ~status:`Bad_Request ~headers:[]
+            Response.respond ~status:Response.status_bad_request
+              ~headers:[]
               (Printf.sprintf "error processing query parameter %S: %s"
                  param msg)
         | `Invalid_body reason ->
-            Response.respond ~status:`Bad_Request ~headers:[]
+            Response.respond ~status:Response.status_bad_request
+              ~headers:[]
               (Printf.sprintf "Invalid or missing request body: %s" reason)
         | `Method_not_allowed ->
-            Response.respond ~status:`Method_Not_Allowed ~headers:[]
-              "Method not allowed"
+            Response.respond ~status:Response.status_method_not_allowed
+              ~headers:[] "Method not allowed"
         | `Not_found ->
-            Response.respond ~status:`Not_Found ~headers:[] "Not found")
+            Response.respond ~status:Response.status_not_found ~headers:[]
+              "Not found")
   end
 end

native/runtime/ppx_deriving_router_runtime_lib.mli

@@ -1,5 +1,13 @@
+type 'a v = {
+  data : 'a option;
+  headers : (string * string) list;
+  status : Dream.status option;
+}
+
 open struct
-  module Request = struct
+  module Request :
+    Ppx_deriving_router_runtime_lib.REQUEST with type t = Dream.request =
+  struct
     type t = Dream.request
 
     let queries = Dream.all_queries
@@ -15,12 +23,48 @@ open struct
       | _ -> failwith "Unsupported method"
   end
 
-  module Response = struct
+  module Response :
+    Ppx_deriving_router_runtime_lib.RESPONSE
+      with type status = Dream.status
+       and type t = Dream.response = struct
+    type status = Dream.status
+
+    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 = Dream.response
 
     let respond ~status ~headers body =
       Dream.respond ~status ~headers body
   end
+
+  module Return :
+    Ppx_deriving_router_runtime_lib.RETURN
+      with type status = Dream.status
+       and type 'a t = 'a v = struct
+    type status = Dream.status
+
+    type 'a t = 'a v = {
+      data : 'a option;
+      headers : (string * string) list;
+      status : status option;
+    }
+
+    let data x = x.data
+    let status x = x.status
+    let headers x = x.headers
+  end
 end
 
-include Ppx_deriving_router_runtime_lib.Make (Request) (Response)
+include Ppx_deriving_router_runtime_lib.Make (Request) (Response) (Return)
+
+module Return = struct
+  include Return
+
+  type 'a t = 'a v
+
+  let return ?status ?(headers = []) data =
+    Lwt.return { data = Some data; headers; status }
+end

native/runtime_dream/ppx_deriving_router_runtime.ml

@@ -1,4 +1,22 @@
+type 'a v = {
+  data : 'a option;
+  headers : (string * string) list;
+  status : Dream.status option;
+}
+
 include
   Ppx_deriving_router_runtime_lib.S
     with type Request.t = Dream.request
      and type Response.t = Dream.response
+     and type Response.status = Dream.status
+     and type 'a Return.t = 'a v
+
+module Return : sig
+  include Ppx_deriving_router_runtime_lib.RETURN with type 'a t = 'a v
+
+  val return :
+    ?status:Dream.status ->
+    ?headers:(string * string) list ->
+    'a ->
+    'a return Lwt.t
+end

native/runtime_dream/ppx_deriving_router_runtime.mli

@@ -1,13 +1,15 @@
 open Routing
 open Lwt.Infix
 
+let return = Ppx_deriving_router_runtime.Return.return
+
 let pages_handle route _req =
   match route with
-  | Pages.Home -> Dream.html "HOME PAGE"
+  | Pages.Home -> return (Dream.response "HOME PAGE")
   | Route_with_implicit_path { param } ->
       let param = Option.value ~default:"-" param in
-      Dream.html ("works as well, param is: " ^ param)
-  | Route_with_implicit_path_post -> Dream.html "posted"
+      return (Dream.response ("works as well, param is: " ^ param))
+  | Route_with_implicit_path_post -> return (Dream.response "posted")
   | Hello { name; modifier } ->
       let name =
         match modifier with
@@ -16,22 +18,29 @@ let pages_handle route _req =
         | Some Lowercase -> String.lowercase_ascii name
       in
       let greeting = Printf.sprintf "Hello, %s!" name in
-      Dream.html greeting
+      return (Dream.response greeting)
 
 let pages_handler = Pages.handle pages_handle
 
-let api_handle : type a. a Api.t -> Dream.request -> a Lwt.t =
+let api_handle :
+    type a.
+    a Api.t -> Dream.request -> a Ppx_deriving_router_runtime.return Lwt.t
+    =
  fun x _req ->
   match x with
-  | Raw_response -> Dream.respond "RAW RESPONSE"
-  | List_users -> Lwt.return []
-  | Create_user { id } -> Lwt.return { Api.id }
-  | Get_user { id } -> Lwt.return { Api.id }
+  | Raw_response -> return (Dream.response "RAW RESPONSE")
+  | List_users -> return []
+  | Create_user { id } -> return { Api.id }
+  | Get_user { id } -> return { Api.id }
 
 let api_handler : Dream.handler = Api.handle { f = api_handle }
 
 let all_handler : Dream.handler =
-  let f : type a. a All.t -> Dream.request -> a Lwt.t =
+  let f :
+      type a.
+      a All.t ->
+      Dream.request ->
+      a Ppx_deriving_router_runtime.return Lwt.t =
    fun x req ->
     match x with
     | Pages p -> pages_handle p req