diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 6440f1d..80eebbf 100644 --- a/.github/workflows/main.yml +++ b/.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 diff --git a/cohttp-eio/dune b/cohttp-eio/dune new file mode 100644 index 0000000..d94d42f --- /dev/null +++ b/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)) diff --git a/cohttp-eio/runtime/dune b/cohttp-eio/runtime/dune new file mode 100644 index 0000000..ed0d30f --- /dev/null +++ b/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)) diff --git a/cohttp-eio/runtime/ppx_deriving_router_runtime.ml b/cohttp-eio/runtime/ppx_deriving_router_runtime.ml new file mode 100644 index 0000000..f28ea8d --- /dev/null +++ b/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) diff --git a/cohttp-eio/runtime/ppx_deriving_router_runtime.mli b/cohttp-eio/runtime/ppx_deriving_router_runtime.mli new file mode 100644 index 0000000..34bc7b6 --- /dev/null +++ b/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 diff --git a/cohttp-eio/test/dune b/cohttp-eio/test/dune new file mode 100644 index 0000000..55e2558 --- /dev/null +++ b/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))) diff --git a/cohttp-eio/test/routing.ml b/cohttp-eio/test/routing.ml new file mode 100644 index 0000000..e802727 --- /dev/null +++ b/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 diff --git a/cohttp-eio/test/test.ml b/cohttp-eio/test/test.ml new file mode 100644 index 0000000..cc0aaee --- /dev/null +++ b/cohttp-eio/test/test.ml @@ -0,0 +1,183 @@ +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 run () = + 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 + +let pages_handler = Pages.handle pages_handle +let api_handler = Api.handle { f = api_handle } + +let test () = + print_endline "# TESTING HREF GENERATION"; + print_endline (Pages.href Home); + print_endline (Pages.href (Route_with_implicit_path { param = None })); + print_endline + (Pages.href (Route_with_implicit_path { param = Some "ok" })); + print_endline + (Pages.href + (Hello { name = "world"; modifier = None; greeting = None })); + print_endline + (Pages.href + (Hello + { name = "world"; modifier = Some Uppercase; greeting = None })); + print_endline (Api.href (Get_user { id = 121 })); + print_endline + (All.href + (Pages (Hello { name = "world"; modifier = None; greeting = None }))); + print_endline (All.href (Api (Get_user { id = 121 }))); + print_endline + (Pages.href (User_info { user_id = User_id.inject "username" })); + print_endline + (Pages.href + (User_info_via_path { user_id = User_id.inject "username" })); + print_endline (Pages.href (Signal { level = Warning })); + print_endline + (Pages.href + (List_users + { user_ids = [ User_id.inject "u1"; User_id.inject "u2" ] })); + print_endline (Pages.href (List_users { user_ids = [] })); + print_endline (All.href (Static { path = "/js/main.js" })); + print_endline "# TESTING ROUTE MATCHING GENERATION"; + let test_req ?body h method_ target = + print_endline + (Printf.sprintf "## %s %s" (Http.Method.to_string method_) target); + let uri = Uri.of_string target in + let req = Request.make ~meth:method_ uri in + let body = + Option.map Eio.Flow.string_source body + |> Option.value ~default:(Eio.Flow.string_source "") + in + let resp, body = h (req, body) in + let body_as_string = Eio.Flow.read_all body in + print_endline + (Printf.sprintf "%s: %s" + (Cohttp.Code.string_of_status (Response.status resp)) + body_as_string) + in + test_req pages_handler `GET "/"; + test_req pages_handler `GET "/hello/world"; + test_req pages_handler `GET "/hello/world?modifier=uppercase"; + test_req pages_handler `GET "/Route_with_implicit_path"; + test_req pages_handler `GET "/Route_with_implicit_path?param=ok"; + test_req pages_handler `POST "/Route_with_implicit_path?param=ok"; + test_req pages_handler `GET "/Route_with_implicit_path_post"; + test_req pages_handler `POST "/Route_with_implicit_path_post"; + test_req pages_handler `GET "/Echo_options?options={a:42}"; + test_req pages_handler `GET "/User_info?user_id=username"; + test_req pages_handler `GET "/user/username_via_path"; + test_req pages_handler `GET "/Signal?level=2"; + test_req pages_handler `GET "/List_users?user_ids=u1&user_ids=u2"; + test_req pages_handler `GET "/List_users"; + print_endline "# TESTING ROUTE MATCHING GENERATION (API)"; + test_req api_handler `GET "/"; + test_req api_handler `POST "/"; + test_req api_handler ~body:"{}" `POST "/"; + test_req api_handler ~body:"1" `POST "/"; + test_req api_handler `GET "/121"; + test_req api_handler `GET "/raw-response"; + print_endline "# TESTING ROUTE MATCHING GENERATION (ALL)"; + test_req all_handler `GET "/hello/world"; + test_req all_handler `GET "/"; + test_req all_handler `GET "/nested/api/121"; + test_req pages_handler `GET + "/hello/pct%20encoded?greeting=pct%20encoded"; + test_req all_handler `GET "/static/js/main.js" + +let () = + match Sys.argv.(1) with + | exception Invalid_argument _ -> run () + | "run" -> run () + | "test" -> test () + | _ -> + prerr_endline "unknown subcommand"; + exit 1 diff --git a/cohttp-eio/test/test.mli b/cohttp-eio/test/test.mli new file mode 100644 index 0000000..e69de29 diff --git a/cohttp-eio/test/test.t b/cohttp-eio/test/test.t new file mode 100644 index 0000000..353c621 --- /dev/null +++ b/cohttp-eio/test/test.t @@ -0,0 +1,70 @@ + + $ ./test.exe test + # TESTING HREF GENERATION + / + /Route_with_implicit_path + /Route_with_implicit_path?param=ok + /hello/world + /hello/world?modifier=uppercase + /121 + /hello/world + /nested/api/121 + /User_info?user_id=username + /user/username + /Signal?level=1 + /List_users?user_ids=u1&user_ids=u2 + /List_users + /static/js/main.js + # TESTING ROUTE MATCHING GENERATION + ## GET / + 200 OK: HOME PAGE + ## GET /hello/world + 200 OK: Hello, world! + ## GET /hello/world?modifier=uppercase + 200 OK: Hello, WORLD! + ## GET /Route_with_implicit_path + 200 OK: works as well, param is: - + ## GET /Route_with_implicit_path?param=ok + 200 OK: works as well, param is: ok + ## POST /Route_with_implicit_path?param=ok + 405 Method Not Allowed: Method not allowed + ## GET /Route_with_implicit_path_post + 405 Method Not Allowed: Method not allowed + ## POST /Route_with_implicit_path_post + 200 OK: posted + ## GET /Echo_options?options={a:42} + 200 OK: {"a":42} + ## GET /User_info?user_id=username + 200 OK: User info for "username" + ## GET /user/username_via_path + 200 OK: User info for "username_via_path" + ## GET /Signal?level=2 + 200 OK: Signal: 2 + ## GET /List_users?user_ids=u1&user_ids=u2 + 200 OK: User ids = [u1, u2] + ## GET /List_users + 200 OK: User ids = [] + # TESTING ROUTE MATCHING GENERATION (API) + ## GET / + 200 OK: [] + ## POST / + 400 Bad Request: Invalid or missing request body: Blank input data + ## POST / + 400 Bad Request: Invalid or missing request body: Expected int, got object + ## POST / + 200 OK: {"id":1} + ## GET /121 + 200 OK: {"id":121} + ## GET /raw-response + 200 OK: RAW RESPONSE + # TESTING ROUTE MATCHING GENERATION (ALL) + ## GET /hello/world + 200 OK: Hello, world! + ## GET / + 200 OK: HOME PAGE + ## GET /nested/api/121 + 200 OK: {"id":121} + ## GET /hello/pct%20encoded?greeting=pct%20encoded + 200 OK: pct encoded, pct encoded! + ## GET /static/js/main.js + 200 OK: path="/js/main.js" diff --git a/dune-project b/dune-project index 81f83d2..24e7132 100644 --- a/dune-project +++ b/dune-project @@ -18,7 +18,7 @@ (package (name ppx_deriving_router) (synopsis "Derive typesafe router from type declarations") - (depopts dream http cohttp cohttp-lwt cohttp-lwt-unix) + (depopts dream http cohttp cohttp-lwt cohttp-lwt-unix eio cohttp-eio) (depends (ocaml (>= 4.14)) diff --git a/ppx_deriving_router.opam b/ppx_deriving_router.opam index a76ccd2..15d97fd 100644 --- a/ppx_deriving_router.opam +++ b/ppx_deriving_router.opam @@ -20,7 +20,9 @@ depends: [ "uri" "odoc" {with-doc} ] -depopts: ["dream" "http" "cohttp" "cohttp-lwt" "cohttp-lwt-unix"] +depopts: [ + "dream" "http" "cohttp" "cohttp-lwt" "cohttp-lwt-unix" "eio" "cohttp-eio" +] build: [ ["dune" "subst"] {dev} [