swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

JJ: Description from the destination commit:

Browse source 
add static.ml

JJ: Description from source commit:
~
This commit is contained in:
swrup 2025-11-30 03:33:25 +01:00
parent 11a69c9404
commit b186dba251
11 changed files with 186 additions and 196 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.ocamlformat
View file

@ -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

3
src/amount.ml
View file

@ -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 =

26
src/assets.ml
View file

@ -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

14
src/config.ml
View file

@ -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

61
src/database.ml
View file

@ -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

14
src/devices.ml
View file

@ -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

101
src/mte.ml
View file

@ -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,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 () =
@ -120,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 ->
@ -133,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

48
src/parse_config.ml
View file

@ -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))

7
src/pg.ml
View file

@ -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) ->

83
src/static.ml Normal file
View file

@ -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

23
src/util.ml
View file

@ -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