From 790b274bd08b675c2b24493be2688cf044632ecd Mon Sep 17 00:00:00 2001 From: swrup Date: Thu, 12 Mar 2026 12:08:21 +0100 Subject: [PATCH] --- src/devices.ml | 26 ++++++++-------- src/fat.ml | 17 ++++++++++ src/keys.ml | 6 ++-- src/mte.ml | 75 +++++++++++++++++++++++++++++++++++++++++---- src/secmod_eddsa.ml | 56 +++++++++++++++++---------------- src/secmod_rsa.ml | 61 ++++++++++++++++++------------------ 6 files changed, 162 insertions(+), 79 deletions(-) create mode 100644 src/fat.ml diff --git a/src/devices.ml b/src/devices.ml index 15c6d389..4f997b2f 100644 --- a/src/devices.ml +++ b/src/devices.ml @@ -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 diff --git a/src/fat.ml b/src/fat.ml new file mode 100644 index 00000000..72b7aeba --- /dev/null +++ b/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 diff --git a/src/keys.ml b/src/keys.ml index 66b48442..4d3f8ca4 100644 --- a/src/keys.ml +++ b/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 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) diff --git a/src/mte.ml b/src/mte.ml index 085cc438..237619f3 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -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 + *) diff --git a/src/secmod_eddsa.ml b/src/secmod_eddsa.ml index f14d7e2e..9ee0b335 100644 --- a/src/secmod_eddsa.ml +++ b/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* 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 diff --git a/src/secmod_rsa.ml b/src/secmod_rsa.ml index 04a8cce6..2d1956ea 100644 --- a/src/secmod_rsa.ml +++ b/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* 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; ()