From 0cfed83325e26b6931032d795e08a367fd6fc255 Mon Sep 17 00:00:00 2001 From: swrup Date: Sun, 30 Nov 2025 09:30:40 +0100 Subject: [PATCH] ~ --- .ocamlformat | 2 +- src/amount.ml | 3 ++- src/assets.ml | 26 ++++++++----------- src/config.ml | 14 ++++------- src/database.ml | 61 +++++++++++++++++---------------------------- src/devices.ml | 14 ++++++++--- src/mte.ml | 17 ++++++++----- src/parse_config.ml | 48 ++++++++++++++++------------------- src/pg.ml | 7 ++++-- src/util.ml | 23 ++++++++++------- 10 files changed, 103 insertions(+), 112 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 4d907d30..43b12fc0 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -2,7 +2,7 @@ version=0.28.1 exp-grouping=preserve type-decl=sparse break-infix=fit-or-vertical -break-collection-expressions=wrap +break-collection-expressions=fit-or-vertical break-sequences=false break-infix-before-func=false dock-collection-brackets=true diff --git a/src/amount.ml b/src/amount.ml index 2b65bd2e..2a49a548 100644 --- a/src/amount.ml +++ b/src/amount.ml @@ -56,7 +56,8 @@ let of_string = choice [ char '+' *> return (Some Sign_plus); - char '-' *> return (Some Sign_minus); return None; + char '-' *> return (Some Sign_minus); + return None; ] in let parse_currency = diff --git a/src/assets.ml b/src/assets.ml index f27b520b..9d6c8088 100644 --- a/src/assets.ml +++ b/src/assets.ml @@ -1,8 +1,4 @@ -(* module to handle assets. for now, assets are defined to all be in - `src/assets/` folder. crunched into the [Assets_crunch] module. - - to keep it simple, we require that /terms and /privacy support the same set - of languages X mimetypes *) +(* TODO clean up *) (* docs: https://docs.taler.net/manpages/taler-exchange.conf.5.html https://docs.taler.net/design-documents/003-tos-rendering.html *) @@ -11,7 +7,7 @@ let default_lang = "en" let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity -(* TODO Taler documentation markdown mimetype should be the prefered one, and be +(* todo: Taler documentation markdown mimetype should be the prefered one, and be supported, according to DD we take text/plain as default instead for now *) let default_mimetype = ("text", "plain") let default_extension = ".txt" @@ -21,10 +17,14 @@ let privacy_legal_version = "1" module Mimetype = struct let mimetype_extension_assoc = [ - (("text", "plain"), ".txt"); (("text", "markdown"), ".md"); - (("text", "html"), ".html"); (("text", "html"), ".htm"); - (("application", "pdf"), ".pdf"); (("image", "jpeg"), ".jpg"); - (("image", "jpeg"), ".jpeg"); (("image", "png"), ".png"); + (("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"); ] @@ -69,9 +69,6 @@ let base_dir = function | Terms -> Fpath.v "terms" | Privacy -> Fpath.v "privacy" -(* TODO - better use of Fmt to have error prefix or smthing - use Logs *) (* does some checks on assets/ folder content and infer the set of supported languages and mimetype *) let supported_lang_arr, supported_ext_arr = let open Syntax in @@ -139,9 +136,6 @@ let is_supported_lang lang = Array.mem lang supported_lang_arr let is_supported_ext ext = Array.mem ext supported_ext_arr let is_supported_mimetype mime = Array.mem mime supported_mimetype_arr -(* todo - - put content in a matrix instead? - - better types to force valid params? *) (* ! lang and mime must be supported *) let get_content ~lang ~mime t = let etag = Headers_lib.Etag.to_raw_string (etag t) in diff --git a/src/config.ml b/src/config.ml index 136c8995..e3c112ee 100644 --- a/src/config.ml +++ b/src/config.ml @@ -3,10 +3,9 @@ open Parse_config let config_data = let path = Fpath.to_string (Fpath.v "default.config") in match Assets_crunch.read path with - | None -> Fmt.failwith "static file not found: `%s`" path + | None -> fail "static file not found: `%s`" path | Some data -> let v = Parse_data.parse data in - (*Fmt.epr "config file:@\n%a@." Pp_debug.pp_config v;*) v module Exchange = struct @@ -117,14 +116,11 @@ module Currency = struct List.find_opt (fun v -> v.code = Exchange.currency) all_currencies with | None -> - fail_with - (Fmt.str - "section `[currency-%s]` not found, currency `%s` is not defined" - Exchange.currency Exchange.currency) + fail "section `[currency-%s]` not found, currency `%s` is not defined" + Exchange.currency Exchange.currency | Some v -> ( match v.enabled = `YES with - | false -> - fail_with (Fmt.str "currency `%s` is not enabled" Exchange.currency) + | false -> fail "currency `%s` is not enabled" Exchange.currency | true -> v) end @@ -171,7 +167,7 @@ module Coin = struct age_restricted= ( get "age_restricted" |> yes_no |> function | `NO -> `NO - | `YES -> fail_with "`age_restricted = YES` is not supported" ); + | `YES -> fail "`age_restricted = YES` is not supported" ); } let all_coins = List.map parse_coin coin_sections diff --git a/src/database.ml b/src/database.ml index bb37ed21..07f5661e 100644 --- a/src/database.ml +++ b/src/database.ml @@ -2,47 +2,32 @@ - GNU Taler db-events? it seems caqti/pgx does not support it *) -let test req server _ = - let (module Conn : Caqti_miou.CONNECTION) = - Vif.Server.device Devices.db_connection server +let on_ok req () = + let open Vif.Response.Syntax in + let* () = + Vif.Response.add ~field:"content-type" "text/plain; charset= utf-8" in - let query = - let open Caqti_request.Infix in - Caqti_type.(unit ->! int) "SELECT 53 - 11" + let* () = + Vif.Response.with_string req (Fmt.str "activate_signing_key done~~@.") in - match Conn.find query () with - | Ok n -> - let open Vif.Response.Syntax in - let* () = - Vif.Response.add ~field:"content-type" "text/plain; charset= utf-8" - in - let* () = Vif.Response.with_string req (Fmt.str "53 - 11 = %d@." n) in - Vif.Response.respond `OK - | Error err -> - (* TODO don't leak private data in error messages *) - let open Vif.Response.Syntax in - let str = Fmt.str "Database error: %a." Caqti_error.pp err in - let* () = Vif.Response.with_string req str in - Vif.Response.respond `Internal_server_error + Vif.Response.respond `OK + +let on_error req err = + (* TODO be sure to not leak private data in error messages *) + let open Vif.Response.Syntax in + let str = Fmt.str "Database error: %a." Caqti_error.pp err in + Logs.err (fun m -> m "%s" str); + let* () = Vif.Response.with_string req str in + Vif.Response.respond `Internal_server_error + +(* TODO master_sig *) +let dummy_master_sig = + Option.some @@ Crypto.EddsaSignature.of_octets (String.make 64 '\x00') let test_activate req server _ = - (*let (module Conn : Caqti_miou.CONNECTION) =*) let db_conn = Vif.Server.device Devices.db_connection server in let secmod_signkey = Vif.Server.device Devices.secmod_signkey server in - let exchange_public_key = secmod_signkey.sm_key in - match Pg.activate_signing_key db_conn exchange_public_key with - | Ok () -> - let open Vif.Response.Syntax in - let* () = - Vif.Response.add ~field:"content-type" "text/plain; charset= utf-8" - in - let* () = - Vif.Response.with_string req (Fmt.str "activate_signing_key done~~@.") - in - Vif.Response.respond `OK - | Error err -> - (* TODO don't leak private data in error messages *) - let open Vif.Response.Syntax in - let str = Fmt.str "Database error: %a." Caqti_error.pp err in - let* () = Vif.Response.with_string req str in - Vif.Response.respond `Internal_server_error + let sm_key = secmod_signkey.sm_key in + let sm_key = { sm_key with master_sig= dummy_master_sig } in + let res = Pg.activate_signing_key db_conn sm_key in + Result.fold ~ok:(on_ok req) ~error:(on_error req) res diff --git a/src/devices.ml b/src/devices.ml index fc821823..34538354 100644 --- a/src/devices.ml +++ b/src/devices.ml @@ -16,7 +16,9 @@ let db_connection : (env, Caqti_miou.connection) Vif.Device.device = match Pg.preflight conn with | Error err -> Fmt.failwith "Database preflight failure: %a." Caqti_error.pp err - | Ok () -> conn) + | Ok () -> + Logs.info (fun m -> m "database connection initialized"); + conn) module Secmod_signkey = struct (* TODO @@ -70,8 +72,11 @@ module Secmod_signkey = struct match load conn with | Ok None -> let t = generate_fresh_secmod_data () in + Logs.info (fun m -> m "secmod_signkey initialized with fresh keys"); t - | Ok (Some v) -> v + | Ok (Some v) -> + Logs.info (fun m -> m "secmod_signkey initialized from storage"); + v | Error _ -> (* TODO error: pretty print *) Fmt.failwith "secmod_signkey init failure." @@ -131,8 +136,11 @@ module Secmod_denom = struct match load conn with | Ok None -> let t = generate_fresh_secmod_data () in + Logs.info (fun m -> m "secmod_denom initialized with fresh keys"); t - | Ok (Some v) -> v + | Ok (Some v) -> + Logs.info (fun m -> m "secmod_denom initialized from storage"); + v | Error _ -> Fmt.failwith "secmod_denom init failure." end diff --git a/src/mte.ml b/src/mte.ml index 328fcb5d..8439cdb0 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -24,11 +24,16 @@ let routes = let open Vif.Uri in let open Vif.Route in let open Vif.Type in + (* just for alignement *) + let get_ = get in + let post = Fun.flip post in [ - get (rel /?? nil) --> hello; get (rel / "terms" /?? nil) --> Static.terms; - get (rel / "privacy" /?? nil) --> Static.privacy; - get (rel / "management" / "keys" /?? nil) --> Management.keys_get; - post any (rel / "management" / "keys" /?? nil) --> Management.keys_post; + get_ (rel /?? nil) --> hello; + get_ (rel / "terms" /?? nil) --> Static.terms; + get_ (rel / "privacy" /?? nil) --> Static.privacy; + get_ (rel / "test" /?? nil) --> Database.test_activate; + get_ (rel / "management" / "keys" /?? nil) --> Management.keys_get; + post (rel / "management" / "keys" /?? nil) any --> Management.keys_post; ] let () = @@ -36,7 +41,7 @@ let () = let cfg = let port = Config.Exchange.port in let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, port)) in - Vif.config ~reporter:Logs.nop_reporter sockaddr + Vif.config ~reporter:Util.Log_reporter.reporter sockaddr in Miou_unix.run @@ fun () -> Caqti_miou.Switch.run @@ fun caqti_switch -> @@ -49,5 +54,5 @@ let () = in let middlewares = Vif.Middlewares.[] in Logs.info (fun m -> - m ~tags:(Util.Log_reporter.detail "~~!") "Starting MTE server"); + m ~tags:(Util.Log_reporter.detail "...") "Starting MTE server"); Vif.run ~cfg ~devices ~middlewares routes env diff --git a/src/parse_config.ml b/src/parse_config.ml index 115d1af7..0fd672a3 100644 --- a/src/parse_config.ml +++ b/src/parse_config.ml @@ -15,9 +15,9 @@ type section = { items: item list; } -let fail_with msg = - Fmt.epr "Configuration failure: %s.@." msg; - exit 1 +let fail fmt = + let k _ppf = exit 1 in + Fmt.kpf k Fmt.stderr ("Configuration failure: " ^^ fmt ^^ ".@.") let is_eol = function '\n' | '\r' -> true | _ -> false let is_whitespace = function ' ' | '\t' -> true | _ -> false @@ -55,7 +55,7 @@ module Parse_data = struct let quoted_value = char '"' *> take_till is_eol >>= fun s -> match String.ends_with ~suffix:"\"" s with - | false -> fail_with "invalid quoted value" + | false -> fail "invalid quoted value" | true -> let value = String.sub s 0 (String.length s - 1) in return value @@ -76,7 +76,7 @@ module Parse_data = struct match l with | [] -> if List.is_empty item_l then section_l - else fail_with "invalid configuration structure" + else fail "invalid configuration structure" | Blank :: tl | Comment _ :: tl -> loop section_l item_l tl | Item item :: tl -> loop section_l (item :: item_l) tl | Header header :: tl -> @@ -87,7 +87,7 @@ module Parse_data = struct let parse s = match parse_string ~consume:All config s with - | Error msg -> fail_with (Fmt.str "parse error `%s`" msg) + | Error msg -> fail "parse error `%s`" msg | Ok v -> fold_sections v end @@ -130,7 +130,7 @@ module Parse_duration = struct let integer = take_while1 (function '0' .. '9' -> true | _ -> false) >>= fun s -> match int_of_string_opt s with - | None -> fail_with (Fmt.str "expected integer, got `%s`" s) + | None -> fail "expected integer, got `%s`" s | Some i -> return i let duration_element = @@ -144,7 +144,7 @@ module Parse_duration = struct | "hour" | "hours" -> return `Hour | "minute" | "minutes" -> return `Minute | "second" | "seconds" | "s" -> return `Second - | s -> fail_with (Fmt.str "expected a duration unit, got `%s`" s) + | s -> fail "expected a duration unit, got `%s`" s in lift2 (fun number dunit -> { number; dunit }) number dunit @@ -164,9 +164,7 @@ module Parse_duration = struct let ptime_span_of_int64 i = match Ptime.Span.of_float_s (Int64.to_float i) with | None -> - fail_with - (Fmt.str "ptime_span_of_int64 error: `%Ld` is not a valid ptime span" - i) + fail "ptime_span_of_int64 error: `%Ld` is not a valid ptime span" i | Some ts -> ts let to_ptime_span t = @@ -181,11 +179,11 @@ module Parse_duration = struct let parse s : duration_element list = match parse_string ~consume:All duration s with - | Error msg -> fail_with (Fmt.str "duration parse error `%s`" msg) + | Error msg -> fail "duration parse error `%s`" msg | Ok v -> v end -let unwrap_res = function Error e -> fail_with (Fmt.str "`%s`." e) | Ok v -> v +let unwrap_res = function Error e -> fail "`%s`." e | Ok v -> v let get_opt t ~section ~field = match List.find_opt (fun v -> v.header = section) t with @@ -197,28 +195,26 @@ let get_opt t ~section ~field = let get t ~section ~field = match get_opt t ~section ~field with - | None -> fail_with (Fmt.str "option `[%s].%s` not found" section field) + | None -> fail "option `[%s].%s` not found" section field | Some v -> v let int s = match int_of_string_opt s with - | None -> fail_with (Fmt.str "expected int value, got `%s`" s) + | None -> fail "expected int value, got `%s`" s | Some v -> v let float s = match float_of_string_opt s with - | None -> fail_with (Fmt.str "expected float value, got `%s`" s) + | None -> fail "expected float value, got `%s`" s | Some v -> v let const_value a b = - match a = b with - | false -> fail_with (Fmt.str "unexpected value `%s`" b) - | true -> a + match a = b with false -> fail "unexpected value `%s`" b | true -> a let yes_no = function | "NO" -> `NO | "YES" -> `YES - | s -> fail_with (Fmt.str "expected `YES`/`NO` value, got `%s`" s) + | s -> fail "expected `YES`/`NO` value, got `%s`" s let uri s = Uri.of_string s let amount s = s |> Amount.of_string |> unwrap_res @@ -238,7 +234,7 @@ module Parse_alt_unit_names = struct match String.starts_with ~prefix:"{" s && String.ends_with ~suffix:"}" s with - | false -> fail_with (Fmt.str "expected json, got `%s`" s) + | false -> fail "expected json, got `%s`" s | true -> let s = String.sub s 1 (String.length s - 2) in s @@ -248,7 +244,7 @@ module Parse_alt_unit_names = struct match String.starts_with ~prefix:"\"" s && String.ends_with ~suffix:"\"" s with - | false -> fail_with (Fmt.str "expected quoted string, got `%s`" s) + | false -> fail "expected quoted string, got `%s`" s | true -> let s = String.sub s 1 (String.length s - 2) in s @@ -259,17 +255,15 @@ module Parse_alt_unit_names = struct |> List.map (String.split_on_char ':') |> List.map (function | [ k; v ] -> (k, v) - | _ -> fail_with "invalid json key-value map") + | _ -> fail "invalid json key-value map") |> List.map (fun (k, v) -> let k = rm_quotes k in let v = rm_quotes v in let k = match int_of_string_opt k with | None -> - fail_with - (Fmt.str - "invalid json key-value map, expected integer key, got `%s`" - k) + fail "invalid json key-value map, expected integer key, got `%s`" + k | Some k -> k in (k, v)) diff --git a/src/pg.ml b/src/pg.ml index 4c97f8a4..b6f6264e 100644 --- a/src/pg.ml +++ b/src/pg.ml @@ -71,8 +71,11 @@ let preflight = Caqti_type.(unit ->. unit) [ "SET SESSION CHARACTERISTICS AS TRANSACTION ISOLATION LEVEL \ - SERIALIZABLE;"; "SET enable_sort=OFF;"; "SET enable_seqscan=OFF;"; - "SET enable_mergejoin=OFF;"; "SET search_path TO exchange;"; + SERIALIZABLE;"; + "SET enable_sort=OFF;"; + "SET enable_seqscan=OFF;"; + "SET enable_mergejoin=OFF;"; + "SET search_path TO exchange;"; ] in fun (module Conn : Caqti_miou.CONNECTION) -> diff --git a/src/util.ml b/src/util.ml index 785958c9..52691564 100644 --- a/src/util.ml +++ b/src/util.ml @@ -35,7 +35,6 @@ module Bin_rsa = struct let z_array_to_octets (arr : Z.t array) = let nb = Array.length arr in - (*Fmt.epr "z_array_to_octets, nb=%d@." nb;*) let bits_arr = Array.map z_to_bits_be arr in let len_arr = Array.map String.length bits_arr in let len = (2 * nb) + Array.fold_left ( + ) 0 len_arr in @@ -55,7 +54,6 @@ module Bin_rsa = struct Bytes.unsafe_to_string b let z_array_of_octets ~nb s = - (*Fmt.epr "z_array_of_octets, nb=%d@." nb;*) let s_len = String.length s in let* () = check (s_len > 2 * nb) in let pos = ref 0 in @@ -122,7 +120,7 @@ module Log_reporter = struct let detail s = Logs.Tag.(empty |> add detail_tag s) let time_anchor = Ptime_clock.now () |> Ptime.to_span - let log_level_color = function + let color_of_log_level = function | Logs.App -> `White | Error -> `Red | Warning -> `Yellow @@ -133,7 +131,7 @@ module Log_reporter = struct let open Fmt in let pp_timestamp = styled `Faint (styled (`Fg `White) (fmt "%04.02f")) in let pp_header ppf v = - let color = fst v |> log_level_color in + let color = color_of_log_level (fst v) in let pp = styled (`Fg color) Logs.pp_header in pf ppf "%a" pp v in @@ -143,7 +141,11 @@ module Log_reporter = struct in let pp_detail = option (styled `Green (fmt " (%s)")) in let report src lvl ~over k msgf = - let ppf = stderr in + let ppf = + match lvl with + | Logs.App -> stdout + | Error | Warning | Info | Debug -> stderr + in let k _ppf = over (); k () in let with_detail h tags k user_fmt = let detail = Option.bind tags (Logs.Tag.find detail_tag) in @@ -161,12 +163,15 @@ module Log_reporter = struct in { report } + (* TODO logs + - vif shouldn't use/set the default reporter + - Log.err all `Internal_server_error response *) let setup () = + let level = Some Logs.Info in + Logs.set_level ~all:false level; Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true (); - Logs.set_reporter reporter; - Logs.set_level ~all:false (Some Logs.Debug); - Logs.Src.set_level Logs.default (Some Logs.Debug); + Logs.Src.set_level Logs.default level; Logs_threaded.enable (); - Printexc.record_backtrace true; + Logs.set_reporter reporter; () end