swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

MNET: wip devices

Browse source
This commit is contained in:
swrup 2026-03-12 12:08:21 +01:00
parent 832098dd58
commit 7ed875cd5e
6 changed files with 162 additions and 79 deletions
Download patch file Download diff file Expand all files Collapse all files

26
src/devices.ml
View file

@ -1,12 +1,6 @@
type env = {
caqti_switch: Caqti_miou.Switch.t;
db_uri: Uri.t;
}
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 } ->
let db_connection caqti_switch : (unit, Caqti_miou.connection) Vif.Device.device =
let f () =
let db_uri= Config.Exchangedb_postgres.config in
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) ->
let keys : (module Keys.S) = (module Keys.Make (Conn)) in
keys
f

17
src/fat.ml Normal file
View file

@ -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

6
src/keys.ml
View file

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

75
src/mte.ml
View file

@ -64,13 +64,75 @@ let routes =
in
tos @ status_info @ management
let () =
Util.Log_reporter.setup ();
let cfg =
let port = Config.Exchange.port in
let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, port)) in
Vif.config ~reporter:Util.Log_reporter.reporter sockaddr
let caqti_get_ok = function
| Error e -> Fmt.failwith "%a" Caqti_error.pp e
| Ok v -> v
let test (module Conn : Caqti_miou.CONNECTION) =
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
*)

56
src/secmod_eddsa.ml
View file

@ -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* l = get_key_dir_contents Cfg.key_dir in
let load fs =
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* opt = load () in
let init fs =
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

61
src/secmod_rsa.ml
View file

@ -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* keys_l = list_map load_section Cfg.sections in
let load fs =
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* opt = load () in
let init fs =
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;
()