MTE unikernel with Mkernel+Mnet+Vifu

.gitignore

@@ -3,3 +3,4 @@ _taler_exchange_sql
 assets
 secrets
 !secrets/.keep
+vendors

.ocamlformat-ignore

@@ -0,0 +1 @@
+vendors/**

GNUmakefile

@@ -0,0 +1,61 @@
+vendor_list := \
+	mkernel zarith bstr mnet mirage-crypto-rng-mkernel gmp digestif \
+	kdf utcp flux h1 httpcats mhttp multipart_form-miou prettym tls \
+	x509 vifu cachet mfat caqti \
+	base32 cohttp mirage-mtime mirage-ptime
+
+secmod_fat=assets/secmod.fat
+tap_device=tap0
+
+check-kvm:
+	$(if $(wildcard /dev/kvm),,$(error KVM support not enabled))
+
+# todo: just opam install . --deps-only?
+installs:
+	opam install --yes dune utop merlin ocp-browser ocamlformat
+	# opam install --yes mcrunch
+	opam install --yes crunch
+	opam install --yes sqlite3 # needed for caqti even if not used
+	opam install --yes caqti-driver-pgx
+	opam install --yes $(vendor_list)
+
+pins:
+	opam pin --no-action --yes "git+https://github.com/robur-coop/mcrunch.git#682ed63c03e3be5664f96c469a260e1d9e9df011"
+	opam pin --no-action --yes "git+https://github.com/mirage/Zarith.git#zarith-1.14"
+	opam pin --no-action --yes "git+https://github.com/swrup/mirage-mtime.git#6a6bb4dd25624a3c43e6417dcdf73f3c689946a7"
+	opam pin --no-action --yes "git+https://github.com/robur-coop/vif.git#8c6ac3fb97cb9a31bf6ad8ec63c942336dcfd03e"
+	opam pin --no-action --yes add caqti "git+https://github.com/swrup/ocaml-caqti.git#7838c29ffa9095d32b95affee26b22ef2ad302fd"
+	opam pin --no-action --yes add caqti-miou "git+https://github.com/swrup/ocaml-caqti.git#7838c29ffa9095d32b95affee26b22ef2ad302fd"
+	opam pin --no-action --yes add caqti-mnet "git+https://github.com/swrup/ocaml-caqti.git#7838c29ffa9095d32b95affee26b22ef2ad302fd"
+	opam pin --no-action --yes add caqti-driver-pgx "git+https://github.com/swrup/ocaml-caqti.git#7838c29ffa9095d32b95affee26b22ef2ad302fd"
+	opam pin --no-action --yes "git+https://github.com/swrup/mfat.git#40afdb419df56d4932928a61906e012a3c534549"
+
+
+.PHONY: vendors
+vendors:
+	@mkdir -p vendors
+	@for v in $(vendor_list); do \
+	  [ -d vendors/$$v ] || opam source $$v --dir vendors/$$v ; \
+	done
+
+.PHONY: clean
+clean:
+	rm -rf _build/
+	rm -rf vendors/
+
+# todo: don't erase already existing
+secmod.fat:
+	@mkdir -p assets
+	mfat make --sectors=2048 $(secmod_fat)
+
+assets:
+	cp default/assets ./
+
+manifest:
+	dune exec src/mte.exe > src/manifest.json
+
+build:
+	dune build src/mte.exe
+
+run: build
+	solo5-hvt --block:storage=$(secmod_fat) --net:service=$(tap_device) -- ./_build/solo5/src/mte.exe --solo5:quiet

default/assets/mte.conf

@@ -27,7 +27,7 @@ max_keys_caching = "4 weeks"
 enable_kyc = NO
 terms_etag = "0"
 privacy_etag = "0"
-base_url = "http://localhost:3434/"
+base_url = "http://10.0.0.2:3434/"
 
 [exchangedb]
 idle_reserve_expiration_time = "1 year 2 weeks 3 hours 4 minutes 5 seconds"
@@ -37,21 +37,17 @@ max_aml_program_runtime = "1 year"
 default_purse_limit = 9999
 
 [exchangedb-postgres]
-config = "pgx://mte:hunter2@localhost:5432/taler-exchange"
+config = "pgx://mte:hunter2@10.0.0.1:5432/taler-exchange"
 
 [taler-exchange-secmod-rsa]
 lookahead_sign = "7 weeks"
 overlap_duration = "1 hour"
 duration = "3 weeks"
-key_dir = "secrets/secmod_rsa"
-sm_priv_key = "secrets/secmod_rsa/sm_key"
 
 [taler-exchange-secmod-eddsa]
 lookahead_sign = "1 year"
 overlap_duration = "1 hour"
 duration = "3 weeks"
-key_dir = "secrets/secmod_eddsa"
-sm_priv_key = "secrets/secmod_eddsa/sm_key"
 
 [coin_kudo_1]
 value= KUDOS:0.01

dune

@@ -0,0 +1 @@
+(vendored_dirs vendors)

dune-project

@@ -2,45 +2,45 @@
 
 (name mte)
 
-(generate_opam_files true)
+; (generate_opam_files true)
-
+;
-; (source
+; ; (source
-; (github username/reponame))
+; ; (github username/reponame))
-
+;
-(authors "Olivier Pierre <swrup@protonmail.com>")
+; (authors "Olivier Pierre <swrup@protonmail.com>")
-
+;
-(maintainers "Olivier Pierre <swrup@protonmail.com>")
+; (maintainers "Olivier Pierre <swrup@protonmail.com>")
-
+;
-(license AGPL-3.0-only)
+; (license AGPL-3.0-only)
-
+;
-; (documentation https://url/to/documentation)
+; ; (documentation https://url/to/documentation)
-
+;
-(package
+; (package
- (name mte)
+;  (name mte)
- (synopsis "MTE - the MirageOS Taler Exchange")
+;  (synopsis "MTE - the MirageOS Taler Exchange")
- (description "A GNU Taler exchange implementation with the unikernel framework MirageOS")
+;  (description "A GNU Taler exchange implementation with the unikernel framework MirageOS")
- (tags
+;  (tags
-  ("GNU Taler" MirageOS unikernel OCaml crypto))
+;   ("GNU Taler" MirageOS unikernel OCaml crypto))
- (depends
+;  (depends
-   (ocaml (>= 5.3))
+;    (ocaml (>= 5.3))
-   base32
+;    base32
-   caqti
+;    caqti
-   caqti-miou
+;    caqti-miou
-   caqti-driver-pgx
+;    caqti-driver-pgx
-   crunch
+;    crunch
-   vif
+;    vif
-   jsont
+;    jsont
-   cohttp
+;    cohttp
-   fmt
+;    fmt
-   bin
+;    bin
-   angstrom
+;    angstrom
-   mirage-crypto
+;    mirage-crypto
-   kdf
+;    kdf
-   digestif
+;    digestif
-   duration
+;    duration
-   jsont
+;    jsont
-   cohttp
+;    cohttp
-   ptime
+;    ptime
-   logs
+;    logs
-  (ocamlformat :with-dev-setup)
+;   (ocamlformat :with-dev-setup)
-   ))
+;    ))

dune-workspace

@@ -0,0 +1,7 @@
+(lang dune 3.0)
+(context (default))
+(context (default
+ (name solo5)
+ (host default)
+ (toolchain solo5)
+ (disable_dynamically_linked_foreign_archives true)))

network.sh

@@ -0,0 +1,9 @@
+#!/bin/bash
+set -e
+
+sudo ip link add br0 type bridge
+sudo ip addr add 10.0.0.1/24 dev br0
+sudo ip tuntap add tap0 mode tap
+sudo ip link set tap0 master br0
+sudo ip link set br0 up
+sudo ip link set tap0 up

src/amount.mli

@@ -18,6 +18,8 @@ val make :
 
 (* fail on differents currencies *)
 val compare : t -> t -> int
+
+(* TODO rename pp_dump *)
 val pp : Format.formatter -> t -> unit
 val to_string : t -> string
 val of_string : string -> (t, string) result

src/config.ml

@@ -211,6 +211,10 @@ module Coin = struct
   let all_coins = List.map parse_coin coin_sections
 end
 
+let spath s =
+  let open Fat.Spath in
+  match of_string s with Error (`Msg e) -> fail "%s" e | Ok v -> v
+
 module Exchange_secmod_rsa = struct
   let get field =
     let section = "taler-exchange-secmod-" ^ "rsa" in
@@ -218,8 +222,10 @@ module Exchange_secmod_rsa = struct
 
   let lookahead_sign = get "lookahead_sign" |> duration
   let overlap_duration = get "overlap_duration" |> duration
-  let key_dir = get "key_dir"
+
-  let sm_priv_key = get "sm_priv_key"
+  (* 8.3 filenames for FAT *)
+  let key_dir = "rsa" |> spath
+  let sm_priv_key = "sm_rsa" |> spath
 end
 
 module Exchange_secmod_eddsa = struct
@@ -230,8 +236,8 @@ module Exchange_secmod_eddsa = struct
   let lookahead_sign = get "lookahead_sign" |> duration
   let overlap_duration = get "overlap_duration" |> duration
   let duration = get "duration" |> duration
-  let key_dir = get "key_dir"
+  let key_dir = "eddsa" |> spath
-  let sm_priv_key = get "sm_priv_key"
+  let sm_priv_key = "sm_eddsa" |> spath
 end
 
 (* -- *)

src/crypto.ml

@@ -1,3 +1,4 @@
+(* TODO refacto crypto+hash+fdh_rsa *)
 open Syntax
 
 module Binary_format_rsa = struct
@@ -237,6 +238,23 @@ module RsaPrivateKey = struct
   let of_octets = Binary_format_rsa.priv_of_octets
   let to_octets = Binary_format_rsa.priv_to_octets
 
+  (* we use Bin.cstring because size of key (~bits) can change depending on section_name
+     we also have to b32 encode/decode our octets because of null-char
+
+     enforce all to be of the same size instead? *)
+  let bin =
+    let of_octets_exn s =
+      let res =
+        let* s = B32.decode s in
+        of_octets s
+      in
+      match res with
+      | Error e -> Fmt.failwith "RsaPrivateKey.bin decoding failure: %s." e
+      | Ok t -> t
+    in
+    let to_octets t = to_octets t |> B32.encode in
+    Bin.map Bin.cstring of_octets_exn to_octets
+
   let jsont =
     let of_b32 s =
       let* s = B32.decode s in
@@ -247,9 +265,18 @@ module RsaPrivateKey = struct
     Jsont.of_of_string ~kind:"RsaPrivateKey" of_b32 ~enc:to_b32
 end
 
-module RsaSignature = struct
+module RsaSignature : sig
+  type t
+
+  val sign : key:RsaPrivateKey.t -> string -> t
+  val jsont : t Jsont.t
+end = struct
   type t = string
 
+  (* decrypt <=> sign *)
+  let sign ~key bmsg =
+    Mirage_crypto_pk.Rsa.decrypt ~crt_hardening:true ~key bmsg
+
   let jsont =
     let of_b32 s = B32.decode s in
     let to_b32 t = B32.encode t in

src/devices.ml

@@ -1,26 +0,0 @@
-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 } ->
-  match Caqti_miou_unix.connect ~sw:caqti_switch db_uri with
-  | Error err ->
-      Fmt.failwith "Database connection failure: %a." Caqti_error.pp err
-  | Ok conn -> (
-      match Pg.preflight conn with
-      | Error err ->
-          Fmt.failwith "Database preflight failure: %a." Caqti_error.pp err
-      | Ok () ->
-          Logs.info (fun m -> m "database connection initialized");
-          conn)
-
-let keys =
-  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

src/dune

@@ -1,34 +1,48 @@
 (executable
- (public_name mte)
  (name mte)
  (modules mte)
- (libraries mte))
+ (link_flags :standard -cclib "-z solo5-abi=hvt")
+ (libraries mte)
+ (foreign_stubs
+  (language c)
+  (names manifest)))
 
 (library
  (name mte)
  (wrapped false)
  (modules :standard \ mte b32)
  (libraries
+  ;
+  mkernel
+  mnet
+  mnet-happy-eyeballs
+  mnet-dns
+  vifu
+  gmp
+  mirage-crypto
+  mirage-crypto-rng
+  mirage-crypto-rng-mkernel
+  mirage-mtime.solo5
+  mirage-ptime.solo5
+  mfat
+  ;
   b32
   ;
   caqti
   caqti-miou
-  caqti-miou.unix
+  caqti-mnet
   caqti-driver-pgx
+  pgx
+  ;
   bin
-  mirage-crypto
+  jsont
+  cohttp ; just for header stuff
+  duration
   kdf.hkdf
   digestif
-  duration
-  vif
   fmt
-  jsont
-  cohttp
-  ptime
   logs
-  logs.fmt
+  logs.fmt))
-  logs.threaded
-  fmt.tty))
 
 (library ; crockford base32
  (name b32)
@@ -43,3 +57,18 @@
   (with-stdout-to
    %{null}
    (run ocaml-crunch -m plain ../assets -o %{target}))))
+
+(rule
+ (targets manifest.c)
+ (deps manifest.json)
+ (enabled_if
+  (= %{context_name} "solo5"))
+ (action
+  (run solo5-elftool gen-manifest manifest.json manifest.c)))
+
+(rule
+ (targets manifest.c)
+ (enabled_if
+  (= %{context_name} "default"))
+ (action
+  (write-file manifest.c "")))

src/env.ml

@@ -0,0 +1,7 @@
+type t = {
+  sw: Caqti_miou.Switch.t;
+  stack: Mnet.stack;
+  tcp: Mnet.TCP.state;
+  dns: Mnet_dns.t;
+  fs: Fat.t;
+}

src/fat.ml

@@ -0,0 +1,27 @@
+module Fat = Mfat.Make (struct
+  include Mkernel.Block
+
+  let read = atomic_read
+  let write = atomic_write
+end)
+
+module Sfn = Mfat.Sfn
+module Spath = Mfat.Spath
+include Fat
+
+type entry = Mfat.entry = {
+  name: Sfn.t;
+  is_dir: bool;
+  size: int32;
+}
+
+let create blk =
+  match Fat.create blk with
+  | Error (`Msg e) -> Fmt.failwith "FAT file system failure: %s." e
+  | Ok fs -> fs
+
+type t = Mkernel.Block.t Mfat.t
+
+module type FS = sig
+  val t : t
+end

src/fdh_rsa.ml

@@ -72,12 +72,9 @@ let unblind_sig pub ~bks bsig =
   let data = Z.rem (Z.mul data r_inv) pub.n in
   Z_extra.to_octets_be data
 
-(* decrypt <=> sign *)
-let sign ~key bmsg = Mirage_crypto_pk.Rsa.decrypt ~crt_hardening:true ~key bmsg
-
 let verify ~key s ~msg =
   let msg_fdh = rsa_full_domain_hash key msg in
-  let s1 = Z_extra.to_octets_be msg_fdh in
+  let s1 = Mirage_crypto_pk.Z_extra.to_octets_be msg_fdh in
   let s2 = Mirage_crypto_pk.Rsa.encrypt ~key s in
   match Eqaf.equal s1 s2 with
   | false -> Fmt.error "RSA signature verification failed"

src/global.ml

@@ -0,0 +1,29 @@
+(* IMPROVE: use caqti pool
+   [connect_pool] with parameter [?post_connect] for preflight *)
+let db_conn =
+  let f Env.{ sw; stack; tcp; dns; fs= _ } =
+    Logs.info (fun m -> m "Connecting to database ...");
+    let db_uri = Config.Exchangedb_postgres.config in
+    match Caqti_mnet.connect ~sw stack tcp dns db_uri with
+    | Error err ->
+        Fmt.failwith "Database connection failure: %a." Caqti_error.pp err
+    | Ok conn ->
+        Logs.info (fun m -> m "... connection done.");
+        let () = Pg.preflight conn in
+        Logs.info (fun m -> m "Preflight done.");
+        conn
+  in
+  let finally (module Conn : Pg.CONN) = Conn.disconnect () in
+  Vifu.Device.v ~name:"db_conn" ~finally [] f
+
+let keys =
+  let f (module Conn : Pg.CONN) (env : Env.t) =
+    let (module Fs : Fat.FS) =
+      (module struct
+        let t = env.fs
+      end)
+    in
+    (module Keys.Make (Conn) (Fs) : Keys.S)
+  in
+  let finally _keys = () in
+  Vifu.Device.v ~name:"keys" ~finally [ Vifu.Device.value db_conn ] f

src/headers.ml

@@ -9,7 +9,7 @@ let avail_languages_header_value =
 (* TODO better headers_lib
    Cohttp raises on invalid *)
 let select_mimetype headers =
-  let opt = Vif.Headers.get headers "accept" in
+  let opt = Vifu.Headers.get headers "accept" in
   Cohttp.Accept.media_ranges opt
   |> Cohttp.Accept.qsort
   |> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp m)
@@ -18,7 +18,7 @@ let select_mimetype headers =
   | Some mime -> mime
 
 let select_language headers =
-  let opt = Vif.Headers.get headers "accept-language" in
+  let opt = Vifu.Headers.get headers "accept-language" in
   Cohttp.Accept.languages opt
   |> Cohttp.Accept.qsort
   |> List.map snd
@@ -28,7 +28,7 @@ let select_language headers =
   | Some lang -> lang
 
 let select_encoding headers =
-  let opt = Vif.Headers.get headers "accept-encoding" in
+  let opt = Vifu.Headers.get headers "accept-encoding" in
   Cohttp.Accept.encodings opt
   |> Cohttp.Accept.qsort
   |> List.map snd

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)
 
@@ -63,7 +63,7 @@ module Make (Conn : Pg.CONN) : S = struct
         ())
 
   let signkeys () : Signkey.t list result =
-    let now = Timestamp.of_ptime @@ Ptime_clock.now () in
+    let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
     let+ l = Pg.get_signkeys conn ~now |> unwrap_caqti in
     let missing_l, l =
       List.partition
@@ -92,8 +92,6 @@ module Make (Conn : Pg.CONN) : S = struct
             m "found %d active denomination(s)" (List.length l));
         l
 
-  let denominations_last_change () = Sm_rsa.last_change ()
-
   let make_future_sk (pub, (start, expire)) =
     Logs.debug (fun m -> m "make_future_sk: `%s`" (EddsaPublicKey.to_b32 pub));
     let open Time in
@@ -198,7 +196,7 @@ module Make (Conn : Pg.CONN) : S = struct
         Ok future_dn
 
   let make_future_keys_response () =
-    let now = Timestamp.of_ptime @@ Ptime_clock.now () in
+    let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
     (* get keys from database to filter out keys already certified *)
     let* sk_db_l = Pg.get_signkeys conn ~now |> unwrap_caqti in
     let sk_ht = Hashtbl.create 0xff in
@@ -289,6 +287,10 @@ module Make (Conn : Pg.CONN) : S = struct
     Denomination.verify_denomination_key_validity ~key:Config.master_public_key
       dn
 
+  (* MIOU *)
+  let last_change = ref Timestamp.never
+  let denominations_last_change () = !last_change
+
   let certify_future_signkey Api.SignKeySignature.{ key= pub; master_sig } =
     match Sm_eddsa.find_key pub with
     | None -> Error "future signkey not found"

src/manifest.json

@@ -0,0 +1 @@
+{"type":"solo5.manifest","version":1,"devices":[{"type":"NET_BASIC","name":"service"},{"type":"BLOCK_BASIC","name":"storage"}]}

src/mte.ml

@@ -14,17 +14,22 @@
     along with this program.  If not, see <https://www.gnu.org/licenses/>. *)
 
 let hello req _server _env =
-  let open Vif.Response in
+  let open Vifu.Response in
   let open Syntax in
   let* () = with_string req "Hello~~\n" in
   let* () = add ~field:"content-type" "text/plain" in
   respond `OK
 
+(* TODO nice routes typing
+   to enforce json verification
+   to specify handlers responses data and status codes
+
+   use Vif.Uri.conv *)
 let routes =
-  let open Vif.Uri in
+  let open Vifu.Uri in
-  let open Vif.Route in
+  let open Vifu.Route in
   let get path = get (path /?? any) in
-  let post path jsont = post (Vif.Type.json_encoding jsont) (path /?? any) in
+  let post path jsont = post (Vifu.Type.json_encoding jsont) (path /?? any) in
   let v s = rel / s in
   let tos =
     [
@@ -64,20 +69,35 @@ let routes =
   in
   tos @ status_info @ management
 
+module RNG = Mirage_crypto_rng.Fortuna
+
 let () =
+  let ( let@ ) finally fn = Fun.protect ~finally fn in
   Util.Log_reporter.setup ();
-  let cfg =
+  let rng =
-    let port = Config.Exchange.port in
+    let rng () = Mirage_crypto_rng_mkernel.initialize (module RNG) in
-    let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, port)) in
+    Mkernel.map rng Mkernel.[]
-    Vif.config ~reporter:Util.Log_reporter.reporter sockaddr
   in
-  Miou_unix.run @@ fun () ->
+  let storage = Mkernel.block "storage" in
-  Caqti_miou.Switch.run @@ fun caqti_switch ->
+  let service =
-  let env : Devices.env =
+    let ipv4 = Ipaddr.V4.Prefix.of_string_exn "10.0.0.2/24" in
-    { caqti_switch; db_uri= Config.Exchangedb_postgres.config }
+    Mnet.stack ~name:"service" ipv4
   in
-  let devices = Vif.Devices.[ Devices.db_connection; Devices.keys ] in
+  Mkernel.(run [ rng; storage; service ])
-  let middlewares = Vif.Middlewares.[] in
+  @@ fun rng storage (stack, tcp, udp) () ->
+  let@ () = fun () -> Mirage_crypto_rng_mkernel.kill rng in
+  let@ () = fun () -> Mnet.kill stack in
+  let hed, he = Mnet_happy_eyeballs.create tcp in
+  let@ () = fun () -> Mnet_happy_eyeballs.kill hed in
+  let dns = Mnet_dns.create (udp, he) in
+  let t = Mnet_dns.transport dns in
+  let@ () = fun () -> Mnet_dns.Transport.kill t in
+  Caqti_miou.Switch.run @@ fun sw ->
+  (* -- *)
+  let fs = Fat.create storage in
+  let env = Env.{ sw; stack; tcp; dns; fs } in
+  let devices = Vifu.Devices.[ Global.db_conn; Global.keys ] in
+  let cfg = Vifu.Config.v Config.Exchange.port in
   Logs.info (fun m ->
       m ~tags:(Util.Log_reporter.detail "...") "Starting MTE server");
-  Vif.run ~cfg ~devices ~middlewares routes env
+  Vifu.run ~cfg ~devices tcp routes env

src/mte_info.ml

@@ -7,9 +7,9 @@ module String_map = Stdlib.Map.Make (Stdlib.String)
    maybe don't use the same RNG-initialization as the one used to generate keys *)
 let seed req _server _env =
   Logs.info (fun m -> m "GET /seed");
-  (* RNG is initialized by Vif.run *)
+  (* RNG is initialized by Vifu.run *)
   let s = Mirage_crypto_rng.generate 64 in
-  let open Vif.Response in
+  let open Vifu.Response in
   let open Syntax in
   let* () = add ~field:"content-type" "application/octet-stream" in
   let* () = with_string req s in
@@ -86,7 +86,7 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date =
 
   (* the eddsa pub key used to sign exchange_sig *)
   let* exchange_pub =
-    let now = Timestamp.of_ptime (Ptime_clock.now ()) in
+    let now = Timestamp.of_ptime (Mirage_ptime.now ()) in
     let opt =
       List.find_opt (fun sk -> Signkey.is_valid_at ~timestamp:now sk) signkeys
     in
@@ -158,11 +158,11 @@ let jsont = ExchangeKeysResponse.jsont
 
 let keys req server _env =
   Logs.info (fun m -> m "GET /keys");
-  let db_conn = Vif.Server.device Devices.db_connection server in
+  let db_conn = Vifu.Server.device Global.db_conn server in
-  let keys = Vif.Server.device Devices.keys server in
+  let keys = Vifu.Server.device Global.keys server in
   let res =
     let* last_issue_date =
-      match Vif.Queries.get req "last_issue_date" with
+      match Vifu.Queries.get req "last_issue_date" with
       | [] -> Ok None
       | s :: _ -> (
           match Int64.of_string_opt s with

src/mte_management.ml

@@ -7,7 +7,7 @@ module Keys_get = struct
 
   let f req server _env =
     Logs.info (fun m -> m "GET /management/keys/");
-    let (module Keys : Keys.S) = Vif.Server.device Devices.keys server in
+    let (module Keys : Keys.S) = Vifu.Server.device Global.keys server in
     let res =
       let* v = Keys.make_future_keys_response () in
       Api.encode jsont v
@@ -31,9 +31,9 @@ module Keys_post = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/keys/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
     let res =
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys v in
       let* () = do_ keys v in
       Ok ()
@@ -56,10 +56,10 @@ module Denom_revoke = struct
 
   let f req h_denom_pub server _env =
     Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
     let res =
       let* h_denom_pub = Crypto.DenominationHash.of_b32 h_denom_pub in
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys h_denom_pub v in
       let* () = do_ keys h_denom_pub v in
       Ok ()
@@ -82,10 +82,10 @@ module Signkey_revoke = struct
 
   let f req exchange_pub server _env =
     Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
     let res =
       let* exchange_pub = Crypto.EddsaPublicKey.of_b32 exchange_pub in
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys exchange_pub v in
       let* () = do_ keys exchange_pub v in
       Ok ()
@@ -133,10 +133,10 @@ module Auditors = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/auditors/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
-    let db_conn = Vif.Server.device Devices.db_connection server in
+    let db_conn = Vifu.Server.device Global.db_conn server in
     let res =
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys v in
       let* () = do_ ~db_conn v in
       Ok ()
@@ -178,11 +178,11 @@ module Auditors_disable = struct
 
   let f req auditor_pub server _env =
     Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
-    let db_conn = Vif.Server.device Devices.db_connection server in
+    let db_conn = Vifu.Server.device Global.db_conn server in
     let res =
       let* auditor_pub = Crypto.EddsaPublicKey.of_b32 auditor_pub in
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys auditor_pub v in
       let* () = do_ ~db_conn auditor_pub v in
       Ok ()
@@ -238,10 +238,10 @@ module Wire_fee = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/wire-fee/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
-    let db_conn = Vif.Server.device Devices.db_connection server in
+    let db_conn = Vifu.Server.device Global.db_conn server in
     let res =
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys v in
       let* () = do_ ~db_conn v in
       Ok ()
@@ -284,9 +284,9 @@ module Global_fees = struct
      and once set for a timeframe, it should not change. *)
   let f req server _env =
     Logs.info (fun m -> m "POST /management/global-fees/");
-    let db_conn = Vif.Server.device Devices.db_connection server in
+    let db_conn = Vifu.Server.device Global.db_conn server in
     let res =
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify v in
       let* () = do_ ~db_conn v in
       Ok ()
@@ -399,10 +399,10 @@ module Wire = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/wire/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
-    let db_conn = Vif.Server.device Devices.db_connection server in
+    let db_conn = Vifu.Server.device Global.db_conn server in
     let res =
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys v in
       let* () = do_ ~db_conn v in
       Ok ()
@@ -438,10 +438,10 @@ module Wire_disable = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/wire/disable/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
-    let db_conn = Vif.Server.device Devices.db_connection server in
+    let db_conn = Vifu.Server.device Global.db_conn server in
     let res =
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys v in
       let* () = do_ ~db_conn v in
       Ok ()
@@ -487,10 +487,10 @@ module Drain = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/drain/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
-    let db_conn = Vif.Server.device Devices.db_connection server in
+    let db_conn = Vifu.Server.device Global.db_conn server in
     let res =
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys v in
       let* () = do_ ~db_conn v in
       Ok ()
@@ -527,10 +527,10 @@ module AmlOfficer = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/aml-officers/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
-    let db_conn = Vif.Server.device Devices.db_connection server in
+    let db_conn = Vifu.Server.device Global.db_conn server in
     let res =
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys v in
       let* () = do_ ~db_conn v in
       Ok ()
@@ -569,10 +569,10 @@ module Partners = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/partners/");
-    let keys = Vif.Server.device Devices.keys server in
+    let keys = Vifu.Server.device Global.keys server in
-    let db_conn = Vif.Server.device Devices.db_connection server in
+    let db_conn = Vifu.Server.device Global.db_conn server in
     let res =
-      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* v = Vifu.Request.of_json req |> unwrap_msg in
       let* () = verify keys v in
       let* () = do_ ~db_conn v in
       Ok ()

src/mte_terms.ml

@@ -2,9 +2,9 @@
 
 let aux asset req _server _env =
   let etag = Assets.etag asset in
-  let headers = Vif.Request.headers req in
+  let headers = Vifu.Request.headers req in
   let has_matching_etag =
-    match Vif.Headers.get headers "if-none-match" with
+    match Vifu.Headers.get headers "if-none-match" with
     | None -> Ok false
     | Some s ->
         Headers_lib.If_none_match.parse s
@@ -19,7 +19,7 @@ let aux asset req _server _env =
       let compression = Headers.select_encoding headers in
       let data = Assets.get_content ~mime ~lang asset in
       (* -- *)
-      let open Vif.Response in
+      let open Vifu.Response in
       let open Syntax in
       let* () = with_string ?compression req data in
       let* () =

src/pg.ml

@@ -26,7 +26,12 @@ let preflight =
         "SET search_path TO exchange;";
       ]
   in
-  fun (module Conn : CONN) -> Syntax.list_iter (fun p -> Conn.exec p ()) l
+  fun (module Conn : CONN) ->
+    let r = Syntax.list_iter (fun p -> Conn.exec p ()) l in
+    match r with
+    | Error err ->
+        Fmt.failwith "Database preflight failure: %a." Caqti_error.pp err
+    | Ok () -> ()
 
 let find_signkey =
   let req =

src/respond.ml

@@ -4,7 +4,7 @@ let encode_error_detail err =
   | Ok s -> s
 
 let respond_json req content status =
-  let open Vif.Response in
+  let open Vifu.Response in
   let open Syntax in
   let* () = add ~field:"content-type" "application/json" in
   let* () = with_string req content in
@@ -32,14 +32,14 @@ let ok content req =
 
 let no_content () =
   Logs.debug (fun m -> m "no content");
-  let open Vif.Response in
+  let open Vifu.Response in
   let open Syntax in
   let* () = empty in
   respond `No_content
 
 let not_modified () =
   Logs.debug (fun m -> m "not modified");
-  let open Vif.Response in
+  let open Vifu.Response in
   let open Syntax in
   let* () = empty in
   respond `Not_modified

src/secmod_eddsa.ml

@@ -1,8 +1,12 @@
 (* TODO
    ! use lock
+   !? Scanf not thread-safe
    schedule tasks
-   sign: check timestamps before signing
+   sign: check timestamps before signing *)
-
+(* IMPROVE
+   Bin encode/decode
+     - catch failure
+     - should use little-endian
    list_issue_date: save timestamp of key generation
    key validity period:
      more checks + do not exceed lookahead
@@ -15,6 +19,8 @@ module Log = (val Logs.src_log src : Logs.LOG)
 open Syntax
 open Crypto
 open Time
+module Sfn = Mfat.Sfn
+module Spath = Mfat.Spath
 module Cfg = Config.Exchange_secmod_eddsa
 
 type key = {
@@ -25,74 +31,65 @@ type key = {
 }
 
 type t = {
-  sm_key_priv: EddsaPrivateKey.t;
+  fs: Fat.t;
+  sm_priv: EddsaPrivateKey.t;
   sm_pub: EddsaPublicKey.t;
   ht: (EddsaPublicKey.t, key) Hashtbl.t;
 }
 
-let parse_filename =
+(* todo: this should be encoded in little-endian *)
-  let scan_filename s =
+let key_bin =
-    Scanf.sscanf_opt s "%Lu-%Lu" (fun t1 t2 ->
+  let open Bin in
-        (TimeAbsolute.of_s t1, TimeAbsolute.of_s t2))
+  record (fun t1 t2 priv ->
-  in
+      let pub = EddsaPrivateKey.pub_of_priv priv in
-  fun fpath -> scan_filename (Fpath.filename fpath)
+      { t1; t2; priv; pub })
+  |+ field TimeAbsolute.bin (fun t -> t.t1)
+  |+ field TimeAbsolute.bin (fun t -> t.t2)
+  |+ field EddsaPrivateKey.bin (fun t -> t.priv)
+  |> sealr
 
-let pp_filename =
+(* for sm_key only *)
-  let to_int64 abs =
+let read_eddsa fs spath =
-    abs |> Timestamp.of_absolute |> Timestamp.to_s |> function
+  Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath);
-    | None ->
+  let* data = Fat.read fs spath |> unwrap_msg in
-        (* (= `never`) this should not happen given resonable config value *)
+  let* priv = EddsaPrivateKey.of_octets data in
-        Fmt.failwith "encountered timestamp with value `never`"
+  let pub = EddsaPrivateKey.pub_of_priv priv in
-    | Some i -> i
+  Ok (priv, pub)
-  in
-  fun ppf (t1, t2) -> Fmt.pf ppf "%Lu-%Lu" (to_int64 t1) (to_int64 t2)
 
-let key_fpath k =
+let write_eddsa fs spath priv =
-  let fname = Fmt.str "%a" pp_filename (k.t1, k.t2) in
+  Log.debug (fun m -> m "writing key file `%a`" Spath.pp spath);
-  Fpath.(v Cfg.key_dir / fname)
-
-(* -- IO -- *)
-
-let read_key fpath =
-  Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
-  let* data = Bos.OS.File.read fpath |> unwrap_msg in
-  EddsaPrivateKey.of_octets data
-
-let write_eddsa 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 spath data |> unwrap_msg
 
-let write_key k = write_eddsa (key_fpath k) k.priv
+let key_spath k =
+  let sfn_res = String.sub (EddsaPublicKey.to_b32 k.pub) 0 8 |> Sfn.of_string in
+  match sfn_res with
+  | Error _ -> failwith "not possible"
+  | Ok sfn -> Spath.(Cfg.key_dir / sfn)
 
-let delete_file fpath =
+let read_key fs spath =
-  (* check fpath just to be safe *)
+  Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath);
-  let () =
+  let* data = Fat.read fs spath |> unwrap_msg in
-    let root = Fpath.v Cfg.key_dir in
+  (* todo: catch failure *)
-    if not @@ Fpath.is_rooted ~root fpath then
+  let k = Bin.decode key_bin data (ref 0) in
-      Fmt.failwith
+  Ok k
-        "delete_file failure: file `%a` is not contained in secmod directory"
+
-        Fpath.pp fpath
+let write_key fs k =
-  in
+  let spath = key_spath k in
-  Log.debug (fun m -> m "delete key file `%a`" Fpath.pp fpath);
+  Log.debug (fun m -> m "writing key file `%a`" Spath.pp spath);
-  let+ () = Bos.OS.File.delete ~must_exist:true fpath |> unwrap_msg in
+  let data = Bin.to_string key_bin k in
+  Fat.write fs spath data |> unwrap_msg
+
+let delete_file fs spath =
+  Log.debug (fun m -> m "delete key file `%a`" Spath.pp spath);
+  let+ () = Fat.remove fs spath |> unwrap_msg in
   ()
 
-let get_key_dir_contents dir =
-  let* dir = Fpath.of_string dir |> unwrap_msg in
-  let* b = Bos.OS.Dir.create ~mode:0o700 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
-  List.map Fpath.normalize l
-
-(* -- *)
-
 let gen_key t1 t2 =
   let priv, pub = EddsaPrivateKey.generate () in
-  Log.debug (fun m ->
+  let k = { priv; pub; t1; t2 } in
-      m "generated key (%a):@,`%s`" pp_filename (t1, t2)
+  Log.debug (fun m -> m "generated key `%s`" (EddsaPublicKey.to_b32 pub));
-        (EddsaPublicKey.to_b32 pub));
+  k
-  { priv; pub; t1; t2 }
 
 let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
 
@@ -124,58 +121,50 @@ let gen_additional_keys_until_lookahead ~now l =
     let new_keys = List.map (fun (t1, t2) -> gen_key t1 t2) periodes in
     new_keys
 
-let sm_key_fpath =
+let load fs =
-  Result.get_ok
+  let* () =
-  @@
+    if Fat.exists fs Cfg.key_dir then Ok ()
-  let+ fpath = Fpath.of_string Cfg.sm_priv_key |> unwrap_msg in
+    else Fat.mkdir fs Cfg.key_dir |> unwrap_msg
-  Fpath.normalize fpath
+  in
-
+  let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in
-(* we load sm_key separately
+  let l = List.map (fun entry -> entry.Fat.name) l in
-   we don't accept non-key files in key_dir *)
+  let l = List.map (Spath.add Cfg.key_dir) l in
-let load_key fpath =
+  let l =
-  match parse_filename fpath with
+    List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_priv_key) l
-  | None -> Fmt.error "invalid file `%a`" Fpath.pp fpath
+  in
-  | Some (t1, t2) ->
+  let* keys = list_map (read_key fs) l in
-      let+ priv = read_key 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 l = List.filter (fun fpath -> not @@ Fpath.equal fpath sm_key_fpath) l in
-  let* keys = list_map load_key l in
   match keys with
   | [] -> Ok None
   | _l ->
-      let* sm_key_priv = read_key sm_key_fpath in
+      let* sm_priv, sm_pub = read_eddsa fs Cfg.sm_priv_key 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_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
     | None ->
-        let sm_key_priv, sm_pub = EddsaPrivateKey.generate () in
+        let sm_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 ht = Hashtbl.create 0xff in
-        Ok { sm_key_priv; sm_pub; ht }
+        let t = { fs; sm_priv; sm_pub; ht } in
+        let* () = write_eddsa fs Cfg.sm_priv_key t.sm_priv in
+        Ok t
   in
-  let now = TimeAbsolute.of_ptime (Ptime_clock.now ()) in
+  let now = TimeAbsolute.of_ptime (Mirage_ptime.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 +174,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_spath k)
 
   let _delete_outdated ~now =
     Hashtbl.to_seq_values t.ht
@@ -203,7 +192,7 @@ module Make () = struct
   (* ---- *)
 
   let sm_pub = t.sm_pub
-  let sign_secmod s = EddsaSignature.sign ~key:t.sm_key_priv s
+  let sign_secmod s = EddsaSignature.sign ~key:t.sm_priv s
 
   let sign pub s =
     let+ k = find pub in

src/secmod_rsa.ml

@@ -6,6 +6,8 @@ module Log = (val Logs.src_log src : Logs.LOG)
 open Syntax
 open Crypto
 open Time
+module Sfn = Mfat.Sfn
+module Spath = Mfat.Spath
 
 module Cfg = struct
   open Config
@@ -48,87 +50,71 @@ type key = {
 }
 
 type t = {
-  sm_key_priv: EddsaPrivateKey.t;
+  fs: Fat.t;
+  sm_priv: EddsaPrivateKey.t;
   sm_pub: EddsaPublicKey.t;
   ht: (DenominationHash.t, key) Hashtbl.t;
-  mutable last_change: Timestamp.t;
 }
 
-let parse_filename =
+let key_bin =
-  let scan_filename s =
+  let open Bin in
-    Scanf.sscanf_opt s "%Lu-%Lu" (fun t1 t2 ->
+  record (fun t1 t2 section_name priv ->
-        (TimeAbsolute.of_s t1, TimeAbsolute.of_s t2))
+      let pub = RsaPrivateKey.pub_of_priv priv in
+      let h_pub = DenominationHash.hash_of_rsa pub in
+      { section_name; t1; t2; priv; pub; h_pub })
+  |+ field TimeAbsolute.bin (fun t -> t.t1)
+  |+ field TimeAbsolute.bin (fun t -> t.t2)
+  |+ field cstring (fun t -> t.section_name)
+  |+ field RsaPrivateKey.bin (fun t -> t.priv)
+  |> sealr
+
+let key_spath k =
+  let sfn_res =
+    String.sub (DenominationHash.to_b32 k.h_pub) 0 8 |> Sfn.of_string
   in
-  fun fpath -> scan_filename (Fpath.filename fpath)
+  match sfn_res with
+  | Error _ -> failwith "not possible"
+  | Ok sfn -> Spath.(Cfg.key_dir / sfn)
 
-let pp_filename =
+let read_eddsa fs spath =
-  let to_int64 abs =
+  Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath);
-    abs |> Timestamp.of_absolute |> Timestamp.to_s |> function
+  let* data = Fat.read fs spath |> unwrap_msg in
-    | None ->
+  let* priv = EddsaPrivateKey.of_octets data in
-        (* (= `never`) this should not happen given resonable config value *)
+  let pub = EddsaPrivateKey.pub_of_priv priv in
-        Fmt.failwith "encountered timestamp with value `never`"
+  Ok (priv, pub)
-    | Some i -> i
-  in
-  fun ppf (t1, t2) -> Fmt.pf ppf "%Lu-%Lu" (to_int64 t1) (to_int64 t2)
 
-let key_fpath k =
+let write_eddsa fs spath priv =
-  let fname = Fmt.str "%a" pp_filename (k.t1, k.t2) in
+  Log.debug (fun m -> m "writing key file `%a`" Spath.pp spath);
-  Fpath.(v Cfg.key_dir / k.section_name / fname)
-
-(* -- IO -- *)
-
-let read_eddsa fpath =
-  Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
-  let* data = Bos.OS.File.read fpath |> unwrap_msg in
-  EddsaPrivateKey.of_octets data
-
-let read_rsa fpath =
-  Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
-  let* data = Bos.OS.File.read fpath |> unwrap_msg in
-  RsaPrivateKey.of_octets data
-
-let write_eddsa 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 spath data |> unwrap_msg
 
-let write_rsa fpath priv =
+let read_key fs spath =
-  let data = RsaPrivateKey.to_octets priv in
+  Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath);
-  Bos.OS.File.write fpath data |> unwrap_msg
+  let* data = Fat.read fs spath |> unwrap_msg in
+  let k = Bin.decode key_bin data (ref 0) in
+  Ok k
 
-let write_key k = write_rsa (key_fpath k) k.priv
+let write_key fs k =
+  let spath = key_spath k in
+  Log.debug (fun m -> m "writing key file `%a`" Spath.pp spath);
+  let data = Bin.to_string key_bin k in
+  Fat.write fs spath data |> unwrap_msg
 
-let delete_file fpath =
+let delete_file fs spath =
-  (* check fpath just to be safe *)
+  Log.debug (fun m -> m "delete key file `%a`" Spath.pp spath);
-  let () =
+  let+ () = Fat.remove fs spath |> unwrap_msg in
-    let root = Fpath.v Cfg.key_dir in
-    if not @@ Fpath.is_rooted ~root fpath then
-      Fmt.failwith
-        "delete_file failure: file `%a` is not contained in secmod directory"
-        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 get_key_dir_contents 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 =
-    Bos.OS.Dir.contents ~dotfiles:false ~rel:false dir_fpath |> unwrap_msg
-  in
-  List.map Fpath.normalize l
-
 (* -- *)
 
 let gen_key ~section_name t1 t2 =
   let bits = Cfg.rsa_keysize ~section_name in
   let priv, pub = RsaPrivateKey.generate ~bits () in
   let h_pub = DenominationHash.hash_of_rsa pub in
+  let k = { section_name; priv; pub; h_pub; t1; t2 } in
   Log.debug (fun m ->
-      m "generated key (%a):@,`%s`" pp_filename (t1, t2)
+      m "generated key %s `%s`" section_name (DenominationHash.to_b32 k.h_pub));
-        (DenominationHash.to_octets h_pub |> B32.encode));
+  k
-  { section_name; priv; pub; h_pub; t1; t2 }
 
 let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
 
@@ -147,8 +133,6 @@ let split_in_periodes ~start ~end_ ~duration_withdraw =
   go acc start end_
 
 let gen_additional_keys_until_lookahead ~now ~section_name l =
-  (* try to _not_ generate keys with validity start in the past
-     (probably not important) *)
   let start =
     match List.rev (sort_keys l) with
     | [] -> now
@@ -164,58 +148,39 @@ let gen_additional_keys_until_lookahead ~now ~section_name l =
     in
     new_keys
 
-let sm_key_fpath =
+let load fs =
-  Result.get_ok
+  let* () =
-  @@
+    if Fat.exists fs Cfg.key_dir then Ok ()
-  let+ fpath = Fpath.of_string Cfg.sm_priv_key |> unwrap_msg in
+    else Fat.mkdir fs Cfg.key_dir |> unwrap_msg
-  Fpath.normalize fpath
+  in
-
+  let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in
-(* we load sm_key separately
+  let l = List.map (fun entry -> entry.Fat.name) l in
-   we don't accept non-key files in key_dir *)
+  let l = List.map (Spath.add Cfg.key_dir) l in
-let load_key ~section_name fpath =
+  let l =
-  match parse_filename fpath with
+    List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_priv_key) l
-  | None -> Fmt.error "invalid file `%a`" Fpath.pp fpath
+  in
-  | Some (t1, t2) ->
+  let* keys = list_map (read_key fs) l in
-      let+ priv = read_rsa 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 section_fpath = Fpath.(v Cfg.key_dir / section_name) in
-  let* l = get_key_dir_contents 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
-  Ok keys
-
-let load () =
-  let* keys_l = list_map load_section 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_priv, sm_pub = read_eddsa fs Cfg.sm_priv_key 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 *)
+      Ok (Some { fs; sm_priv; sm_pub; ht })
-      let last_change = Timestamp.never in
-      Ok (Some { 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 now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in
   let* t =
     match opt with
     | Some t -> Ok t
     | None ->
-        let sm_key_priv, sm_pub = EddsaPrivateKey.generate () in
+        let sm_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 Cfg.sm_priv_key sm_priv in
         let ht = Hashtbl.create 0xff in
-        let last_change = Timestamp.of_absolute now in
+        Ok { fs; sm_priv; sm_pub; ht }
-        Ok { 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 +194,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 +209,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_spath k)
 
   let _delete_outdated ~now =
     Hashtbl.to_seq t.ht
@@ -254,20 +219,17 @@ module Make () = struct
     |> list_iter delete
 
   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;
     ()
 
-  let last_change () = t.last_change
   let sm_pub = t.sm_pub
-  let sign_secmod s = EddsaSignature.sign ~key:t.sm_key_priv s
+  let sign_secmod s = EddsaSignature.sign ~key:t.sm_priv s
 
   let sign h_pub msg =
     let+ k = find h_pub in
-    let data = Fdh_rsa.sign ~key:k.priv msg in
+    let data = RsaSignature.sign ~key:k.priv msg in
     data
 
   let revoke h_pub =

src/time.ml

@@ -92,6 +92,7 @@ module TimeAbsolute = struct
     if Int64.unsigned_div v 1_000_000L <> s then never else v
 
   let of_ptime v = v |> Ptime.to_float_s |> Int64.of_float |> of_s
+  let bin = Bin.beint64
   let pp ppf t = if t = never then Fmt.pf ppf "never" else Fmt.pf ppf "%Lu" t
 end
 

src/time.mli

@@ -14,6 +14,8 @@ module TimeRelative : sig
   val bin : t Bin.t
   val caqti : t Caqti_type.t
   val jsont : t Jsont.t
+
+  (* TODO rename pp_dump *)
   val pp : Format.formatter -> t -> unit
 end
 
@@ -30,6 +32,9 @@ module TimeAbsolute : sig
   val sub : t -> TimeRelative.t -> t
   val of_s : int64 -> t
   val of_ptime : Ptime.t -> t
+  val bin : t Bin.t
+
+  (* TODO rename pp_dump *)
   val pp : Format.formatter -> t -> unit
 end
 
@@ -54,5 +59,7 @@ module Timestamp : sig
   val bin : t Bin.t
   val caqti : t Caqti_type.t
   val jsont : t Jsont.t
+
+  (* TODO rename pp_dump *)
   val pp : Format.formatter -> t -> unit
 end

src/util.ml

@@ -3,7 +3,7 @@ module Log_reporter = struct
     Logs.Tag.def "Detail tag" ~doc:"" Fmt.string
 
   let detail s = Logs.Tag.(empty |> add detail_tag s)
-  let time_anchor = Ptime_clock.now () |> Ptime.to_span
+  let time_anchor = Mirage_ptime.now () |> Ptime.to_span
 
   let color_of_log_level = function
     | Logs.App -> `White
@@ -35,7 +35,7 @@ module Log_reporter = struct
       let with_detail h tags k user_fmt =
         let detail = Option.bind tags (Logs.Tag.find detail_tag) in
         let timestamp =
-          Ptime.sub_span (Ptime_clock.now ()) time_anchor
+          Ptime.sub_span (Mirage_ptime.now ()) time_anchor
           |> Option.map Ptime.to_float_s
           |> Option.value ~default:0.
         in
@@ -54,12 +54,10 @@ module Log_reporter = struct
     ()
 
   let setup () =
-    (*set_level_secmods (Some Logs.Debug);*)
+    set_level_secmods (Some Logs.Debug);
-    let level = Some Logs.Info in
+    let level = Some Logs.Debug in
     Logs.set_level ~all:false level;
-    Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ();
     Logs.Src.set_level Logs.default level;
-    Logs_threaded.enable ();
     Logs.set_reporter reporter;
     ()
 end