aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/brr_handler/dune11
-rw-r--r--lib/brr_handler/js_handler.ml53
-rw-r--r--lib/brr_handler/js_handler.mli8
-rw-r--r--lib/cohttp_handler/cohttp_handler.ml83
-rw-r--r--lib/cohttp_handler/dune15
-rw-r--r--lib/dream_handler/dream_handler.ml165
-rw-r--r--lib/dream_handler/dream_handler.mli47
-rw-r--r--lib/dream_handler/dune13
-rw-r--r--lib/dune2
-rw-r--r--lib/operators/dune4
-rw-r--r--lib/operators/operators.ml94
-rw-r--r--lib/path/dune6
-rw-r--r--lib/path/path.ml116
-rw-r--r--lib/path/path.mli18
-rw-r--r--lib/services/dune10
-rw-r--r--lib/services/services.ml49
-rw-r--r--lib/virtuals/_readme.rst5
-rw-r--r--lib/virtuals/v_string/brr_string/dune4
-rw-r--r--lib/virtuals/v_string/brr_string/v_string.ml10
-rw-r--r--lib/virtuals/v_string/dream_string/dune4
-rw-r--r--lib/virtuals/v_string/dream_string/v_string.ml6
-rw-r--r--lib/virtuals/v_string/dune4
-rw-r--r--lib/virtuals/v_string/v_string.mli14
23 files changed, 741 insertions, 0 deletions
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.
+ *)
generated by cgit v1.2.3 (git 2.39.1) at 2025-07-05 04:29:50 +0000