From 392bb3bd88f6cd51d58e4c5324f58ee1cf34e113 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sun, 9 Feb 2025 18:56:08 +0100 Subject: [PATCH] Add middleware --- lib/vif/vif.ml | 61 +++++++++++++++++++++++++++++++---------- lib/vif/vif.mli | 25 +++++++++++++++-- lib/vif/vif_headers.ml | 2 ++ lib/vif/vif_m.ml | 34 +++++++++++++++++++++++ lib/vif/vif_request.ml | 21 +++++++++++--- lib/vif/vif_request0.ml | 17 ++++++++++++ 6 files changed, 139 insertions(+), 21 deletions(-) create mode 100644 lib/vif/vif_request0.ml diff --git a/lib/vif/vif.ml b/lib/vif/vif.ml index 6f2885c..e2a3d47 100644 --- a/lib/vif/vif.ml +++ b/lib/vif/vif.ml @@ -20,6 +20,7 @@ end module C = Vif_c module D = Vif_d module S = Vif_s +module M = Vif_m module Ds = struct type 'value t = @@ -44,6 +45,31 @@ module Ds = struct Vif_d.Hmap.iter fn m end +module Ms = struct + type 'cfg t = [] : 'cfg t | ( :: ) : ('cfg, 'a) Vif_m.t * 'cfg t -> 'cfg t + type ('cfg, 'v) fn = ('cfg, 'v) Vif_m.fn + + let make = Vif_m.make + + type ('value, 'a, 'c) ctx = { + server: Vif_s.t + ; request: Vif_request0.t + ; target: string + ; user's_value: 'value + } + + let rec run : type v. v t -> (v, 'a, 'c) ctx -> Vif_m.Hmap.t -> Vif_m.Hmap.t = + fun lst ctx env -> + match lst with + | [] -> env + | Middleware (fn, key) :: r -> begin + match fn ctx.request ctx.target ctx.server ctx.user's_value with + | Some value -> run r ctx (Vif_m.Hmap.add key value env) + | None -> run r ctx env + | exception _exn -> run r ctx env + end +end + module Content_type = Vif_content_type module Stream = Stream module Method = Vif_method @@ -75,7 +101,7 @@ let method_of_request server = | `V1 reqd -> ((H1.Reqd.request reqd).H1.Request.meth :> H2.Method.t) | `V2 reqd -> ((H2.Reqd.request reqd).H2.Request.meth :> H2.Method.t) -let request server = +let request ~env server = let extract : type c a. Vif_method.t option -> (c, a) Vif_content_type.t @@ -84,47 +110,47 @@ let request server = let meth' = method_of_request server in match (meth, meth', c) with | None, _, (Vif_content_type.Any as encoding) -> - Some (Vif_request.of_reqd ~encoding server.S.reqd) + Some (Vif_request.of_reqd ~encoding ~env server.S.reqd) | Some a, b, (Vif_content_type.Any as encoding) -> - if a = b then Some (Vif_request.of_reqd ~encoding server.S.reqd) + if a = b then Some (Vif_request.of_reqd ~encoding ~env server.S.reqd) else None | None, _, (Null as encoding) -> - Some (Vif_request.of_reqd ~encoding server.S.reqd) + Some (Vif_request.of_reqd ~encoding ~env server.S.reqd) | Some a, b, (Null as encoding) -> - if a = b then Some (Vif_request.of_reqd ~encoding server.S.reqd) + if a = b then Some (Vif_request.of_reqd ~encoding ~env server.S.reqd) else None | None, _, (Json_encoding _ as encoding) -> let c = content_type server in let application_json = Result.map is_application_json c in let application_json = Result.value ~default:false application_json in if application_json then - Some (Vif_request.of_reqd ~encoding server.S.reqd) + Some (Vif_request.of_reqd ~encoding ~env server.S.reqd) else None | Some a, b, (Json_encoding _ as encoding) -> let c = content_type server in let application_json = Result.map is_application_json c in let application_json = Result.value ~default:false application_json in if application_json && a = b then - Some (Vif_request.of_reqd ~encoding server.S.reqd) + Some (Vif_request.of_reqd ~encoding ~env server.S.reqd) else None | None, _, (Json as encoding) -> let c = content_type server in let application_json = Result.map is_application_json c in let application_json = Result.value ~default:false application_json in if application_json then - Some (Vif_request.of_reqd ~encoding server.S.reqd) + Some (Vif_request.of_reqd ~encoding ~env server.S.reqd) else None | Some a, b, (Json as encoding) -> let c = content_type server in let application_json = Result.map is_application_json c in let application_json = Result.value ~default:false application_json in if application_json && a = b then - Some (Vif_request.of_reqd ~encoding server.S.reqd) + Some (Vif_request.of_reqd ~encoding ~env server.S.reqd) else None in { Vif_r.extract } -let handler ~default routes devices user's_value = +let handler ~default ~middlewares routes devices user's_value = (); fun socket reqd -> let target = @@ -133,7 +159,11 @@ let handler ~default routes devices user's_value = | `V2 reqd -> (H2.Reqd.request reqd).H2.Request.target in let server = { Vif_s.reqd; socket; devices } in - let request = request server in + let ctx = + { Ms.server; request= Vif_request0.of_reqd reqd; target; user's_value } + in + let env = Ms.run middlewares ctx Vif_m.Hmap.empty in + let request = request ~env server in Log.debug (fun m -> m "Handle a new request to %s" target); let fn = R.dispatch ~default routes ~request ~target in match fn server user's_value with Vif_response.Response -> () @@ -165,8 +195,8 @@ let store_pid = function output_string oc (string_of_int (Unix.getpid ())); close_out oc -let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[]) ~default - routes user's_value = +let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[]) + ?(middlewares = Ms.[]) ~default routes user's_value = let interactive = !Sys.interactive in let domains = Miou.Domain.available () in store_pid cfg.pid; @@ -185,10 +215,11 @@ let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[]) ~default Ds.run Vif_d.empty devices user's_value in Logs.debug (fun m -> m "devices launched"); - let fn0 = handler ~default routes devices user's_value in + let fn0 = handler ~default ~middlewares routes devices user's_value in let prm = Miou.async @@ fun () -> handle stop cfg fn0 in let tasks = - List.init domains (fun _ -> handler ~default routes devices user's_value) + List.init domains (fun _ -> + handler ~default ~middlewares routes devices user's_value) in let tasks = if domains > 0 then Miou.parallel (handle stop cfg) tasks else [] diff --git a/lib/vif/vif.mli b/lib/vif/vif.mli index e7d3ed6..8efbe67 100644 --- a/lib/vif/vif.mli +++ b/lib/vif/vif.mli @@ -22,10 +22,14 @@ module U : sig val eval : ('f, string) t -> 'f end +module Json = Json module Stream = Stream module Headers : sig type t = (string * string) list + + val add_unless_exists : t -> string -> string -> t + val get : t -> string -> string option end module Method : sig @@ -41,8 +45,6 @@ module Method : sig | `Other of string ] end -module Json = Json - module Content_type : sig type null type json @@ -54,6 +56,10 @@ module Content_type : sig val any : ('c, string) t end +module M : sig + type ('cfg, 'v) t +end + module Request : sig type ('c, 'a) t @@ -64,6 +70,13 @@ module Request : sig val to_string : ('c, 'a) t -> string val to_stream : ('c, 'a) t -> string Stream.stream val of_json : (Content_type.json, 'a) t -> ('a, [ `Msg of string ]) result + val get : ('cfg, 'v) M.t -> ('c, 'a) t -> 'v option + + type request + + val headers_of_request : request -> Headers.t + val method_of_request : request -> Method.t + val target_of_request : request -> string end module R : sig @@ -168,6 +181,13 @@ module S : sig val device : ('value, 'a) D.device -> t -> 'a end +module Ms : sig + type 'cfg t = [] : 'cfg t | ( :: ) : ('cfg, 'a) M.t * 'cfg t -> 'cfg t + type ('cfg, 'v) fn = Request.request -> string -> S.t -> 'cfg -> 'v option + + val make : name:string -> ('cfg, 'v) fn -> ('cfg, 'v) M.t +end + module Status : sig type t = [ `Accepted @@ -257,6 +277,7 @@ val config : val run : ?cfg:config -> ?devices:'value Ds.t + -> ?middlewares:'value Ms.t -> default:(('c, string) Request.t -> string -> S.t -> 'value -> Response.t) -> (S.t -> 'value -> Response.t) R.route list -> 'value diff --git a/lib/vif/vif_headers.ml b/lib/vif/vif_headers.ml index a8b5436..72ddd1d 100644 --- a/lib/vif/vif_headers.ml +++ b/lib/vif/vif_headers.ml @@ -2,3 +2,5 @@ type t = (string * string) list let add_unless_exists hdrs k v = if List.mem_assoc k hdrs then hdrs else (k, v) :: hdrs + +let get hdrs key = List.assoc_opt key hdrs diff --git a/lib/vif/vif_m.ml b/lib/vif/vif_m.ml index e69de29..7a9c5af 100644 --- a/lib/vif/vif_m.ml +++ b/lib/vif/vif_m.ml @@ -0,0 +1,34 @@ +module Key = struct + type 'a t = { name: string } + + let make ~name = { name } +end + +module Hmap = Hmap.Make (Key) + +type ('cfg, 'v) fn = Vif_request0.t -> string -> Vif_s.t -> 'cfg -> 'v option +type ('cfg, 'v) t = Middleware : ('cfg, 'v) fn * 'v Hmap.key -> ('cfg, 'v) t +type 'cfg m = [] : 'cfg m | ( :: ) : ('cfg, 'a) t * 'cfg m -> 'cfg m + +type ('value, 'a, 'c) ctx = { + server: Vif_s.t + ; request: Vif_request0.t + ; target: string + ; user's_value: 'value +} + +let make : type v. name:string -> ('cfg, v) fn -> ('cfg, v) t = + fun ~name fn -> + let key = Hmap.Key.create (Key.make ~name) in + Middleware (fn, key) + +let rec run : type v. v m -> (v, 'a, 'c) ctx -> Hmap.t -> Hmap.t = + fun lst ctx env -> + match lst with + | [] -> env + | Middleware (fn, key) :: r -> begin + match fn ctx.request ctx.target ctx.server ctx.user's_value with + | Some value -> run r ctx (Hmap.add key value env) + | None -> run r ctx env + | exception _exn -> run r ctx env + end diff --git a/lib/vif/vif_request.ml b/lib/vif/vif_request.ml index 3cbec65..b084fea 100644 --- a/lib/vif/vif_request.ml +++ b/lib/vif/vif_request.ml @@ -6,19 +6,23 @@ type ('c, 'a) t = { request: [ `V1 of H1.Request.t | `V2 of H2.Request.t ] ; body: [ `V1 of H1.Body.Reader.t | `V2 of H2.Body.Reader.t ] ; encoding: ('c, 'a) Vif_content_type.t + ; env: Vif_m.Hmap.t } let of_reqd : type c a. - encoding:(c, a) Vif_content_type.t -> Httpcats.Server.reqd -> (c, a) t = - fun ~encoding -> function + encoding:(c, a) Vif_content_type.t + -> env:Vif_m.Hmap.t + -> Httpcats.Server.reqd + -> (c, a) t = + fun ~encoding ~env -> function | `V1 reqd -> let request = `V1 (H1.Reqd.request reqd) in let body = `V1 (H1.Reqd.request_body reqd) in - { request; body; encoding } + { request; body; encoding; env } | `V2 reqd -> let request = `V2 (H2.Reqd.request reqd) in let body = `V2 (H2.Reqd.request_body reqd) in - { request; body; encoding } + { request; body; encoding; env } let target { request; _ } = match request with @@ -102,3 +106,12 @@ let of_json : type a. error_msgf "Invalid JSON value" end end + +let get : type v. ('cfg, v) Vif_m.t -> ('a, 'c) t -> v option = + fun (Vif_m.Middleware (_, key)) { env; _ } -> Vif_m.Hmap.find key env + +type request = Vif_request0.t + +let headers_of_request = Vif_request0.headers +let method_of_request = Vif_request0.meth +let target_of_request = Vif_request0.target diff --git a/lib/vif/vif_request0.ml b/lib/vif/vif_request0.ml new file mode 100644 index 0000000..abe1107 --- /dev/null +++ b/lib/vif/vif_request0.ml @@ -0,0 +1,17 @@ +type t = V1 of H1.Request.t | V2 of H2.Request.t + +let of_reqd = function + | `V1 reqd -> V1 (H1.Reqd.request reqd) + | `V2 reqd -> V2 (H2.Reqd.request reqd) + +let headers = function + | V1 req -> H1.Headers.to_list req.H1.Request.headers + | V2 req -> H2.Headers.to_list req.H2.Request.headers + +let meth = function + | V1 req -> req.H1.Request.meth + | V2 req -> req.H2.Request.meth + +let target = function + | V1 req -> req.H1.Request.target + | V2 req -> req.H2.Request.target