From 2f18b8a33cabd0ea666781ba048d0174b4dc5031 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Sun, 1 Jun 2025 17:12:06 +0200 Subject: Initial commit --- lib/dream_handler/dream_handler.ml | 165 ++++++++++++++++++++++++++++++++++++ lib/dream_handler/dream_handler.mli | 47 ++++++++++ lib/dream_handler/dune | 13 +++ 3 files changed, 225 insertions(+) create mode 100644 lib/dream_handler/dream_handler.ml create mode 100644 lib/dream_handler/dream_handler.mli create mode 100644 lib/dream_handler/dune (limited to 'lib/dream_handler') diff --git a/lib/dream_handler/dream_handler.ml b/lib/dream_handler/dream_handler.ml new file mode 100644 index 0000000..0454b32 --- /dev/null +++ b/lib/dream_handler/dream_handler.ml @@ -0,0 +1,165 @@ +open Lwt_result.Syntax + +(** Extract the content from the body request. + + The module given in argument is the definition of the service. *) +let read_body : + (module Services.JsonServerHandler with type request = 'request) -> + Dream.request -> + ('request, Dream.response) result Lwt.t = + fun (type request) + (module S : Services.JsonServerHandler with type request = request) + request -> + let%lwt json = + match S.method_ with + | GET | HEAD -> + (* GET and HEAD method doesn’t have any body. We assume here the body + is typed as Unit *) + Lwt.return `Null + | _ -> + let%lwt body = Dream.body request in + Yojson.Safe.from_string body |> Lwt.return + in + let json_content = Lwt.return @@ S.request_of_yojson json in + Lwt_result.ok json_content + +let create_response : + (module Services.JsonServerHandler with type response = 'response) -> + ('response, Dream.response) result Lwt.t -> + Dream.response Dream.promise = + fun (type response) + (module S : Services.JsonServerHandler with type response = response) + response_content -> + let response = + let* response_content = response_content in + let yojson_content = S.yojson_of_response response_content in + Yojson.Safe.to_string yojson_content |> Lwt_result.return + in + match%lwt response with Ok json -> Dream.json json | Error e -> Lwt.return e + +(** Simple handler which read the content and apply the transformations to the + response. *) +let handle : + (module Services.JsonServerHandler + with type placeholders = 'placeholders + and type request = 'request + and type response = 'response) -> + ('placeholders -> 'request -> ('response, string) Lwt_result.t) -> + 'placeholders -> + Dream.handler = + fun (type placeholders request response) + (module S : Services.JsonServerHandler + with type placeholders = placeholders + and type response = response + and type request = request) f args request -> + let response = + let* body = read_body (module S) request in + Lwt_result.map_error + (fun e -> Dream.response ~status:`Internal_Server_Error e) + (f args body) + in + create_response (module S) response + +module MakeChecked (S : Services.JsonServerHandler) = struct + exception Invalid_method + + (** Derive the handler from the standard one by adding a new field [token] in + the request *) + module Service = struct + include S + open Ppx_yojson_conv_lib.Yojson_conv.Primitives + + type ('a, 'b) result = ('a, 'b) Result.t = Ok of 'a | Error of 'b + [@@deriving yojson] + + type request = { content : S.request; token : string } + [@@deriving of_yojson] + (** This type add the validation token in the body message *) + + let method_ : (request, response) Services.method_ = + match S.method_ with + (* We can’t add the crsf token with thoses methods because they do not + have body *) + | GET | HEAD -> raise Invalid_method + | POST -> POST + | PUT -> PUT + | DELETE -> DELETE + | CONNECT -> CONNECT + | OPTIONS -> OPTIONS + | TRACE -> TRACE + | PATCH -> PATCH + end + + let check_token : + Dream.request -> string -> (unit, Dream.response) Lwt_result.t = + fun request token -> + match%lwt Dream.verify_csrf_token request token with + | `Ok -> Lwt.return_ok () + | _ -> Lwt_result.fail (Dream.response ~status:`Unauthorized "") + + (** Override the handle function by checking the token validity *) + let handle : + (S.placeholders -> S.request -> (S.response, string) Lwt_result.t) -> + S.placeholders -> + Dream.handler = + fun f args request -> + let response = + let* content = read_body (module Service) request in + + (* Extract the token from the body and check the validity *) + let* () = check_token request content.token in + + Lwt_result.map_error + (fun e -> Dream.response ~status:`Internal_Server_Error e) + (f args content.content) + in + create_response (module Service) response +end + +let extract_param request name = + Dream.param request name |> Dream.from_percent_encoded + +let method' : type a b. + (a, b) Services.method_ -> string -> Dream.handler -> Dream.route = function + | GET -> Dream.get + | PUT -> Dream.put + | POST -> Dream.post + | DELETE -> Dream.delete + | HEAD -> Dream.head + | CONNECT -> Dream.connect + | OPTIONS -> Dream.options + | TRACE -> Dream.trace + | PATCH -> Dream.patch + +(** Handle the given URL encoded in the application. + + Use the type system to ensure that the path for the route will use the same + arguments name as in the extraction, and that this url will match the + signature for the handler + + [handle] method ?path url handler + + will call the [handler] with the arguments extracted from [url]. If [path] + is given, the route will be created against [path] instead, which allow to + use differents url inside a scope. *) +let register : + ?path:'placeholders Path.t -> + (module Services.JsonServerHandler with type placeholders = 'placeholders) -> + ('a -> Dream.handler) -> + Dream.route = + fun (type placeholders) ?path + (module S : Services.JsonServerHandler + with type placeholders = placeholders) f -> + let partial_handler = + (* There is no unification possible for the type p' and p when both are + available. + That’s why need to evaluate it now in order to remove any abstraction as + soon as possible *) + match path with + | None -> method' S.method_ Path.(repr' S.path) + | Some p' -> method' S.method_ Path.(repr' p') + in + + partial_handler (fun request -> + let placeholders = Path.unzip S.path (extract_param request) in + f placeholders request) diff --git a/lib/dream_handler/dream_handler.mli b/lib/dream_handler/dream_handler.mli new file mode 100644 index 0000000..636ba64 --- /dev/null +++ b/lib/dream_handler/dream_handler.mli @@ -0,0 +1,47 @@ +val handle : + (module Services.JsonServerHandler + with type placeholders = 'placeholders + and type request = 'request + and type response = 'response) -> + ('placeholders -> 'request -> ('response, string) Lwt_result.t) -> + 'placeholders -> + Dream.handler +(** [handle (module S) f] create a handler for the requests. + + @arg f is the function receiving the variable parts of the url, the body + (matching the type S.request), the request (in order to fetch the + parameters) and returning a content of type S.response. + + The function does not read any parameters from the URI, as the body is + supposed having all the required informations. + + *) + +module MakeChecked (S : Services.JsonServerHandler) : sig + exception Invalid_method + (** Exception raised if the method does not allow body content *) + + val handle : + (S.placeholders -> S.request -> (S.response, string) Lwt_result.t) -> + S.placeholders -> + Dream.handler +end + +val register : + ?path:'placeholders Path.t -> + (module Services.JsonServerHandler with type placeholders = 'placeholders) -> + ('placeholders -> Dream.handler) -> + Dream.route +(** Register a handler as a route. The module gives all the required information + (path, methods…) we need, and the handler can be created using the function + `handle` just above. + + {[ + let handler = + Dream_handler.handle + (module Service) + (fun (_args : Service.parameters) (_body : Services.request) -> + Lwt.return_ok _) + + let route = Route_builder.register (module Service) handler + ]}*) diff --git a/lib/dream_handler/dune b/lib/dream_handler/dune new file mode 100644 index 0000000..3e3ff18 --- /dev/null +++ b/lib/dream_handler/dune @@ -0,0 +1,13 @@ +(library + (name dream_handler) + + (libraries + lwt + dream + result + yojson + path + services) + (preprocess (pps ppx_yojson_conv lwt_ppx)) + ) + -- cgit v1.2.3