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/dune-project b/dune-project index 163a239d..5bd4e1f1 100644 --- a/dune-project +++ b/dune-project @@ -41,5 +41,6 @@ jsont cohttp ptime + logs (ocamlformat :with-dev-setup) )) diff --git a/mte.opam b/mte.opam index 1c4d5904..8bdbc121 100644 --- a/mte.opam +++ b/mte.opam @@ -28,6 +28,7 @@ depends: [ "jsont" "cohttp" "ptime" + "logs" "ocamlformat" {with-dev-setup} "odoc" {with-doc} ] 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/dune b/src/dune index fb09a728..2a1a266a 100644 --- a/src/dune +++ b/src/dune @@ -24,7 +24,11 @@ fmt jsont cohttp - ptime)) + ptime + logs + logs.fmt + logs.threaded + fmt.tty)) (library ; crockford base32 (name b32) diff --git a/src/mte.ml b/src/mte.ml index b7b46b8a..8439cdb0 100644 --- a/src/mte.ml +++ b/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 . *) -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,18 +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 [ - 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 () = + 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 -> @@ -131,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 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/static.ml b/src/static.ml new file mode 100644 index 00000000..a69d2dc0 --- /dev/null +++ b/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 diff --git a/src/util.ml b/src/util.ml index 8d5d1f8b..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 @@ -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