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/brr_handler/dune | 11 ++ lib/brr_handler/js_handler.ml | 53 ++++++++ lib/brr_handler/js_handler.mli | 8 ++ lib/cohttp_handler/cohttp_handler.ml | 83 +++++++++++++ lib/cohttp_handler/dune | 15 +++ lib/dream_handler/dream_handler.ml | 165 +++++++++++++++++++++++++ lib/dream_handler/dream_handler.mli | 47 +++++++ lib/dream_handler/dune | 13 ++ lib/dune | 2 + lib/operators/dune | 4 + lib/operators/operators.ml | 94 ++++++++++++++ lib/path/dune | 6 + lib/path/path.ml | 116 +++++++++++++++++ lib/path/path.mli | 18 +++ lib/services/dune | 10 ++ lib/services/services.ml | 49 ++++++++ lib/virtuals/_readme.rst | 5 + lib/virtuals/v_string/brr_string/dune | 4 + lib/virtuals/v_string/brr_string/v_string.ml | 10 ++ lib/virtuals/v_string/dream_string/dune | 4 + lib/virtuals/v_string/dream_string/v_string.ml | 6 + lib/virtuals/v_string/dune | 4 + lib/virtuals/v_string/v_string.mli | 14 +++ 23 files changed, 741 insertions(+) create mode 100644 lib/brr_handler/dune create mode 100644 lib/brr_handler/js_handler.ml create mode 100644 lib/brr_handler/js_handler.mli create mode 100644 lib/cohttp_handler/cohttp_handler.ml create mode 100644 lib/cohttp_handler/dune 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 create mode 100644 lib/dune create mode 100644 lib/operators/dune create mode 100644 lib/operators/operators.ml create mode 100644 lib/path/dune create mode 100644 lib/path/path.ml create mode 100644 lib/path/path.mli create mode 100644 lib/services/dune create mode 100644 lib/services/services.ml create mode 100644 lib/virtuals/_readme.rst create mode 100644 lib/virtuals/v_string/brr_string/dune create mode 100644 lib/virtuals/v_string/brr_string/v_string.ml create mode 100644 lib/virtuals/v_string/dream_string/dune create mode 100644 lib/virtuals/v_string/dream_string/v_string.ml create mode 100644 lib/virtuals/v_string/dune create mode 100644 lib/virtuals/v_string/v_string.mli (limited to 'lib') 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. + *) -- cgit v1.2.3