diff --git a/GNUmakefile b/GNUmakefile index 785b6343..839e8dc5 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -16,8 +16,8 @@ pin-deps: opam pin --no-action --yes add mhttp "git+https://github.com/robur-coop/mhttp.git#b2e55ae693b07ad3ef87c26c37c8f5d14c2e205c" opam pin --no-action --yes add vif "git+https://github.com/swrup/vif.git#1b16040ba06c6af82019f02811e781e81084d269" opam pin --no-action --yes add vifu "git+https://github.com/swrup/vif.git#1b16040ba06c6af82019f02811e781e81084d269" - opam pin --no-action --yes "git+https://github.com/robur-coop/mfat.git#5b1204d914e853f0139c6d2776511f530b753550" - opam pin --no-action --yes "git+https://github.com/swrup/mirage-mtime.git#6a6bb4dd25624a3c43e6417dcdf73f3c689946a7" + opam pin --no-action --yes add mfat "git+https://github.com/robur-coop/mfat.git#5b1204d914e853f0139c6d2776511f530b753550" + opam pin --no-action --yes add mirage-mtime "git+https://github.com/swrup/mirage-mtime.git#6a6bb4dd25624a3c43e6417dcdf73f3c689946a7" opam pin --no-action --yes add caqti "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0" opam pin --no-action --yes add caqti-miou "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0" opam pin --no-action --yes add caqti-mnet "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0" @@ -27,9 +27,12 @@ pin-deps: install-deps: # opam install --yes mcrunch opam install --yes dune utop merlin ocp-browser ocamlformat + opam install --yes solo5 ocaml-solo5 opam install --yes crunch + opam install --yes mirage-mtime opam install --yes sqlite3 # needed for caqti even if not used opam install --yes caqti-driver-pgx + opam install --yes caqti-mnet opam install --yes $(vendors_list) .PHONY: vendors @@ -45,7 +48,7 @@ clean: rm -rf vendors/ assets: - @cp default/assets ./ + @cp -r default/assets ./ fat-image: @mkdir -p assets diff --git a/network.sh b/network.sh index 0b0632e6..712edd58 100755 --- a/network.sh +++ b/network.sh @@ -1,9 +1,9 @@ #!/bin/bash set -e -sudo ip link add br0 type bridge +sudo ip link add name br0 type bridge sudo ip addr add 10.0.0.1/24 dev br0 -sudo ip tuntap add tap0 mode tap +sudo ip tuntap add name 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/assets.ml b/src/assets.ml index 8208c0b7..c98f3ab2 100644 --- a/src/assets.ml +++ b/src/assets.ml @@ -1,6 +1,10 @@ (* https://docs.taler.net/design-documents/003-tos-rendering.html must support `text/plain` and `text/markdown` *) +module Cfg = struct + let config = "mte.conf" +end + let failure fmt = Fmt.kstr (fun s -> @@ -8,157 +12,78 @@ let failure fmt = exit 1) fmt -type t = - | Terms - | Privacy - -module Cfg = struct - (* hardcoded config just for static assets *) - let default_lang = "en" - let default_mimetype = ("text", "plain") - let default_extension = ".txt" - let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity - let base_dir = function Terms -> "terms" | Privacy -> "privacy" - - (* TODO this should be in the config like terms_etag *) - let terms_legal_version = "0" -end - -let etag k = - match k with Terms -> Config.terms_etag | Privacy -> Config.privacy_etag - -let supported_lang_arr, supported_ext_arr = - let aux t = - let prefix = Fpath.v (Cfg.base_dir t) in - let path_l = List.map Fpath.v Assets_crunch.file_list in - let path_l = List.filter_map (Fpath.rem_prefix prefix) path_l in - let ext_l = - path_l |> List.map Fpath.get_ext |> List.sort_uniq String.compare - in - let lang_l = - List.map - (fun path -> - match Fpath.segs path with - | [] -> assert false - | [ dir; _file ] -> dir - | _l -> - failure "invalid folder structure, file `%s` is misplaced" - (Fpath.to_string Fpath.(prefix // path))) - path_l - in - let lang_l = List.sort_uniq String.compare lang_l in - let etag = etag t in - List.iter - (fun path -> - let etag' = Fpath.to_string (Fpath.rem_ext (Fpath.base path)) in - if not @@ String.equal etag etag' then - failure "filename `%s` does not match configuration ETAG value `%s`" - (Fpath.to_string Fpath.(prefix // path)) - etag) - path_l; - if List.is_empty lang_l then failure "no language supported"; - if List.is_empty ext_l then failure "no mimetype supported"; - if not @@ List.mem Cfg.default_lang lang_l then - failure "default language `%s` files not found" Cfg.default_lang; - if not @@ List.mem ".txt" ext_l then failure "plain text file not found"; - if not @@ List.mem ".md" ext_l then failure "markdown file not found"; - List.iter - (fun dir -> - if String.length dir <> 2 then - failure "language directory with invalid name: `%s`" dir) - lang_l; - if List.length path_l <> List.length ext_l * List.length lang_l then - failure - "invalid folder structure, all supported language must provide the \ - same set of file mimetype" - else (lang_l, ext_l) - in - let lang_l, ext_l = aux Terms in - let lang_l', ext_l' = aux Privacy in - match - List.equal String.equal lang_l lang_l' - && List.equal String.equal ext_l ext_l' - with - | false -> - failure - "invalid folder structure, /terms and /privacy must support the same \ - set of languages and mimetypes" - | true -> (Array.of_list lang_l, Array.of_list ext_l) - -module Mimetype = struct - type t = string * string - - let pp fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime) - - let assoc = - List.filter - (fun (_mime, ext) -> Array.mem ext supported_ext_arr) - [ - (("text", "plain"), ".txt"); - (("text", "markdown"), ".md"); - (("text", "html"), ".html"); - (("text", "html"), ".htm"); - (("application", "pdf"), ".pdf"); - (("image", "jpeg"), ".jpg"); - (("image", "jpeg"), ".jpeg"); - (("image", "png"), ".png"); - (("image", "gif"), ".gif"); - ] - - let default = Cfg.default_mimetype - - let () = - if not @@ List.mem (Cfg.default_mimetype, Cfg.default_extension) assoc then - failure "default content type `%a` not supported" pp Cfg.default_mimetype - - let arr = - let all_supported, all_supported_ext = List.split assoc in - match - Array.find_opt - (fun ext -> not @@ List.exists (( = ) ext) all_supported_ext) - supported_ext_arr - with - | Some ext -> failure "extension `%s` unsupported" ext - | None -> Array.of_list all_supported - - let of_cohttp = function - | Cohttp.Accept.MediaType (m, m_sub) -> - Array.find_opt (( = ) (m, m_sub)) arr - | AnyMediaSubtype m -> Array.find_opt (fun (m', _) -> String.equal m m') arr - | AnyMedia -> Some default - - let to_extension_exn t = - match List.assoc_opt t assoc with - | None -> Fmt.failwith "Mimetype.to_extension failure: `%a` unknown" pp t - | Some ext -> ext -end - -module Language = struct - type t = string - - let arr = supported_lang_arr - let default = Cfg.default_lang - - let () = - if not @@ Array.mem default arr then - failure "default language `%s` not supported" Cfg.default_lang - - let of_cohttp = function - | Cohttp.Accept.AnyLanguage -> Some default - | Language language_range -> ( - (* ignore language subtags (e.g. "en-US" -> "en") *) - match language_range with - | [] -> assert false - | lang :: _ when Array.mem lang supported_lang_arr -> Some lang - | _ -> None) -end - -(* ! lang and mime must be supported *) -let get_content ~lang ~mime t = - let ext = Mimetype.to_extension_exn mime in - let path = - Fpath.to_string Fpath.((v (Cfg.base_dir t) / lang / etag t) + ext) - in - match Assets_crunch.read path with - | None -> Fmt.failwith "static file not found: `%s`" path +let config = + match Assets_crunch.read Cfg.config with + | None -> failure "static configuration file `%s` not found" Cfg.config | Some data -> data + +let mimetype_of_ext ext = + List.assoc_opt ext + [ + (".txt", ("text", "plain")); + (".md", ("text", "markdown")); + (".html", ("text", "html")); + (".htm", ("text", "html")); + (".pdf", ("application", "pdf")); + (".jpg", ("image", "jpeg")); + (".jpeg", ("image", "jpeg")); + (".png", ("image", "png")); + (".gif", ("image", "gif")); + ] + +let load asset_prefix asset_etag = + let asset_files = + Assets_crunch.file_list + |> List.map (String.split_on_char '/') + |> List.filter (function hd :: _tl -> hd = asset_prefix | _ -> false) + in + let lang_l, ext_l = + asset_files + |> List.map (function + | [ asset_prefix; dir; filename ] -> + if String.length dir <> 2 then + failure "invalid language directory name: `%s`" dir; + let etag, ext = + match String.split_on_char '.' filename with + | [ etag; ext ] -> (etag, "." ^ ext) + | _ -> failure "invalid filename: `%s`" filename + in + if not @@ String.equal asset_etag etag then + failure + "file `%s/%s/%s%s` does not match configuration ETAG value `%s`" + asset_prefix dir etag ext asset_etag; + (dir, ext) + | _ -> failure "invalid directory contents") + |> List.split + in + let lang_l = List.sort_uniq String.compare lang_l in + let ext_l = List.sort_uniq String.compare ext_l in + if List.is_empty lang_l then failure "no language supported"; + if List.is_empty ext_l then failure "no mimetype supported"; + if not @@ List.mem ".txt" ext_l then failure "plain text file not found"; + if not @@ List.mem ".md" ext_l then failure "markdown file not found"; + if List.length asset_files <> List.length ext_l * List.length lang_l then + failure + "invalid folder structure, all supported language must provide the same \ + set of file mimetype"; + let lang_arr = Array.of_list (List.sort compare lang_l) in + let ext_arr = Array.of_list (List.sort compare ext_l) in + let mime_arr = + Array.map + (fun ext -> + match mimetype_of_ext ext with + | None -> failure "unsupported extension: `%s`" ext + | Some mime -> mime) + ext_arr + in + let content_matrix = + Array.init (Array.length lang_arr) (fun i -> + Array.init (Array.length ext_arr) (fun j -> + let lang = lang_arr.(i) in + let ext = ext_arr.(j) in + let file = Fmt.str "%s/%s/%s%s" asset_prefix lang asset_etag ext in + match Assets_crunch.read file with + | None -> failure "static file not found: `%s`" file + | Some content_matrix -> content_matrix)) + in + (lang_arr, mime_arr, content_matrix) diff --git a/src/config.ml b/src/config.ml index 8e65832d..28fc01eb 100644 --- a/src/config.ml +++ b/src/config.ml @@ -1,19 +1,10 @@ open Config_parser -module Cfg = struct - let config_filename = "mte.conf" -end - -let config_data = - match Assets_crunch.read Cfg.config_filename with - | None -> failure "static file `%s` not found" Cfg.config_filename - | Some data -> - let v = Config_section.parse data in - v +let config = Config_section.parse Assets.config module Exchange = struct - let get_opt field = get_opt config_data ~section:"exchange" ~field - let get field = get config_data ~section:"exchange" ~field + let get_opt field = get_opt config ~section:"exchange" ~field + let get field = get config ~section:"exchange" ~field (* - *) let currency = (* todo: constraint on currency string *) get "currency" @@ -54,19 +45,10 @@ module Exchange = struct let aml_spa_dialect = get_opt "aml_spa_dialect" let toplevel_redirect_url = get_opt "toplevel_redirect_url" let tiny_amount = get_opt "tiny_amount" |> Option.map amount - - (* not implemented or not relevant to MTE: - let max_requests = get "max_requests" |> int - aggregator_shard_size - serve - unixpath - unixpath_mode - terms_dir - privacy_dir *) end module Exchangedb = struct - let get field = get config_data ~section:"exchangedb" ~field + let get field = get config ~section:"exchangedb" ~field (* - *) let idle_reserve_expiration_time = @@ -81,8 +63,7 @@ module Exchangedb = struct end module Exchangedb_postgres = struct - let config = - get config_data ~section:"exchangedb-postgres" ~field:"config" |> uri + let config = get config ~section:"exchangedb-postgres" ~field:"config" |> uri end module Currency = struct @@ -99,10 +80,10 @@ module Currency = struct let currency_sections = List.filter (fun v -> String.starts_with ~prefix:"currency-" v.header) - config_data + config let parse_currency section = - let get field = get config_data ~section:section.header ~field in + let get field = get config ~section:section.header ~field in { enabled= get "enabled" |> yes_no; code= get "code"; @@ -160,10 +141,10 @@ module Coin = struct (* ! '_' not '-' *) let prefix = "coin_" in let prefix_len = String.length prefix in - config_data + config |> List.filter (fun v -> String.starts_with ~prefix v.header) |> List.map (fun section -> - let get field = get config_data ~section:section.header ~field in + let get field = get config ~section:section.header ~field in let section_name = String.sub section.header prefix_len (String.length section.header - prefix_len) @@ -191,7 +172,7 @@ end module Exchange_secmod_rsa = struct let get field = let section = "taler-exchange-secmod-" ^ "rsa" in - get config_data ~section ~field + get config ~section ~field let lookahead = get "lookahead_sign" |> duration let overlap = get "overlap_duration" |> duration @@ -200,7 +181,7 @@ end module Exchange_secmod_eddsa = struct let get field = let section = "taler-exchange-secmod-" ^ "eddsa" in - get config_data ~section ~field + get config ~section ~field let lookahead = get "lookahead_sign" |> duration let overlap = get "overlap_duration" |> duration diff --git a/src/denomination.ml b/src/denomination.ml index 535be269..eaed5a54 100644 --- a/src/denomination.ml +++ b/src/denomination.ml @@ -17,11 +17,11 @@ type t = { master_sig: Signatures.DenominationKeyValidity.t; } -let verify_denomination_key_validity ~key dn = +let verify ~master_key dn = let open Signatures.DenominationKeyValidity in - verify key dn.master_sig + verify master_key dn.master_sig { - R.master= key; + R.master= master_key; start= dn.stamp_start; expire_withdraw= dn.stamp_expire_withdraw; expire_spend= dn.stamp_expire_deposit; diff --git a/src/dune b/src/dune index 0f55dd10..2670b56d 100644 --- a/src/dune +++ b/src/dune @@ -2,7 +2,6 @@ (name mte) (modules fat - headers respond pg_type pg @@ -10,8 +9,10 @@ mte_device mte_handler mte - mte_terms - mte_info + mte_tos + mte_seed + mte_config + mte_keys mte_management secmod_eddsa secmod_rsa diff --git a/src/headers.ml b/src/headers.ml deleted file mode 100644 index 477059f8..00000000 --- a/src/headers.ml +++ /dev/null @@ -1,45 +0,0 @@ -let accept_header_value = - Fmt.str "%a" - (Fmt.array ~sep:(Fmt.any ", ") Assets.Mimetype.pp) - Assets.Mimetype.arr - -let avail_languages_header_value = - Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") Fmt.string) Assets.Language.arr - -(* TODO better headers_lib - Cohttp raises on invalid *) -let select_mimetype headers = - 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) - |> function - | None -> Assets.Mimetype.default - | Some mime -> mime - -let select_language headers = - let opt = Vifu.Headers.get headers "accept-language" in - Cohttp.Accept.languages opt - |> Cohttp.Accept.qsort - |> List.map snd - |> List.find_map Assets.Language.of_cohttp - |> function - | None -> Assets.Language.default - | Some lang -> lang - -let select_encoding headers = - let opt = Vifu.Headers.get headers "accept-encoding" in - Cohttp.Accept.encodings opt - |> Cohttp.Accept.qsort - |> List.map snd - |> List.find_map (function - | Cohttp.Accept.Identity -> Some `Identity - | Deflate -> Some `DEFLATE - | Gzip -> Some `Gzip - | AnyEncoding -> Some Assets.Cfg.default_encoding - | Encoding _ | Compress -> (* unsupported *) None) - |> function - | None -> None - | Some `Identity -> None - | Some `DEFLATE -> Some `DEFLATE - | Some `Gzip -> Some `Gzip diff --git a/src/mte.ml b/src/mte.ml index c498cc2d..afc8c8c9 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -13,61 +13,40 @@ You should have received a copy of the GNU Affero General Public License along with this program. If not, see . *) -let hello req _server _env = - 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 Vifu.Uri in let open Vifu.Route in let get path = get (path /?? any) in - let post path jsont = post (Vifu.Type.json_encoding jsont) (path /?? any) in + let post path json_enc = post json_enc (path /?? any) in let v s = rel / s in - let tos = - [ - get rel --> hello; - get (v "terms") --> Mte_terms.terms; - get (v "privacy") --> Mte_terms.privacy; - ] - in - let status_info = - [ - get (v "seed") --> Mte_info.seed; - get (v "config") --> Mte_info.config; - get (v "keys") --> Mte_info.keys; - ] - in - let management = - let open Mte_management in - let v s = v "management" / s in - [ - get (v "keys") --> Keys_get.f; - post (v "keys") Keys_post.jsont --> Keys_post.f; - post (v "denominations" /% string `Path / "revoke") Denom_revoke.jsont - --> Denom_revoke.f; - post (v "signkeys" /% string `Path / "revoke") Signkey_revoke.jsont - --> Signkey_revoke.f; - post (v "auditors") Auditors.jsont --> Auditors.f; - post (v "auditors" /% string `Path / "disable") Auditors_disable.jsont - --> Auditors_disable.f; - post (v "wire-fee") Wire_fee.jsont --> Wire_fee.f; - post (v "global-fees") Global_fees.jsont --> Global_fees.f; - post (v "wire") Wire.jsont --> Wire.f; - post (v "wire" / "disable") Wire_disable.jsont --> Wire_disable.f; - post (v "drain") Drain.jsont --> Drain.f; - post (v "aml-officers") AmlOfficer.jsont --> AmlOfficer.f; - post (v "partners") Partners.jsont --> Partners.f; - ] - in - tos @ status_info @ management + [ + get (v "terms") --> Mte_tos.terms; + get (v "privacy") --> Mte_tos.privacy; + get (v "seed") --> Mte_seed.f; + get (v "config") --> Mte_config.f; + get (v "keys") --> Mte_keys.f; + ] + @ + let open Mte_management in + let v s = rel / "management" / s in + [ + get (v "keys") --> Keys_get.f; + post (v "keys") Keys_post.json_enc --> Keys_post.f; + post (v "denominations" /% string `Path / "revoke") Denom_revoke.json_enc + --> Denom_revoke.f; + post (v "signkeys" /% string `Path / "revoke") Signkey_revoke.json_enc + --> Signkey_revoke.f; + post (v "auditors") Auditors.json_enc --> Auditors.f; + post (v "auditors" /% string `Path / "disable") Auditors_disable.json_enc + --> Auditors_disable.f; + post (v "wire-fee") Wire_fee.json_enc --> Wire_fee.f; + post (v "global-fees") Global_fees.json_enc --> Global_fees.f; + post (v "wire") Wire.json_enc --> Wire.f; + post (v "wire" / "disable") Wire_disable.json_enc --> Wire_disable.f; + post (v "drain") Drain.json_enc --> Drain.f; + post (v "aml-officers") AmlOfficer.json_enc --> AmlOfficer.f; + post (v "partners") Partners.json_enc --> Partners.f; + ] module RNG = Mirage_crypto_rng.Fortuna diff --git a/src/mte_config.ml b/src/mte_config.ml new file mode 100644 index 00000000..3a0a4599 --- /dev/null +++ b/src/mte_config.ml @@ -0,0 +1,14 @@ +let f req _server _env = + Logs.info (fun m -> m "GET /config"); + let open Api.ExchangeVersionResponse in + Respond.ok req jsont + { + version= Libtool_version.mte_protocol_version; + name= "taler-exchange"; + currency= Config.currency; + currency_specification= Config.Currency.specification; + implementation= None; + shopping_url= None; + open_banking_gateway= None; + aml_spa_dialect= None; + } diff --git a/src/mte_info.ml b/src/mte_info.ml index 44d5425c..e69de29b 100644 --- a/src/mte_info.ml +++ b/src/mte_info.ml @@ -1,226 +0,0 @@ -open Syntax -open Api -open Time -module String_map = Stdlib.Map.Make (Stdlib.String) - -(* TODO mirage-crypto - is this ok? - 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 Vifu.run *) - let s = Mirage_crypto_rng.generate 64 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 - respond `OK - -let config req _server _env = - Logs.info (fun m -> m "GET /config"); - Respond.ok req ExchangeVersionResponse.jsont - ExchangeVersionResponse. - { - version= Libtool_version.mte_protocol_version; - name= "taler-exchange"; - currency= Config.currency; - currency_specification= Config.Currency.specification; - implementation= None; - shopping_url= None; - open_banking_gateway= None; - aml_spa_dialect= None; - } - -(* --- *) - -(* TODO *) -let last_change = ref Timestamp.never -let get_denominations_last_change () = !last_change - -let warn_once msg = - let b = ref true in - fun () -> - if !b then begin - b := false; - Logs.warn (fun m -> m "%s" msg) - end - -let warn_keyring_state_mismatch = - warn_once - "keyring state mismatch: database and secmod have different active keys \ - data" - -let get_signkeys sm_eddsa pool = - let now = Timestamp.of_ptime @@ Mirage_ptime.now () in - let+ l = Pg.use_pool pool @@ fun conn -> Pg.get_signkeys conn ~now in - let missing_l, l = - List.partition - (fun sk -> Option.is_none (Secmod_eddsa.find_key sm_eddsa sk.Signkey.pub)) - l - in - if missing_l <> [] then warn_keyring_state_mismatch (); - l - -let get_denominations sm_rsa pool = - let+ l = Pg.use_pool pool @@ fun conn -> Pg.get_denominations conn () in - let missing_l, l = - List.partition - (fun dn -> - Option.is_none @@ Secmod_rsa.find_key sm_rsa dn.Denomination.h_pub) - l - in - if missing_l <> [] then warn_keyring_state_mismatch (); - l - -let mk_keys sm_eddsa sm_rsa pool last_issue_date = - let version = Libtool_version.mte_protocol_version in - let base_url = Config.base_url in - let currency = Config.currency in - let shopping_url = Config.shopping_url in - let open_banking_gateway = Config.open_banking_gateway_url in - let bank_compliance_language = Config.bank_compliance_language in - let currency_specification = Config.Currency.specification in - let tiny_amount = Config.tiny_amount in - let stefan_abs = Config.stefan_abs in - let stefan_log = Config.stefan_log in - let stefan_lin = Config.stefan_lin in - (* type of the asset. "fiat", "crypto", "regional" or "stock". *) - let asset_type = "fiat" in - let* accounts = - Pg.use_pool pool @@ fun conn -> Pg.get_wire_accounts conn () - in - let* wire_fees = - (* wire_methods? *) - let wire_method = "x-taler-bank" in - let+ wire_fees = - Pg.use_pool pool @@ fun conn -> Pg.get_wire_fees conn ~wire_method - in - String_map.singleton wire_method wire_fees - in - let wads = [] in - let kyc_enabled = false in - let disable_direct_deposit = false in - let master_public_key = Config.master_public_key in - let reserve_closing_delay = Config.Exchangedb.idle_reserve_expiration_time in - let wallet_balance_limit_without_kyc = None in - let hard_limits = [] in - let zero_limits = [] in - - let* denom_l = get_denominations sm_rsa pool in - let list_issue_date = get_denominations_last_change () in - let denom_l = - (* if `?last_issue_date` query param does not exactly match the `stamp_start` - of one of the denomination keys, all keys are returned *) - let stamp_start_opt = - match last_issue_date with - | None -> None - | Some timestamp -> - List.find_map - (fun v -> - if Timestamp.equal v.Denomination.stamp_start timestamp then - Some v.stamp_start - else None) - denom_l - in - match stamp_start_opt with - | None -> denom_l - | Some timestamp -> - List.filter - (fun v -> Timestamp.compare timestamp v.Denomination.stamp_start <= 0) - denom_l - in - let denominations = Denomination.make_denom_group_sorted denom_l in - - let* signkeys = get_signkeys sm_eddsa pool in - - (* the eddsa pub key used to sign exchange_sig *) - let* exchange_pub = - 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 - match opt with - | None -> Fmt.error_msg "exchange has no active signkey" - | Some sk -> Ok sk.pub - in - let signkeys = List.map Api.SignKey.of_signkey signkeys in - - (* ! depends on denominations order *) - let exchange_sig = - let open Signatures.ExchangeKeySet in - signf - (Secmod_eddsa.sign sm_eddsa exchange_pub) - R. - { - list_issue_date; - hc= Denomination.hash_over_master_sigs denominations; - } - in - - let recoup = (* /recoup *) [] in - let* global_fees = - Pg.use_pool pool @@ fun conn -> - Pg.get_global_fees conn ~start_date:Timestamp.zero - in - let* auditors = - (* /auditors/$AUDITOR_PUB/$H_DENOM_PUB *) - Pg.use_pool pool @@ fun conn -> Pg.get_auditor_keys conn - in - let extensions = None in - let extensions_sig = None in - Ok - ExchangeKeysResponse. - { - version; - base_url; - currency; - shopping_url; - open_banking_gateway; - bank_compliance_language; - currency_specification; - tiny_amount; - stefan_abs; - stefan_log; - stefan_lin; - asset_type; - accounts; - wire_fees; - wads; - kyc_enabled; - disable_direct_deposit; - master_public_key; - reserve_closing_delay; - wallet_balance_limit_without_kyc; - hard_limits; - zero_limits; - denominations; - exchange_sig; - exchange_pub; - recoup; - global_fees; - list_issue_date; - auditors; - signkeys; - extensions; - extensions_sig; - } - -let jsont = ExchangeKeysResponse.jsont - -let keys req server _env = - Logs.info (fun m -> m "GET /keys"); - Respond.result req jsont - @@ - let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in - let sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in - let pool = Vifu.Server.device Mte_device.pool server in - let* last_issue_date = - match Vifu.Queries.get req "last_issue_date" with - | [] -> Ok None - | s :: _ -> ( - match Int64.of_string_opt s with - | None -> - Fmt.error_msg "invalid `?last_issue_date` query param, not an int" - | Some n -> Ok (Some (Timestamp.of_s n))) - in - mk_keys sm_eddsa sm_rsa pool last_issue_date diff --git a/src/mte_keys.ml b/src/mte_keys.ml new file mode 100644 index 00000000..40df4f56 --- /dev/null +++ b/src/mte_keys.ml @@ -0,0 +1,194 @@ +open Syntax +open Api +open Time +module String_map = Stdlib.Map.Make (Stdlib.String) + +(* TODO *) +let last_change = ref Timestamp.never +let get_denominations_last_change () = !last_change + +let warn_once msg = + let b = ref true in + fun () -> + if !b then begin + b := false; + Logs.warn (fun m -> m "%s" msg) + end + +let warn_keyring_state_mismatch = + warn_once + "keyring state mismatch: database and secmod have different active keys \ + data" + +let get_signkeys sm_eddsa pool = + let now = Timestamp.of_ptime @@ Mirage_ptime.now () in + let+ l = Pg.use_pool pool @@ fun conn -> Pg.get_signkeys conn ~now in + let missing_l, l = + List.partition + (fun sk -> Option.is_none (Secmod_eddsa.find_key sm_eddsa sk.Signkey.pub)) + l + in + if missing_l <> [] then warn_keyring_state_mismatch (); + l + +let get_denominations sm_rsa pool = + let+ l = Pg.use_pool pool @@ fun conn -> Pg.get_denominations conn () in + let missing_l, l = + List.partition + (fun dn -> + Option.is_none @@ Secmod_rsa.find_key sm_rsa dn.Denomination.h_pub) + l + in + if missing_l <> [] then warn_keyring_state_mismatch (); + l + +let mk sm_eddsa sm_rsa pool last_issue_date = + let version = Libtool_version.mte_protocol_version in + let base_url = Config.base_url in + let currency = Config.currency in + let shopping_url = Config.shopping_url in + let open_banking_gateway = Config.open_banking_gateway_url in + let bank_compliance_language = Config.bank_compliance_language in + let currency_specification = Config.Currency.specification in + let tiny_amount = Config.tiny_amount in + let stefan_abs = Config.stefan_abs in + let stefan_log = Config.stefan_log in + let stefan_lin = Config.stefan_lin in + (* type of the asset. "fiat", "crypto", "regional" or "stock". *) + let asset_type = "fiat" in + let* accounts = + Pg.use_pool pool @@ fun conn -> Pg.get_wire_accounts conn () + in + let* wire_fees = + (* wire_methods? *) + let wire_method = "x-taler-bank" in + let+ wire_fees = + Pg.use_pool pool @@ fun conn -> Pg.get_wire_fees conn ~wire_method + in + String_map.singleton wire_method wire_fees + in + let wads = [] in + let kyc_enabled = false in + let disable_direct_deposit = false in + let master_public_key = Config.master_public_key in + let reserve_closing_delay = Config.Exchangedb.idle_reserve_expiration_time in + let wallet_balance_limit_without_kyc = None in + let hard_limits = [] in + let zero_limits = [] in + + let* denom_l = get_denominations sm_rsa pool in + let list_issue_date = get_denominations_last_change () in + let denom_l = + (* if `?last_issue_date` query param does not exactly match the `stamp_start` + of one of the denomination keys, all keys are returned *) + let stamp_start_opt = + match last_issue_date with + | None -> None + | Some timestamp -> + List.find_map + (fun v -> + if Timestamp.equal v.Denomination.stamp_start timestamp then + Some v.stamp_start + else None) + denom_l + in + match stamp_start_opt with + | None -> denom_l + | Some timestamp -> + List.filter + (fun v -> Timestamp.compare timestamp v.Denomination.stamp_start <= 0) + denom_l + in + let denominations = Denomination.make_denom_group_sorted denom_l in + + let* signkeys = get_signkeys sm_eddsa pool in + + (* the eddsa pub key used to sign exchange_sig *) + let* exchange_pub = + 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 + match opt with + | None -> Fmt.error_msg "exchange has no active signkey" + | Some sk -> Ok sk.pub + in + let signkeys = List.map Api.SignKey.of_signkey signkeys in + + (* ! depends on denominations order *) + let exchange_sig = + let open Signatures.ExchangeKeySet in + signf + (Secmod_eddsa.sign sm_eddsa exchange_pub) + R. + { + list_issue_date; + hc= Denomination.hash_over_master_sigs denominations; + } + in + + let recoup = (* /recoup *) [] in + let* global_fees = + Pg.use_pool pool @@ fun conn -> + Pg.get_global_fees conn ~start_date:Timestamp.zero + in + let* auditors = + (* /auditors/$AUDITOR_PUB/$H_DENOM_PUB *) + Pg.use_pool pool @@ fun conn -> Pg.get_auditor_keys conn + in + let extensions = None in + let extensions_sig = None in + Ok + ExchangeKeysResponse. + { + version; + base_url; + currency; + shopping_url; + open_banking_gateway; + bank_compliance_language; + currency_specification; + tiny_amount; + stefan_abs; + stefan_log; + stefan_lin; + asset_type; + accounts; + wire_fees; + wads; + kyc_enabled; + disable_direct_deposit; + master_public_key; + reserve_closing_delay; + wallet_balance_limit_without_kyc; + hard_limits; + zero_limits; + denominations; + exchange_sig; + exchange_pub; + recoup; + global_fees; + list_issue_date; + auditors; + signkeys; + extensions; + extensions_sig; + } + +let f req server _env = + Logs.info (fun m -> m "GET /keys"); + Respond.result req ExchangeKeysResponse.jsont + @@ + let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in + let sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in + let pool = Vifu.Server.device Mte_device.pool server in + let* last_issue_date = + match Vifu.Queries.get req "last_issue_date" with + | [] -> Ok None + | s :: _ -> ( + match Int64.of_string_opt s with + | None -> + Fmt.error_msg "invalid `?last_issue_date` query param, not an int" + | Some n -> Ok (Some (Timestamp.of_s n))) + in + mk sm_eddsa sm_rsa pool last_issue_date diff --git a/src/mte_management.ml b/src/mte_management.ml index c4350ee3..d78b3d87 100644 --- a/src/mte_management.ml +++ b/src/mte_management.ml @@ -7,9 +7,8 @@ let request_of_json req = Vifu.Request.of_json req |> Result.map_error (fun (`Msg e) -> `Json_decode e) module Future_keys = struct - let make_future_sk sm_eddsa (pub, (start, expire)) = - Logs.debug (fun m -> m "make_future_sk: `%a`" Eddsa.pp_pub pub); - let open Time in + let make_fsk sm_eddsa (pub, (start, expire)) = + Logs.debug (fun m -> m "make_fsk: `%a`" Eddsa.pp_pub pub); let stamp_start = Timestamp.of_absolute start in let stamp_expire = Timestamp.of_absolute expire in let stamp_end = @@ -25,10 +24,10 @@ module Future_keys = struct (Secmod_eddsa.sign_secmod sm_eddsa) { exchange_pub; anchor_time; duration } in - Api.FutureSignKey. + FutureSignKey. { key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig } - let make_future_dn sm_rsa (h_pub, (coin, pub, start)) = + let make_fdn sm_rsa (h_pub, (coin, pub, start)) = let { Config.Coin.section_name; value; @@ -43,8 +42,7 @@ module Future_keys = struct } = coin in - Logs.debug (fun m -> m "make_future_dn: `%a`" DenominationHash.pp h_pub); - let open Time in + Logs.debug (fun m -> m "make_fdn: `%a`" DenominationHash.pp h_pub); let stamp_start = Timestamp.of_absolute start in let stamp_expire_withdraw = Timestamp.of_absolute @@ TimeAbsolute.add start duration_withdraw @@ -55,7 +53,6 @@ module Future_keys = struct let stamp_expire_legal = Timestamp.of_absolute @@ TimeAbsolute.add start duration_legal in - let open Api in let rsa_denomination_key = RsaDenominationKey.{ age_mask= 0; rsa_pub= pub } in @@ -66,7 +63,7 @@ module Future_keys = struct (Secmod_rsa.sign_secmod sm_rsa) { h_denom_pub= h_pub; - h_section_name= Hash.H64_cstring.hash section_name; + h_section_name= H64_cstring.hash section_name; anchor_time= stamp_start; duration_withdraw= Timestamp.diff stamp_start stamp_expire_withdraw; } @@ -87,65 +84,14 @@ module Future_keys = struct denom_secmod_sig; } - let make_future_keys_response sm_eddsa sm_rsa pool = - let now = Timestamp.of_ptime @@ Mirage_ptime.now () in - (* get keys from database to filter out keys already certified *) - let* sk_db_l = Pg.use_pool pool @@ fun conn -> Pg.get_signkeys conn ~now in - let sk_ht = Hashtbl.create 0xff in - List.iter (fun sk -> Hashtbl.replace sk_ht sk.Signkey.pub ()) sk_db_l; - let future_signkeys = - Secmod_eddsa.keys sm_eddsa - |> List.filter (fun (pub, _) -> not @@ Hashtbl.mem sk_ht pub) - |> List.map (make_future_sk sm_eddsa) - in - let* dn_db_l = - Pg.use_pool pool @@ fun conn -> Pg.get_denominations conn () - in - let dn_ht = Hashtbl.create 0xff in - List.iter (fun dn -> Hashtbl.replace dn_ht dn.Denomination.h_pub ()) dn_db_l; - let future_denoms = - Secmod_rsa.keys sm_rsa - |> List.filter (fun (h_pub, _) -> not @@ Hashtbl.mem dn_ht h_pub) - |> List.map (make_future_dn sm_rsa) - in - Logs.info (fun m -> - m "%d future signkey(s) and %d future denomination(s) to certify" - (List.length future_signkeys) - (List.length future_denoms)); - let signkey_secmod_public_key = Secmod_eddsa.sm_pub sm_eddsa in - let denom_secmod_public_key = Secmod_rsa.sm_pub sm_rsa in - Ok - Api.FutureKeysResponse. - { - future_denoms; - future_signkeys; - master_pub= Config.Exchange.master_public_key; - denom_secmod_public_key; - signkey_secmod_public_key; - } - - let find_future_signkey sm_eddsa pub = - match Secmod_eddsa.find_key sm_eddsa pub with - | None -> Fmt.error_msg "future signkey not found" - | Some (pub, (t1, t2)) -> - let fsk = make_future_sk sm_eddsa (pub, (t1, t2)) in - Ok fsk - - let find_future_denomination sm_rsa h_pub = - match Secmod_rsa.find_key sm_rsa h_pub with - | None -> Fmt.error_msg "future denomination not found" - | Some v -> - let future_dn = make_future_dn sm_rsa v in - Ok future_dn - - let sk_of_future_sk - Api.FutureSignKey. + let sk_of_fsk + FutureSignKey. { key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ } master_sig = Signkey.{ pub= key; stamp_start; stamp_expire; stamp_end; master_sig } - let dn_of_future_dn - Api.FutureDenom. + let dn_of_fdn + FutureDenom. { section_name= _; value; @@ -160,7 +106,7 @@ module Future_keys = struct fee_refund; denom_secmod_sig= _; } h_pub master_sig = - let (Rsa Api.RsaDenominationKey.{ age_mask= _; rsa_pub }) = denom_pub in + let (Rsa RsaDenominationKey.{ age_mask= _; rsa_pub }) = denom_pub in Denomination. { pub= rsa_pub; @@ -178,110 +124,112 @@ module Future_keys = struct master_sig; } - let verify_future_signkey sm_eddsa Api.SignKeySignature.{ key; master_sig } = - let* fsk = find_future_signkey sm_eddsa key in - let sk = sk_of_future_sk fsk master_sig in - Signkey.verify_exchange_signing_key_validity ~key:Config.master_public_key - sk - - let verify_future_denomination sm_rsa - Api.DenomSignature.{ h_denom_pub; master_sig } = - let* fdn = find_future_denomination sm_rsa h_denom_pub in - let dn = dn_of_future_dn fdn h_denom_pub master_sig in - Denomination.verify_denomination_key_validity ~key:Config.master_public_key - dn - - let certify_future_signkey sm_eddsa pool - Api.SignKeySignature.{ key= pub; master_sig } = + let find_fsk sm_eddsa pub = match Secmod_eddsa.find_key sm_eddsa pub with | None -> Error (`Not_found "future eddsa key") | Some (pub, (t1, t2)) -> - (* rebuild it *) - let future_sk = make_future_sk sm_eddsa (pub, (t1, t2)) in - let sk = sk_of_future_sk future_sk master_sig in - let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_signkey conn sk in - Logs.info (fun m -> m "certified signkey `%a`" Eddsa.pp_pub sk.pub); - () + let fsk = make_fsk sm_eddsa (pub, (t1, t2)) in + Ok fsk - let certify_future_denomination sm_rsa pool - Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } = + let find_fdn sm_rsa h_pub = match Secmod_rsa.find_key sm_rsa h_pub with | None -> Error (`Not_found "future rsa denomination key") - | Some (h_pub, (section_name, pub, t1)) -> - let future_dn = - make_future_dn sm_rsa (h_pub, (section_name, pub, t1)) - in - let dn = dn_of_future_dn future_dn h_pub master_sig in - let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_denom conn dn in - Logs.info (fun m -> - m "certified denomination `%a`" DenominationHash.pp dn.h_pub); - () - - let revoke_signkey sm_eddsa pool pub revoked_sig = - let* opt = Pg.use_pool pool @@ fun conn -> Pg.find_signkey conn pub in - match opt with - | None -> Fmt.error_msg "signkey not found" - | Some _sk -> - let* () = Secmod_eddsa.revoke sm_eddsa pub in - let+ () = - Pg.use_pool pool @@ fun conn -> - Pg.insert_signkey_revocation conn pub revoked_sig - in - Logs.info (fun m -> m "revoked signkey `%a`" Eddsa.pp_pub pub); - () - - let revoke_denomination sm_rsa pool h_pub revoked_sig = - let* opt = - Pg.use_pool pool @@ fun conn -> Pg.find_denomination conn h_pub - in - match opt with - | None -> Fmt.error_msg "denomination not found" - | Some dn -> - let* () = Secmod_rsa.revoke sm_rsa dn.h_pub in - let+ () = - Pg.use_pool pool @@ fun conn -> - Pg.insert_denomination_revocation conn dn.h_pub revoked_sig - in - Logs.info (fun m -> - m "revoked denomination `%a`" DenominationHash.pp h_pub); - () + | Some v -> + let fdn = make_fdn sm_rsa v in + Ok fdn end module Keys_get = struct - let jsont = FutureKeysResponse.jsont + let process sm_eddsa sm_rsa pool = + let now = Timestamp.of_ptime @@ Mirage_ptime.now () in + (* get keys from database to filter out keys already certified *) + let* sk_db_l = Pg.use_pool pool @@ fun conn -> Pg.get_signkeys conn ~now in + let sk_ht = Hashtbl.create 0xff in + List.iter (fun sk -> Hashtbl.replace sk_ht sk.Signkey.pub ()) sk_db_l; + let future_signkeys = + Secmod_eddsa.keys sm_eddsa + |> List.filter (fun (pub, _) -> not @@ Hashtbl.mem sk_ht pub) + |> List.map (Future_keys.make_fsk sm_eddsa) + in + let* dn_db_l = + Pg.use_pool pool @@ fun conn -> Pg.get_denominations conn () + in + let dn_ht = Hashtbl.create 0xff in + List.iter (fun dn -> Hashtbl.replace dn_ht dn.Denomination.h_pub ()) dn_db_l; + let future_denoms = + Secmod_rsa.keys sm_rsa + |> List.filter (fun (h_pub, _) -> not @@ Hashtbl.mem dn_ht h_pub) + |> List.map (Future_keys.make_fdn sm_rsa) + in + Logs.info (fun m -> + m "%d future signkey(s) and %d future denomination(s) to certify" + (List.length future_signkeys) + (List.length future_denoms)); + let signkey_secmod_public_key = Secmod_eddsa.sm_pub sm_eddsa in + let denom_secmod_public_key = Secmod_rsa.sm_pub sm_rsa in + Ok + FutureKeysResponse. + { + future_denoms; + future_signkeys; + master_pub= Config.Exchange.master_public_key; + denom_secmod_public_key; + signkey_secmod_public_key; + } let f req server _env = Logs.info (fun m -> m "GET /management/keys/"); let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in let sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in let pool = Vifu.Server.device Mte_device.pool server in - Respond.result req jsont + Respond.result req FutureKeysResponse.jsont @@ - let* v = Future_keys.make_future_keys_response sm_eddsa sm_rsa pool in + let* v = process sm_eddsa sm_rsa pool in Ok v end module Keys_post = struct + let verify_sk sk = Signkey.verify ~master_key:Config.master_public_key sk + let verify_dn dn = Denomination.verify ~master_key:Config.master_public_key dn + + let verify_fsk sm_eddsa SignKeySignature.{ key; master_sig } = + let* fsk = Future_keys.find_fsk sm_eddsa key in + let sk = Future_keys.sk_of_fsk fsk master_sig in + verify_sk sk + + let verify_fdn sm_rsa DenomSignature.{ h_denom_pub= h_pub; master_sig } = + let* fdn = Future_keys.find_fdn sm_rsa h_pub in + let dn = Future_keys.dn_of_fdn fdn h_pub master_sig in + verify_dn dn + + let certify_fsk sm_eddsa pool SignKeySignature.{ key; master_sig } = + let* fsk = Future_keys.find_fsk sm_eddsa key in + let sk = Future_keys.sk_of_fsk fsk master_sig in + let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_signkey conn sk in + Logs.info (fun m -> m "certified signkey `%a`" Eddsa.pp_pub sk.pub); + () + + let certify_fdn sm_rsa pool DenomSignature.{ h_denom_pub= h_pub; master_sig } + = + let* fdn = Future_keys.find_fdn sm_rsa h_pub in + let dn = Future_keys.dn_of_fdn fdn h_pub master_sig in + let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_denom conn dn in + Logs.info (fun m -> + m "certified denomination `%a`" DenominationHash.pp dn.h_pub); + () + let verify sm_eddsa sm_rsa MasterSignatures.{ denom_sigs; signkey_sigs } = - let* () = - list_iter (Future_keys.verify_future_signkey sm_eddsa) signkey_sigs - in - let* () = - list_iter (Future_keys.verify_future_denomination sm_rsa) denom_sigs - in + let* () = list_iter (verify_fsk sm_eddsa) signkey_sigs in + let* () = list_iter (verify_fdn sm_rsa) denom_sigs in Ok () let process sm_eddsa sm_rsa pool MasterSignatures.{ denom_sigs; signkey_sigs } = - let* () = - list_iter (Future_keys.certify_future_signkey sm_eddsa pool) signkey_sigs - in - let* () = - list_iter (Future_keys.certify_future_denomination sm_rsa pool) denom_sigs - in + let* () = list_iter (certify_fsk sm_eddsa pool) signkey_sigs in + let* () = list_iter (certify_fdn sm_rsa pool) denom_sigs in Ok () - let jsont = MasterSignatures.jsont + let json_enc = Vifu.Type.json_encoding MasterSignatures.jsont let f req server _env = Logs.info (fun m -> m "POST /management/keys/"); @@ -301,13 +249,23 @@ module Denom_revoke = struct let open Signatures.MasterDenominationKeyRevocation in verify Config.master_public_key master_sig { h_denom_pub } - let process sm_rsa pool h_denom_pub DenomRevocationSignature.{ master_sig } = - let+ () = - Future_keys.revoke_denomination sm_rsa pool h_denom_pub master_sig + let process sm_rsa pool h_pub DenomRevocationSignature.{ master_sig } = + let* opt = + Pg.use_pool pool @@ fun conn -> Pg.find_denomination conn h_pub in - () + match opt with + | None -> Error (`Not_found "denomination not found") + | Some _dn -> + let* () = Secmod_rsa.revoke sm_rsa h_pub in + let+ () = + Pg.use_pool pool @@ fun conn -> + Pg.insert_denomination_revocation conn h_pub master_sig + in + Logs.info (fun m -> + m "revoked denomination `%a`" DenominationHash.pp h_pub); + () - let jsont = DenomRevocationSignature.jsont + let json_enc = Vifu.Type.json_encoding DenomRevocationSignature.jsont let f req h_denom_pub server _env = Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/"); @@ -330,14 +288,20 @@ module Signkey_revoke = struct let open Signatures.MasterSigningKeyRevocation in verify Config.master_public_key master_sig { exchange_pub } - let process sm_eddsa pool exchange_pub - SignkeyRevocationSignature.{ master_sig } = - let+ () = - Future_keys.revoke_signkey sm_eddsa pool exchange_pub master_sig - in - () + let process sm_eddsa pool pub SignkeyRevocationSignature.{ master_sig } = + let* opt = Pg.use_pool pool @@ fun conn -> Pg.find_signkey conn pub in + match opt with + | None -> Error (`Not_found "signkey not found") + | Some _sk -> + let* () = Secmod_eddsa.revoke sm_eddsa pub in + let+ () = + Pg.use_pool pool @@ fun conn -> + Pg.insert_signkey_revocation conn pub master_sig + in + Logs.info (fun m -> m "revoked signkey `%a`" Eddsa.pp_pub pub); + () - let jsont = SignkeyRevocationSignature.jsont + let json_enc = Vifu.Type.json_encoding SignkeyRevocationSignature.jsont let f req exchange_pub server _env = Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/"); @@ -388,7 +352,9 @@ module Auditors = struct () | Some auditor -> if Timestamp.compare validity_start auditor.last_change <= 0 then - Error (`Conflict "replay detected on enable-auditor") + Error + (`Replay_attack + ("/management/auditors/", auditor.last_change, validity_start)) else let+ () = Pg.use_pool pool @@ fun conn -> Pg.update_auditor conn auditor @@ -396,7 +362,7 @@ module Auditors = struct Logs.info (fun m -> m "updated auditor"); () - let jsont = AuditorSetupMessage.jsont + let json_enc = Vifu.Type.json_encoding AuditorSetupMessage.jsont let f req server _env = Logs.info (fun m -> m "POST /management/auditors/"); @@ -424,7 +390,11 @@ module Auditors_disable = struct | None -> Error (`Not_found "auditor pub key") | Some auditor -> ( if Timestamp.compare validity_end auditor.last_change <= 0 then - Error (`Conflict "replay detected on disable-auditor") + Error + (`Replay_attack + ( "/management/auditors/$AUDITOR_PUB/disable/", + auditor.last_change, + validity_end )) else match auditor.is_active with | false -> @@ -441,7 +411,7 @@ module Auditors_disable = struct m "revoked auditor `%a`" Eddsa.pp_pub auditor_pub); ()) - let jsont = AuditorTeardownMessage.jsont + let json_enc = Vifu.Type.json_encoding AuditorTeardownMessage.jsont let f req auditor_pub server _env = Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/"); @@ -503,7 +473,7 @@ module Wire_fee = struct "invalid database state, multiple wire-fee found in database for \ this time frame" - let jsont = WireFeeSetupMessage.jsont + let json_enc = Vifu.Type.json_encoding WireFeeSetupMessage.jsont let f req server _env = Logs.info (fun m -> m "POST /management/wire-fee/"); @@ -547,7 +517,7 @@ module Global_fees = struct "invalid database state, multiple global-fees found in database for \ this time frame" - let jsont = GlobalFees.jsont + let json_enc = Vifu.Type.json_encoding GlobalFees.jsont (* TODO better global_fees ensure it is defined for the current time. @@ -655,7 +625,8 @@ module Wire = struct () | Some (wire, _is_active, last_change) -> if Timestamp.compare validity_start last_change <= 0 then - Error (`Conflict "replay detected on enable-wire") + Error + (`Replay_attack ("/management/wire/", last_change, validity_start)) else let+ () = Pg.use_pool pool @@ fun conn -> @@ -664,7 +635,7 @@ module Wire = struct Logs.info (fun m -> m "updated wire method"); () - let jsont = WireSetupMessage.jsont + let json_enc = Vifu.Type.json_encoding WireSetupMessage.jsont let f req server _env = Logs.info (fun m -> m "POST /management/wire/"); @@ -690,7 +661,9 @@ module Wire_disable = struct | None -> Error (`Not_found "wire payto-uri") | Some (wire, _is_active, last_change) -> if Timestamp.compare validity_end last_change <= 0 then - Error (`Conflict "replay detected on disable-wire") + Error + (`Replay_attack + ("/management/wire/disable/", last_change, validity_end)) else let+ () = Pg.use_pool pool @@ fun conn -> @@ -699,7 +672,7 @@ module Wire_disable = struct Logs.info (fun m -> m "disabled wire method"); () - let jsont = WireTeardownMessage.jsont + let json_enc = Vifu.Type.json_encoding WireTeardownMessage.jsont let f req server _env = Logs.info (fun m -> m "POST /management/wire/disable/"); @@ -749,7 +722,7 @@ module Drain = struct Logs.info (fun m -> m "added drain profit message to database"); () - let jsont = DrainProfitsMessage.jsont + let json_enc = Vifu.Type.json_encoding DrainProfitsMessage.jsont let f req server _env = Logs.info (fun m -> m "POST /management/drain/"); @@ -789,7 +762,7 @@ module AmlOfficer = struct in () - let jsont = AmlOfficerSetup.jsont + let json_enc = Vifu.Type.json_encoding AmlOfficerSetup.jsont let f req server _env = Logs.info (fun m -> m "POST /management/aml-officers/"); @@ -829,7 +802,7 @@ module Partners = struct let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_partner conn v in () - let jsont = ExchangePartnerSetupRequest.jsont + let json_enc = Vifu.Type.json_encoding ExchangePartnerSetupRequest.jsont let f req server _env = Logs.info (fun m -> m "POST /management/partners/"); diff --git a/src/mte_seed.ml b/src/mte_seed.ml new file mode 100644 index 00000000..99ba1872 --- /dev/null +++ b/src/mte_seed.ml @@ -0,0 +1,10 @@ +(* TODO crypto + is this ok? + maybe don't use the same RNG-initialization as the one used to generate keys *) +let f req _server _env = + Logs.info (fun m -> m "GET /seed"); + let open Vifu.Response in + let open Syntax in + let* () = add ~field:"content-type" "application/octet-stream" in + let* () = with_string req (Mirage_crypto_rng.generate 64) in + respond `OK diff --git a/src/mte_terms.ml b/src/mte_terms.ml deleted file mode 100644 index 48e61e47..00000000 --- a/src/mte_terms.ml +++ /dev/null @@ -1,42 +0,0 @@ -(* /terms + /privacy *) - -let aux asset req _server _env = - let etag = Assets.etag asset in - let headers = Vifu.Request.headers req in - let has_matching_etag = - match Vifu.Headers.get headers "if-none-match" with - | None -> false - | Some s -> String.equal etag s - in - match has_matching_etag with - | true -> Respond.not_modified () - | false -> - let mime = Headers.select_mimetype headers in - let lang = Headers.select_language headers in - let compression = Headers.select_encoding headers in - let data = Assets.get_content ~mime ~lang asset in - (* -- *) - let open Vifu.Response in - let open Syntax in - let* () = with_string ?compression req data in - let* () = add ~field:"etag" etag in - let* () = - add ~field:"taler-terms-version" Assets.Cfg.terms_legal_version - in - let* () = - add ~field:"avail-languages" Headers.avail_languages_header_value - in - let* () = - let content_type = Fmt.str "%a" Assets.Mimetype.pp mime in - add ~field:"content-type" content_type - in - let* () = add ~field:"content-language" lang in - respond `OK - -let terms req _server _env = - Logs.info (fun m -> m "GET /terms"); - aux Assets.Terms req _server _env - -let privacy req _server _env = - Logs.info (fun m -> m "GET /privacy"); - aux Assets.Privacy req _server _env diff --git a/src/mte_tos.ml b/src/mte_tos.ml new file mode 100644 index 00000000..e8490aed --- /dev/null +++ b/src/mte_tos.ml @@ -0,0 +1,119 @@ +(* /terms + /privacy *) + +module Cfg = struct + let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity + let default_mimetype = ("text", "plain") + let default_language = "en" + let terms_legal_version = "0" + let terms_dir = "terms" + let privacy_dir = "privacy" +end + +let terms = Assets.load Cfg.terms_dir Config.terms_etag +let privacy = Assets.load Cfg.privacy_dir Config.privacy_etag + +let asset_etag t = + match t with `Terms -> Config.terms_etag | `Privacy -> Config.privacy_etag + +let asset_data t = match t with `Terms -> terms | `Privacy -> privacy + +let has_matching_etag etag headers = + match Vifu.Headers.get headers "if-none-match" with + | None -> false + | Some s -> String.equal etag s + +(* todo: should have a middleware for this *) +let select_encoding headers = + let opt = Vifu.Headers.get headers "accept-encoding" in + Cohttp.Accept.encodings opt + |> Cohttp.Accept.qsort + |> List.map snd + |> List.find_map (function + | Cohttp.Accept.Identity -> Some `Identity + | Deflate -> Some `DEFLATE + | Gzip -> Some `Gzip + | AnyEncoding -> Some Cfg.default_encoding + | Encoding _ | Compress -> None) + |> function + | None -> None + | Some `Identity -> None + | Some `DEFLATE -> Some `DEFLATE + | Some `Gzip -> Some `Gzip + +let get_accept headers = + Vifu.Headers.get headers "accept" + |> Cohttp.Accept.media_ranges + |> Cohttp.Accept.qsort + |> List.map (fun (_q, (m, _p)) -> m) + +let get_accept_language headers = + Vifu.Headers.get headers "accept-language" + |> Cohttp.Accept.languages + |> Cohttp.Accept.qsort + |> List.map snd + +let avail_languages t = + let supported_languages, _, _ = asset_data t in + Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") Fmt.string) supported_languages + +let pp_mimetype fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime) + +let accept t = + let _, supported_mimetypes, _ = asset_data t in + Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") pp_mimetype) supported_mimetypes + +let get_content t accept accept_language = + let supported_languages, supported_mimetypes, content_matrix = asset_data t in + let find_lang_index = function + | Cohttp.Accept.AnyLanguage -> + Array.find_index + (fun mm' -> Cfg.default_language = mm') + supported_languages + | Language language_range -> ( + (* ignore language subtags (e.g. "en-US" -> "en") *) + match language_range with + | [] -> assert false + | lang :: _ -> + Array.find_index (fun mm' -> lang = mm') supported_languages) + in + let find_mime_index = function + | Cohttp.Accept.AnyMedia -> + Array.find_index (( = ) Cfg.default_mimetype) supported_mimetypes + | MediaType (m, mm) -> Array.find_index (( = ) (m, mm)) supported_mimetypes + | AnyMediaSubtype m -> + Array.find_index (fun (m', _) -> m = m') supported_mimetypes + in + let i = List.find_map find_lang_index accept_language in + let j = List.find_map find_mime_index accept in + (* TODO *) + let i = Option.get i in + let j = Option.get j in + (supported_languages.(i), supported_mimetypes.(j), content_matrix.(i).(j)) + +let aux t req _server _env = + let headers = Vifu.Request.headers req in + if has_matching_etag (asset_etag t) headers then Respond.not_modified () + else + let compression = select_encoding headers in + let language, mimetype, content = + get_content t (get_accept headers) (get_accept_language headers) + in + (* -- *) + let open Vifu.Response in + let open Syntax in + let* () = with_string ?compression req content in + let* () = add ~field:"etag" (asset_etag t) in + let* () = add ~field:"taler-terms-version" Cfg.terms_legal_version in + let* () = add ~field:"accept" (accept t) in + let* () = add ~field:"avail-languages" (avail_languages t) in + let* () = add ~field:"content-type" (Fmt.str "%a" pp_mimetype mimetype) in + let* () = add ~field:"content-language" language in + respond `OK + +let terms req _server _env = + Logs.info (fun m -> m "GET /terms"); + aux `Terms req _server _env + +let privacy req _server _env = + Logs.info (fun m -> m "GET /privacy"); + aux `Privacy req _server _env diff --git a/src/respond.ml b/src/respond.ml index a1ff686f..a5606866 100644 --- a/src/respond.ml +++ b/src/respond.ml @@ -31,6 +31,7 @@ let map_err_status err = match err with | `Json_decode _ | `Bin_decode _ -> `Bad_request | `Invalid_signature_eddsa | `Invalid_signature_rsa -> `Forbidden + | `Replay_attack _ -> `Conflict | `Not_found _ -> `Not_found | `Conflict _ -> `Conflict | `Caqti _s | `Mfat _s | `Json_encode _s | `Bin_encode _s | `Msg _s -> diff --git a/src/result.ml b/src/result.ml index 744edfeb..a9c177cf 100644 --- a/src/result.ml +++ b/src/result.ml @@ -1,10 +1,12 @@ include Stdlib.Result +open Time type err = [ `Json_decode of string | `Bin_decode of string | `Invalid_signature_eddsa | `Invalid_signature_rsa + | `Replay_attack of string * Timestamp.t * Timestamp.t | (* - *) `Not_found of string | `Conflict of string @@ -25,6 +27,9 @@ let err_to_string : err -> string = function | `Bin_encode s -> Fmt.str "Bin encode: %s" s | `Invalid_signature_eddsa -> Fmt.str "Invalid eddsa signature" | `Invalid_signature_rsa -> Fmt.str "Invalid rsa signature" + | `Replay_attack (url, ours, theirs) -> + Fmt.str "Replay attack detected on %s. Got `%a` but received `%a`" url + Timestamp.pp ours Timestamp.pp theirs (* - *) | `Not_found s -> Fmt.str "Not found: %s" s | `Conflict s -> Fmt.str "Conflict: %s" s diff --git a/src/signkey.ml b/src/signkey.ml index 0109efaf..74355e11 100644 --- a/src/signkey.ml +++ b/src/signkey.ml @@ -8,9 +8,9 @@ type t = { master_sig: Signatures.ExchangeSigningKeyValidity.t; } -let verify_exchange_signing_key_validity ~key sk = +let verify ~master_key sk = let open Signatures.ExchangeSigningKeyValidity in - verify key sk.master_sig + verify master_key sk.master_sig { R.start= sk.stamp_start; expire= sk.stamp_expire; diff --git a/test/validate.ml b/test/validate.ml index d1e0f145..4de801cc 100644 --- a/test/validate.ml +++ b/test/validate.ml @@ -42,9 +42,7 @@ let keys content = let sk_l = List.map SignKey.to_signkey v.signkeys in let* () = - sk_l - |> list_iter - (Signkey.verify_exchange_signing_key_validity ~key:v.master_public_key) + sk_l |> list_iter (Signkey.verify ~master_key:v.master_public_key) in let* () = @@ -71,13 +69,12 @@ let keys content = let denom_l = v.denominations |> Denomination.denoms_of_denomgroups in let* () = - denom_l - |> list_iter - (Denomination.verify_denomination_key_validity ~key:v.master_public_key) + denom_l |> list_iter (Denomination.verify ~master_key:v.master_public_key) in let* () = - (* TODO O(n^2) *) + let dn_ht = Hashtbl.create 0xff in + List.iter (fun dn -> Hashtbl.replace dn_ht dn.Denomination.h_pub dn) denom_l; v.auditors |> List.concat_map (fun @@ -87,30 +84,29 @@ let keys content = let auditor_url_hash = H64_cstring.hash auditor_url in denomination_keys |> List.map - (fun AuditorDenominationKey.{ denom_pub_h; auditor_sig } -> - (denom_pub_h, auditor_url_hash, auditor_pub, auditor_sig))) - |> list_iter - (fun (denom_pub_h, auditor_url_hash, auditor_pub, auditor_sig) -> - let open Denomination in - denom_l |> List.find_opt (fun dn -> dn.h_pub = denom_pub_h) - |> function - | None -> Fmt.error_msg "auditor denomination key not found" - | Some dn -> - let open Signatures.ExchangeKeyValidity in - verify auditor_pub auditor_sig - { - auditor_url_hash; - master= auditor_pub; - start= dn.stamp_start; - expire_withdraw= dn.stamp_expire_withdraw; - expire_spend= dn.stamp_expire_deposit; - expire_legal= dn.stamp_expire_legal; - value= dn.value; - fee_withdraw= dn.fee_withdraw; - fee_deposit= dn.fee_deposit; - fee_refresh= dn.fee_refresh; - denom_hash= dn.h_pub; - }) + (fun + AuditorDenominationKey.{ denom_pub_h= h_pub; auditor_sig } -> + (h_pub, (auditor_url_hash, auditor_pub, auditor_sig)))) + |> list_iter (fun (h_pub, (auditor_url_hash, auditor_pub, auditor_sig)) -> + Hashtbl.find_opt dn_ht h_pub |> function + | None -> Fmt.error_msg "auditor denomination key not found" + | Some dn -> + let open Denomination in + let open Signatures.ExchangeKeyValidity in + verify auditor_pub auditor_sig + { + auditor_url_hash; + master= auditor_pub; + start= dn.stamp_start; + expire_withdraw= dn.stamp_expire_withdraw; + expire_spend= dn.stamp_expire_deposit; + expire_legal= dn.stamp_expire_legal; + value= dn.value; + fee_withdraw= dn.fee_withdraw; + fee_deposit= dn.fee_deposit; + fee_refresh= dn.fee_refresh; + denom_hash= dn.h_pub; + }) in Ok () diff --git a/tools/offline_impl.ml b/tools/offline_impl.ml index 5f42ed1f..362c5f6c 100644 --- a/tools/offline_impl.ml +++ b/tools/offline_impl.ml @@ -4,6 +4,10 @@ open Hash let () = Mirage_crypto_rng_unix.use_default () +(* TODO monotonic time: + add something for tests / broken monotonic time + + https://docs.taler.net/manpages/taler-exchange-offline.1.html#security-considerations *) let now_s () = let ns = Mtime_clock.now_ns () in Int64.unsigned_div ns 1_000_000_000L