src/devices.ml

@@ -1,12 +1,6 @@
-type env = {
+let db_connection caqti_switch : (unit, Caqti_miou.connection) Vif.Device.device =
-  caqti_switch: Caqti_miou.Switch.t;
+let f () =
-  db_uri: Uri.t;
+  let db_uri= Config.Exchangedb_postgres.config in
-}
-
-let db_connection : (env, Caqti_miou.connection) Vif.Device.device =
-  let finally (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect () in
-  Vif.Device.v ~name:"db_connection" ~finally []
-  @@ fun { caqti_switch; db_uri } ->
   match Caqti_miou_unix.connect ~sw:caqti_switch db_uri with
   | Error err ->
       Fmt.failwith "Database connection failure: %a." Caqti_error.pp err
@@ -17,10 +11,16 @@ let db_connection : (env, Caqti_miou.connection) Vif.Device.device =
       | Ok () ->
           Logs.info (fun m -> m "database connection initialized");
           conn)
+in
+  let finally (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect () in
+  Vif.Device.v ~name:"db_connection" ~finally [] f
 
-let keys =
+let keys storage =
+let f (module Conn : Pg.CONN) () =
+  let (module Fs) = (module (struct let t = storage end)) in
+  let keys : (module Keys.S) = (module Keys.Make (Conn) (Fs) ) in
+  keys
+in
   let finally _key = () in
   Vif.Device.v ~name:"keys" ~finally [ Vif.Device.value db_connection ]
-  @@ fun (module Conn : Pg.CONN) (_env : env) ->
+  f
-  let keys : (module Keys.S) = (module Keys.Make (Conn)) in
-  keys

src/fat.ml

@@ -0,0 +1,17 @@
+
+
+module Fat = Mfat.Make (struct
+  include Mkernel.Block
+
+  let read = atomic_read
+
+  let write = atomic_write
+end)
+
+include Fat
+
+type t = Mkernel.Block.t Mfat.t
+
+module type FS = sig
+val t : t
+end

src/keys.ml

@@ -26,9 +26,9 @@ module type S = sig
     denom_hash -> Signatures.MasterDenominationKeyRevocation.t -> unit result
 end
 
-module Make (Conn : Pg.CONN) : S = struct
+module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
-  module Sm_eddsa = Secmod_eddsa.Make ()
+  module Sm_eddsa = Secmod_eddsa.Make (Fs)
-  module Sm_rsa = Secmod_rsa.Make ()
+  module Sm_rsa = Secmod_rsa.Make (Fs)
 
   let conn = (module Conn : Pg.CONN)
 

src/mte.ml

@@ -64,13 +64,75 @@ let routes =
   in
   tos @ status_info @ management
 
-let () =
+let caqti_get_ok = function
-  Util.Log_reporter.setup ();
+  | Error e -> Fmt.failwith "%a" Caqti_error.pp e
-  let cfg =
+  | Ok v -> v
-    let port = Config.Exchange.port in
+
-    let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, port)) in
+let test (module Conn : Caqti_miou.CONNECTION) =
-    Vif.config ~reporter:Util.Log_reporter.reporter sockaddr
+  let minus_req =
+    let open Caqti_request.Infix in
+    let open Caqti_type in
+    (t2 int int ->! int) "SELECT ? - ?"
   in
+  let a = 22 in
+  let b = 17 in
+  let c = Conn.find minus_req (22, 17) |> caqti_get_ok in
+  assert (a - b = c);
+  Logs.app (fun f -> f "%d - %d = %d" a b c);
+  ()
+
+let disconnect (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect ()
+
+
+module RNG = Mirage_crypto_rng.Fortuna
+
+
+let () =
+  let ( let@ ) finally fn = Fun.protect ~finally fn in
+  Util.Log_reporter.setup ();
+let rng =
+  let rng () = Mirage_crypto_rng_mkernel.initialize (module RNG) in
+  Mkernel.map rng Mkernel.[]
+in
+  let storage = Mkernel.storage ~name:"storage" in
+  let service =
+    let ipv4 = Ipaddr.V4.Prefix.of_string_exn "10.0.0.2/24" in
+    Mnet.stack ~name:"service" ipv4
+  in
+  Mkernel.(run [ rng; storage; service ])
+  @@ fun rng storage (stack, tcp, udp) () ->
+  let@ () = fun () -> Mirage_crypto_rng_mkernel.kill rng in
+  let@ () = fun () -> Mnet.kill stack in
+  (* -- setup db connection -- *)
+  let hed, he = Mnet_happy_eyeballs.create tcp in
+  let@ () = fun () -> Mnet_happy_eyeballs.kill hed in
+  let dns = Mnet_dns.create (udp_db, he) in
+  let t = Mnet_dns.transport dns in
+  let@ () = fun () -> Mnet_dns.Transport.kill t in
+  Caqti_miou.Switch.run @@ fun sw ->
+  Logs.app (fun m -> m "Connecting to the database");
+  let db_connection =
+    let config = Caqti_connect_config.default in
+    let r = Caqti_mnet.connect ~config ~sw stack tcp dns db_uri in
+    caqti_get_ok r
+  in
+  let@ () = fun () -> disconnect db_connection in
+  Logs.app (fun m -> m "Connected");
+  test db_connection;
+  Logs.app (fun m -> m "Test OK");
+  (* -- *)
+  (* -- start webserver -- *)
+  let devices = [
+  ]
+  in
+  let cfg = Vifu.Config.v Config.Exchange.port in
+  let db_device = Devices.db_connection sw in
+  let keys_device = Devices.keys storage (Vifu.Device.value db_device) in
+  let devices = Vifu.Devices.[ db_device; keys_device] in
+  Vifu.run ~cfg ~devices tcp routes ()
+
+
+  (*
   Miou_unix.run @@ fun () ->
   Caqti_miou.Switch.run @@ fun caqti_switch ->
   let env : Devices.env =
@@ -81,3 +143,4 @@ let () =
   Logs.info (fun m ->
       m ~tags:(Util.Log_reporter.detail "...") "Starting MTE server");
   Vif.run ~cfg ~devices ~middlewares routes env
+  *)

src/secmod_eddsa.ml

@@ -1,11 +1,12 @@
 (* TODO
    ! use lock
    schedule tasks
-   sign: check timestamps before signing
+   sign: check timestamps before signing *)
-
+(* IMPROVE
    list_issue_date: save timestamp of key generation
    key validity period:
      more checks + do not exceed lookahead
+   look into ocaml-diet maybe
    refacto common parts with secmod_eddsa *)
 let src = Logs.Src.create "mte.secmod_eddsa"
 
@@ -25,6 +26,7 @@ type key = {
 }
 
 type t = {
+  fs: Fat.t;
   sm_key_priv: EddsaPrivateKey.t;
   sm_pub: EddsaPublicKey.t;
   ht: (EddsaPublicKey.t, key) Hashtbl.t;
@@ -53,19 +55,19 @@ let key_fpath k =
 
 (* -- IO -- *)
 
-let read_key fpath =
+let read_key fs fpath =
   Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
-  let* data = Bos.OS.File.read fpath |> unwrap_msg in
+  let* data = Fat.read fs fpath |> unwrap_msg in
   EddsaPrivateKey.of_octets data
 
-let write_eddsa fpath priv =
+let write_eddsa fs fpath priv =
   Log.debug (fun m -> m "writing key file `%a`" Fpath.pp fpath);
   let data = EddsaPrivateKey.to_octets priv in
-  Bos.OS.File.write fpath data |> unwrap_msg
+  Fat.write fs fpath data |> unwrap_msg
 
-let write_key k = write_eddsa (key_fpath k) k.priv
+let write_key fs k = write_eddsa fs (key_fpath k) k.priv
 
-let delete_file fpath =
+let delete_file fs fpath =
   (* check fpath just to be safe *)
   let () =
     let root = Fpath.v Cfg.key_dir in
@@ -75,14 +77,14 @@ let delete_file fpath =
         Fpath.pp fpath
   in
   Log.debug (fun m -> m "delete key file `%a`" Fpath.pp fpath);
-  let+ () = Bos.OS.File.delete ~must_exist:true fpath |> unwrap_msg in
+  let+ () = Fat.remove fs fpath |> unwrap_msg in
   ()
 
-let get_key_dir_contents dir =
+let get_key_dir_contents fs dir =
   let* dir = Fpath.of_string dir |> unwrap_msg in
-  let* b = Bos.OS.Dir.create ~mode:0o700 dir |> unwrap_msg in
+  let* b = Fat.create fs dir |> unwrap_msg in
   if b then Log.info (fun m -> m "created directory `%a`" Fpath.pp dir);
-  let+ l = Bos.OS.Dir.contents ~dotfiles:false ~rel:false dir |> unwrap_msg in
+  let+ l = Fat.ls fs dir |> unwrap_msg in
   List.map Fpath.normalize l
 
 (* -- *)
@@ -132,29 +134,29 @@ let sm_key_fpath =
 
 (* we load sm_key separately
    we don't accept non-key files in key_dir *)
-let load_key fpath =
+let load_key fs fpath =
   match parse_filename fpath with
   | None -> Fmt.error "invalid file `%a`" Fpath.pp fpath
   | Some (t1, t2) ->
-      let+ priv = read_key fpath in
+      let+ priv = read_key fs fpath in
       let pub = EddsaPrivateKey.pub_of_priv priv in
       { priv; pub; t1; t2 }
 
-let load () =
+let load fs =
-  let* l = get_key_dir_contents Cfg.key_dir in
+  let* l = get_key_dir_contents fs Cfg.key_dir in
   let l = List.filter (fun fpath -> not @@ Fpath.equal fpath sm_key_fpath) l in
-  let* keys = list_map load_key l in
+  let* keys = list_map (load_key fs) l in
   match keys with
   | [] -> Ok None
   | _l ->
-      let* sm_key_priv = read_key sm_key_fpath in
+      let* sm_key_priv = read_key fs sm_key_fpath in
       let sm_pub = EddsaPrivateKey.pub_of_priv sm_key_priv in
       let ht = Hashtbl.create 0xff in
       let () = List.iter (fun k -> Hashtbl.replace ht k.pub k) keys in
-      Ok (Some { sm_key_priv; sm_pub; ht })
+      Ok (Some { fs; sm_key_priv; sm_pub; ht })
 
-let init () =
+let init fs =
-  let* opt = load () in
+  let* opt = load fs in
   let* t =
     match opt with
     | Some t -> Ok t
@@ -164,18 +166,18 @@ let init () =
             m "generated secmod key: `%s`" (EddsaPublicKey.to_b32 sm_pub));
         let* () = write_eddsa sm_key_fpath sm_key_priv in
         let ht = Hashtbl.create 0xff in
-        Ok { sm_key_priv; sm_pub; ht }
+        Ok { fs; sm_key_priv; sm_pub; ht }
   in
   let now = TimeAbsolute.of_ptime (Ptime_clock.now ()) in
   let keys = List.of_seq @@ Hashtbl.to_seq_values t.ht in
   let new_keys = gen_additional_keys_until_lookahead ~now keys in
   List.iter (fun k -> Hashtbl.replace t.ht k.pub k) new_keys;
-  let+ () = list_iter write_key new_keys in
+  let+ () = list_iter (write_key fs) new_keys in
   t
 
-module Make () = struct
+module Make (Fs : Fat.FS) = struct
   let t =
-    match init () with
+    match init Fs.t with
     | Error e -> Fmt.failwith "secmod_eddsa initialization failure: %s." e
     | Ok t -> t
 
@@ -185,13 +187,13 @@ module Make () = struct
   let add t1 t2 =
     let k = gen_key t1 t2 in
     Hashtbl.replace t.ht k.pub k;
-    let+ () = write_key k in
+    let+ () = write_key t.fs k in
     ()
 
   let delete pub =
     let* k = find pub in
     Hashtbl.remove t.ht k.pub;
-    delete_file (key_fpath k)
+    delete_file t.fs (key_fpath k)
 
   let _delete_outdated ~now =
     Hashtbl.to_seq_values t.ht

src/secmod_rsa.ml

@@ -48,6 +48,7 @@ type key = {
 }
 
 type t = {
+  fs: Fat.t;
   sm_key_priv: EddsaPrivateKey.t;
   sm_pub: EddsaPublicKey.t;
   ht: (DenominationHash.t, key) Hashtbl.t;
@@ -77,28 +78,28 @@ let key_fpath k =
 
 (* -- IO -- *)
 
-let read_eddsa fpath =
+let read_eddsa fs fpath =
   Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
-  let* data = Bos.OS.File.read fpath |> unwrap_msg in
+  let* data = Fat.read fs fpath |> unwrap_msg in
   EddsaPrivateKey.of_octets data
 
-let read_rsa fpath =
+let read_rsa fs fpath =
   Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
-  let* data = Bos.OS.File.read fpath |> unwrap_msg in
+  let* data = Fat.read fs fpath |> unwrap_msg in
   RsaPrivateKey.of_octets data
 
-let write_eddsa fpath priv =
+let write_eddsa fs fpath priv =
   Log.debug (fun m -> m "writing key file `%a`" Fpath.pp fpath);
   let data = EddsaPrivateKey.to_octets priv in
-  Bos.OS.File.write fpath data |> unwrap_msg
+  Fat.write fs fpath data |> unwrap_msg
 
-let write_rsa fpath priv =
+let write_rsa fs fpath priv =
   let data = RsaPrivateKey.to_octets priv in
-  Bos.OS.File.write fpath data |> unwrap_msg
+  Fat.write fs fpath data |> unwrap_msg
 
-let write_key k = write_rsa (key_fpath k) k.priv
+let write_key fs k = write_rsa fs (key_fpath k) k.priv
 
-let delete_file fpath =
+let delete_file fs fpath =
   (* check fpath just to be safe *)
   let () =
     let root = Fpath.v Cfg.key_dir in
@@ -108,10 +109,10 @@ let delete_file fpath =
         Fpath.pp fpath
   in
   Log.debug (fun m -> m "delete key file `%a`" Fpath.pp fpath);
-  let+ () = Bos.OS.File.delete ~must_exist:true fpath |> unwrap_msg in
+  let+ () = Fat.remove fs fpath |> unwrap_msg in
   ()
 
-let get_key_dir_contents dir_fpath =
+let get_key_dir_contents fs dir_fpath =
   let* b = Bos.OS.Dir.create ~mode:0o700 dir_fpath |> unwrap_msg in
   if b then Log.info (fun m -> m "created directory `%a`" Fpath.pp dir_fpath);
   let+ l =
@@ -172,38 +173,38 @@ let sm_key_fpath =
 
 (* we load sm_key separately
    we don't accept non-key files in key_dir *)
-let load_key ~section_name fpath =
+let load_key fs ~section_name fpath =
   match parse_filename fpath with
   | None -> Fmt.error "invalid file `%a`" Fpath.pp fpath
   | Some (t1, t2) ->
-      let+ priv = read_rsa fpath in
+      let+ priv = read_rsa fs fpath in
       let pub = RsaPrivateKey.pub_of_priv priv in
       let h_pub = DenominationHash.hash_of_rsa pub in
       { section_name; priv; pub; h_pub; t1; t2 }
 
-let load_section section_name =
+let load_section fs section_name =
   let section_fpath = Fpath.(v Cfg.key_dir / section_name) in
-  let* l = get_key_dir_contents section_fpath in
+  let* l = get_key_dir_contents fs section_fpath in
   let l = List.filter (fun fpath -> not @@ Fpath.equal fpath sm_key_fpath) l in
-  let* keys = list_map (load_key ~section_name) l in
+  let* keys = list_map (load_key fs ~section_name) l in
   Ok keys
 
-let load () =
+let load fs =
-  let* keys_l = list_map load_section Cfg.sections in
+  let* keys_l = list_map (load_section fs) Cfg.sections in
   let keys = List.concat keys_l in
   match keys with
   | [] -> Ok None
   | _l ->
-      let* sm_key_priv = read_eddsa sm_key_fpath in
+      let* sm_key_priv = read_eddsa fs sm_key_fpath in
       let sm_pub = EddsaPrivateKey.pub_of_priv sm_key_priv in
       let ht = Hashtbl.create 0xff in
       let () = List.iter (fun k -> Hashtbl.replace ht k.h_pub k) keys in
       (* TODO list_issue_date *)
       let last_change = Timestamp.never in
-      Ok (Some { sm_key_priv; sm_pub; ht; last_change })
+      Ok (Some { fs; sm_key_priv; sm_pub; ht; last_change })
 
-let init () =
+let init fs =
-  let* opt = load () in
+  let* opt = load fs in
   let now = TimeAbsolute.of_ptime (Ptime_clock.now ()) in
   let* t =
     match opt with
@@ -212,10 +213,10 @@ let init () =
         let sm_key_priv, sm_pub = EddsaPrivateKey.generate () in
         Log.debug (fun m ->
             m "generated secmod key: `%s`" (EddsaPublicKey.to_b32 sm_pub));
-        let* () = write_eddsa sm_key_fpath sm_key_priv in
+        let* () = write_eddsa fs sm_key_fpath sm_key_priv in
         let ht = Hashtbl.create 0xff in
         let last_change = Timestamp.of_absolute now in
-        Ok { sm_key_priv; sm_pub; ht; last_change }
+        Ok { fs; sm_key_priv; sm_pub; ht; last_change }
   in
   let all_keys = List.of_seq @@ Hashtbl.to_seq_values t.ht in
   let new_keys_l =
@@ -229,12 +230,12 @@ let init () =
   in
   let new_keys = List.concat new_keys_l in
   List.iter (fun k -> Hashtbl.replace t.ht k.h_pub k) new_keys;
-  let+ () = list_iter write_key new_keys in
+  let+ () = list_iter (write_key fs) new_keys in
   t
 
-module Make () = struct
+module Make (Fs : Fat.FS) = struct
   let t =
-    match init () with
+    match init Fs.t with
     | Error e -> Fmt.failwith "secmod_rsa initialization failure: %s." e
     | Ok t -> t
 
@@ -244,7 +245,7 @@ module Make () = struct
   let delete h_pub =
     let* k = find h_pub in
     Hashtbl.remove t.ht h_pub;
-    delete_file (key_fpath k)
+    delete_file t.fs (key_fpath k)
 
   let _delete_outdated ~now =
     Hashtbl.to_seq t.ht
@@ -256,7 +257,7 @@ module Make () = struct
   let add section_name t1 t2 =
     let last_change = Timestamp.of_ptime (Ptime_clock.now ()) in
     let k = gen_key ~section_name t1 t2 in
-    let+ () = write_key k in
+    let+ () = write_key t.fs k in
     Hashtbl.replace t.ht k.h_pub k;
     t.last_change <- last_change;
     ()