Add middleware

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
+let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[])
-    routes user's_value =
+    ?(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 []

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

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

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

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 =
+       encoding:(c, a) Vif_content_type.t
- fun ~encoding -> function
+    -> 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

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