use logs + add static.ml + fmt

.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

dune-project

@@ -41,5 +41,6 @@
    jsont
    cohttp
    ptime
+   logs
   (ocamlformat :with-dev-setup)
    ))

mte.opam

@@ -28,6 +28,7 @@ depends: [
   "jsont"
   "cohttp"
   "ptime"
+  "logs"
   "ocamlformat" {with-dev-setup}
   "odoc" {with-doc}
 ]

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/dune

@@ -24,7 +24,11 @@
   fmt
   jsont
   cohttp
-  ptime))
+  ptime
+  logs
+  logs.fmt
+  logs.threaded
+  fmt.tty))
 
 (library ; crockford base32
  (name b32)

src/management.ml

@@ -99,7 +99,7 @@ let mk_future_keys_response (secmod_signkey : Secmod_signkey.t)
       signkey_secmod_public_key;
     }
 
-let keys req server _env =
+let keys_get req server _env =
   let open Vif.Response in
   let open Syntax in
   let secmod_signkey = Vif.Server.device Devices.secmod_signkey server in
@@ -113,6 +113,6 @@ let keys req server _env =
 let keys_post req _server _env =
   let open Vif.Response in
   let open Syntax in
-  let* () = with_string req "todo~~" in
+  let* () = with_string req {||} in
   let* () = add ~field:"content-type" "application/json" in
   respond `OK

src/mte.ml

@@ -13,90 +13,6 @@
     You should have received a copy of the GNU Affero General Public License
     along with this program.  If not, see <https://www.gnu.org/licenses/>. *)
 
-let error_detail ?hint _status =
-  let open Api in
-  let code = -1 in
-  let s = encode_exn ErrorDetail.jsont { code; hint } in
-  s
-
-module Respond_with = struct
-  open Vif.Response
-  open Syntax
-
-  let bad_request ?hint req =
-    let body = error_detail ?hint `Bad_request in
-    let* () = with_string ?compression:None req body in
-    respond `Bad_request
-
-  let not_modified () =
-    let* () = empty in
-    respond `Not_modified
-
-  let unsupported_media_type req =
-    let body =
-      error_detail ~hint:"no acceptable mimetype" `Unsupported_media_type
-    in
-    let* () = with_string ?compression:None req body in
-    let* () = add ~field:"accept" Headers.accept_header_value in
-    respond `Unsupported_media_type
-end
-
-(* TODO check for mathcing ETAG with a middleware instead? *)
-(* /terms + /privacy
-   - try to find a response with an acceptable mime-type
-   - pick the version in the most preferred language of the user
-   - apply compression if that is allowed by the client
-   - set ETAG header
-   - If it did not change, a "304 Not Modified" response will be returned
-   - A "Taler-Terms-Version" header is generated to indicate the legal version of the terms
-   - When returning a full response (not a "304 Not Modified"),
-     include a "Avail-Languages" header: a comma-separated list of the languages available *)
-module Static = struct
-  let f kind req _server _env =
-    let etag = Assets.etag kind in
-    let headers = Vif.Request.headers req in
-    let has_matching_etag =
-      match Vif.Headers.get headers "if-none-match" with
-      | None -> Ok false
-      | Some s ->
-          Headers_lib.Etag.parse s
-          |> Result.map (Headers_lib.Etag.evaluate etag)
-    in
-    match has_matching_etag with
-    | Error e -> Respond_with.bad_request ~hint:e req
-    | Ok true -> Respond_with.not_modified ()
-    | Ok false -> (
-        match Headers.select_mimetype headers with
-        | None -> Respond_with.unsupported_media_type req
-        | Some mime ->
-            let lang = Headers.select_language headers in
-            let compression = Headers.select_encoding headers in
-            let data = Assets.get_content ~mime ~lang kind in
-            (* -- *)
-            let open Vif.Response in
-            let open Syntax in
-            let* () = with_string ?compression req data in
-            let* () =
-              let etag_field_value = Headers_lib.Etag.to_field_value etag in
-              add ~field:"etag" etag_field_value
-            in
-            let* () =
-              (* todo: is it "taler-privacy-version" for /policy ? *)
-              add ~field:"taler-terms-version" Assets.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 mime in
-              add ~field:"content-type" content_type
-            in
-            respond `OK)
-
-  let terms = f Assets.Terms
-  let privacy = f Assets.Privacy
-end
-
 let hello req _server _env =
   let open Vif.Response in
   let open Syntax in
@@ -108,23 +24,24 @@ 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
   [
-    post any
+    get_ (rel /?? nil) --> hello;
-      (*(json_encoding Api.MasterSignatures.jsont)*)
+    get_ (rel / "terms" /?? nil) --> Static.terms;
-      (rel / "management" / "keys" /?? nil)
+    get_ (rel / "privacy" /?? nil) --> Static.privacy;
-    --> Management.keys_post; get (rel /?? nil) --> hello;
+    get_ (rel / "test" /?? nil) --> Database.test_activate;
-    get (rel / "terms" /?? nil) --> Static.terms;
+    get_ (rel / "management" / "keys" /?? nil) --> Management.keys_get;
-    get (rel / "privacy" /?? nil) --> Static.privacy;
+    post (rel / "management" / "keys" /?? nil) any --> Management.keys_post;
-    get (rel / "management" / "keys" /?? nil) --> Management.keys;
-    get (rel / "db_test" /?? nil) --> Database.test;
-    get (rel / "db_activate" /?? nil) --> Database.test_activate;
   ]
 
 let () =
+  Util.Log_reporter.setup ();
   let cfg =
     let port = Config.Exchange.port in
     let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, port)) in
-    Vif.config sockaddr
+    Vif.config ~reporter:Util.Log_reporter.reporter sockaddr
   in
   Miou_unix.run @@ fun () ->
   Caqti_miou.Switch.run @@ fun caqti_switch ->
@@ -136,4 +53,6 @@ let () =
       [ Devices.db_connection; Devices.secmod_signkey; Devices.secmod_denom ]
   in
   let middlewares = Vif.Middlewares.[] in
+  Logs.info (fun m ->
+      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/static.ml

@@ -0,0 +1,83 @@
+(* TODO check for mathcing ETAG with a middleware instead? *)
+(* /terms + /privacy
+   - try to find a response with an acceptable mime-type
+   - pick the version in the most preferred language of the user
+   - apply compression if that is allowed by the client
+   - set ETAG header
+   - If it did not change, a "304 Not Modified" response will be returned
+   - A "Taler-Terms-Version" header is generated to indicate the legal version of the terms
+   - When returning a full response (not a "304 Not Modified"),
+     include a "Avail-Languages" header: a comma-separated list of the languages available *)
+
+module Respond_with = struct
+  open Vif.Response
+  open Syntax
+
+  open struct
+    let error_detail ?hint _status =
+      let open Api in
+      let code = -1 in
+      let s = encode_exn ErrorDetail.jsont { code; hint } in
+      s
+  end
+
+  let bad_request ?hint req =
+    let body = error_detail ?hint `Bad_request in
+    let* () = with_string ?compression:None req body in
+    respond `Bad_request
+
+  let not_modified () =
+    let* () = empty in
+    respond `Not_modified
+
+  let unsupported_media_type req =
+    let body =
+      error_detail ~hint:"no acceptable mimetype" `Unsupported_media_type
+    in
+    let* () = with_string ?compression:None req body in
+    let* () = add ~field:"accept" Headers.accept_header_value in
+    respond `Unsupported_media_type
+end
+
+let aux kind req _server _env =
+  let etag = Assets.etag kind in
+  let headers = Vif.Request.headers req in
+  let has_matching_etag =
+    match Vif.Headers.get headers "if-none-match" with
+    | None -> Ok false
+    | Some s ->
+        Headers_lib.Etag.parse s |> Result.map (Headers_lib.Etag.evaluate etag)
+  in
+  match has_matching_etag with
+  | Error e -> Respond_with.bad_request ~hint:e req
+  | Ok true -> Respond_with.not_modified ()
+  | Ok false -> (
+      match Headers.select_mimetype headers with
+      | None -> Respond_with.unsupported_media_type req
+      | Some mime ->
+          let lang = Headers.select_language headers in
+          let compression = Headers.select_encoding headers in
+          let data = Assets.get_content ~mime ~lang kind in
+          (* -- *)
+          let open Vif.Response in
+          let open Syntax in
+          let* () = with_string ?compression req data in
+          let* () =
+            let etag_field_value = Headers_lib.Etag.to_field_value etag in
+            add ~field:"etag" etag_field_value
+          in
+          let* () =
+            (* todo: is it "taler-privacy-version" for /policy ? *)
+            add ~field:"taler-terms-version" Assets.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 mime in
+            add ~field:"content-type" content_type
+          in
+          respond `OK)
+
+let terms req _server _env = aux Assets.Terms req _server _env
+let privacy req _server _env = aux Assets.Privacy req _server _env

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
@@ -114,3 +112,66 @@ module Bin_rsa = struct
     | Error (`Msg e) -> Fmt.failwith "rsa priv_of_octets failure: %s@." e
     | Ok v -> v
 end
+
+module Log_reporter = struct
+  let detail_tag : string Logs.Tag.def =
+    Logs.Tag.def "Detail tag" ~doc:"" Fmt.string
+
+  let detail s = Logs.Tag.(empty |> add detail_tag s)
+  let time_anchor = Ptime_clock.now () |> Ptime.to_span
+
+  let color_of_log_level = function
+    | Logs.App -> `White
+    | Error -> `Red
+    | Warning -> `Yellow
+    | Info -> `Blue
+    | Debug -> `Magenta
+
+  let reporter : Logs.reporter =
+    let open Fmt in
+    let pp_timestamp = styled `Faint (styled (`Fg `White) (fmt "%04.02f")) in
+    let pp_header ppf v =
+      let color = color_of_log_level (fst v) in
+      let pp = styled (`Fg color) Logs.pp_header in
+      pf ppf "%a" pp v
+    in
+    let pp_src_name =
+      let pp = using Logs.Src.name (styled `Cyan (fmt "%s: ")) in
+      fun ppf v -> if not @@ Logs.Src.equal Logs.default v then pp ppf v
+    in
+    let pp_detail = option (styled `Green (fmt " (%s)")) in
+    let report src lvl ~over k msgf =
+      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
+        let timestamp =
+          Ptime.sub_span (Ptime_clock.now ()) time_anchor
+          |> Option.map Ptime.to_float_s
+          |> Option.value ~default:0.
+        in
+        let k ppf = kpf k ppf "%a@." pp_detail detail in
+        let k ppf = kpf k ppf user_fmt in
+        kpf k ppf "%a %a %a" pp_timestamp timestamp pp_header (lvl, h)
+          pp_src_name src
+      in
+      msgf @@ fun ?header ?tags fmt -> with_detail header tags k fmt
+    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.Src.set_level Logs.default level;
+    Logs_threaded.enable ();
+    Logs.set_reporter reporter;
+    ()
+end