diff --git a/.gitignore b/.gitignore index 7aeab444..aba8e136 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ _taler_exchange_sql assets secrets !secrets/.keep +vendors diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore new file mode 100644 index 00000000..0c891b5b --- /dev/null +++ b/.ocamlformat-ignore @@ -0,0 +1 @@ +vendors/** diff --git a/GNUmakefile b/GNUmakefile new file mode 100644 index 00000000..09d3e86f --- /dev/null +++ b/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 diff --git a/default/assets/mte.conf b/default/assets/mte.conf index e328eece..f9064832 100644 --- a/default/assets/mte.conf +++ b/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 diff --git a/dune b/dune new file mode 100644 index 00000000..07287393 --- /dev/null +++ b/dune @@ -0,0 +1 @@ +(vendored_dirs vendors) diff --git a/dune-project b/dune-project index d4fc79ff..1fdae6f6 100644 --- a/dune-project +++ b/dune-project @@ -2,45 +2,45 @@ (name mte) -(generate_opam_files true) - -; (source -; (github username/reponame)) - -(authors "Olivier Pierre ") - -(maintainers "Olivier Pierre ") - -(license AGPL-3.0-only) - -; (documentation https://url/to/documentation) - -(package - (name mte) - (synopsis "MTE - the MirageOS Taler Exchange") - (description "A GNU Taler exchange implementation with the unikernel framework MirageOS") - (tags - ("GNU Taler" MirageOS unikernel OCaml crypto)) - (depends - (ocaml (>= 5.3)) - base32 - caqti - caqti-miou - caqti-driver-pgx - crunch - vif - jsont - cohttp - fmt - bin - angstrom - mirage-crypto - kdf - digestif - duration - jsont - cohttp - ptime - logs - (ocamlformat :with-dev-setup) - )) +; (generate_opam_files true) +; +; ; (source +; ; (github username/reponame)) +; +; (authors "Olivier Pierre ") +; +; (maintainers "Olivier Pierre ") +; +; (license AGPL-3.0-only) +; +; ; (documentation https://url/to/documentation) +; +; (package +; (name mte) +; (synopsis "MTE - the MirageOS Taler Exchange") +; (description "A GNU Taler exchange implementation with the unikernel framework MirageOS") +; (tags +; ("GNU Taler" MirageOS unikernel OCaml crypto)) +; (depends +; (ocaml (>= 5.3)) +; base32 +; caqti +; caqti-miou +; caqti-driver-pgx +; crunch +; vif +; jsont +; cohttp +; fmt +; bin +; angstrom +; mirage-crypto +; kdf +; digestif +; duration +; jsont +; cohttp +; ptime +; logs +; (ocamlformat :with-dev-setup) +; )) diff --git a/dune-workspace b/dune-workspace new file mode 100644 index 00000000..3d54f458 --- /dev/null +++ b/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))) diff --git a/network.sh b/network.sh new file mode 100755 index 00000000..0b0632e6 --- /dev/null +++ b/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 diff --git a/src/amount.mli b/src/amount.mli index 75b6773f..01496ff5 100644 --- a/src/amount.mli +++ b/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 diff --git a/src/config.ml b/src/config.ml index a62866e9..438bbcc5 100644 --- a/src/config.ml +++ b/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 sm_priv_key = get "sm_priv_key" + let key_dir = "eddsa" |> spath + let sm_priv_key = "sm_eddsa" |> spath end (* -- *) diff --git a/src/crypto.ml b/src/crypto.ml index 5c480085..54b1b516 100644 --- a/src/crypto.ml +++ b/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 diff --git a/src/devices.ml b/src/devices.ml deleted file mode 100644 index 15c6d389..00000000 --- a/src/devices.ml +++ /dev/null @@ -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 diff --git a/src/dune b/src/dune index 0a6fa0ea..e44363fe 100644 --- a/src/dune +++ b/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.threaded - fmt.tty)) + logs.fmt)) (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 ""))) diff --git a/src/env.ml b/src/env.ml new file mode 100644 index 00000000..d93b4e4e --- /dev/null +++ b/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; +} diff --git a/src/fat.ml b/src/fat.ml new file mode 100644 index 00000000..cb9889ec --- /dev/null +++ b/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 diff --git a/src/fdh_rsa.ml b/src/fdh_rsa.ml index 87df2883..f8e98634 100644 --- a/src/fdh_rsa.ml +++ b/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" diff --git a/src/global.ml b/src/global.ml new file mode 100644 index 00000000..04a76dfb --- /dev/null +++ b/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 diff --git a/src/headers.ml b/src/headers.ml index 6d4a64f7..97678517 100644 --- a/src/headers.ml +++ b/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 diff --git a/src/keys.ml b/src/keys.ml index 66b48442..e2f7dc37 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) @@ -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" diff --git a/src/manifest.json b/src/manifest.json new file mode 100644 index 00000000..54f7af0c --- /dev/null +++ b/src/manifest.json @@ -0,0 +1 @@ +{"type":"solo5.manifest","version":1,"devices":[{"type":"NET_BASIC","name":"service"},{"type":"BLOCK_BASIC","name":"storage"}]} diff --git a/src/mte.ml b/src/mte.ml index 085cc438..0d54dbca 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -14,17 +14,22 @@ along with this program. If not, see . *) 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 Vif.Route in + let open Vifu.Uri 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 port = Config.Exchange.port in - let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, port)) in - Vif.config ~reporter:Util.Log_reporter.reporter sockaddr + let rng = + let rng () = Mirage_crypto_rng_mkernel.initialize (module RNG) in + Mkernel.map rng Mkernel.[] in - Miou_unix.run @@ fun () -> - Caqti_miou.Switch.run @@ fun caqti_switch -> - let env : Devices.env = - { caqti_switch; db_uri= Config.Exchangedb_postgres.config } + let storage = Mkernel.block "storage" in + let service = + let ipv4 = Ipaddr.V4.Prefix.of_string_exn "10.0.0.2/24" in + Mnet.stack ~name:"service" ipv4 in - let devices = Vif.Devices.[ Devices.db_connection; Devices.keys ] in - let middlewares = Vif.Middlewares.[] 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 + 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 diff --git a/src/mte_info.ml b/src/mte_info.ml index 60c5bf59..5ce10b62 100644 --- a/src/mte_info.ml +++ b/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 keys = Vif.Server.device Devices.keys server in + let db_conn = Vifu.Server.device Global.db_conn 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 diff --git a/src/mte_management.ml b/src/mte_management.ml index d289678f..4583db6f 100644 --- a/src/mte_management.ml +++ b/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 db_conn = Vif.Server.device Devices.db_connection server in + let keys = Vifu.Server.device Global.keys 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 db_conn = Vif.Server.device Devices.db_connection server in + let keys = Vifu.Server.device Global.keys 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 db_conn = Vif.Server.device Devices.db_connection server in + let keys = Vifu.Server.device Global.keys 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 db_conn = Vif.Server.device Devices.db_connection server in + let keys = Vifu.Server.device Global.keys 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 db_conn = Vif.Server.device Devices.db_connection server in + let keys = Vifu.Server.device Global.keys 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 db_conn = Vif.Server.device Devices.db_connection server in + let keys = Vifu.Server.device Global.keys 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 db_conn = Vif.Server.device Devices.db_connection server in + let keys = Vifu.Server.device Global.keys 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 db_conn = Vif.Server.device Devices.db_connection server in + let keys = Vifu.Server.device Global.keys 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 () diff --git a/src/mte_terms.ml b/src/mte_terms.ml index 4dca972a..a055b5e4 100644 --- a/src/mte_terms.ml +++ b/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* () = diff --git a/src/pg.ml b/src/pg.ml index 39b29992..39d968dc 100644 --- a/src/pg.ml +++ b/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 = diff --git a/src/respond.ml b/src/respond.ml index a7780c36..60fb46a3 100644 --- a/src/respond.ml +++ b/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 diff --git a/src/secmod_eddsa.ml b/src/secmod_eddsa.ml index f14d7e2e..e5163fcf 100644 --- a/src/secmod_eddsa.ml +++ b/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 = - let scan_filename s = - Scanf.sscanf_opt s "%Lu-%Lu" (fun t1 t2 -> - (TimeAbsolute.of_s t1, TimeAbsolute.of_s t2)) - in - fun fpath -> scan_filename (Fpath.filename fpath) +(* todo: this should be encoded in little-endian *) +let key_bin = + let open Bin in + record (fun t1 t2 priv -> + let pub = EddsaPrivateKey.pub_of_priv priv in + { 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 = - let to_int64 abs = - abs |> Timestamp.of_absolute |> Timestamp.to_s |> function - | None -> - (* (= `never`) this should not happen given resonable config value *) - Fmt.failwith "encountered timestamp with value `never`" - | Some i -> i - in - fun ppf (t1, t2) -> Fmt.pf ppf "%Lu-%Lu" (to_int64 t1) (to_int64 t2) +(* for sm_key only *) +let read_eddsa fs spath = + Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath); + let* data = Fat.read fs spath |> unwrap_msg in + let* priv = EddsaPrivateKey.of_octets data in + let pub = EddsaPrivateKey.pub_of_priv priv in + Ok (priv, pub) -let key_fpath k = - let fname = Fmt.str "%a" pp_filename (k.t1, k.t2) in - 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 write_eddsa fs spath priv = + Log.debug (fun m -> m "writing key file `%a`" Spath.pp spath); 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 = - (* check fpath just to be safe *) - let () = - 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 read_key fs spath = + Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath); + let* data = Fat.read fs spath |> unwrap_msg in + (* todo: catch failure *) + let k = Bin.decode key_bin data (ref 0) in + Ok k + +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 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 -> - m "generated key (%a):@,`%s`" pp_filename (t1, t2) - (EddsaPublicKey.to_b32 pub)); - { priv; pub; t1; t2 } + let k = { priv; pub; t1; t2 } in + Log.debug (fun m -> m "generated key `%s`" (EddsaPublicKey.to_b32 pub)); + k 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 = - Result.get_ok - @@ - let+ fpath = Fpath.of_string Cfg.sm_priv_key |> unwrap_msg in - Fpath.normalize fpath - -(* we load sm_key separately - we don't accept non-key files in key_dir *) -let load_key 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 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 +let load fs = + let* () = + if Fat.exists fs Cfg.key_dir then Ok () + else Fat.mkdir fs Cfg.key_dir |> unwrap_msg + in + let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in + let l = List.map (fun entry -> entry.Fat.name) l in + let l = List.map (Spath.add Cfg.key_dir) l in + let l = + List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_priv_key) l + in + let* keys = list_map (read_key fs) l in match keys with | [] -> Ok None | _l -> - let* sm_key_priv = read_key sm_key_fpath in - let sm_pub = EddsaPrivateKey.pub_of_priv sm_key_priv in + let* sm_priv, sm_pub = read_eddsa fs Cfg.sm_priv_key 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* opt = load () in +let init fs = + 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 diff --git a/src/secmod_rsa.ml b/src/secmod_rsa.ml index 04a8cce6..1383fa26 100644 --- a/src/secmod_rsa.ml +++ b/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 scan_filename s = - Scanf.sscanf_opt s "%Lu-%Lu" (fun t1 t2 -> - (TimeAbsolute.of_s t1, TimeAbsolute.of_s t2)) +let key_bin = + let open Bin in + record (fun t1 t2 section_name priv -> + 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 to_int64 abs = - abs |> Timestamp.of_absolute |> Timestamp.to_s |> function - | None -> - (* (= `never`) this should not happen given resonable config value *) - Fmt.failwith "encountered timestamp with value `never`" - | Some i -> i - in - fun ppf (t1, t2) -> Fmt.pf ppf "%Lu-%Lu" (to_int64 t1) (to_int64 t2) +let read_eddsa fs spath = + Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath); + let* data = Fat.read fs spath |> unwrap_msg in + let* priv = EddsaPrivateKey.of_octets data in + let pub = EddsaPrivateKey.pub_of_priv priv in + Ok (priv, pub) -let key_fpath k = - let fname = Fmt.str "%a" pp_filename (k.t1, k.t2) in - 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 write_eddsa fs spath priv = + Log.debug (fun m -> m "writing key file `%a`" Spath.pp spath); 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 data = RsaPrivateKey.to_octets priv in - Bos.OS.File.write fpath data |> unwrap_msg +let read_key fs spath = + Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath); + 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 = - (* check fpath just to be safe *) - let () = - 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 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_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) - (DenominationHash.to_octets h_pub |> B32.encode)); - { section_name; priv; pub; h_pub; t1; t2 } + m "generated key %s `%s`" section_name (DenominationHash.to_b32 k.h_pub)); + k 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 = - Result.get_ok - @@ - let+ fpath = Fpath.of_string Cfg.sm_priv_key |> unwrap_msg in - Fpath.normalize fpath - -(* we load sm_key separately - we don't accept non-key files in key_dir *) -let load_key ~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 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 +let load fs = + let* () = + if Fat.exists fs Cfg.key_dir then Ok () + else Fat.mkdir fs Cfg.key_dir |> unwrap_msg + in + let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in + let l = List.map (fun entry -> entry.Fat.name) l in + let l = List.map (Spath.add Cfg.key_dir) l in + let l = + List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_priv_key) l + in + let* keys = list_map (read_key fs) l in match keys with | [] -> Ok None | _l -> - let* sm_key_priv = read_eddsa sm_key_fpath in - let sm_pub = EddsaPrivateKey.pub_of_priv sm_key_priv in + let* sm_priv, sm_pub = read_eddsa fs Cfg.sm_priv_key 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_priv; sm_pub; ht }) -let init () = - let* opt = load () in - let now = TimeAbsolute.of_ptime (Ptime_clock.now ()) in +let init fs = + let* opt = load fs 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 { sm_key_priv; sm_pub; ht; last_change } + Ok { fs; sm_priv; sm_pub; ht } 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 = diff --git a/src/time.ml b/src/time.ml index 6c3b634e..4428e24d 100644 --- a/src/time.ml +++ b/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 diff --git a/src/time.mli b/src/time.mli index 7955f822..2f232148 100644 --- a/src/time.mli +++ b/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 diff --git a/src/util.ml b/src/util.ml index 07215a01..c173cd9b 100644 --- a/src/util.ml +++ b/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);*) - let level = Some Logs.Info in + set_level_secmods (Some Logs.Debug); + 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