Commit cc60f700 authored by Vlad Dumitru's avatar Vlad Dumitru
Browse files

code compiles, but at what cost?

parent bcf41a0c
......@@ -72,7 +72,7 @@ let info tg_path =
let versions ~db ~uuid =
let open Result.Monad_infix in
Speechcake.bucket db uuid
>>| Speechcake.Storage.Bucket.versions
>>| Speechcake.Storage.versions
......@@ -97,8 +97,8 @@ let identify_textgrid ~db ~textgrid =
| [parent] ->
let doc = Speechcake.get_at_version db (Uuidm.to_string uuid) parent in
let forbidden_branches =
Option.value_exn (Speechcake.Storage.bucket db.storage (Uuidm.to_string uuid))
|> Speechcake.Storage.Bucket.branches
Option.value_exn (Speechcake.Database.of_key db.db (Uuidm.to_string uuid))
|> Speechcake.Storage.tags
|> Hashtbl.keys in
name, Result.map doc ~f:(fun doc -> `Known (uuid, doc.key, parent, forbidden_branches))
| parents -> (* multiple parents means we're in a merging process *)
......@@ -125,7 +125,7 @@ let put ~db ~tiers ~tier_name ~key =
Error (`Unknown_tier tier_name)
let most_recent_version bkt versions =
List.map versions ~f:(fun v -> Result.map (Speechcake.Storage.Bucket.version bkt v) ~f:(fun d -> v, d))
List.map versions ~f:(fun v -> Result.map (Speechcake.Storage.get bkt v) ~f:(fun d -> v, d))
|> List.filter_map ~f:Result.ok
|> List.dedup_and_sort ~compare:(fun (_, (_, x)) (_, (_, y)) ->
let x = ISO8601.Permissive.datetime x.Storage.Metadata.date in
......@@ -133,8 +133,7 @@ let most_recent_version bkt versions =
Float.compare x y)
|> List.rev
|> List.hd_exn
|> fun (hash, (root, meta)) ->
let json = Speechcake.Storage.Bucket.to_json bkt root in
|> fun (hash, (json, meta)) ->
let doc = Speechcake.document_of_json json in
Result.map doc ~f:(fun doc -> hash, doc, meta)
......@@ -152,7 +151,7 @@ let update ~db ~tiers ~tier_name ~uuid ~branch =
begin match info with
| Fresh _name ->
Speechcake.get_latest db key
>>= fun (_, latest) ->
>>= fun (_, _, latest) ->
let doc = Speechcake.document
~key:latest.Speechcake.key ~tags:latest.tags tier in
Speechcake.put db key ~parents:[] ~tag:branch doc
......@@ -215,7 +214,7 @@ let list_tiers ?prefix ?tags db =
Fmt.(option ~none:(any "(none)") (list ~sep:(any "/") string)) prefix
Fmt.(option ~none:(any "(none)") (list ~sep:(any ",@ ") string)) (Option.map ~f:Set.to_list tags)) ;
let key_index =
Speechcake.Storage.list db.Speechcake.storage
Speechcake.Database.list db.Speechcake.db
|> List.map ~f:(fun uuid ->
Result.map (Speechcake.get_latest db uuid) ~f:(fun doc -> uuid, doc))
|> List.bind ~f:(function
......@@ -232,8 +231,8 @@ let list_tiers ?prefix ?tags db =
| Error (`Tag_not_found t) ->
Log.err (fun m -> m "tag not found: %s" t) ;
[]
| Error (`Not_a_version_block) ->
Log.err (fun m -> m "not a version block") ;
| Error (`Not_a_version_block h) ->
Log.err (fun m -> m "not a version block: %08Lx" h) ;
[]
| Error (`Block_not_found b) ->
Log.err (fun m -> m "block not found: %08Lx" b) ;
......@@ -242,11 +241,11 @@ let list_tiers ?prefix ?tags db =
match prefix with
| Some prefix ->
key_index
|> List.filter ~f:(fun doc -> has_prefix ~prefix (snd (snd doc)).Speechcake.key)
|> List.filter ~f:(fun doc -> has_one_of_tags ?tags (snd (snd doc)).Speechcake.tags)
|> List.filter ~f:(fun (_, (_, _, doc)) -> has_prefix ~prefix doc.Speechcake.key)
|> List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_tags ?tags doc.Speechcake.tags)
| None ->
key_index
|> List.filter ~f:(fun doc -> has_one_of_tags ?tags (snd (snd doc)).Speechcake.tags)
|> List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_tags ?tags doc.Speechcake.tags)
(*
......
......@@ -28,26 +28,24 @@ let encode_version_info { Speechcake.Storage.Metadata.author; comment; date; par
; "parents", `List (List.map parents ~f:(fun p -> `String (Fmt.str "%08Lx" p)))
]
let encode_version (hash, (head, info, branch_head)) =
let encode_version (hash, (info, branch_head)) =
match branch_head with
| Some branch_head ->
`Assoc
[ "id", `String (Fmt.str "%08Lx" hash)
; "root", `String (Fmt.str "%a" Speechcake.Storage.Bucket.pp_value head)
; "info", encode_version_info info
; "head", `String branch_head
]
| None ->
`Assoc
[ "id", `String (Fmt.str "%08Lx" hash)
; "root", `String (Fmt.str "%a" Speechcake.Storage.Bucket.pp_value head)
; "info", encode_version_info info
]
let encode_version_listing : (int64, (Speechcake.Storage.Bucket.value * Speechcake.Storage.Metadata.t * string option)) Hashtbl.t encoder =
let encode_version_listing : (int64, (Speechcake.Storage.Metadata.t * string option)) Hashtbl.t encoder =
fun versions ->
Hashtbl.to_alist versions
|> List.dedup_and_sort ~compare:(fun (_, (_, x, _)) (_, (_, y, _)) ->
|> List.dedup_and_sort ~compare:(fun (_, (x, _)) (_, (y, _)) ->
Storage.Metadata.compare_date x y)
|> List.rev
|> List.map ~f:encode_version
......@@ -127,15 +125,15 @@ let encode_tier_info =
[ "type", `String "error"
; "reason", `String (Fmt.str "decoding error: %s" (Decoders_yojson.Basic.Decode.string_of_error e))
]
| name, Error (`Missing_block h) ->
| name, Error (`Block_not_found h) ->
name, `Assoc
[ "type", `String "error"
; "reason", `String (Fmt.str "missing block: %08Lx" h)
]
| name, Error (`Not_a_version_block) ->
| name, Error (`Not_a_version_block h) ->
name, `Assoc
[ "type", `String "error"
; "reason", `String (Fmt.str "not a version block")
; "reason", `String (Fmt.str "not a version block: %08Lx" h)
]
| name, Error (`Missing_parent_info) ->
name, `Assoc
......
......@@ -3,7 +3,7 @@
(flags (:standard -cclib -static -cclib -no-pie))))
(executables
(names konditorei tort)
(names konditorei)
(libraries
core
dream
......
......@@ -33,7 +33,7 @@ let get_tiers db ?prefix request =
let tiers = Action.list_tiers ?prefix ?tags db in
let body =
tiers
|> List.map ~f:(fun (uuid, (_, doc)) -> uuid, doc.Speechcake.key, doc.Speechcake.tags)
|> List.map ~f:(fun (uuid, (_, _, doc)) -> uuid, doc.Speechcake.key, doc.Speechcake.tags)
|> C.encode_tier_listing
|> Yojson.Safe.to_string in
Dream.json body
......@@ -64,22 +64,13 @@ let list_branches db request =
let open Result.Monad_infix in
let uuid = Dream.param "uuid" request in
Speechcake.bucket db uuid
>>| Speechcake.Storage.Bucket.branches in
>>| Speechcake.Storage.tags in
match result with
| Ok branches ->
let body =
Hashtbl.to_alist branches
|> List.map ~f:(fun (name, (hash, (root, Speechcake.Storage.Metadata.{ author; date; comment; parents }))) ->
name, `Assoc
[ "id", `String (Fmt.str "%08Lx" hash)
; "root", `String (Fmt.str "%a" Speechcake.Storage.Bucket.pp_value root)
; "info", `Assoc
[ "author", `String author
; "date", `String date
; "comment", `String comment
; "parents", `List (List.map ~f:(fun p -> `String (Fmt.str "%08Lx" p)) parents)
]
])
|> List.map ~f:(fun (name, hash) ->
name, `String (Fmt.str "%08Lx" hash))
|> fun pairs -> `Assoc pairs
|> Yojson.Basic.to_string in
Dream.json body
......@@ -93,12 +84,12 @@ let get_tier db request =
let tag = Dream.param "tag" request in
Speechcake.bucket db uuid
>>= fun bucket ->
Ok (Hashtbl.to_alist (Speechcake.Storage.Bucket.versions bucket))
Ok (Hashtbl.to_alist (Speechcake.Storage.versions bucket))
>>= fun versions ->
Speechcake.get_tagged db uuid ~tag
>>| fun tagged -> uuid, versions, tagged in
match result with
| Ok (uuid, versions, (_, tagged)) ->
| Ok (uuid, versions, (_, _, tagged)) ->
let body =
`Assoc
[ "key", `List (List.map tagged.Speechcake.key ~f:(fun part -> `String part))
......@@ -115,8 +106,8 @@ let get_tier db request =
Dream.respond ~status:`Not_Found ("tag " ^ tag)
| Error (`Block_not_found h) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "block not found: %08Lx" h)
| Error (`Not_a_version_block) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "not a version block")
| Error (`Not_a_version_block h) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "not a version block: %08Lx" h)
| Error (`Decoding_error e) ->
Dream.respond ~status:`Bad_Request (Decoders_yojson.Basic.Decode.string_of_error e)
......@@ -153,8 +144,7 @@ let string_of_error = function
| `Unknown_version v -> Fmt.str "unknown version: %016Lx" v
| `Document_not_found u -> Fmt.str "document not found: %s" u
| `Decoding_error e -> Fmt.str "decoding error: %s" (Decoders_yojson.Basic.Decode.string_of_error e)
| `Missing_block h -> Fmt.str "missing block: %08Lx" h
| `Not_a_version_block -> Fmt.str "not a version block"
| `Not_a_version_block h -> Fmt.str "not a version block: %08Lx" h
| `Tag_not_found t -> Fmt.str "tag not found: %s" t
| `Block_not_found h -> Fmt.str "block not found: %08Lx" h
| `Conflict c -> Fmt.str "conflict: %s" c
......@@ -178,8 +168,7 @@ let json_of_error =
| `Unknown_version v -> obj [ "name", string "unknown version"; "which", string (Fmt.str "%016Lx" v) ]
| `Document_not_found u -> obj [ "name", string "document not found"; "which", string u ]
| `Decoding_error e -> obj [ "name", string "decoding error"; "reason", string (Decoders_yojson.Basic.Decode.string_of_error e) ]
| `Missing_block h -> obj [ "name", string "missing block"; "which", string (Fmt.str "%08Lx" h) ]
| `Not_a_version_block -> obj [ "name", string "not a version block" ]
| `Not_a_version_block h -> obj [ "name", string (Fmt.str "not a version block: %08Lx" h) ]
| `Tag_not_found t -> obj [ "name", string "tag not found"; "which", string t ]
| `Block_not_found h -> obj [ "name", string "block not found"; "which", string (Fmt.str "%08Lx" h) ]
| `Conflict c -> obj [ "name", string "conflict"; "reason", string c ]
......@@ -229,11 +218,11 @@ let set_key db request =
Uuidm.of_string uuid |> Result.of_option ~error:(`Invalid_UUID uuid)
>>= fun uuid ->
Speechcake.get_tagged db (Uuidm.to_string uuid) ~tag
>>= fun (parent, doc) ->
let doc' = { doc with key } in
>>= fun (parent_hash, _parent_meta, parent_doc) ->
let doc' = { parent_doc with key } in
let comment =
Fmt.(str "move from `%a`" (list ~sep:(any "/") string) doc.key) in
Speechcake.put ~parents:[parent] ~comment ~tag db (Uuidm.to_string uuid) doc'
Fmt.(str "move from `%a`" (list ~sep:(any "/") string) parent_doc.key) in
Speechcake.put ~parents:[parent_hash] ~comment ~tag db (Uuidm.to_string uuid) doc'
>>| fun version ->
Speechcake.update_key_index db.key_index key uuid ;
version
......@@ -254,10 +243,10 @@ let set_tags db request =
Uuidm.of_string uuid |> Result.of_option ~error:(`Invalid_UUID uuid)
>>= fun uuid ->
Speechcake.get_tagged db (Uuidm.to_string uuid) ~tag
>>= fun (parent, doc) ->
let doc' = { doc with tags } in
>>= fun (parent_hash, _parent_meta, parent_doc) ->
let doc' = { parent_doc with tags } in
let comment = "change tags" in
Speechcake.put ~parents:[parent] ~comment ~tag db (Uuidm.to_string uuid) doc'
Speechcake.put ~parents:[parent_hash] ~comment ~tag db (Uuidm.to_string uuid) doc'
>>| fun version ->
Speechcake.update_tag_index db.tag_index uuid tags ;
version
......@@ -346,18 +335,18 @@ let export_tier db request =
let tag = Dream.param "tag" request in
Speechcake.bucket db uuid
>>= fun bucket ->
Ok (Hashtbl.to_alist (Speechcake.Storage.Bucket.versions bucket))
Ok (Hashtbl.to_alist (Speechcake.Storage.versions bucket))
>>= fun versions ->
Speechcake.get_tagged db uuid ~tag
>>| fun latest -> uuid, versions, latest in
match result with
| Ok (uuid, _versions, (parent, latest)) ->
| Ok (uuid, _versions, (latest_hash, _latest_meta, latest_doc)) ->
let info =
Speechcake.Stamp.known
~uuid:(Option.value_exn (Uuidm.of_string uuid))
~parents:[parent]
(Annotation.Tier.name latest.data) in
let tier = Speechcake.stamp info latest.data in
~parents:[latest_hash]
(Annotation.Tier.name latest_doc.data) in
let tier = Speechcake.stamp info latest_doc.data in
let body =
Speechcake.Annotation.Textgrid.Write.to_string [ None, tier ] in
Dream.respond ~status:`OK body
......@@ -368,8 +357,8 @@ let export_tier db request =
Dream.respond ~status:`Not_Found ("tag " ^ tag)
| Error (`Block_not_found h) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "block not found: %08Lx" h)
| Error (`Not_a_version_block) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "not a version block")
| Error (`Not_a_version_block h) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "not a version block: %08Lx" h)
| Error (`Decoding_error e) ->
Dream.respond ~status:`Bad_Request (Decoders_yojson.Basic.Decode.string_of_error e)
......@@ -426,7 +415,7 @@ let run_server repo_path interface port =
; get "/css" (Dream.from_filesystem "assets" "style.css")
(* history *)
; get "/history" (get_history db)
; get "/history" (get_history db.Speechcake.db)
(* tier listing *)
; get "/tiers" (get_tiers db)
......
open Core
open Cmdliner
(*
environment params: DB_PATH
commands:
- extract <textgrid-path> <tier-name> -> <tier-as-json>
- persist <bucket> <json> -> <value>
- commit --author <author> --comment <comment> --tag <tag> <value> -> <version>
#!/bin/bash
JSON=$(tort extract 001M002M.TextGrid 001M)
VALUE=$(echo $JSON | tort persist 001M)
VERSION=$(tort commit "version one" --tag "latest" $VALUE)
*)
let src = Logs.Src.create "tort" ~doc:"tort events"
module Log = (val Logs.src_log src : Logs.LOG)
let terminal_cols ?default:(default=80) () =
let inp = Unix.open_process_in "tput cols" in
let lines = In_channel.input_lines inp in
match lines with
| [ line ] -> (try Int.of_string line with _ -> default)
| _ -> default
let actually_setup style_renderer log_level =
let cols = terminal_cols ~default:80 () in
Fmt_tty.setup_std_outputs ?style_renderer ~utf_8:true ();
Format.(pp_set_margin std_formatter cols);
Format.(pp_set_margin err_formatter cols);
Logs.set_level log_level;
`Ok ()
let setup =
let style_renderer =
let env = Arg.env_var "COLOR" in
Fmt_cli.style_renderer ~docs:Manpage.s_common_options ~env () in
let log_level =
let env = Arg.env_var "LOG_LEVEL" in
Logs_cli.level ~docs:Manpage.s_common_options ~env () in
Term.(ret (const actually_setup $ style_renderer $ log_level))
let bucket_of_file path =
match Sys.file_exists path with
| `Yes -> Yojson.Basic.from_file path |> Speechcake.Storage.Bucket.load
| _ -> Ok (Speechcake.Storage.Bucket.init ())
let tiers () path =
let contents = In_channel.read_all path in
let result =
let open Result.Monad_infix in
Speechcake.Annotation.Textgrid.Read.of_string contents
>>| fun tiers ->
List.map tiers ~f:Annotation.Tier.name
in
match result with
| Ok tiers ->
Fmt.(pr "%a@." (list ~sep:(any "@.") string)) tiers
| Error (`Parsing_error e) ->
Fmt.epr "parsing error: %s@." e
| Error (`Tier_not_found t) ->
Fmt.epr "tier not found: %s@." t
let extract () path name =
let contents = In_channel.read_all path in
let result =
let open Result.Monad_infix in
Speechcake.Annotation.Textgrid.Read.of_string contents
>>= fun tiers ->
List.find tiers
~f:(fun tier -> String.equal (Annotation.Tier.name tier) name)
|> Result.of_option ~error:(`Tier_not_found name)
in
match result with
| Ok tier ->
Fmt.pr "%s@." (Yojson.Basic.to_string (Annotation.Tier.to_json tier))
| Error (`Parsing_error e) ->
Fmt.epr "parsing error: %s@." e
| Error (`Tier_not_found t) ->
Fmt.epr "tier not found: %s@." t
let wrap () key tags =
let key = String.split key ~on:'/' in
let tags =
String.split tags ~on:','
|> Set.of_list (module String) in
let contents =
In_channel.input_all In_channel.stdin
|> Yojson.Basic.from_string
|> Decoders_yojson.Basic.Decode.decode_value Annotation.Tier.of_json in
match contents with
| Ok tier ->
let doc = Speechcake.document ~key ~tags tier in
Fmt.pr "%s@." (Yojson.Basic.to_string (Speechcake.document_to_json doc))
| Error e ->
Fmt.epr "decoding error: %s@." (Decoders_yojson.Basic.Decode.string_of_error e)
let persist () root key =
let data = In_channel.input_all In_channel.stdin in
match bucket_of_file (root ^ "/" ^ key) with
| Ok bucket ->
let value = Speechcake.Storage.Bucket.of_json bucket (Yojson.Basic.from_string data) in
Out_channel.write_all (root ^ "/" ^ key) ~data:(Yojson.Basic.to_string (Speechcake.Storage.Bucket.dump bucket)) ;
Fmt.pr "%s@." (Sexp.to_string (Speechcake.Storage.Bucket.sexp_of_value value))
| Error e ->
Fmt.epr "decoding error: %s@." (Decoders_yojson.Basic.Decode.string_of_error e)
let commit () root key value author comment =
let date = ISO8601.Permissive.string_of_datetime (Unix.gettimeofday ()) in
let info = Speechcake.Storage.Metadata.v ~author ~date ~comment () in
let value =
Sexp.of_string value
|> Speechcake.Storage.Bucket.value_of_sexp in
match bucket_of_file (root ^ "/" ^ key) with
| Ok bucket ->
let hash = Speechcake.Storage.Bucket.commit bucket value ~info in
Out_channel.write_all (root ^ "/" ^ key) ~data:(Yojson.Basic.to_string (Speechcake.Storage.Bucket.dump bucket)) ;
Fmt.pr "%08Lx@." hash
| Error e ->
Fmt.epr "decoding error: %s@." (Decoders_yojson.Basic.Decode.string_of_error e)
let tag () root key name hash =
let hash = Int64.of_string ("0x" ^ hash) in
match bucket_of_file (root ^ "/" ^ key) with
| Ok bucket ->
Speechcake.Storage.Bucket.tag bucket name hash ;
Out_channel.write_all (root ^ "/" ^ key) ~data:(Yojson.Basic.to_string (Speechcake.Storage.Bucket.dump bucket))
| Error e ->
Fmt.epr "decoding error: %s@." (Decoders_yojson.Basic.Decode.string_of_error e)
let default_t =
let open Term in
const (fun () -> Fmt.pr "no default action@.") $ setup, info ""
let uuid_t =
let open Term in
let action () =
let uuid = Uuidm.v `V4 in
Fmt.pr "%s@." (Uuidm.to_string uuid)
in
let doc = "Generate a random UUIDv4" in
( const action $ setup
, info ~doc "uuid"
)
let tiers_t =
let open Term in
let path =
let doc = "Path to the TextGrid file" in
Arg.(value & pos 0 string "" & info [] ~docv:"PATH" ~doc) in
let doc = "List the tiers from a TextGrid file" in
( const tiers $ setup $ path
, info ~doc "tiers"
)
let extract_t =
let open Term in
let path =
let doc = "Path to the TextGrid file" in
Arg.(value & pos 0 string "" & info [] ~docv:"PATH" ~doc) in
let name =
let doc = "Name of the tier" in
Arg.(value & pos 1 string "" & info [] ~docv:"NAME" ~doc) in
let doc = "Extract a tier from a TextGrid file" in
( const extract $ setup $ path $ name
, info ~doc "extract"
)
let wrap_t =
let open Term in
let key =
let doc = "Key of the destination bucket" in
Arg.(value & pos 0 string "" & info [] ~docv:"KEY" ~doc) in
let tags =
let doc = "Short identifiers (comma-separated)" in
Arg.(value & opt string "" & info [ "t"; "tags" ] ~docv:"TAGS" ~doc) in
let doc = "Wrap a tier into a document (adding metadata)" in
( const wrap $ setup $ key $ tags
, info ~doc "wrap"
)
let persist_t =
let open Term in
let root =
let doc = "The location of the Speechcake repository" in
let env = Arg.env_var "DB_ROOT" ~doc in
Arg.(value & opt string "/tmp" & info ["root"] ~env ~docv:"ROOT" ~doc) in
let key =
let doc = "Key of the destination bucket" in
Arg.(value & pos 0 string "" & info [] ~docv:"KEY" ~doc) in
let doc = "List the versions of a tier that are stored in the repository"
in
( const persist $ setup $ root $ key
, info ~doc "persist"
)
let commit_t =
let open Term in
let root =
let doc = "The location of the Speechcake repository" in
let env = Arg.env_var "DB_ROOT" ~doc in
Arg.(value & opt string "/tmp" & info ["root"] ~env ~docv:"ROOT" ~doc) in
let key =
let doc = "Key of the destination bucket" in
Arg.(value & pos 0 string "" & info [] ~docv:"KEY" ~doc) in
let value =
let doc = "Value to commit" in
Arg.(required & pos 1 (some string) None & info [] ~docv:"VALUE" ~doc) in
let author =
let doc = "Name of the author" in
Arg.(value & opt string "Anonymous" & info [ "a"; "author" ] ~docv:"AUTHOR" ~doc) in
let comment =
let doc = "Description of this version" in
Arg.(value & opt string "" & info [ "c"; "comment" ] ~docv:"COMMENT" ~doc) in
let doc = "Commit a value to the store" in
( const commit $ setup $ root $ key $ value $ author $ comment
, info ~doc "commit"
)
let tag_t =
let open Term in
let root =
let doc = "The location of the Speechcake repository" in
let env = Arg.env_var "DB_ROOT" ~doc in
Arg.(value & opt string "/tmp" & info ["root"] ~env ~docv:"ROOT" ~doc) in
let key =
let doc = "Key of the destination bucket" in
Arg.(value & pos 0 string "" & info [] ~docv:"KEY" ~doc) in
let name =
let doc = "Name of the tag" in
Arg.(required & pos 1 (some string) None & info [] ~docv:"NAME" ~doc) in
let hash =
let doc = "Version pointer" in
Arg.(required & pos 2 (some string) None & info [] ~docv:"HASH" ~doc) in
let doc = "Commit a value to the store" in
( const tag $ setup $ root $ key $ name $ hash
, info ~doc "tag"
)
let pp_header ppf (l, h) =
let pp_h ppf style h = Fmt.pf ppf "[%a]" Fmt.(styled style string) h in
match l with
| Logs.App ->
begin match h with
| None -> ()
| Some h -> Fmt.pf ppf "[%a] " Fmt.(styled `Magenta string) h
end
| Logs.Error ->
pp_h ppf `Red (match h with None -> "ERR" | Some h -> h)
| Logs.Warning ->
pp_h ppf `Yellow (match h with None -> "WRN" | Some h -> h)
| Logs.Info ->
pp_h ppf `Blue (match h with None -> "INF" | Some h -> h)
| Logs.Debug ->
pp_h ppf `Faint (match h with None -> "DBG" | Some h -> h)
let reporter ppf =
let report src level ~over k msgf =
let k _ = over () ; k () in
let with_metadata header _tags k ppf fmt =
Format.kfprintf k ppf
("@[<2>%a[%a] " ^^ fmt ^^ "@]\n%!")
pp_header (level, header)
Fmt.(styled `Magenta string)
(Logs.Src.name src)
in
msgf (fun ?header ?tags fmt -> with_metadata header tags k ppf fmt)
in
{ Logs.report }
let () =
Logs.set_reporter (reporter Fmt.stderr);
Term.exit @@
Term.eval_choice default_t
[ uuid_t
; tiers_t; extract_t
; wrap_t
; persist_t
; commit_t
; tag_t
]
open Core
open Cmdliner