JJ: Description from the destination commit:

print App logs to stdout

JJ: Description from source commit:
~

.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

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 =

src/assets.ml

@@ -1,8 +1,4 @@
-(* module to handle assets. for now, assets are defined to all be in
+(* TODO clean up *)
-   `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 *)
 
 (* 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", "plain"), ".txt");
-      (("text", "html"), ".html"); (("text", "html"), ".htm");
+      (("text", "markdown"), ".md");
-      (("application", "pdf"), ".pdf"); (("image", "jpeg"), ".jpg");
+      (("text", "html"), ".html");
-      (("image", "jpeg"), ".jpeg"); (("image", "png"), ".png");
+      (("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

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
+        fail "section `[currency-%s]` not found, currency `%s` is not defined"
-          (Fmt.str
+          Exchange.currency Exchange.currency
-             "section `[currency-%s]` not found, currency `%s` is not defined"
-             Exchange.currency Exchange.currency)
     | Some v -> (
         match v.enabled = `YES with
-        | false ->
+        | false -> fail "currency `%s` is not enabled" Exchange.currency
-            fail_with (Fmt.str "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

src/database.ml

@@ -2,36 +2,7 @@
    - GNU Taler db-events?
      it seems caqti/pgx does not support it *)
 
-let test req server _ =
+let on_ok req () =
-  let (module Conn : Caqti_miou.CONNECTION) =
-    Vif.Server.device Devices.db_connection server
-  in
-  let query =
-    let open Caqti_request.Infix in
-    Caqti_type.(unit ->! int) "SELECT 53 - 11"
-  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
-
-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"
@@ -40,9 +11,23 @@ let test_activate req server _ =
     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 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 db_conn = Vif.Server.device Devices.db_connection server in
+  let secmod_signkey = Vif.Server.device Devices.secmod_signkey server in
+  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

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
 

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 /?? nil) --> hello;
-    get (rel / "privacy" /?? nil) --> Static.privacy;
+    get_ (rel / "terms" /?? nil) --> Static.terms;
-    get (rel / "management" / "keys" /?? nil) --> Management.keys_get;
+    get_ (rel / "privacy" /?? nil) --> Static.privacy;
-    post any (rel / "management" / "keys" /?? nil) --> Management.keys_post;
+    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

src/parse_config.ml

@@ -15,9 +15,9 @@ type section = {
   items: item list;
 }
 
-let fail_with msg =
+let fail fmt =
-  Fmt.epr "Configuration failure: %s.@." msg;
+  let k _ppf = exit 1 in
-  exit 1
+  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
+        fail "ptime_span_of_int64 error: `%Ld` is not a valid ptime span" i
-          (Fmt.str "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
+  match a = b with false -> fail "unexpected value `%s`" b | true -> a
-  | false -> fail_with (Fmt.str "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
+              fail "invalid json key-value map, expected integer key, got `%s`"
-                (Fmt.str
+                k
-                   "invalid json key-value map, expected integer key, got `%s`"
-                   k)
           | Some k -> k
         in
         (k, v))

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;";
+         SERIALIZABLE;";
-        "SET enable_mergejoin=OFF;"; "SET search_path TO exchange;";
+        "SET enable_sort=OFF;";
+        "SET enable_seqscan=OFF;";
+        "SET enable_mergejoin=OFF;";
+        "SET search_path TO exchange;";
       ]
   in
   fun (module Conn : Caqti_miou.CONNECTION) ->

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.Src.set_level Logs.default level;
-    Logs.set_level ~all:false (Some Logs.Debug);
-    Logs.Src.set_level Logs.default (Some Logs.Debug);
     Logs_threaded.enable ();
-    Printexc.record_backtrace true;
+    Logs.set_reporter reporter;
     ()
 end