lib/vif/vif.ml

@@ -1,24 +1,30 @@
 module U = Vif_u
 module R = Vif_r
 module C = Vif_c
+module D = Vif_d
+module S = Vif_s
 
-let rng_d, rng_s =
-  let initialize () =
-    Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna))
-  in
-  let finally = Mirage_crypto_rng_miou_unix.kill in
-  Vif_d.device ~name:"rng" ~finally Vif_d.[ const () ] initialize
+module Ds = struct
+  type 'value t =
+    | [] : 'value t
+    | ( :: ) : ('value, 'a) D.device * 'value t -> 'value t
 
-module D = struct
-  include Vif_d
+  let run : Vif_d.t -> 'value t -> 'value -> Vif_d.t =
+   fun t lst user's_value ->
+    let rec go t = function
+      | [] -> t
+      | x :: r -> go (Vif_d.run t user's_value x) r
+    in
+    go t lst
 
-  let rng = rng_d
-end
-
-module S = struct
-  include Vif_s
-
-  let rng = rng_s
+  let finally : Vif_d.t -> unit =
+   fun t ->
+    let[@warning "-8"] (Vif_d.Devices m) = t in
+    let fn (Vif_d.Hmap.B (k, v)) =
+      let { Vif_d.Device.finally; _ } = Vif_d.Hmap.Key.info k in
+      finally v
+    in
+    Vif_d.Hmap.iter fn m
 end
 
 module Stream = Stream
@@ -42,16 +48,6 @@ type config = {
   ; sockaddr: Unix.sockaddr
 }
 
-type devices = [] : devices | ( :: ) : 'a Vif_d.arg * devices -> devices
-
-let rec keval devices k = function
-  | [] -> k devices
-  | device :: rest ->
-      let devices, _ = Vif_d.ctor devices device in
-      keval devices k rest
-
-let eval devices = keval Vif_d.(Devices Hmap.empty) Fun.id devices
-
 let config ?http ?tls ?(backlog = 64) ?stop sockaddr =
   let http =
     match http with
@@ -84,14 +80,13 @@ let run ~cfg ~devices ~default routes user's_value =
         Httpcats.Server.clear ?stop:cfg.stop ~config ~handler cfg.sockaddr
     | None, None -> Httpcats.Server.clear ?stop:cfg.stop ~handler cfg.sockaddr
   in
-  let[@warning "-8"] (Vif_d.Devices devices) = eval devices in
+  let[@warning "-8"] (Vif_d.Devices devices) =
+    Ds.run Vif_d.empty devices user's_value
+  in
   let handler = handler ~default routes devices user's_value in
   let prm = Miou.async @@ fun () -> handle handler in
   if domains > 0 then
     Miou.parallel handle (List.init domains (Fun.const handler))
     |> List.iter (function Ok () -> () | Error exn -> raise exn);
   Miou.await_exn prm;
-  let finally (Vif_d.Hmap.B (k, v)) =
-    (Vif_d.Hmap.Key.info k).Vif_d.Device.finally v
-  in
-  Vif_d.Hmap.iter finally devices
+  Ds.finally (Vif_d.Devices devices)

lib/vif/vif.mli

@@ -77,26 +77,31 @@ module C : sig
 end
 
 module D : sig
-  type 'a arg
-  type 'a device
+  type ('value, 'a) arg
+  type ('value, 'a) device
 
-  type ('f, 'r) args =
-    | [] : ('r, 'r) args
-    | ( :: ) : 'a arg * ('f, 'a -> 'r) args -> ('f, 'r) args
+  type ('value, 'fn, 'r) args =
+    | [] : ('value, 'value -> 'r, 'r) args
+    | ( :: ) :
+        ('value, 'a) arg * ('value, 'fn, 'r) args
+        -> ('value, 'a -> 'fn, 'r) args
 
-  val const : 'a -> 'a arg
-  val map : ('f, 'r) args -> 'f -> 'r arg
+  val value : ('value, 'a) device -> ('value, 'a) arg
+  val const : 'a -> ('value, 'a) arg
+  val map : ('value, 'f, 'r) args -> 'f -> ('value, 'r) arg
 
   val device :
        name:string
     -> finally:('r -> unit)
-    -> ('f, 'r) args
+    -> ('v, 'f, 'r) args
     -> 'f
-    -> 'r arg * 'r device
+    -> ('v, 'r) device
+end
 
-  (** Some devices. *)
-
-  val rng : Mirage_crypto_rng_miou_unix.rng arg
+module Ds : sig
+  type 'value t =
+    | [] : 'value t
+    | ( :: ) : ('value, 'a) D.device * 'value t -> 'value t
 end
 
 module S : sig
@@ -104,8 +109,7 @@ module S : sig
   type reqd = [ `V1 of H1.Reqd.t | `V2 of H2.Reqd.t ]
 
   val reqd : t -> reqd
-  val device : 'a D.device -> t -> 'a
-  val rng : Mirage_crypto_rng_miou_unix.rng D.device
+  val device : ('value, 'a) D.device -> t -> 'a
 end
 
 module Stream : sig
@@ -223,11 +227,9 @@ val config :
 
 val stop : unit -> stop
 
-type devices = [] : devices | ( :: ) : 'a D.arg * devices -> devices
-
 val run :
      cfg:config
-  -> devices:devices
+  -> devices:'value Ds.t
   -> default:(string -> S.t -> Request.t -> 'value -> unit)
   -> (S.t -> Request.t -> 'value -> unit) R.route list
   -> 'value

lib/vif/vif_d.ml

@@ -1,64 +1,79 @@
 type t = ..
 
 module Device = struct
-  type nonrec 'a t = {
-      name: string
-    ; initialize: t -> t * 'a
-    ; finally: 'a -> unit
-  }
+  type nonrec 'a t = { name: string; finally: 'a -> unit }
 
-  let make ~initialize ~finally name = { name; initialize; finally }
+  let make ~name finally = { name; finally }
 end
 
 module Hmap = Hmap.Make (Device)
 
+let failwithf fmt = Format.kasprintf failwith fmt
+
 type t += Devices : Hmap.t -> t
-(* NOTE(dinosaure): or module-rec? *)
 
-type 'a arg =
-  | Value : 'a Hmap.key -> 'a arg
-  | Const : 'a -> 'a arg
-  | Map : ('f, 'a) args * 'f -> 'a arg
+let empty = Devices Hmap.empty
 
-and ('fu, 'return) args =
-  | [] : ('r, 'r) args
-  | ( :: ) : 'a arg * ('f, 'a -> 'r) args -> ('f, 'r) args
+type ('value, 'a) arg =
+  | Value : 'a Hmap.key -> ('value, 'a) arg
+  | Const : 'a -> ('value, 'a) arg
+  | Map : ('value, 'fn, 'r) args * 'fn -> ('value, 'r) arg
 
-and 'a device = 'a Hmap.key
+and ('value, 'fn, 'r) args =
+  | [] : ('value, 'value -> 'r, 'r) args
+  | ( :: ) :
+      ('value, 'a) arg * ('value, 'fn, 'r) args
+      -> ('value, 'a -> 'fn, 'r) args
 
-let map args fn = Map (args, fn)
-let const value = Const value
-
-let rec ctor : type a. t -> a arg -> t * a =
- fun devices -> function
+let rec arg : type a v. t -> v -> (v, a) arg -> t * a =
+ fun devices user's_value -> function
   | Const v -> (devices, v)
-  | Map (lst, fn) -> keval_args devices (fun devices x -> (devices, x)) lst fn
-  | Value k -> (
+  | Value k ->
       let[@warning "-8"] (Devices m) = devices in
-      match Hmap.find k m with
-      | None ->
-          let devices, device = (Hmap.Key.info k).Device.initialize devices in
-          let[@warning "-8"] (Devices devices) = devices in
-          let devices = Hmap.add k device devices in
-          (Devices devices, device)
-      | Some device -> (devices, device))
+      begin
+        match Hmap.find k m with
+        | None -> failwithf "Device %s not found" (Hmap.Key.info k).name
+        | Some device -> (devices, device)
+      end
+  | Map (args, fn) ->
+      let v = ref None in
+      let k fn devices =
+        v := Some devices;
+        fn user's_value
+      in
+      let value = keval_args devices user's_value k args fn in
+      (Option.get !v, value)
 
-and keval_args : type f x r. t -> (t -> x -> r) -> (f, x) args -> f -> r =
- fun devices k -> function
-  | [] -> k devices
+and keval_args : type f r v a.
+    t -> v -> ((v -> r) -> t -> r) -> (v, f, r) args -> f -> r =
+ fun devices user's_value k -> function
+  | [] -> fun fn -> k fn devices
   | x :: r ->
-      let devices, v = ctor devices x in
-      let k devices fn = k devices (fn v) in
-      keval_args devices k r
+      let devices, v = arg devices user's_value x in
+      fun fn ->
+        let k fn devices = k fn devices in
+        (keval_args devices user's_value k r) (fn v)
 
-let device : type r.
-    name:string -> finally:(r -> unit) -> ('f, r) args -> 'f -> r arg * r device
-    =
+type ('v, 'r) device =
+  | Device : ('v, 'f, 'r) args * 'f * 'r Hmap.key -> ('v, 'r) device
+
+let const v = Const v
+let value (Device (_, _, key)) = Value key
+let map args fn = Map (args, fn)
+
+let device : type v f r.
+    name:string -> finally:(r -> unit) -> (v, f, r) args -> f -> (v, r) device =
  fun ~name ~finally args fn ->
-  let initialize devices =
-    let k devices v = (devices, v) in
-    keval_args devices k args fn
+  let key : r Hmap.key = Hmap.Key.create { name; finally } in
+  Device (args, fn, key)
+
+let run : type v. t -> v -> (v, 'r) device -> t =
+ fun devices user's_value (Device (args, fn, key)) ->
+  let v = ref None in
+  let k fn devices =
+    v := Some devices;
+    fn user's_value
   in
-  let device = Device.make ~initialize ~finally name in
-  let key = Hmap.Key.create device in
-  (Value key, key)
+  let x = keval_args devices user's_value k args fn in
+  let[@warning "-8"] (Devices t) = Option.get !v in
+  Devices (Hmap.add key x t)

lib/vif/vif_s.ml

@@ -1,12 +1,13 @@
 type t = { reqd: reqd; socket: socket; devices: Vif_d.Hmap.t }
 and reqd = Httpcats.Server.reqd
 and socket = [ `Tcp of Miou_unix.file_descr | `Tls of Tls_miou_unix.t ]
-and 'a device = 'a Vif_d.device
 
 let reqd { reqd; _ } = reqd
 
-let device : type a. a Vif_d.device -> t -> a =
- fun k { devices; _ } ->
+let device : type a. ('value, a) Vif_d.device -> t -> a =
+ fun (Vif_d.Device (_, _, k)) { devices; _ } ->
   match Vif_d.Hmap.find k devices with
   | Some value -> value
-  | None -> failwith "Device not found"
+  | None ->
+      Fmt.failwith "Device %s not found"
+        (Vif_d.Hmap.Key.info k).Vif_d.Device.name

main.ml

@@ -55,13 +55,16 @@ let default target server req () =
   Vif.Response.with_string server `Not_found (Fmt.str "%S not found\n%!" target)
 ;;
 
-let my_device_as_arg, my_device =
-  Vif.D.device ~name:"my-device" ~finally:ignore [] ()
+let rng =
+  let open Mirage_crypto_rng_miou_unix in
+  let finally = kill in
+  Vif.D.device ~name:"rng" ~finally [] @@ fun _cfg ->
+  initialize (module Pfortuna)
 ;;
 
 let () =
   Miou_unix.run @@ fun () ->
   let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
   let cfg = Vif.config sockaddr in
-  Vif.run ~cfg ~default ~devices:Vif.[ D.rng; my_device_as_arg ] routes ()
+  Vif.run ~cfg ~default ~devices:Vif.Ds.[ rng; ] routes ()
 ;;