diff options
| author | Sébastien Dailly <sebastien@dailly.me> | 2025-06-01 17:12:06 +0200 |
|---|---|---|
| committer | Sébastien Dailly <sebastien@dailly.me> | 2025-06-14 10:58:01 +0200 |
| commit | 2f18b8a33cabd0ea666781ba048d0174b4dc5031 (patch) | |
| tree | aacda421b89e8133e3c73942e9ede61283a5005c | |
Initial commit
36 files changed, 1265 insertions, 0 deletions
diff --git a/bin/client.ml b/bin/client.ml new file mode 100644 index 0000000..17284e1 --- /dev/null +++ b/bin/client.ml @@ -0,0 +1,23 @@ +open Lwt.Syntax + +let root = "http://[::1]:8080" + +let request = + let* result = + Cohttp_handler.request ~root + (module Services_impl.Nb_car) + () { value = "foobar" } + in + match result with + | Error code -> + prerr_endline ("Got code " ^ code); + Lwt.return_unit + | Ok { value; nbcar } -> + print_endline + (String.concat " " + [ + "The number of characters for"; value; "is"; Int64.to_string nbcar; + ]); + Lwt.return_unit + +let _ = Lwt_main.run request diff --git a/bin/dune b/bin/dune new file mode 100644 index 0000000..7044b82 --- /dev/null +++ b/bin/dune @@ -0,0 +1,22 @@ +(executables + (public_names dream_service client) + (names main client) + (libraries + lwt + lwt.unix + dream + dream_handler + cohttp_handler + uri + services + services_impl + ) + ) + + +(rule + (target jsAssets.ml) + (deps (glob_files js_assets/**)) + (action (with-stdout-to %{null} + (run ocaml-crunch -m plain js_assets/ -o %{target})))) + diff --git a/bin/js_assets/dune b/bin/js_assets/dune new file mode 100644 index 0000000..155a383 --- /dev/null +++ b/bin/js_assets/dune @@ -0,0 +1,3 @@ +; Copy the files generated with js_of_ocaml into this directory. +; We have to explicitaly name the targets we want to include here. +(copy_files ../../js/content.js) diff --git a/bin/main.ml b/bin/main.ml new file mode 100644 index 0000000..f1f0cfd --- /dev/null +++ b/bin/main.ml @@ -0,0 +1,58 @@ +(** Create the handler for the service *) +let handler = + Dream_handler.handle + (module Services_impl.Nb_car) + (fun (() : Services_impl.Nb_car.placeholders) body -> + Lwt.return_ok + Services_impl.Nb_car. + { + value = body.value; + nbcar = Int64.of_int (String.length body.value); + }) + +(* The handler and the route are not created at the same time because we may + want create a specific handler, for example one checking CRSF in the query + and can’t infer this from the service signature only *) + +(** And create the route. *) +let route = Dream_handler.register (module Services_impl.Nb_car) handler + +(** Generate a default static page *) +let hello : Dream.handler = + fun _ -> + Dream.html + {|<html> + <body> + <h1>Hello!</h1> + <div> + <noscript>Sorry, you need to enable JavaScript to see this page.</noscript> + <script id="lib" type="text/javascript" defer="defer" src="js/content.js"></script> + <script> + var script = document.getElementById('lib'); + lib.addEventListener('load', function() { + client.start() + }) + </script> + </div> + <div id="content" /> + </body> +</html>|} + +let js_assets _root path _request = + (* This module is automatically generated — see the dune file to see the rule *) + match JsAssets.read path with + | None -> Dream.empty `Not_Found + | Some asset -> Dream.respond asset + +let () = + Dream.run @@ Dream.logger + @@ Dream.router + [ + Dream.get "/js/**" (Dream.static ~loader:js_assets ""); + Dream.get "/" hello; + route; + ] + +(* Now test the application by connecting to + http://localhost:8080/ + *) diff --git a/dream_service.opam b/dream_service.opam new file mode 100644 index 0000000..55a27b2 --- /dev/null +++ b/dream_service.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "A short synopsis" +description: "A longer description" +maintainer: ["Maintainer Name <maintainer@example.com>"] +authors: ["Author Name <author@example.com>"] +license: "LICENSE" +tags: ["add topics" "to describe" "your" "project"] +homepage: "https://github.com/username/reponame" +doc: "https://url/to/documentation" +bug-reports: "https://github.com/username/reponame/issues" +depends: [ + "dune" {>= "3.19"} + "ocaml" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/username/reponame.git" +x-maintenance-intent: ["(latest)"] diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..d14c1f0 --- /dev/null +++ b/dune-project @@ -0,0 +1,27 @@ +(lang dune 3.19) + +(name dream_service) + +(generate_opam_files true) +(implicit_transitive_deps false) + +(source + (github username/reponame)) + +(authors "Author Name <author@example.com>") + +(maintainers "Maintainer Name <maintainer@example.com>") + +(license LICENSE) + +(documentation https://url/to/documentation) + +(package + (name dream_service) + (synopsis "A short synopsis") + (description "A longer description") + (depends ocaml) + (tags + ("add topics" "to describe" your project))) + +; See the complete stanza docs at https://dune.readthedocs.io/en/stable/reference/dune-project/index.html diff --git a/js/application.ml b/js/application.ml new file mode 100755 index 0000000..fcc3fb4 --- /dev/null +++ b/js/application.ml @@ -0,0 +1,31 @@ +module Make (S : sig + type t +end) = +struct + module State = S + + module type Processor = sig + type t + + val process : t -> S.t -> S.t + end + + module ID : Processor with type t = unit = struct + type t = unit + + let process () state = state + end + + type event = E : 'a * (module Processor with type t = 'a) -> event + + (** Simple helper for the main event loop *) + let run : ?eq:(S.t -> S.t -> bool) -> S.t -> event Note.E.t -> S.t Note.S.t = + fun ?eq init event -> + let action = + Note.E.map (fun (E (t, (module P))) st -> P.process t st) event + in + Note.S.accum ?eq init action + + let dispatch : (module Processor with type t = 's) -> 's -> event = + fun (type s) (module P : Processor with type t = s) v -> E (v, (module P)) +end diff --git a/js/application.mli b/js/application.mli new file mode 100644 index 0000000..2e813f5 --- /dev/null +++ b/js/application.mli @@ -0,0 +1,63 @@ +(** The Make module build the main application loop.contents + + The function [run] update the state on each event, and return a new state. + Each event must follow the [event] type, which is composed from the type + [t], and a module with a fonction [update]. + + This example create an application with the state containing a simple + counter. An even which increment this counter is created and can be used to + update the state. + + {[ + type state = { value : int } + + (** Increment the state. *) + module Incr = struct + type t = unit + + let process () state = { value = state.value + 1 } + end + + (** Decrement the state. *) + module Incr = struct + type t = unit + + let process () state = { value = state.value - 1 } + end + + module App = Make(struct type t = state end) + + (* Create the event processor *) + let incr_event = App.dispatch (module Incr) () + and decr_event = App.dispatch (module Decr) () in + + let init = { value = 0 } in + + (* Run the main loop *) + let state = App.run + init + (E.select + [ incr_event + ; decr_event ] ) in … + ]} *) +module Make (S : sig + type t +end) : sig + module type Processor = sig + type t + + val process : t -> S.t -> S.t + end + + module ID : Processor with type t = unit + + type event + + val dispatch : (module Processor with type t = 's) -> 's -> event + (** [dispatch (module P) v] will create an event holding a value [v] and + associated with the processor [P] *) + + val run : ?eq:(S.t -> S.t -> bool) -> S.t -> event Note.E.t -> S.t Note.S.t + (** The function [run state ev] will create a signal continually updated each + time the event [ev] occur *) +end diff --git a/js/content.ml b/js/content.ml new file mode 100644 index 0000000..f41bc46 --- /dev/null +++ b/js/content.ml @@ -0,0 +1,122 @@ +module OptionInfix = Operators.Binding (Option) + +let add_field : + label:Jstr.t -> + id':Jstr.t -> + value':Jstr.t -> + Brr.El.t list -> + Brr.El.t list = + fun ~label ~id' ~value' elt -> + Brr.El.label ~at:Brr.At.[ for' id' ] [ Brr.El.txt label ] + :: Brr.El.input ~at:Brr.At.[ type' (Jstr.v "text"); id id'; value value' ] () + :: elt + +module State = struct + type t = { word : string; len : int; counter : int } + + let repr_html : t -> Brr.El.t list = + fun { word; len; counter } -> + [ + Brr.El.form + @@ add_field ~id':(Jstr.v "text_state") ~label:(Jstr.v "Word received") + ~value':(Jstr.v word) + @@ add_field ~id':(Jstr.v "nbcar_state") ~label:(Jstr.v "Nb of car") + ~value':(Jstr.of_int len) + @@ add_field ~id':(Jstr.v "counter_state") ~label:(Jstr.v "Request sent") + ~value':(Jstr.of_int counter) []; + ] +end + +(** Service transforming the response from the request into the state *) +module WordCount = struct + type t = Services_impl.Nb_car.response + + let process response state = + Brr.Console.log + [ + Jstr.v response.Services_impl.Nb_car.value; + Int64.to_int response.Services_impl.Nb_car.nbcar; + ]; + State. + { + counter = state.counter + 1; + word = response.Services_impl.Nb_car.value; + len = Int64.to_int response.Services_impl.Nb_car.nbcar; + } +end + +module App = Application.Make (State) + +let main () = + let open OptionInfix in + let- content_div = + Brr.Document.find_el_by_id Brr.G.document (Jstr.v "content") + in + + let form = + Brr.El.form + [ + Brr.El.label + ~at:Brr.At.[ for' (Jstr.v "text") ] + [ Brr.El.txt (Jstr.v "Text") ]; + Brr.El.input + ~at: + Brr.At. + [ + type' (Jstr.v "text"); id (Jstr.v "text"); name (Jstr.v "text"); + ] + (); + Brr.El.input + ~at:Brr.At.[ type' (Jstr.v "submit"); value (Jstr.v "Count") ] + (); + ] + in + + (* Listen the submit event on the form. This is an example of event of event : + + First we listen for the click event, and then for the request response + event. *) + let post_event : Brr.El.t -> App.event Note.event = + fun form -> + Note.E.join + @@ Note_brr.Evr.on_el Brr_io.Form.Ev.submit + (fun ev -> + (* Do not send the query, we use it with javascript *) + Brr.Ev.prevent_default ev; + + (* Extract the data from the form *) + let data = Brr_io.Form.(Data.of_form (of_el form)) in + let text_value = Brr_io.Form.Data.find data (Jstr.v "text") in + let value = + match text_value with + | Some (`String s) -> Jstr.to_string s + | _ -> "" + in + + (* Send the request *) + Js_handler.send (module Services_impl.Nb_car) () { value } + |> Note_brr.Futr.to_event + |> Note.E.map (function + | Error _ -> App.dispatch (module App.ID) () + | Ok response -> App.dispatch (module WordCount) response)) + form + in + let bottom = Brr.El.div [] in + Brr.El.append_children content_div [ form; Brr.El.hr (); bottom ]; + + let state = + App.run + { word = ""; len = 0; counter = 0 } + (Note.E.select [ post_event form ]) + in + + Note_brr.Elr.def_children bottom (Note.S.map State.repr_html state); + + let log state = ignore state in + Note.Logr.hold (Note.S.log state log) + +let () = + Brr.Console.(debug [ Jstr.v "Js started" ]); + let open Jv in + let post = obj [| ("start", repr main) |] in + set global "client" post @@ -0,0 +1,23 @@ +(executable + (name content) + (libraries + brr + note + note.brr + + operators + services_impl + js_handler + brr_string + ) + (modes js) + (preprocess (pps js_of_ocaml-ppx)) + (link_flags (:standard -no-check-prims)) + (js_of_ocaml (flags :standard --opt 3 --target-env browser --disable genprim --disable debugger)) + ) + +(rule + (targets content.js) + (deps content.bc.js) + (action (copy %{deps} %{targets}))) + diff --git a/lib/brr_handler/dune b/lib/brr_handler/dune new file mode 100644 index 0000000..7d096c9 --- /dev/null +++ b/lib/brr_handler/dune @@ -0,0 +1,11 @@ +(library + (name js_handler) + (libraries + brr + yojson + v_string + path + services + ) + (preprocess (pps ppx_yojson_conv lwt_ppx)) + ) diff --git a/lib/brr_handler/js_handler.ml b/lib/brr_handler/js_handler.ml new file mode 100644 index 0000000..71e1ce6 --- /dev/null +++ b/lib/brr_handler/js_handler.ml @@ -0,0 +1,53 @@ +let get_method : type a b. (a, b) Services.method_ -> Jstr.t = function + | GET -> Jstr.v "GET" + | POST -> Jstr.v "POST" + | PUT -> Jstr.v "PUT" + | DELETE -> Jstr.v "DELETE" + | HEAD -> Jstr.v "HEAD" + | CONNECT -> Jstr.v "CONNECT" + | OPTIONS -> Jstr.v "OPTIONS" + | TRACE -> Jstr.v "TRACE" + | PATCH -> Jstr.v "PATCH" + +let send : + (module Services.JsonClientHandler + with type request = 'request + and type response = 'response + and type placeholders = 'placeholders) -> + 'placeholders -> + 'request -> + ('response, Jv.Error.t) Fut.result = + fun (type request response placeholders) + (module S : Services.JsonClientHandler + with type request = request + and type response = response + and type placeholders = placeholders) parameters request -> + let json_repr = + S.yojson_of_request request |> Ppx_yojson_conv_lib.Yojson.Safe.to_string + in + let body = + match S.method_ with + | GET | HEAD -> None + | _ -> Some (Brr_io.Fetch.Body.of_jstr (Jstr.of_string json_repr)) + in + let init = + Brr_io.Fetch.Request.init ?body ~method':(get_method S.method_) () + in + + (* There is no way to retreive the type of the string from the virtual module. + I know the type match, but I have to tell this to the compiler… + *) + let url_of_string : V_string.t -> Jstr.t = Obj.magic in + let url' : Jstr.t = url_of_string @@ Path.build parameters S.path in + let response = Brr_io.Fetch.(request @@ Request.v ~init url') in + + (* Now handle the response *) + let open Fut.Result_syntax in + let* content = response in + let body = Brr_io.Fetch.Response.as_body content in + let* str_body = Brr_io.Fetch.Body.text body in + let str = Jstr.to_string str_body in + try + let json = Ppx_yojson_conv_lib.Yojson.Safe.from_string str in + Result.Ok (S.response_of_yojson json) |> Fut.return + with Yojson.Json_error err -> Fut.error (Jv.Error.v (Jstr.v err)) diff --git a/lib/brr_handler/js_handler.mli b/lib/brr_handler/js_handler.mli new file mode 100644 index 0000000..c8611f7 --- /dev/null +++ b/lib/brr_handler/js_handler.mli @@ -0,0 +1,8 @@ +val send : + (module Services.JsonClientHandler + with type request = 'request + and type response = 'response + and type placeholders = 'placeholders) -> + 'placeholders -> + 'request -> + ('response, Jv.Error.t) Fut.result diff --git a/lib/cohttp_handler/cohttp_handler.ml b/lib/cohttp_handler/cohttp_handler.ml new file mode 100644 index 0000000..3842e7c --- /dev/null +++ b/lib/cohttp_handler/cohttp_handler.ml @@ -0,0 +1,83 @@ +open Cohttp_lwt_unix +open Lwt.Syntax + +let url_of_string : V_string.t -> string = Obj.magic + +let code_of_response : Response.t -> (int, string) Result.t = + fun resp -> + let code = resp |> Response.status |> Cohttp.Code.code_of_status in + match Cohttp.Code.is_success code with + | true -> Ok 200 + | false -> Error (string_of_int code) + +let get_method : type a b. (a, b) Services.method_ -> Http.Method.t = function + | POST -> `POST + | GET -> `GET + | PUT -> `PUT + | DELETE -> `DELETE + | PATCH -> `PATCH + | HEAD -> `HEAD + | CONNECT -> `CONNECT + | OPTIONS -> `OPTIONS + | TRACE -> `TRACE + +(** Encodde the response given by cohttp for the service *) +let map_response : + (module Services.JsonClientHandler + with type request = 'request + and type response = 'response + and type placeholders = 'placeholders) -> + Cohttp_lwt.Body.t -> + 'response Lwt.t = + fun (type request response placeholders) + (module S : Services.JsonClientHandler + with type request = request + and type response = response + and type placeholders = placeholders) body -> + match S.method_ with + | GET | POST | PUT | DELETE | PATCH | CONNECT | OPTIONS | TRACE -> + let* body_content = Cohttp_lwt.Body.to_string body in + let json = Ppx_yojson_conv_lib.Yojson.Safe.from_string body_content in + Lwt.return (S.response_of_yojson json) + | HEAD -> Lwt.return_unit + +let request : + root:string -> + (module Services.JsonClientHandler + with type request = 'request + and type response = 'response + and type placeholders = 'placeholders) -> + 'placeholders -> + 'request -> + ('response, string) result Lwt.t = + fun (type request response placeholders) ~root + (module S : Services.JsonClientHandler + with type request = request + and type response = response + and type placeholders = placeholders) parameters request -> + let uri = + V_string.concat ~sep:(V_string.v "/") + [ V_string.v root; Path.build parameters S.path ] + in + + (* There is no body for GET or HEAD method *) + let request_body = + match S.method_ with + | Services.GET | Services.HEAD -> None + | _ -> + Some + (request |> S.yojson_of_request + |> Ppx_yojson_conv_lib.Yojson.Safe.to_string + |> Cohttp_lwt.Body.of_string) + in + + let uri = Uri.of_string (url_of_string uri) in + let* response, body = + Client.call ?headers:None ?body:request_body (get_method S.method_) uri + in + + match code_of_response response with + | Error _ as e -> Lwt.return e + | Ok _ -> + let* response_body = map_response (module S) body in + Lwt.return_ok response_body diff --git a/lib/cohttp_handler/dune b/lib/cohttp_handler/dune new file mode 100644 index 0000000..3aabbd0 --- /dev/null +++ b/lib/cohttp_handler/dune @@ -0,0 +1,15 @@ +(library + (name cohttp_handler) + (libraries + uri + cohttp + cohttp-lwt + cohttp-lwt-unix + + operators + v_string + path + services + ) + (preprocess (pps ppx_yojson_conv lwt_ppx)) + ) 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)) + ) + diff --git a/lib/dune b/lib/dune new file mode 100644 index 0000000..75fa3fa --- /dev/null +++ b/lib/dune @@ -0,0 +1,2 @@ +(library + (name dream_service)) diff --git a/lib/operators/dune b/lib/operators/dune new file mode 100644 index 0000000..c3eb766 --- /dev/null +++ b/lib/operators/dune @@ -0,0 +1,4 @@ +(library + (name operators) + + (libraries lwt)) diff --git a/lib/operators/operators.ml b/lib/operators/operators.ml new file mode 100644 index 0000000..88d8563 --- /dev/null +++ b/lib/operators/operators.ml @@ -0,0 +1,94 @@ +module type T = sig + type 'a t + + val iter : ('a -> unit) -> 'a t -> unit + val map : ('a -> 'b) -> 'a t -> 'b t + val bind : 'a t -> ('a -> 'b t) -> 'b t +end + +module DefaultIter (T : sig + type 'a t + + val map : ('a -> 'b) -> 'a t -> 'b t +end) = +struct + let iter f v = ignore (T.map f v) +end + +module type MONAD = sig + type 'a t + + val map : ('a -> 'b) -> 'a t -> 'b t + val return : 'a -> 'a t + val bind : 'a t -> ('a -> 'b t) -> 'b t +end + +module Binding (T : T) = struct + (* Create the let binding operators for a module. + + - let* is the binding operator we can find in a monad. + - let/ is the map operator + - let- is the operator which reduce to unit. (I wanted to use . as symbol + like in caqti, but this is not allowed ) + + The list of the symbols used is describe here : + https://v2.ocaml.org/manual/bindingops.html#start-section + *) + + let ( let* ) : 'a T.t -> ('a -> 'b T.t) -> 'b T.t = T.bind + let ( let+ ) : 'a T.t -> ('a -> 'b) -> 'b T.t = fun t f -> T.map f t + let ( let- ) : 'a T.t -> ('a -> unit) -> unit = fun t f -> T.iter f t +end + +module type Traversable = sig + type 'a t + + (** + + Build the traversable module. + + [>] means that the parameter is not wrapped in the MONAD + [**] means that the function is returning both a MONAD and the type + [*] means that the function binding into a new MONAD + + The name is choosen in order to make sense in the successive binding. You + should have the first binding using [let>…] form, then [let_], and finally + just [let] + + *) + module Make (T : MONAD) : sig + val ( let>** ) : 'a t -> ('a -> 'b t T.t) -> 'b t T.t + val ( let>* ) : 'a t -> ('a -> 'b T.t) -> 'b t T.t + val ( let** ) : 'a t T.t -> ('a -> 'b t T.t) -> 'b t T.t + val ( let* ) : 'a t T.t -> ('a -> 'b T.t) -> 'b t T.t + end +end + +module TraversableResult : Traversable with type 'a t = ('a, string) result = +struct + type 'a t = ('a, string) result + + module Make (T : MONAD) = struct + let traverse : 'a t -> ('a -> 'b T.t) -> 'b t T.t = + fun v f -> + match v with + | Ok x -> T.map (fun x -> Ok x) (f x) + | Error e -> T.return (Error e) + + let ( let>* ) : 'a t -> ('a -> 'b T.t) -> 'b t T.t = traverse + + let ( let>** ) : 'a t -> ('a -> 'b t T.t) -> 'b t T.t = + fun v f -> + let result = traverse v (fun v -> f v) in + T.map Result.join result + + let ( let* ) : 'a t T.t -> ('a -> 'b T.t) -> 'b t T.t = + fun v f -> T.bind v (fun v -> traverse v f) + + let ( let** ) : 'a t T.t -> ('a -> 'b t T.t) -> 'b t T.t = + fun v f -> + T.bind v (fun v -> + let result = traverse v (fun v -> f v) in + T.map Result.join result) + end +end diff --git a/lib/path/dune b/lib/path/dune new file mode 100644 index 0000000..83e17c2 --- /dev/null +++ b/lib/path/dune @@ -0,0 +1,6 @@ +(library + (name path) + + (libraries v_string) + ) + diff --git a/lib/path/path.ml b/lib/path/path.ml new file mode 100644 index 0000000..7caba87 --- /dev/null +++ b/lib/path/path.ml @@ -0,0 +1,116 @@ +(** Describe the components in the path *) +type _ typ = + | Int : int64 typ + | String : string typ + | Fixed : V_string.t -> unit typ + +(** [get_param f] extract the value from the poositional argument. + + The function [f] call the server engine for the value *) +let get_param : type a. int -> (string -> string) -> a typ -> a = + fun idx f -> function + | Fixed _ -> () + | String -> f (string_of_int idx) + | Int -> Int64.of_string (f (string_of_int idx)) + +let repr_param : type a. int -> a typ -> V_string.t = + fun idx -> function + | String | Int -> V_string.v (":" ^ string_of_int idx) + | Fixed v -> v + +let encode_param : type a. a -> a typ -> V_string.t = + fun value -> function + | String -> V_string.v value + | Int -> V_string.v (Int64.to_string value) + | Fixed v -> v + +type _ t = + | [] : unit t + | ( :: ) : 'x t * 'y t -> ('x * 'y) t + | T1 : 'a typ -> 'a t + | T2 : 'a typ * 'b typ -> ('a * 'b) t + | T3 : 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) t + | T4 : 'a typ * 'b typ * 'c typ * 'd typ -> ('a * 'b * 'c * 'd) t + +(** Count the number of arguments. *) +let rec count : type a. a t -> int = function + | [] -> 0 + | T1 _ -> 1 + | T2 _ -> 2 + | T3 _ -> 3 + | T4 _ -> 4 + | p1 :: p2 -> count p1 + count p2 + +(** Extract the arguments from the path template *) +let unzip : 'a t -> (string -> string) -> 'a = + fun t f -> + let rec _unzip : type a. int -> a t -> a = + fun idx path -> + let extract idx p = get_param idx f p in + match path with + | [] -> () + | p1 :: tl -> (_unzip idx p1, _unzip (idx + count p1) tl) + | T1 p1 -> extract idx p1 + | T2 (p1, p2) -> (extract idx p1, extract (idx + 1) p2) + | T3 (p1, p2, p3) -> + (extract idx p1, extract (idx + 1) p2, extract (idx + 2) p3) + | T4 (p1, p2, p3, p4) -> + ( extract idx p1, + extract (idx + 1) p2, + extract (idx + 2) p3, + extract (idx + 3) p4 ) + in + _unzip 0 t + +let repr : 'a t -> V_string.t = + fun t -> + let rec _repr : type a. int -> V_string.t list -> a t -> V_string.t list = + fun idx acc t -> + match t with + | [] -> acc + | T1 t -> repr_param idx t :: acc + | T2 (t1, t2) -> repr_param idx t1 :: repr_param (idx + 1) t2 :: acc + | T3 (t1, t2, t3) -> + repr_param idx t1 + :: repr_param (idx + 2) t2 + :: repr_param (idx + 3) t3 + :: acc + | T4 (t1, t2, t3, t4) -> + repr_param idx t1 + :: repr_param (idx + 1) t2 + :: repr_param (idx + 2) t3 + :: repr_param (idx + 3) t4 + :: acc + | tx :: ty -> + let idx' = count tx in + let acc' = _repr idx' acc ty in + _repr idx acc' tx + in + let args = _repr 0 [] t in + V_string.concat ~sep:(V_string.v "/") args + +let repr' a = repr a |> V_string.s + +let build : 'a -> 'a t -> V_string.t = + fun parameters uri -> + ignore (parameters, uri); + let rec _build : type a. V_string.t list -> a -> a t -> V_string.t list = + fun acc value path -> + match path with + | [] -> acc + | T1 t -> encode_param value t :: acc + | T2 (t1, t2) -> + let v1, v2 = value in + encode_param v1 t1 :: encode_param v2 t2 :: acc + | T3 (t1, t2, t3) -> + let v1, v2, v3 = value in + encode_param v1 t1 :: encode_param v2 t2 :: encode_param v3 t3 :: acc + | T4 (t1, t2, t3, t4) -> + let v1, v2, v3, v4 = value in + encode_param v1 t1 :: encode_param v2 t2 :: encode_param v3 t3 + :: encode_param v4 t4 :: acc + | tx :: ty -> + let vx, vy = value in + _build (_build acc vy ty) vx tx + in + V_string.concat ~sep:(V_string.v "/") (_build [] parameters uri) diff --git a/lib/path/path.mli b/lib/path/path.mli new file mode 100644 index 0000000..e5b5029 --- /dev/null +++ b/lib/path/path.mli @@ -0,0 +1,18 @@ +(** Describe the components in the path *) +type _ typ = + | Int : int64 typ + | String : string typ + | Fixed : V_string.t -> unit typ + +type _ t = + | [] : unit t + | ( :: ) : 'x t * 'y t -> ('x * 'y) t + | T1 : 'a typ -> 'a t + | T2 : 'a typ * 'b typ -> ('a * 'b) t + | T3 : 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) t + | T4 : 'a typ * 'b typ * 'c typ * 'd typ -> ('a * 'b * 'c * 'd) t + +val unzip : 'a t -> (string -> string) -> 'a +val repr : 'a t -> V_string.t +val repr' : 'a t -> string +val build : 'a -> 'a t -> V_string.t diff --git a/lib/services/dune b/lib/services/dune new file mode 100644 index 0000000..be8de92 --- /dev/null +++ b/lib/services/dune @@ -0,0 +1,10 @@ +(library + (name services) + + (libraries + lwt + yojson + path) + (preprocess (pps ppx_yojson_conv)) + ) + diff --git a/lib/services/services.ml b/lib/services/services.ml new file mode 100644 index 0000000..c0895fe --- /dev/null +++ b/lib/services/services.ml @@ -0,0 +1,49 @@ +type ('a, 'b) method_ = + | GET : (unit, 'b) method_ + | POST : ('a, 'b) method_ + | PUT : ('a, 'b) method_ + | DELETE : ('a, 'b) method_ + | HEAD : (unit, unit) method_ + | CONNECT : ('a, 'b) method_ + | OPTIONS : ('a, 'b) method_ + | TRACE : ('a, 'b) method_ + | PATCH : ('a, 'b) method_ + +(** A simple service, with an input and and answer *) +module type Handler = sig + type request + (** The body of the request *) + + type response + (** The body of the response *) + + val method_ : (request, response) method_ + (** The method used in the service. *) + + type placeholders + (** Parameters given in the url path. This type will match variable parts in + the path to the service *) + + val path : placeholders Path.t + (** Path to the service *) +end + +(** The service implemented in the server: + + We need to be able to decode the content and encode the response. *) +module type JsonServerHandler = sig + include Handler + + val request_of_yojson : Yojson.Safe.t -> request + (** Extract the request elements from the json *) + + val yojson_of_response : response -> Yojson.Safe.t + (** Produce a json from the response given by the service *) +end + +module type JsonClientHandler = sig + include Handler + + val yojson_of_request : request -> Yojson.Safe.t + val response_of_yojson : Yojson.Safe.t -> response +end diff --git a/lib/virtuals/_readme.rst b/lib/virtuals/_readme.rst new file mode 100644 index 0000000..4c31089 --- /dev/null +++ b/lib/virtuals/_readme.rst @@ -0,0 +1,5 @@ +This directory contains hold the `virtual libraries` used in the application. +They allow to share common code between the javascript and server side with +differents implementations (for exemple in the string representation). + +.. _`virtual libraries`: https://dune.readthedocs.io/en/stable/variants.html#virtual-library diff --git a/lib/virtuals/v_string/brr_string/dune b/lib/virtuals/v_string/brr_string/dune new file mode 100644 index 0000000..0e3f942 --- /dev/null +++ b/lib/virtuals/v_string/brr_string/dune @@ -0,0 +1,4 @@ +(library + (name brr_string) + (libraries brr) + (implements v_string)) diff --git a/lib/virtuals/v_string/brr_string/v_string.ml b/lib/virtuals/v_string/brr_string/v_string.ml new file mode 100644 index 0000000..9aeb01f --- /dev/null +++ b/lib/virtuals/v_string/brr_string/v_string.ml @@ -0,0 +1,10 @@ +type t = Jstr.t + +let v : string -> t = Jstr.v +let s = Jstr.to_string +let concat : ?sep:t -> t list -> t = Jstr.concat + +let encode v = + match Brr.Uri.encode_component v with + | Ok s -> s + | Error _ -> Jstr.empty diff --git a/lib/virtuals/v_string/dream_string/dune b/lib/virtuals/v_string/dream_string/dune new file mode 100644 index 0000000..ff6c9b2 --- /dev/null +++ b/lib/virtuals/v_string/dream_string/dune @@ -0,0 +1,4 @@ +(library + (name dream_string) + (libraries dream) + (implements v_string)) diff --git a/lib/virtuals/v_string/dream_string/v_string.ml b/lib/virtuals/v_string/dream_string/v_string.ml new file mode 100644 index 0000000..14a4e33 --- /dev/null +++ b/lib/virtuals/v_string/dream_string/v_string.ml @@ -0,0 +1,6 @@ +type t = string + +let v : string -> t = Fun.id +let s : t -> string = Fun.id +let concat : ?sep:t -> t list -> t = fun ?(sep = "") -> StringLabels.concat ~sep +let encode = Dream.to_percent_encoded ?international:None diff --git a/lib/virtuals/v_string/dune b/lib/virtuals/v_string/dune new file mode 100644 index 0000000..badb7d3 --- /dev/null +++ b/lib/virtuals/v_string/dune @@ -0,0 +1,4 @@ +(library + (name v_string) + (virtual_modules v_string) + (default_implementation dream_string)) diff --git a/lib/virtuals/v_string/v_string.mli b/lib/virtuals/v_string/v_string.mli new file mode 100644 index 0000000..267dbf2 --- /dev/null +++ b/lib/virtuals/v_string/v_string.mli @@ -0,0 +1,14 @@ +type t +(** + This module provide a common signature between the server and javascript + side in order to create URL in the same way. +*) + +val v : string -> t +val s : t -> string +val concat : ?sep:t -> t list -> t + +val encode : t -> t +(** Encode an element of the url by percent-encoding. The function is + expected to encode "/" as well. + *) diff --git a/readme.rst b/readme.rst new file mode 100644 index 0000000..adbc3ba --- /dev/null +++ b/readme.rst @@ -0,0 +1,95 @@ +.. -*- mode: rst -*- +.. -*- coding: utf-8 -*- + +This is a sample project showing how to process http requests in a safe way in +OCaml. + +For example: + + - A service using the GET method cannot have any body resquest + - A service using the HEAD method cannot have any body response + +Interface +========= + +The interface for a service is given in an OCaml module, and is declaring all +the possibles values for a service. + +Each service shall describe: + +- an URL to the server +- the body of the request +- the body of the response + +.. code:: ocaml + + type request = { value : string } [@@deriving yojson] + + type response = { value : string; nbcar : int64 } [@@deriving yojson] + + (** The method used in the service *) + let method_ = Services.POST + + type placeholders = unit + (** No placeholder here in the request url *) + + (** The path to the service, matching the type parameters *) + let path = Path.(T1 (Fixed (V_string.v "api/counter"))) + +Here, we are not declaring any implementation, only the types. + +Implementation +============== + +The server part +--------------- + + +There is no implementation yet, this is done in the server, for example using +`Dream_handler`: + +.. code:: ocaml + + let handler = + Dream_handler.handle + (module Services_impl.Nb_car) + (fun (() : Services_impl.Nb_car.placeholders) body -> + Lwt.return_ok + Services_impl.Nb_car. + { + value = body.value; + nbcar = Int64.of_int (String.length body.value); + }) + +As the url is also given in the service interface, we can also create the route: + +.. code:: ocaml + + let route = Dream_handler.register (module Services_impl.Nb_car) handler + + let () = + Dream.run @@ Dream.logger + @@ Dream.router + [ + route; + ] + + +The client part +--------------- + +This example use the library brr to make a request to this service: + +.. code:: ocaml + + let futr = Js_handler.send (module Services_impl.Nb_car) () { value } + +Another example using cohttp : + +.. code:: ocaml + + let root = "http://[::1]:8080" + let* result = + Cohttp_handler.request ~root + (module Services_impl.Nb_car) + () { value = "foobar" } diff --git a/services/dune b/services/dune new file mode 100644 index 0000000..fe10406 --- /dev/null +++ b/services/dune @@ -0,0 +1,10 @@ +(library + (name services_impl) + (libraries + path + services + v_string + ) + (preprocess (pps ppx_yojson_conv)) + ) + diff --git a/services/nb_car.ml b/services/nb_car.ml new file mode 100644 index 0000000..3d8f329 --- /dev/null +++ b/services/nb_car.ml @@ -0,0 +1,15 @@ +(** Service counting the characters in a word *) + +open Ppx_yojson_conv_lib.Yojson_conv.Primitives + +type request = { value : string } [@@deriving yojson] +type response = { value : string; nbcar : int64 } [@@deriving yojson] + +(** The method used in the service *) +let method_ = Services.POST + +type placeholders = unit +(** No placeholder here in the request url *) + +(** The path to the service, matching the type parameters *) +let path = Path.(T1 (Fixed (V_string.v "api/counter"))) |