This commit is contained in:
parent
aa2ff7b2f0
commit
2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
10
unikernel/duniverse/logs/.gitignore
vendored
Normal file
10
unikernel/duniverse/logs/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
_b0
|
||||
_build
|
||||
tmp
|
||||
*~
|
||||
\.\#*
|
||||
\#*#
|
||||
*.native
|
||||
*.byte
|
||||
*.html
|
||||
*.install
|
||||
4
unikernel/duniverse/logs/.merlin
Normal file
4
unikernel/duniverse/logs/.merlin
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
PKG b0.kit fmt fmt.tty fmt.cli js_of_ocaml-compiler.runtime mtime.clock lwt
|
||||
S src
|
||||
S test
|
||||
B _b0/**
|
||||
128
unikernel/duniverse/logs/B0.ml
Normal file
128
unikernel/duniverse/logs/B0.ml
Normal file
|
|
@ -0,0 +1,128 @@
|
|||
open B0_kit.V000
|
||||
|
||||
(* OCaml library names *)
|
||||
|
||||
let b0_std = B0_ocaml.libname "b0.std"
|
||||
|
||||
let compiler_libs_toplevel = B0_ocaml.libname "compiler-libs.toplevel"
|
||||
let mtime = B0_ocaml.libname "mtime"
|
||||
let mtime_clock = B0_ocaml.libname "mtime.clock"
|
||||
let unix = B0_ocaml.libname "unix"
|
||||
let threads = B0_ocaml.libname "threads.posix"
|
||||
let cmdliner = B0_ocaml.libname "cmdliner"
|
||||
let fmt = B0_ocaml.libname "fmt"
|
||||
let fmt_tty = B0_ocaml.libname "fmt.tty"
|
||||
let fmt_cli = B0_ocaml.libname "fmt.cli"
|
||||
let lwt = B0_ocaml.libname "lwt"
|
||||
let lwt_unix = B0_ocaml.libname "lwt.unix"
|
||||
let js_of_ocaml_compiler_runtime =
|
||||
B0_ocaml.libname "js_of_ocaml-compiler.runtime"
|
||||
|
||||
let logs = B0_ocaml.libname "logs"
|
||||
let logs_fmt = B0_ocaml.libname "logs.fmt"
|
||||
let logs_browser = B0_ocaml.libname "logs.browser"
|
||||
let logs_cli = B0_ocaml.libname "logs.cli"
|
||||
let logs_lwt = B0_ocaml.libname "logs.lwt"
|
||||
let logs_threaded = B0_ocaml.libname "logs.threaded"
|
||||
let logs_top = B0_ocaml.libname "logs.top"
|
||||
|
||||
(* Libraries *)
|
||||
|
||||
let logs_lib =
|
||||
B0_ocaml.lib logs ~srcs:[`Dir ~/"src"] ~requires:[]
|
||||
|
||||
let logs_fmt_lib =
|
||||
let srcs = [`Dir ~/"src/fmt"] in
|
||||
B0_ocaml.lib logs_fmt ~srcs ~requires:[logs; fmt] ~exports:[logs]
|
||||
|
||||
let logs_browser_lib =
|
||||
let srcs = [`Dir ~/"src/browser"] in
|
||||
let requires = [logs; js_of_ocaml_compiler_runtime] in
|
||||
B0_ocaml.lib logs_browser ~srcs ~requires ~exports:[logs]
|
||||
|
||||
let logs_threaded_lib =
|
||||
let srcs = [`Dir ~/"src/threaded"] in
|
||||
B0_ocaml.lib logs_threaded ~srcs ~requires:[logs; threads] ~exports:[logs]
|
||||
|
||||
let logs_cli_lib =
|
||||
let srcs = [`Dir ~/"src/cli"] in
|
||||
B0_ocaml.lib logs_cli ~srcs ~requires:[logs; cmdliner] ~exports:[logs]
|
||||
|
||||
let logs_lwt_lib =
|
||||
let srcs = [`Dir ~/"src/lwt"] in
|
||||
B0_ocaml.lib logs_lwt ~srcs ~requires:[logs; lwt] ~exports:[logs]
|
||||
|
||||
let logs_top_lib =
|
||||
let srcs = [`Dir ~/"src/top"] in
|
||||
B0_ocaml.lib logs_top ~srcs ~requires:[logs; compiler_libs_toplevel]
|
||||
|
||||
(* Tests *)
|
||||
|
||||
let test ?(requires = []) = B0_ocaml.test ~requires:(logs :: requires)
|
||||
|
||||
let test_fmt =
|
||||
let requires = [fmt_tty; logs_fmt] in
|
||||
test ~/"test/test_fmt.ml" ~requires ~run:false (* exits with 1. *)
|
||||
|
||||
let test_formatter =
|
||||
test ~/"test/test_formatter.ml" ~run:false (* exits with 1. *)
|
||||
|
||||
let test_tool =
|
||||
let requires = [logs_fmt; logs_cli; fmt_cli; fmt_tty; cmdliner] in
|
||||
test ~/"test/tool.ml" ~requires ~run:false (* exits with 1 *)
|
||||
|
||||
let test_tags =
|
||||
test ~/"test/tags.ml" ~requires:[mtime; mtime_clock]
|
||||
|
||||
let test_multi =
|
||||
test ~/"test/test_multi.ml" ~requires:[logs; logs_fmt; fmt_tty]
|
||||
|
||||
let test_threaded =
|
||||
test ~/"test/test_threaded.ml" ~requires:[logs_fmt; logs_threaded; threads]
|
||||
|
||||
let test_lwt =
|
||||
let requires = [b0_std; logs_fmt; logs_lwt; fmt; fmt_tty; lwt; lwt_unix] in
|
||||
test ~/"test/test_lwt.ml" ~requires
|
||||
|
||||
let test_count = test ~/"test/test_count.ml" ~requires:[b0_std]
|
||||
|
||||
(* Packs *)
|
||||
|
||||
let default =
|
||||
let meta =
|
||||
B0_meta.empty
|
||||
|> ~~ B0_meta.authors ["The logs programmers"]
|
||||
|> ~~ B0_meta.maintainers ["Daniel Bünzli <daniel.buenzl i@erratique.ch>"]
|
||||
|> ~~ B0_meta.homepage "https://erratique.ch/software/logs"
|
||||
|> ~~ B0_meta.online_doc "https://erratique.ch/software/logs/doc"
|
||||
|> ~~ B0_meta.licenses ["ISC"]
|
||||
|> ~~ B0_meta.repo "git+https://erratique.ch/repos/logs.git"
|
||||
|> ~~ B0_meta.issues "https://github.com/dbuenzli/logs/issues"
|
||||
|> ~~ B0_meta.description_tags ["log"; "system"; "org:erratique"; ]
|
||||
|> B0_meta.tag B0_opam.tag
|
||||
|> ~~ B0_opam.build
|
||||
{|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"
|
||||
"--with-js_of_ocaml-compiler" "%{js_of_ocaml-compiler:installed}%"
|
||||
"--with-fmt" "%{fmt:installed}%"
|
||||
"--with-cmdliner" "%{cmdliner:installed}%"
|
||||
"--with-lwt" "%{lwt:installed}%"
|
||||
"--with-base-threads" "%{base-threads:installed}%"]]|}
|
||||
|> ~~ B0_opam.depopts
|
||||
["cmdliner", "";
|
||||
"js_of_ocaml-compiler", "";
|
||||
"fmt", "";
|
||||
"lwt", "";
|
||||
"base-threads", ""]
|
||||
|> B0_meta.add B0_opam.conflicts [
|
||||
"cmdliner", {|< "1.3.0"|};
|
||||
"js_of_ocaml-compiler", {|< "5.5.0"|};
|
||||
"fmt", {|< "0.9.0"|}; ]
|
||||
|> ~~ B0_opam.depends
|
||||
[ "ocaml", {|>= "4.14.0"|};
|
||||
"ocamlfind", {|build|};
|
||||
"ocamlbuild", {|build|};
|
||||
"topkg", {|build & >= "1.0.3"|};
|
||||
"mtime", {|with-test|};]
|
||||
in
|
||||
B0_pack.make "default" ~doc:"logs package" ~meta ~locked:true @@
|
||||
B0_unit.list ()
|
||||
1
unikernel/duniverse/logs/BRZO
Normal file
1
unikernel/duniverse/logs/BRZO
Normal file
|
|
@ -0,0 +1 @@
|
|||
(srcs-x tmp pkg)
|
||||
101
unikernel/duniverse/logs/CHANGES.md
Normal file
101
unikernel/duniverse/logs/CHANGES.md
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
v0.9.0 2025-07-08 Zagreb
|
||||
------------------------
|
||||
|
||||
* Replace references and mutable fields by atomic references to avoid
|
||||
race conditions (#56). Thanks to Nathan Taylor for reporting.
|
||||
* Fix `Logs.{err,warn}_count`. The counts were counting the reports
|
||||
not the logs which is not what the spec says. This means the counts
|
||||
were wrong when the reporting level was below the corresponding
|
||||
level (#55). Thanks to Mathieu Barbin for the report.
|
||||
* Fix `Log.Tag.list` always returning the empty list.
|
||||
* `Logs.format_reporter` and `Logs_fmt.reporter` replace a few format
|
||||
strings and `^^` uses by direct calls to `Format` primitives.
|
||||
* Requires OCaml >= 4.14.
|
||||
* Use Format.pp_print_text instead of your own.
|
||||
* Export `logs` from each sub library.
|
||||
|
||||
v0.8.0 2025-03-10 La Forclaz (VS)
|
||||
---------------------------------
|
||||
|
||||
* Install one library per directory (#48). Thanks to @mefyl
|
||||
for the suggestion.
|
||||
* Requires OCaml >= 4.08, Cmdliner >= 1.3.0, Fmt >= 0.9.0
|
||||
and js_of_ocaml-compiler >= 5.5.0
|
||||
* Depend on the `js_of_ocaml-compiler.runtime` library rather than
|
||||
`js_of_ocaml`.
|
||||
* Handle `cmdliner` deprecations.
|
||||
|
||||
v0.7.0 2019-08-09 Zagreb
|
||||
------------------------
|
||||
|
||||
Support for thread safe logging, thanks to Jules Aguillon for the
|
||||
work.
|
||||
|
||||
* Add `Logs.set_reporter_mutex` for installing mutual exclusion
|
||||
primitives to access the reporter.
|
||||
* Add `Logs_threaded.enable` to install mutual exclusion
|
||||
primitives for OCaml threads.
|
||||
|
||||
v0.6.3 2019-04-19 La Forclaz (VS)
|
||||
---------------------------------
|
||||
|
||||
* Make the package compatible with `js_of_ocaml` 3.3.0's
|
||||
namespacing. Thanks to Hugo Heuzard for the patch.
|
||||
* Fix toplevel initialisation for `Omod` (#21).
|
||||
* Fix 4.08 `Pervasives` deprecation.
|
||||
* Drop support for ocaml < 4.03.0
|
||||
* Doc: various improvements and typo fixing.
|
||||
|
||||
v0.6.2 2016-08-10 Zagreb
|
||||
------------------------
|
||||
|
||||
* 4.04.0 compatibility. Thanks to Damien Doligez for the patch.
|
||||
|
||||
|
||||
v0.6.1 2016-06-08 Cambridge (UK)
|
||||
--------------------------------
|
||||
|
||||
* Fix logs.top package on case sensitive file systems.
|
||||
|
||||
v0.6.0 2016-05-23 La Forclaz (VS)
|
||||
---------------------------------
|
||||
|
||||
* Build depend on topkg.
|
||||
* Relicensed from BSD3 to ISC.
|
||||
* Revise the command line interface provided by `Logs_cli`. Removes
|
||||
the argument from option `-v`. See issue #13 for details.
|
||||
* Add `Logs.format_reporter` a reporter like `Logs_fmt.reporter`
|
||||
but without colors and hence without the dependency on `Fmt`.
|
||||
Thanks to Simon Cruanes for the suggestion.
|
||||
* `Logs_fmt.reporter`, the optional argument `prefix` is changed to
|
||||
`pp_header` and becomes a formatter. The default prefix now favors
|
||||
the basename of `Sys.argv.(0)` if it exists over
|
||||
`Sys.executable_name`; this gives better results for interpreted
|
||||
programs.
|
||||
* Fix colors in `Logs_fmt.pp_header`, only `Logs.err_style` was
|
||||
being used.
|
||||
* Add `Logs.level_{of,to}_string`.
|
||||
|
||||
|
||||
v0.5.0 2016-01-07 La Forclaz (VS)
|
||||
---------------------------------
|
||||
|
||||
* Support for OCaml 4.01.0
|
||||
* Change the logging structure from `Logs.err fmt (fun m -> m ...)`
|
||||
to `Logs.err (fun m -> m fmt ...)`. See the documentation basics
|
||||
for more details. Thanks to Edwin Török for suggesting this.
|
||||
* Remove the `Logs.unit[_msgf]` functions, they are no longer needed.
|
||||
* Rename the `Logs_stdo` library to `Logs_fmt`.
|
||||
* Changes the signature of reporters to take a callback function to
|
||||
call unconditionally once the report is over. Thanks to Edwin Török
|
||||
for suggesting the mecanism.
|
||||
* Add the optional `Logs_lwt` library. Provides logging functions
|
||||
returning `lwt` threads that proceed only once the report is over.
|
||||
* Add `Logs_fmt.pp_header` and `Logs_fmt.{err_warn,info_debug}_style`.
|
||||
* Add `Logs.pp_{level,header}`.
|
||||
|
||||
|
||||
v0.4.2 2015-12-03 Cambridge (UK)
|
||||
--------------------------------
|
||||
|
||||
First release.
|
||||
6
unikernel/duniverse/logs/DEVEL.md
Normal file
6
unikernel/duniverse/logs/DEVEL.md
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
This project uses (perhaps the development version of) [`b0`] for
|
||||
development. Consult [b0 occasionally] for quick hints on how to
|
||||
perform common development tasks.
|
||||
|
||||
[`b0`]: https://erratique.ch/software/b0
|
||||
[b0 occasionally]: https://erratique.ch/software/b0/doc/occasionally.html
|
||||
13
unikernel/duniverse/logs/LICENSE.md
Normal file
13
unikernel/duniverse/logs/LICENSE.md
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
Copyright (c) 2016 The logs programmers
|
||||
|
||||
Permission to use, copy, modify, and/or distribute this software for any
|
||||
purpose with or without fee is hereby granted, provided that the above
|
||||
copyright notice and this permission notice appear in all copies.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
||||
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
||||
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
||||
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
||||
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
||||
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
||||
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
||||
51
unikernel/duniverse/logs/README.md
Normal file
51
unikernel/duniverse/logs/README.md
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
Logs — Logging infrastructure for OCaml
|
||||
=======================================
|
||||
|
||||
Logs provides a logging infrastructure for OCaml. Logging is performed
|
||||
on sources whose reporting level can be set independently. Log message
|
||||
report is decoupled from logging and is handled by a reporter.
|
||||
|
||||
A few optional log reporters are distributed with the base library and
|
||||
the API easily allows to implement your own.
|
||||
|
||||
`Logs` has no dependencies. The optional `Logs_fmt` reporter on OCaml
|
||||
formatters depends on [Fmt][fmt]. The optional `Logs_browser`
|
||||
reporter that reports to the web browser console depends on
|
||||
[js_of_ocaml][jsoo]. The optional `Logs_cli` library that provides
|
||||
command line support for controlling Logs depends on
|
||||
[`Cmdliner`][cmdliner]. The optional `Logs_lwt` library that provides
|
||||
Lwt logging functions depends on [`Lwt`][lwt]
|
||||
|
||||
Logs and its reporters are distributed under the ISC license.
|
||||
|
||||
[fmt]: http://erratique.ch/software/fmt
|
||||
[jsoo]: http://ocsigen.org/js_of_ocaml/
|
||||
[cmdliner]: http://erratique.ch/software/cmdliner
|
||||
[lwt]: http://ocsigen.org/lwt/
|
||||
|
||||
Home page: <http://erratique.ch/software/logs>
|
||||
|
||||
## Installation
|
||||
|
||||
Logs can be installed with `opam`:
|
||||
|
||||
opam install logs
|
||||
opam install fmt cmdliner lwt js_of_ocaml logs # Install all opt libraries
|
||||
|
||||
If you don't use `opam` consult the [`opam`](opam) file for build
|
||||
instructions.
|
||||
|
||||
## Documentation
|
||||
|
||||
The documentation can be consulted [online][doc] or via `odig doc logs`.
|
||||
|
||||
Questions are welcome but better asked on the [OCaml forum][ocaml-forum]
|
||||
than on the issue tracker.
|
||||
|
||||
[doc]: https://erratique.ch/software/logs/doc
|
||||
[ocaml-forum]: https://discuss.ocaml.org/
|
||||
|
||||
## Sample programs
|
||||
|
||||
A few tests can be found in the [`test`](test/) directory.
|
||||
|
||||
9
unikernel/duniverse/logs/_tags
Normal file
9
unikernel/duniverse/logs/_tags
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
true : bin_annot, safe_string
|
||||
<_b0> : -traverse
|
||||
<src> : include
|
||||
<src/fmt/logs_fmt*> : package(fmt)
|
||||
<src/browser/logs_browser*> : package(js_of_ocaml-compiler.runtime)
|
||||
<src/cli/logs_cli*> : package(cmdliner)
|
||||
<src/lwt/logs_lwt*> : package(lwt)
|
||||
<src/top/logs_top*> : package(compiler-libs.toplevel)
|
||||
<src/threaded/logs_threaded*> : thread, package(threads)
|
||||
26
unikernel/duniverse/logs/doc/index.mld
Normal file
26
unikernel/duniverse/logs/doc/index.mld
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
{0 Logs {%html: <span class="version">v0.9.0+dune2</span>%}}
|
||||
|
||||
Logs provides a logging infrastructure.
|
||||
|
||||
Logging is performed on sources whose reporting level can be set
|
||||
independently. Log message report is decoupled from logging and is
|
||||
handled by a reporter. A few optional log reporters are distributed
|
||||
with the package and the API easily allows to implement your own.
|
||||
|
||||
See the {{!Logs.basics}basics}.
|
||||
|
||||
{1:library_logs Library [logs]}
|
||||
|
||||
{!modules: Logs}
|
||||
|
||||
{1:libraries Libraries [logs.{browser,cli,fmt,lwt,threaded}]}
|
||||
|
||||
Each of these modules lives in its own library.
|
||||
|
||||
{!modules:
|
||||
Logs_browser
|
||||
Logs_cli
|
||||
Logs_fmt
|
||||
Logs_lwt
|
||||
Logs_threaded
|
||||
}
|
||||
3
unikernel/duniverse/logs/dune-project
Normal file
3
unikernel/duniverse/logs/dune-project
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
(lang dune 1.0)
|
||||
(name logs)
|
||||
(version v0.9.0+dune2)
|
||||
54
unikernel/duniverse/logs/logs.opam
Normal file
54
unikernel/duniverse/logs/logs.opam
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
version: "0.9.0+dune2"
|
||||
opam-version: "2.0"
|
||||
name: "logs"
|
||||
synopsis: "Logging infrastructure for OCaml"
|
||||
description: """\
|
||||
Logs provides a logging infrastructure for OCaml. Logging is performed
|
||||
on sources whose reporting level can be set independently. Log message
|
||||
report is decoupled from logging and is handled by a reporter.
|
||||
|
||||
A few optional log reporters are distributed with the base library and
|
||||
the API easily allows to implement your own.
|
||||
|
||||
`Logs` has no dependencies. The optional `Logs_fmt` reporter on OCaml
|
||||
formatters depends on [Fmt][fmt]. The optional `Logs_browser`
|
||||
reporter that reports to the web browser console depends on
|
||||
[js_of_ocaml][jsoo]. The optional `Logs_cli` library that provides
|
||||
command line support for controlling Logs depends on
|
||||
[`Cmdliner`][cmdliner]. The optional `Logs_lwt` library that provides
|
||||
Lwt logging functions depends on [`Lwt`][lwt]
|
||||
|
||||
Logs and its reporters are distributed under the ISC license.
|
||||
|
||||
[fmt]: http://erratique.ch/software/fmt
|
||||
[jsoo]: http://ocsigen.org/js_of_ocaml/
|
||||
[cmdliner]: http://erratique.ch/software/cmdliner
|
||||
[lwt]: http://ocsigen.org/lwt/
|
||||
|
||||
Home page: <http://erratique.ch/software/logs>"""
|
||||
maintainer: "Daniel Bünzli <daniel.buenzl i@erratique.ch>"
|
||||
authors: "The logs programmers"
|
||||
license: "ISC"
|
||||
tags: ["log" "system" "org:erratique"]
|
||||
homepage: "https://erratique.ch/software/logs"
|
||||
doc: "https://erratique.ch/software/logs/doc"
|
||||
bug-reports: "https://github.com/dbuenzli/logs/issues"
|
||||
depends: [
|
||||
"ocaml" {>= "4.14.0"}
|
||||
"lwt"
|
||||
"fmt" {>= "0.9.0"}
|
||||
"cmdliner" {>= "1.3.0"}
|
||||
"dune"
|
||||
"mtime" {with-test}
|
||||
]
|
||||
depopts: [
|
||||
"js_of_ocaml"
|
||||
]
|
||||
conflicts: [
|
||||
"js_of_ocaml-compiler" {< "5.5.0"}
|
||||
]
|
||||
build: [[ "dune" "build" "-p" name ]]
|
||||
dev-repo: "git+https://github.com/dune-universe/logs.git"
|
||||
url {
|
||||
src: "git://github.com/dune-universe/logs.git#duniverse-v0.9.0"
|
||||
}
|
||||
85
unikernel/duniverse/logs/pkg/META
Normal file
85
unikernel/duniverse/logs/pkg/META
Normal file
|
|
@ -0,0 +1,85 @@
|
|||
description = "Logging infrastructure for OCaml"
|
||||
version = "0.9.0+dune2"
|
||||
requires = ""
|
||||
archive(byte) = "logs.cma"
|
||||
archive(native) = "logs.cmxa"
|
||||
plugin(byte) = "logs.cma"
|
||||
plugin(native) = "logs.cmxs"
|
||||
exists_if = "logs.cma logs.cmxa"
|
||||
|
||||
package "browser" (
|
||||
directory = "browser"
|
||||
description = "The logs.browser library"
|
||||
version = "0.9.0+dune2"
|
||||
requires = "logs js_of_ocaml-compiler.runtime"
|
||||
exports = "logs"
|
||||
archive(byte) = "logs_browser.cma"
|
||||
archive(native) = "logs_browser.cmxa"
|
||||
plugin(byte) = "logs_browser.cma"
|
||||
plugin(native) = "logs_browser.cmxs"
|
||||
exists_if = "logs_browser.cma logs_browser.cmxa"
|
||||
)
|
||||
|
||||
package "cli" (
|
||||
directory = "cli"
|
||||
description = "The logs.cli library"
|
||||
version = "0.9.0+dune2"
|
||||
requires = "logs cmdliner"
|
||||
exports = "logs"
|
||||
archive(byte) = "logs_cli.cma"
|
||||
archive(native) = "logs_cli.cmxa"
|
||||
plugin(byte) = "logs_cli.cma"
|
||||
plugin(native) = "logs_cli.cmxs"
|
||||
exists_if = "logs_cli.cma logs_cli.cmxa"
|
||||
)
|
||||
|
||||
package "fmt" (
|
||||
directory = "fmt"
|
||||
description = "The logs.fmt library"
|
||||
version = "0.9.0+dune2"
|
||||
requires = "logs fmt"
|
||||
exports = "logs"
|
||||
archive(byte) = "logs_fmt.cma"
|
||||
archive(native) = "logs_fmt.cmxa"
|
||||
plugin(byte) = "logs_fmt.cma"
|
||||
plugin(native) = "logs_fmt.cmxs"
|
||||
exists_if = "logs_fmt.cma logs_fmt.cmxa"
|
||||
)
|
||||
|
||||
package "lwt" (
|
||||
directory = "lwt"
|
||||
description = "The logs.lwt library"
|
||||
version = "0.9.0+dune2"
|
||||
requires = "logs lwt"
|
||||
exports = "logs"
|
||||
archive(byte) = "logs_lwt.cma"
|
||||
archive(native) = "logs_lwt.cmxa"
|
||||
plugin(byte) = "logs_lwt.cma"
|
||||
plugin(native) = "logs_lwt.cmxs"
|
||||
exists_if = "logs_lwt.cma logs_lwt.cmxa"
|
||||
)
|
||||
|
||||
package "threaded" (
|
||||
directory = "threaded"
|
||||
description = "The logs.threaded library"
|
||||
version = "0.9.0+dune2"
|
||||
requires = "logs threads.posix"
|
||||
exports = "logs"
|
||||
archive(byte) = "logs_threaded.cma"
|
||||
archive(native) = "logs_threaded.cmxa"
|
||||
plugin(byte) = "logs_threaded.cma"
|
||||
plugin(native) = "logs_threaded.cmxs"
|
||||
exists_if = "logs_threaded.cma logs_threaded.cmxa"
|
||||
)
|
||||
|
||||
package "top" (
|
||||
directory = "top"
|
||||
description = "The logs.top library"
|
||||
version = "0.9.0+dune2"
|
||||
requires = "logs"
|
||||
archive(byte) = "logs_top.cma"
|
||||
archive(native) = "logs_top.cmxa"
|
||||
plugin(byte) = "logs_top.cma"
|
||||
plugin(native) = "logs_top.cmxs"
|
||||
exists_if = "logs_top.cma logs_top.cmxa"
|
||||
)
|
||||
29
unikernel/duniverse/logs/pkg/pkg.ml
Executable file
29
unikernel/duniverse/logs/pkg/pkg.ml
Executable file
|
|
@ -0,0 +1,29 @@
|
|||
#!/usr/bin/env ocaml
|
||||
#use "topfind"
|
||||
#require "topkg"
|
||||
open Topkg
|
||||
|
||||
let jsoo = Conf.with_pkg "js_of_ocaml-compiler"
|
||||
let cmdliner = Conf.with_pkg "cmdliner"
|
||||
let fmt = Conf.with_pkg "fmt"
|
||||
let lwt = Conf.with_pkg "lwt"
|
||||
let threads = Conf.with_pkg "base-threads"
|
||||
let () =
|
||||
Pkg.describe "logs" @@ fun c ->
|
||||
let jsoo = Conf.value c jsoo in
|
||||
let cmdliner = Conf.value c cmdliner in
|
||||
let fmt = Conf.value c fmt in
|
||||
let lwt = Conf.value c lwt in
|
||||
let threads = Conf.value c threads in
|
||||
Ok [ Pkg.mllib "src/logs.mllib";
|
||||
Pkg.mllib ~cond:fmt "src/fmt/logs_fmt.mllib" ~dst_dir:"fmt";
|
||||
Pkg.mllib ~cond:jsoo "src/browser/logs_browser.mllib" ~dst_dir:"browser";
|
||||
Pkg.mllib ~cond:cmdliner "src/cli/logs_cli.mllib" ~dst_dir:"cli";
|
||||
Pkg.mllib ~cond:lwt "src/lwt/logs_lwt.mllib" ~dst_dir:"lwt";
|
||||
Pkg.mllib ~cond:fmt ~api:[] "src/top/logs_top.mllib" ~dst_dir:"top";
|
||||
Pkg.mllib ~cond:threads
|
||||
"src/threaded/logs_threaded.mllib" ~dst_dir:"threaded";
|
||||
Pkg.lib "src/top/logs_top_init.ml";
|
||||
Pkg.lib "src/top/logs_top_init.ml" ~dst:"top/logs_top_init_ml";
|
||||
Pkg.lib "src/fmt/logs_fmt_top_init.ml" ~dst:"fmt/logs_fmt_top_init.ml";
|
||||
Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld"]
|
||||
34
unikernel/duniverse/logs/src/browser/logs_browser.ml
Normal file
34
unikernel/duniverse/logs/src/browser/logs_browser.ml
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
(* Console reporter *)
|
||||
|
||||
open Jsoo_runtime
|
||||
|
||||
let console_obj = Js.pure_js_expr "console"
|
||||
let console : Logs.level -> string -> unit =
|
||||
fun level s ->
|
||||
let meth = match level with
|
||||
| Logs.Error -> "error"
|
||||
| Logs.Warning -> "warn"
|
||||
| Logs.Info -> "info"
|
||||
| Logs.Debug -> "debug"
|
||||
| Logs.App -> "log"
|
||||
in
|
||||
ignore (Js.meth_call console_obj meth [| Js.string s |])
|
||||
|
||||
let ppf, flush =
|
||||
let b = Buffer.create 255 in
|
||||
let flush () = let s = Buffer.contents b in Buffer.clear b; s in
|
||||
Format.formatter_of_buffer b, flush
|
||||
|
||||
let console_report src level ~over k msgf =
|
||||
let k _ = console level (flush ()); over (); k () in
|
||||
msgf @@ fun ?header ?tags fmt ->
|
||||
match header with
|
||||
| None -> Format.kfprintf k ppf ("@[" ^^ fmt ^^ "@]@.")
|
||||
| Some h -> Format.kfprintf k ppf ("[%s] @[" ^^ fmt ^^ "@]@.") h
|
||||
|
||||
let console_reporter () = { Logs.report = console_report }
|
||||
19
unikernel/duniverse/logs/src/browser/logs_browser.mli
Normal file
19
unikernel/duniverse/logs/src/browser/logs_browser.mli
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
(** Web browser reporters for {!Logs}. *)
|
||||
|
||||
(** {1 Reporters} *)
|
||||
|
||||
val console_reporter : unit -> Logs.reporter
|
||||
(** [console_reporter ()] logs message using the
|
||||
{{:https://github.com/DeveloperToolsWG/console-object/blob/master/api.md}
|
||||
browser console object} at the corresponding level and uses
|
||||
[console.log] for the [App] level.
|
||||
|
||||
The reporter does not process or render information about
|
||||
message sources or tags.
|
||||
|
||||
Consult the {{:http://caniuse.com/#search=console}browser support}. *)
|
||||
7
unikernel/duniverse/logs/src/cli/dune
Normal file
7
unikernel/duniverse/logs/src/cli/dune
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
(library
|
||||
(name logs_cli)
|
||||
(public_name logs.cli)
|
||||
(libraries logs cmdliner)
|
||||
(modules logs_cli)
|
||||
(flags :standard -w -27 -safe-string)
|
||||
(wrapped false))
|
||||
47
unikernel/duniverse/logs/src/cli/logs_cli.ml
Normal file
47
unikernel/duniverse/logs/src/cli/logs_cli.ml
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
open Cmdliner
|
||||
|
||||
let strf = Format.asprintf
|
||||
|
||||
let level ?env ?docs () =
|
||||
let vopts =
|
||||
let doc = "Increase verbosity. Repeatable, but more than twice does
|
||||
not bring more."
|
||||
in
|
||||
Arg.(value & flag_all & info ["v"; "verbose"] ~doc ?docs)
|
||||
in
|
||||
let verbosity =
|
||||
let enum =
|
||||
[ "warning", None; (* Hack for the option's absent rendering *)
|
||||
"quiet", Some None;
|
||||
"error", Some (Some Logs.Error);
|
||||
"warning", Some (Some Logs.Warning);
|
||||
"info", Some (Some Logs.Info);
|
||||
"debug", Some (Some Logs.Debug); ]
|
||||
in
|
||||
let log_level = Arg.enum enum in
|
||||
let enum_alts = Arg.doc_alts_enum List.(tl enum) in
|
||||
let doc = strf "Be more or less verbose. $(docv) must be %s. Takes over
|
||||
$(b,-v)." enum_alts
|
||||
in
|
||||
Arg.(value & opt log_level None &
|
||||
info ["verbosity"] ?env ~docv:"LEVEL" ~doc ?docs)
|
||||
in
|
||||
let quiet =
|
||||
let doc = "Be quiet. Takes over $(b,-v) and $(b,--verbosity)." in
|
||||
Arg.(value & flag & info ["q"; "quiet"] ~doc ?docs)
|
||||
in
|
||||
let choose quiet verbosity vopts =
|
||||
if quiet then None else match verbosity with
|
||||
| Some verbosity -> verbosity
|
||||
| None ->
|
||||
match List.length vopts with
|
||||
| 0 -> Some Logs.Warning
|
||||
| 1 -> Some Logs.Info
|
||||
| n -> Some Logs.Debug
|
||||
in
|
||||
Term.(const choose $ quiet $ verbosity $ vopts)
|
||||
73
unikernel/duniverse/logs/src/cli/logs_cli.mli
Normal file
73
unikernel/duniverse/logs/src/cli/logs_cli.mli
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
(** {!Cmdliner} support for {!Logs}.
|
||||
|
||||
See a full {{!ex}example}. *)
|
||||
|
||||
(** {1 Options for setting the report level} *)
|
||||
|
||||
val level : ?env:Cmdliner.Cmd.Env.info -> ?docs:string -> unit ->
|
||||
Logs.level option Cmdliner.Term.t
|
||||
(** [level ?env ?docs ()] is a term for three {!Cmdliner} options that
|
||||
can be used with {!Logs.set_level}. The options are documented
|
||||
under [docs] (defaults to the default of {!Cmdliner.Arg.info}).
|
||||
|
||||
The options work as follows:
|
||||
{ul
|
||||
{- [-v] or [--verbose], if it appears once, the value of
|
||||
the term is [Some Logs.Info] and more than once
|
||||
[Some Logs.Debug].}
|
||||
{- [--verbosity=LEVEL], the value of the term is [l] where
|
||||
[l] depends on on [LEVEL]. Takes over the option [-v].}
|
||||
{- [-q] or [--quiet], the value of the term is [None]. Takes
|
||||
over the [-v] and [--verbosity] options.}
|
||||
{- If both options are absent the default value is
|
||||
[Some Logs.warning]}}
|
||||
|
||||
If [env] is provided, the default value in case all options are
|
||||
absent can be overridden by the corresponding environment
|
||||
variable. *)
|
||||
|
||||
(** {1:ex Example}
|
||||
|
||||
The following example shows how to setup {!Logs} and {!Fmt} so
|
||||
that logging is performed on standard outputs with ANSI coloring
|
||||
if these are [tty]s. The command line interface provides options
|
||||
to control the use of colors and the log reporting level.
|
||||
{[
|
||||
let hello _ msg =
|
||||
Logs.app (fun m -> m "%s" msg);
|
||||
Logs.info (fun m -> m "End-user information.");
|
||||
Logs.debug (fun m -> m "Developer information.");
|
||||
Logs.err (fun m -> m "Something bad happened.");
|
||||
Logs.warn (fun m -> m "Something bad may happen in the future.");
|
||||
if Logs.err_count () > 0 then 1 else 0
|
||||
|
||||
let setup_log style_renderer level =
|
||||
Fmt_tty.setup_std_outputs ?style_renderer ();
|
||||
Logs.set_level level;
|
||||
Logs.set_reporter (Logs_fmt.reporter ())
|
||||
|
||||
(* Command line interface *)
|
||||
|
||||
open Cmdliner
|
||||
|
||||
let setup_log =
|
||||
let env = Cmd.Env.info "TOOL_VERBOSITY" in
|
||||
Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ~env ())
|
||||
|
||||
let msg =
|
||||
let doc = "The message to output." in
|
||||
Arg.(value & pos 0 string "Hello horrible world!" & info [] ~doc)
|
||||
|
||||
let main () =
|
||||
let cmd = Cmd.make (Cmd.info "tool") Term.(const hello $ setup_log $ msg) in
|
||||
Cmd.eval' cmd
|
||||
|
||||
let () = if !Sys.interactive then () else exit (main ())
|
||||
]}
|
||||
|
||||
*)
|
||||
6
unikernel/duniverse/logs/src/dune
Normal file
6
unikernel/duniverse/logs/src/dune
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
(library
|
||||
(name logs)
|
||||
(public_name logs)
|
||||
(modules logs)
|
||||
(flags :standard -w -27 -safe-string)
|
||||
(wrapped false))
|
||||
7
unikernel/duniverse/logs/src/fmt/dune
Normal file
7
unikernel/duniverse/logs/src/fmt/dune
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
(library
|
||||
(name logs_fmt)
|
||||
(public_name logs.fmt)
|
||||
(libraries fmt logs)
|
||||
(modules logs_fmt)
|
||||
(flags :standard -w -27 -safe-string)
|
||||
(wrapped false))
|
||||
48
unikernel/duniverse/logs/src/fmt/logs_fmt.ml
Normal file
48
unikernel/duniverse/logs/src/fmt/logs_fmt.ml
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
let app_style = `Cyan
|
||||
let err_style = `Red
|
||||
let warn_style = `Yellow
|
||||
let info_style = `Blue
|
||||
let debug_style = `Green
|
||||
|
||||
let pp_brackets pp_v ppf v = Fmt.char ppf '['; pp_v ppf v; Fmt.char ppf ']'
|
||||
|
||||
let pp_header ~pp_h ppf (l, h) = match l with
|
||||
| Logs.App ->
|
||||
begin match h with
|
||||
| None -> ()
|
||||
| Some h ->
|
||||
pp_brackets Fmt.(styled app_style string) ppf h; Fmt.char ppf ' '
|
||||
end
|
||||
| Logs.Error ->
|
||||
pp_h ppf err_style (match h with None -> "ERROR" | Some h -> h)
|
||||
| Logs.Warning ->
|
||||
pp_h ppf warn_style (match h with None -> "WARNING" | Some h -> h)
|
||||
| Logs.Info ->
|
||||
pp_h ppf info_style (match h with None -> "INFO" | Some h -> h)
|
||||
| Logs.Debug ->
|
||||
pp_h ppf debug_style (match h with None -> "DEBUG" | Some h -> h)
|
||||
|
||||
let pp_exec_header =
|
||||
let exec = match Array.length Sys.argv with
|
||||
| 0 -> Filename.basename Sys.executable_name
|
||||
| n -> Filename.basename Sys.argv.(0)
|
||||
in
|
||||
let pp_h ppf style h =
|
||||
Fmt.string ppf exec;
|
||||
Fmt.string ppf ": ";
|
||||
pp_brackets Fmt.(styled style string) ppf h;
|
||||
Fmt.char ppf ' ';
|
||||
in
|
||||
pp_header ~pp_h
|
||||
|
||||
let reporter ?(pp_header = pp_exec_header) ?app ?dst () =
|
||||
Logs.format_reporter ~pp_header ?app ?dst ()
|
||||
|
||||
let pp_header =
|
||||
let pp_h ppf style h = pp_brackets Fmt.(styled style string) ppf h in
|
||||
pp_header ~pp_h
|
||||
40
unikernel/duniverse/logs/src/fmt/logs_fmt.mli
Normal file
40
unikernel/duniverse/logs/src/fmt/logs_fmt.mli
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
(** {!Format} colorful reporter for {!Logs}. *)
|
||||
|
||||
(** {1 Reporter} *)
|
||||
|
||||
val reporter :
|
||||
?pp_header:(Logs.level * string option) Fmt.t ->
|
||||
?app:Format.formatter ->
|
||||
?dst:Format.formatter -> unit -> Logs.reporter
|
||||
(** [reporter] is like {!Logs.format_reporter} except ANSI colors may be
|
||||
used in message header rendering if the formatters are configured to do so;
|
||||
see {!Fmt.set_style_renderer} and {!Fmt_tty}.
|
||||
|
||||
Consult a full command line {{!Logs_cli.ex}setup example}. *)
|
||||
|
||||
(** {1:cheader Colored message headers} *)
|
||||
|
||||
val app_style : Fmt.style
|
||||
(** [app_style] is the style used to render headers at app level. *)
|
||||
|
||||
val err_style : Fmt.style
|
||||
(** [err_style] is the style used to render headers at error level. *)
|
||||
|
||||
val warn_style : Fmt.style
|
||||
(** [warn_style] is the style used to render headers at warning level. *)
|
||||
|
||||
val info_style : Fmt.style
|
||||
(** [info_style] is the style used to render headers at info level. *)
|
||||
|
||||
val debug_style : Fmt.style
|
||||
(** [debug_style] is the style used to render headers at debug level. *)
|
||||
|
||||
val pp_header : (Logs.level * string option) Fmt.t
|
||||
(** [pp_header] is like {!Logs.pp_header} but may use ANSI colors if the
|
||||
formatter is configured to do so, see {!Fmt.set_style_renderer} and
|
||||
{!Fmt_tty}. *)
|
||||
8
unikernel/duniverse/logs/src/fmt/logs_fmt_top_init.ml
Normal file
8
unikernel/duniverse/logs/src/fmt/logs_fmt_top_init.ml
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
let () =
|
||||
Logs.set_reporter (Logs_fmt.reporter ());
|
||||
()
|
||||
324
unikernel/duniverse/logs/src/logs.ml
Normal file
324
unikernel/duniverse/logs/src/logs.ml
Normal file
|
|
@ -0,0 +1,324 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
let rec atomic_list_cons v atomic =
|
||||
let l = Atomic.get atomic in
|
||||
if Atomic.compare_and_set atomic l (v :: l) then () else
|
||||
atomic_list_cons v atomic
|
||||
|
||||
(* Reporting levels *)
|
||||
|
||||
type level = App | Error | Warning | Info | Debug
|
||||
let level' = Atomic.make (Some Warning)
|
||||
let level () = Atomic.get level'
|
||||
let pp_level ppf = function
|
||||
| App -> ()
|
||||
| Error -> Format.pp_print_string ppf "ERROR"
|
||||
| Warning -> Format.pp_print_string ppf "WARNING"
|
||||
| Info -> Format.pp_print_string ppf "INFO"
|
||||
| Debug -> Format.pp_print_string ppf "DEBUG"
|
||||
|
||||
let level_to_string = function
|
||||
| None -> "quiet" | Some App -> "app" | Some Error -> "error"
|
||||
| Some Warning -> "warning" | Some Info -> "info" | Some Debug -> "debug"
|
||||
|
||||
let level_of_string = function
|
||||
| "quiet" -> Ok None
|
||||
| "app" -> Ok (Some App)
|
||||
| "error" -> Ok (Some Error)
|
||||
| "warning" -> Ok (Some Warning)
|
||||
| "info" -> Ok (Some Info)
|
||||
| "debug" -> Ok (Some Debug)
|
||||
| l -> Error (`Msg (Printf.sprintf "%S: unknown log level" l))
|
||||
|
||||
(* Sources *)
|
||||
|
||||
module Src = struct
|
||||
type t =
|
||||
{ uid : int;
|
||||
name : string;
|
||||
doc : string;
|
||||
level : level option Atomic.t }
|
||||
|
||||
let uid =
|
||||
let id = Atomic.make 0 in
|
||||
fun () -> Atomic.fetch_and_add id 1
|
||||
|
||||
let list = Atomic.make []
|
||||
|
||||
let create ?(doc = "undocumented") name =
|
||||
let level = Atomic.make (Atomic.get level') in
|
||||
let src = { uid = uid (); name; doc; level } in
|
||||
atomic_list_cons src list; src
|
||||
|
||||
let name s = s.name
|
||||
let doc s = s.doc
|
||||
let level s = Atomic.get (s.level)
|
||||
let set_level s l = Atomic.set s.level l
|
||||
let equal src0 src1 = src0.uid = src1.uid
|
||||
let compare src0 src1 = (compare : int -> int -> int) src0.uid src1.uid
|
||||
|
||||
let pp ppf src = Format.fprintf ppf
|
||||
"@[<1>(src@ @[<1>(name %S)@]@ @[<1>(uid %d)@] @[<1>(doc %S)@])@]"
|
||||
src.name src.uid src.doc
|
||||
|
||||
let list () = Atomic.get list
|
||||
end
|
||||
|
||||
type src = Src.t
|
||||
|
||||
let default = Src.create "application" ~doc:"The application log"
|
||||
|
||||
let set_level ?(all = true) l =
|
||||
Atomic.set level' l;
|
||||
if all then List.iter (fun s -> Src.set_level s l) (Src.list ())
|
||||
|
||||
(* Message tags *)
|
||||
|
||||
module Tag = struct
|
||||
|
||||
(* Universal type, see http://mlton.org/UniversalType.
|
||||
Note: we can get rid of that once we have OCaml >= 5.1 *)
|
||||
|
||||
type univ = exn
|
||||
let univ (type s) () =
|
||||
let module M = struct exception E of s option end in
|
||||
(fun x -> M.E (Some x)), (function M.E x -> x | _ -> None)
|
||||
|
||||
(* Tag definitions *)
|
||||
|
||||
type 'a def =
|
||||
{ uid : int;
|
||||
to_univ : 'a -> univ;
|
||||
of_univ : univ -> 'a option;
|
||||
name : string;
|
||||
doc : string;
|
||||
pp : Format.formatter -> 'a -> unit; }
|
||||
|
||||
type def_e = Def : 'a def -> def_e
|
||||
|
||||
let list = Atomic.make ([] : def_e list)
|
||||
let uid =
|
||||
let id = Atomic.make 0 in
|
||||
fun () -> Atomic.fetch_and_add id 1
|
||||
|
||||
let def ?(doc = "undocumented") name pp =
|
||||
let to_univ, of_univ = univ () in
|
||||
let tag = { uid = uid (); to_univ; of_univ; name; doc; pp } in
|
||||
atomic_list_cons (Def tag) list;
|
||||
tag
|
||||
|
||||
let name d = d.name
|
||||
let doc d = d.doc
|
||||
let printer d = d.pp
|
||||
let pp_def ppf d = Format.fprintf ppf "tag:%s" d.name
|
||||
let list () = Atomic.get list
|
||||
|
||||
(* Tag values *)
|
||||
|
||||
type t = V : 'a def * 'a -> t
|
||||
|
||||
let pp ppf (V (d, v)) =
|
||||
Format.fprintf ppf "@[<1>(%a@ @[%a@])@]" pp_def d d.pp v
|
||||
|
||||
(* Tag sets *)
|
||||
|
||||
module Key = struct
|
||||
type t = V : 'a def -> t
|
||||
let compare (V k0) (V k1) = (compare : int -> int -> int) k0.uid k1.uid
|
||||
end
|
||||
|
||||
module M = Map.Make (Key)
|
||||
|
||||
type set = t M.t
|
||||
|
||||
let empty = M.empty
|
||||
let is_empty = M.is_empty
|
||||
let mem k s = M.mem (Key.V k) s
|
||||
let add k v s = M.add (Key.V k) (V (k, v)) s
|
||||
let rem k s = M.remove (Key.V k) s
|
||||
let find : type a. a def -> set -> a option =
|
||||
fun k s ->
|
||||
try match M.find (Key.V k) s with
|
||||
| V (k', v) -> k.of_univ (k'.to_univ v)
|
||||
with Not_found -> None
|
||||
|
||||
let get k s = match find k s with
|
||||
| None -> invalid_arg (Printf.sprintf "tag named %s not found in set" k.name)
|
||||
| Some v -> v
|
||||
|
||||
let fold f s acc = M.fold (fun _ t acc -> f t acc) s acc
|
||||
let pp_set ppf s =
|
||||
let pp_tag tag is_first =
|
||||
if is_first then () else Format.fprintf ppf "@,";
|
||||
Format.fprintf ppf "%a" pp tag;
|
||||
false
|
||||
in
|
||||
Format.fprintf ppf "@[<1>{";
|
||||
ignore (fold pp_tag s true);
|
||||
Format.fprintf ppf "}@]";
|
||||
()
|
||||
end
|
||||
|
||||
(* Reporters *)
|
||||
|
||||
type ('a, 'b) msgf =
|
||||
(?header:string -> ?tags:Tag.set ->
|
||||
('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b
|
||||
|
||||
type reporter_mutex = { lock : unit -> unit; unlock : unit -> unit }
|
||||
let reporter_mutex' =
|
||||
Atomic.make { lock = (fun () -> ()); unlock = (fun () -> ()) }
|
||||
|
||||
let set_reporter_mutex ~lock ~unlock =
|
||||
Atomic.set reporter_mutex' { lock; unlock }
|
||||
|
||||
type reporter =
|
||||
{ report :
|
||||
'a 'b. src -> level -> over:(unit -> unit) -> (unit -> 'b) ->
|
||||
('a, 'b) msgf -> 'b }
|
||||
|
||||
let nop_reporter = { report = fun _ _ ~over k _ -> over (); k () }
|
||||
let reporter' = Atomic.make nop_reporter
|
||||
let set_reporter r = Atomic.set reporter' r
|
||||
let reporter () = Atomic.get reporter'
|
||||
let report src level ~over k msgf =
|
||||
let mutex = Atomic.get reporter_mutex' in
|
||||
let over () = over (); mutex.unlock () in
|
||||
mutex.lock ();
|
||||
(Atomic.get reporter').report src level ~over k msgf
|
||||
|
||||
let pp_brackets pp_v ppf v =
|
||||
Format.pp_print_char ppf '['; pp_v ppf v; Format.pp_print_char ppf ']'
|
||||
|
||||
let pp_header ppf (l, h) = match h with
|
||||
| None -> if l = App then () else pp_brackets pp_level ppf l
|
||||
| Some h -> pp_brackets Format.pp_print_string ppf h
|
||||
|
||||
let pp_exec_header =
|
||||
let exec = match Array.length Sys.argv with
|
||||
| 0 -> Filename.basename Sys.executable_name
|
||||
| n -> Filename.basename Sys.argv.(0)
|
||||
in
|
||||
fun ppf (l, h) ->
|
||||
if l = App then match h with
|
||||
| None -> ()
|
||||
| Some h ->
|
||||
pp_brackets Format.pp_print_string ppf h;
|
||||
Format.pp_print_char ppf ' '
|
||||
else match h with
|
||||
| None ->
|
||||
Format.pp_print_string ppf exec;
|
||||
Format.pp_print_string ppf ": ";
|
||||
pp_brackets pp_level ppf l;
|
||||
Format.pp_print_char ppf ' '
|
||||
| Some h ->
|
||||
Format.pp_print_string ppf exec;
|
||||
Format.pp_print_string ppf ": ";
|
||||
pp_brackets Format.pp_print_string ppf h;
|
||||
Format.pp_print_char ppf ' '
|
||||
|
||||
let format_reporter
|
||||
?(pp_header = pp_exec_header)
|
||||
?(app = Format.std_formatter)
|
||||
?(dst = Format.err_formatter) ()
|
||||
=
|
||||
let report src level ~over k msgf =
|
||||
let k ppf =
|
||||
Format.pp_close_box ppf ();
|
||||
Format.pp_print_newline ppf ();
|
||||
over (); k ()
|
||||
in
|
||||
msgf @@ fun ?header ?tags fmt ->
|
||||
let ppf = if level = App then app else dst in
|
||||
pp_header ppf (level, header);
|
||||
Format.pp_open_box ppf 0;
|
||||
Format.kfprintf k ppf fmt
|
||||
in
|
||||
{ report }
|
||||
|
||||
(* Log functions *)
|
||||
|
||||
let err_count' = Atomic.make 0
|
||||
let err_count () = Atomic.get err_count'
|
||||
let incr_err_count () = Atomic.incr err_count'
|
||||
|
||||
let warn_count' = Atomic.make 0
|
||||
let warn_count () = Atomic.get warn_count'
|
||||
let incr_warn_count () = Atomic.incr warn_count'
|
||||
|
||||
type 'a log = ('a, unit) msgf -> unit
|
||||
|
||||
let over () = ()
|
||||
let kmsg k ?(src = default) level msgf =
|
||||
begin match level with
|
||||
| Error -> Atomic.incr err_count'
|
||||
| Warning -> Atomic.incr warn_count'
|
||||
| _ -> ()
|
||||
end;
|
||||
match Src.level src with
|
||||
| None -> k ()
|
||||
| Some current_level when level > current_level -> k ()
|
||||
| Some _ -> report src level ~over k msgf
|
||||
|
||||
let kunit _ = ()
|
||||
let msg ?src level msgf = kmsg kunit ?src level msgf
|
||||
let app ?src msgf = kmsg kunit ?src App msgf
|
||||
let err ?src msgf = kmsg kunit ?src Error msgf
|
||||
let warn ?src msgf = kmsg kunit ?src Warning msgf
|
||||
let info ?src msgf = kmsg kunit ?src Info msgf
|
||||
let debug ?src msgf = kmsg kunit ?src Debug msgf
|
||||
|
||||
(* Log result errors *)
|
||||
|
||||
let on_error ?src ?(level = Error) ?header ?tags ~pp ~use = function
|
||||
| Ok v -> v
|
||||
| Error e ->
|
||||
kmsg (fun () -> use e) ?src level @@ fun m ->
|
||||
m ?header ?tags "@[%a@]" pp e
|
||||
|
||||
let on_error_msg ?src ?(level = Error) ?header ?tags ~use = function
|
||||
| Ok v -> v
|
||||
| Error (`Msg msg) ->
|
||||
kmsg use ?src level @@ fun m ->
|
||||
m ?header ?tags "@[%a@]" Format.pp_print_text msg
|
||||
|
||||
(* Source specific logging functions *)
|
||||
|
||||
module type LOG = sig
|
||||
val msg : level -> 'a log
|
||||
val app : 'a log
|
||||
val err : 'a log
|
||||
val warn : 'a log
|
||||
val info : 'a log
|
||||
val debug : 'a log
|
||||
val kmsg : (unit -> 'b) -> level -> ('a, 'b) msgf -> 'b
|
||||
val on_error :
|
||||
?level:level -> ?header:string -> ?tags:Tag.set ->
|
||||
pp:(Format.formatter -> 'b -> unit) -> use:('b -> 'a) -> ('a, 'b) result ->
|
||||
'a
|
||||
|
||||
val on_error_msg :
|
||||
?level:level -> ?header:string -> ?tags:Tag.set ->
|
||||
use:(unit -> 'a) -> ('a, [`Msg of string]) result -> 'a
|
||||
end
|
||||
|
||||
let src_log src =
|
||||
let module Log = struct
|
||||
let msg level msgf = msg ~src level msgf
|
||||
let kmsg k level msgf = kmsg k ~src level msgf
|
||||
let app msgf = msg App msgf
|
||||
let err msgf = msg Error msgf
|
||||
let warn msgf = msg Warning msgf
|
||||
let info msgf = msg Info msgf
|
||||
let debug msgf = msg Debug msgf
|
||||
let on_error ?level ?header ?tags ~pp ~use =
|
||||
on_error ~src ?level ?header ?tags ~pp ~use
|
||||
|
||||
let on_error_msg ?level ?header ?tags ~use =
|
||||
on_error_msg ~src ?level ?header ?tags ~use
|
||||
end
|
||||
in
|
||||
(module Log : LOG)
|
||||
609
unikernel/duniverse/logs/src/logs.mli
Normal file
609
unikernel/duniverse/logs/src/logs.mli
Normal file
|
|
@ -0,0 +1,609 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
(** Logging.
|
||||
|
||||
[Logs] provides a basic logging infrastructure. {{!func}Logging}
|
||||
is performed on {{!srcs}sources} whose reporting
|
||||
{{!type:level}level} can be set independently. Log message
|
||||
report is decoupled from logging and handled by a
|
||||
{{!reporters}reporter}.
|
||||
|
||||
See the {{!basics}basics}, a few {{!usage}usage conventions} to
|
||||
respect and a note on {{!sync}synchronous logging}. *)
|
||||
|
||||
(** {1:levels Reporting levels} *)
|
||||
|
||||
(** The type for reporting levels. For level semantics see the
|
||||
{{!usage}usage conventions}.
|
||||
|
||||
Log {{!srcs}sources} have an optional {{!Src.level}reporting level}. If
|
||||
the level is [Some l] then any message whose level is smaller or
|
||||
equal to [l] is reported. If the level is [None] no message is
|
||||
ever reported. *)
|
||||
type level = App | Error | Warning | Info | Debug
|
||||
|
||||
val level : unit -> level option
|
||||
(** [level ()] is the reporting level given to {{!Src.create}new sources}. *)
|
||||
|
||||
val set_level : ?all:bool -> level option -> unit
|
||||
(** [set_level ?all l] sets the reporting level given to
|
||||
{{!Src.create}new sources}. If [all] is [true] (default), also
|
||||
sets the reporting level of all {{!Src.list}existing sources}. Use
|
||||
{!Src.set_level} to only affect a specific source. Only applications
|
||||
should use this function directly see {{!usage}usage conventions}. *)
|
||||
|
||||
val pp_level : Format.formatter -> level -> unit
|
||||
(** [pp_level ppf l] prints an unspecified representation of [l] on
|
||||
[ppf]. *)
|
||||
|
||||
val level_to_string : level option -> string
|
||||
(** [level_to_string l] converts [l] to an US-ASCII string that can be
|
||||
parsed back by {!level_of_string} and by the [LEVEL] option
|
||||
argument of {!Logs_cli.level}. *)
|
||||
|
||||
val level_of_string : string -> (level option, [`Msg of string]) result
|
||||
(** [level_of_string s] parses the representation of {!level_to_string}
|
||||
from [s]. *)
|
||||
|
||||
(** {1:srcs Log sources} *)
|
||||
|
||||
type src
|
||||
(** The type for log sources. A source defines a named unit of logging
|
||||
whose reporting level can be set independently. *)
|
||||
|
||||
val default : src
|
||||
(** [default] is a logging source that is reserved for use by
|
||||
applications. See {{!usage}usage conventions}. *)
|
||||
|
||||
(** Sources. *)
|
||||
module Src : sig
|
||||
|
||||
(** {1 Sources} *)
|
||||
|
||||
type t = src
|
||||
(** The type for log sources. *)
|
||||
|
||||
val create : ?doc:string -> string -> src
|
||||
(** [create ?doc name] is a new log source. [name] is the name of
|
||||
the source; it doesn't need to be unique but it is good practice
|
||||
to prefix the name with the name of your package or library
|
||||
(e.g. ["mypkg.network"]). [doc] is a documentation string
|
||||
describing the source, defaults to ["undocumented"]. The initial
|
||||
reporting level of the source is defined by {!Logs.level}. *)
|
||||
|
||||
val name : src -> string
|
||||
(** [name] is [src]'s name. *)
|
||||
|
||||
val doc : src -> string
|
||||
(** [doc src] is [src]'s documentation string. *)
|
||||
|
||||
val level : src -> level option
|
||||
(** [level src] is the report level of [src] (if any). *)
|
||||
|
||||
val set_level : src -> level option -> unit
|
||||
(** [set_level src l] sets the report level of [src] to [l]. Only
|
||||
applications should use this function directly, see {{!usage}usage
|
||||
conventions}. *)
|
||||
|
||||
val equal : src -> src -> bool
|
||||
(** [equal src src'] is [true] iff [src] and [src'] are the same source. *)
|
||||
|
||||
val compare : src -> src -> int
|
||||
(** [compare src src'] is a total order on sources. *)
|
||||
|
||||
val pp : Format.formatter -> src -> unit
|
||||
(** [pp ppf src] prints an unspecified representation of [src] on
|
||||
[ppf]. *)
|
||||
|
||||
val list : unit -> src list
|
||||
(** [list ()] is the current exisiting source list. *)
|
||||
end
|
||||
|
||||
(** {1:func Log functions} *)
|
||||
|
||||
(** Message tags.
|
||||
|
||||
Message tags are arbitrary named and typed values that can be
|
||||
associated to log messages. See an {{!ex1}example}. *)
|
||||
module Tag : sig
|
||||
|
||||
(** {1 Tag definitions} *)
|
||||
|
||||
type 'a def
|
||||
(** The type for tag definitions. The type ['a] is the type of the
|
||||
tag. The definition specifies a name for the tag, a pretty-printer
|
||||
for the type of the tag and a documentation string. See {!val:def}. *)
|
||||
|
||||
(** The type for existential tag definitions. *)
|
||||
type def_e = Def : 'a def -> def_e
|
||||
|
||||
val def : ?doc:string -> string -> (Format.formatter -> 'a -> unit) -> 'a def
|
||||
(** [def ~doc name pp] is a tag definition. [name] is the name of
|
||||
the tag, it doesn't need to be unique. [pp] is a printer for the
|
||||
type of the tag. [doc] is a documentation string describing
|
||||
the tag (defaults to ["undocumented"]). *)
|
||||
|
||||
val name : 'a def -> string
|
||||
(** [name d] is [d]'s name. *)
|
||||
|
||||
val doc : 'a def -> string
|
||||
(** [doc d] is [d]'s documentation string. *)
|
||||
|
||||
val printer : 'a def -> (Format.formatter -> 'a -> unit)
|
||||
(** [printer d] is [d]'s type pretty-printer. *)
|
||||
|
||||
val pp_def : Format.formatter -> 'a def -> unit
|
||||
(** [pp_def ppf d] prints an unspecified representation of [d] on [ppf]. *)
|
||||
|
||||
val list : unit -> def_e list
|
||||
(** [tag_list ()] is the list of currently existing tag definitions. *)
|
||||
|
||||
(** {1 Tags} *)
|
||||
|
||||
(** The type for tags. Tuples the tag definition and its value. *)
|
||||
type t = V : 'a def * 'a -> t
|
||||
|
||||
val pp : Format.formatter -> t -> unit
|
||||
(** [pp ppf t] prints an unspecified representation of [t] on [ppf]. *)
|
||||
|
||||
(** {1 Tag sets} *)
|
||||
|
||||
type set
|
||||
(** The type for tag sets. A tag set contains at most one tag per
|
||||
tag definition. *)
|
||||
|
||||
val empty : set
|
||||
(** [empty] is the empty set. *)
|
||||
|
||||
val is_empty : set -> bool
|
||||
(** [is_empty s] is [true] iff [s] is empty. *)
|
||||
|
||||
val mem : 'a def -> set -> bool
|
||||
(** [mem d s] is [true] iff [s] has a tag with definition [d]. *)
|
||||
|
||||
val add : 'a def -> 'a -> set -> set
|
||||
(** [add d v s] is [s] with the tag [(V (d, v))] added. If there was a tag
|
||||
with definition [d] in [s] it is replaced. *)
|
||||
|
||||
val rem : 'a def -> set -> set
|
||||
(** [rem d s] is [s] without the tag defined by [d] (if there was one). *)
|
||||
|
||||
val find : 'a def -> set -> 'a option
|
||||
(** [find d s] is the tag value with definition [d] in [s] (if any). *)
|
||||
|
||||
val get : 'a def -> set -> 'a
|
||||
(** [get d s] is like [find d s] but @raise Invalid_argument if there
|
||||
is no tag with definition [d] in [s]. *)
|
||||
|
||||
val fold : (t -> 'a -> 'a) -> set -> 'a -> 'a
|
||||
(** [fold f s acc] is the result of folding [f] over the tags
|
||||
of [s] starting with [acc]. *)
|
||||
|
||||
val pp_set : Format.formatter -> set -> unit
|
||||
(** [pp_set ppf s] prints an unspecified representation of s on [ppf]. *)
|
||||
end
|
||||
|
||||
type ('a, 'b) msgf =
|
||||
(?header:string -> ?tags:Tag.set ->
|
||||
('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b
|
||||
(** The type for client specified message formatting functions.
|
||||
|
||||
Message formatting functions are called with a message
|
||||
construction function whenever a message needs to be reported. The
|
||||
message formatting function must call the given message
|
||||
construction function with a format string and its arguments to
|
||||
define the message contents, see the {{!logging}basics} for examples.
|
||||
The optional arguments of the message construction function are:
|
||||
{ul
|
||||
{- [header], an optional printable message header. Default to [None].}
|
||||
{- [tags], a set of tags to attach to the message. Defaults
|
||||
{!Tag.empty}.}} *)
|
||||
|
||||
type 'a log = ('a, unit) msgf -> unit
|
||||
(** The type for log functions. See the {{!logging}basics} to understand
|
||||
how to use log functions. *)
|
||||
|
||||
val msg : ?src:src -> level -> 'a log
|
||||
(** [msg ?src l (fun m -> m fmt ...)] logs with level [l] on the source
|
||||
[src] (defaults to {!default}) a message formatted with [fmt]. For the
|
||||
semantics of levels see the {{!usage}the usage conventions}. *)
|
||||
|
||||
val app : ?src:src -> 'a log
|
||||
(** [app] is [msg App]. *)
|
||||
|
||||
val err : ?src:src -> 'a log
|
||||
(** [err] is [msg Error]. *)
|
||||
|
||||
val warn : ?src:src -> 'a log
|
||||
(** [warn] is [msg Warning]. *)
|
||||
|
||||
val info : ?src:src -> 'a log
|
||||
(** [info] is [msg Info]. *)
|
||||
|
||||
val debug : ?src:src -> 'a log
|
||||
(** [debug] is [msg Debug]. *)
|
||||
|
||||
val kmsg : (unit -> 'b) -> ?src:src -> level -> ('a, 'b) msgf -> 'b
|
||||
(** [kmsg k] is like {!msg} but calls [k] for returning. *)
|
||||
|
||||
(** {2:result Logging [result] value [Error]s} *)
|
||||
|
||||
val on_error : ?src:src -> ?level:level -> ?header:string -> ?tags:Tag.set ->
|
||||
pp:(Format.formatter -> 'b -> unit) -> use:('b -> 'a) -> ('a, 'b) result -> 'a
|
||||
(** [on_error ~level ~pp ~use r] is:
|
||||
{ul
|
||||
{- [v] if [r = Ok v]}
|
||||
{- [use e] if [r = Error e]. As a side effect [msg] is logged
|
||||
with [pp] on level [level] (defaults to {!Logs.Error}).}} *)
|
||||
|
||||
val on_error_msg : ?src:src -> ?level:level -> ?header:string ->
|
||||
?tags:Tag.set -> use:(unit -> 'a) ->
|
||||
('a, [`Msg of string]) result -> 'a
|
||||
(** [on_error_msg] is like {!on_error} but uses
|
||||
{!Format.pp_print_text} to format the message. *)
|
||||
|
||||
(** {1:srcfunc Source specific log functions} *)
|
||||
|
||||
(** The type for source specific logging functions. *)
|
||||
module type LOG = sig
|
||||
|
||||
(** {1:func Log functions} *)
|
||||
|
||||
val msg : level -> 'a log
|
||||
(** See {!Logs.msg}. *)
|
||||
|
||||
val app : 'a log
|
||||
(** [app] is [msg App]. *)
|
||||
|
||||
val err : 'a log
|
||||
(** [err] is [msg Error]. *)
|
||||
|
||||
val warn : 'a log
|
||||
(** [warn] is [msg Warning]. *)
|
||||
|
||||
val info : 'a log
|
||||
(** [info] is [msg Info]. *)
|
||||
|
||||
val debug : 'a log
|
||||
(** [debug] is [msg Debug]. *)
|
||||
|
||||
val kmsg : (unit -> 'b) -> level -> ('a, 'b) msgf -> 'b
|
||||
(** See {!Logs.kmsg}. *)
|
||||
|
||||
(** {2:result Logging [result] value [Error]s} *)
|
||||
|
||||
val on_error : ?level:level -> ?header:string -> ?tags:Tag.set ->
|
||||
pp:(Format.formatter -> 'b -> unit) -> use:('b -> 'a) -> ('a, 'b) result ->
|
||||
'a
|
||||
(** See {!Logs.on_error}. *)
|
||||
|
||||
val on_error_msg : ?level:level -> ?header:string -> ?tags:Tag.set ->
|
||||
use:(unit -> 'a) -> ('a, [`Msg of string]) result -> 'a
|
||||
(** See {!Logs.on_error_msg}. *)
|
||||
end
|
||||
|
||||
val src_log : src -> (module LOG)
|
||||
(** [src_log src] is a {{!LOG}set of logging functions} for [src]. *)
|
||||
|
||||
(** {1:reporters Reporters} *)
|
||||
|
||||
type reporter =
|
||||
{ report : 'a 'b. src -> level -> over:(unit -> unit) -> (unit -> 'b) ->
|
||||
('a, 'b) msgf -> 'b }
|
||||
(** The type for reporters.
|
||||
|
||||
A reporter formats and handles log messages that get
|
||||
reported. Whenever a {{!func}log function} gets called on a source
|
||||
with a level equal or smaller to the {{!Src.level}source's reporting
|
||||
level}, the {{!reporter}current reporter}'s field [r.report]
|
||||
gets called as [r.report src level ~over k msgf]
|
||||
where:
|
||||
{ul
|
||||
{- [src] is the logging source.}
|
||||
{- [level] is the reporting level.}
|
||||
{- [over] must be called by the reporter once the logging operation is
|
||||
over from the reporter's perspective. This may happen before or
|
||||
after [k] is called.}
|
||||
{- [k] is the function to invoke to return.}
|
||||
{- [msgf] is the {{!msgf}message formatting function} to call.}}
|
||||
See an {{!ex1}example}. *)
|
||||
|
||||
val nop_reporter : reporter
|
||||
(** [nop_reporter] is the initial reporter returned by {!reporter}, it
|
||||
does nothing if a log message gets reported. *)
|
||||
|
||||
val format_reporter :
|
||||
?pp_header:(Format.formatter -> (level * string option) -> unit) ->
|
||||
?app:Format.formatter -> ?dst:Format.formatter -> unit -> reporter
|
||||
(** [format_reporter ~pp_header ~app ~dst ()] is a reporter that reports
|
||||
{!App} level messages on [app] (defauts to {!Format.std_formatter})
|
||||
and all other level on [dst] (defaults to {!Format.err_formatter}).
|
||||
|
||||
[pp_header] determines how message headers are rendered. The default
|
||||
prefixes the program name and renders the header with {!pp_header}.
|
||||
Use {!Logs_fmt.reporter} if you want colored headers rendering.
|
||||
|
||||
The reporter does not process or render information about message
|
||||
sources or tags.
|
||||
|
||||
{b Important.} This is a synchronous reporter it considers the log
|
||||
operation to be over once the message was formatted and before
|
||||
calling the continuation (see the {{!Logs.sync}note on synchronous
|
||||
logging}). In particular if the formatters are backed by channels,
|
||||
it will block until the message has been formatted on the channel
|
||||
before proceeding which may not be suitable in a cooperative
|
||||
concurrency setting like {!Lwt}. *)
|
||||
|
||||
val reporter : unit -> reporter
|
||||
(** [reporter ()] is the current repporter. *)
|
||||
|
||||
val set_reporter : reporter -> unit
|
||||
(** [set_reporter r] sets the current reporter to [r]. *)
|
||||
|
||||
val set_reporter_mutex : lock:(unit -> unit) -> unlock:(unit -> unit) -> unit
|
||||
(** [set_reporter_mutex ~lock ~unlock] sets the mutex primitives used
|
||||
to access the reporter. [lock] is called before invoking the
|
||||
reporter and [unlock] after it returns. Initially both [lock] and
|
||||
[unlock] are [fun () -> ()]. *)
|
||||
|
||||
(**/**)
|
||||
val report : src -> level -> over:(unit -> unit) -> (unit -> 'b) ->
|
||||
('a, 'b) msgf -> 'b
|
||||
val incr_err_count : unit -> unit
|
||||
val incr_warn_count : unit -> unit
|
||||
(**/**)
|
||||
|
||||
val pp_header : Format.formatter -> (level * string option) -> unit
|
||||
(** [pp_header ppf (l, h)] prints an unspecified representation
|
||||
of log header [h] for level [l]. *)
|
||||
|
||||
(** {1:monitoring Logs monitoring} *)
|
||||
|
||||
val err_count : unit -> int
|
||||
(** [err_count ()] is the number of messages logged with level [Error]
|
||||
across all sources. *)
|
||||
|
||||
val warn_count : unit -> int
|
||||
(** [warn_count ()] is the number of messages logged with level
|
||||
[Warning] across all sources. *)
|
||||
|
||||
(** {1:basics Basics}
|
||||
|
||||
{2:logging Logging}
|
||||
|
||||
In order to minimize the overhead whenever a log message is not reported,
|
||||
message formatting only occurs on actual message report via the
|
||||
{{!msgf}message formatting function} you provide to log functions. This
|
||||
leads to the following logging structure:
|
||||
{[
|
||||
let k, v = ... in
|
||||
Logs.err (fun m -> m "invalid kv (%a,%a)" pp_key k pp_val v);
|
||||
Logs.err (fun m -> m "NO CARRIER");
|
||||
]}
|
||||
The pattern is quite simple: it is as if you were formatting with
|
||||
a [printf]-like function except you get this function in the [m]
|
||||
argument of the function you give to the logging function.
|
||||
|
||||
If you want to abstract a repeated log report it is better to keep
|
||||
the message formatting function structure for the arguments of the
|
||||
messages. Here's how the above examples can be abstracted and
|
||||
invoked:
|
||||
{[
|
||||
let err_invalid_kv args =
|
||||
Logs.err @@ fun m ->
|
||||
args (fun k v -> m "invalid kv (%a,%a)" pp_key k pp_val v)
|
||||
|
||||
let err_no_carrier args =
|
||||
Logs.err @@ fun m -> args (m "NO CARRIER")
|
||||
|
||||
let () =
|
||||
err_invalid_kv (fun args -> args "key" "value");
|
||||
err_no_carrier (fun () -> ());
|
||||
()
|
||||
]}
|
||||
Note that log messages are formatted and hit the reporter only if
|
||||
they have not been filtered out by the current
|
||||
{{!Src.level}reporting level} of the source you log on. See also
|
||||
the log source and reporting level {{!usage}usage conventions}.
|
||||
|
||||
{2:setupreporter Reporter setup}
|
||||
|
||||
If you are writing an application you must remember to
|
||||
{{!set_reporter}set} the reporter before any logging operation
|
||||
takes place otherwise no messages will be reported. For example if
|
||||
you are using the {{!Logs_fmt}formatter reporter}, logging
|
||||
can be setup as follows:
|
||||
{[
|
||||
let main () =
|
||||
Logs.set_reporter (Logs_fmt.reporter ());
|
||||
...
|
||||
if Logs.err_count () > 0 then 1 else 0
|
||||
|
||||
let () = if !Sys.interactive then () else exit (main ())
|
||||
]}
|
||||
If you have logging code that is performed in the toplevel
|
||||
initialization code of modules (not a good idea) or you depend on
|
||||
(bad) libraries that do so, you must call and link the reporter
|
||||
install code before these initialization bits are being executed
|
||||
otherwise you will miss these messages.
|
||||
|
||||
In multi-threaded programs you likely want to ensure mutual
|
||||
exclusion on reporter access. This can be done by invoking
|
||||
{!Logs.set_reporter_mutex} with suitable mutual exclusion
|
||||
primitives. If you use OCaml {!Thread}s simply calling
|
||||
{!Logs_threaded.enable} with handle that for you.
|
||||
|
||||
If you need to use multiple reporters in your program see this
|
||||
{{!ex2}sample code}.
|
||||
|
||||
The documentation of {!Logs_cli} module has a {{!Logs_cli.ex}full setup
|
||||
example} that includes command line options to control color and log
|
||||
reporting level.
|
||||
|
||||
If you are writing a library you should neither install reporters, nor
|
||||
set the reporting level of sources, nor log on the {!default} source or
|
||||
at the [App] level; follow the {{!usage}the usage conventions}. A
|
||||
library should simply log on another existing source or define
|
||||
its own source like in the example below:
|
||||
{[
|
||||
let src = Logs.Src.create "mylib.network" ~doc:"logs mylib's network events"
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
]}
|
||||
The [Log] module defines logging functions that are specific to the
|
||||
source [src].
|
||||
|
||||
{1:usage Usage conventions}
|
||||
|
||||
A library should never log on the {!default} source or at the
|
||||
[App] level these are reserved for use by the application. It
|
||||
should either create a source for itself or log on the source
|
||||
defined by one of its dependencies. It should also never set the
|
||||
reporting level of the sources it deals with or install reporters since
|
||||
control over this must be left to the application.
|
||||
|
||||
The semantics of {{!type:level}reporting levels} should be understood
|
||||
as follows:
|
||||
{ul
|
||||
{- [App], this level can be used for the standard output or console
|
||||
of an application. It should never be used by libraries.}
|
||||
{- [Error], error condition that prevent the program from
|
||||
running normally.}
|
||||
{- [Warning], suspicious condition that does not prevent the
|
||||
program from running normally but may eventually lead to an
|
||||
error condition.}
|
||||
{- [Info], condition that allows the program {e user} to get a better
|
||||
understanding of what the program is doing.}
|
||||
{- [Debug], condition that allows the program {e developer} to get a
|
||||
better understanding of what the program is doing.}}
|
||||
|
||||
{1:sync Note on synchronous logging}
|
||||
|
||||
In synchronous logging, a client call to a log function proceeds
|
||||
only once the reporter has finished the report operation. In
|
||||
[Logs] this depends both on the reporter and the log functions
|
||||
that the client uses.
|
||||
|
||||
Whenever the client uses a log function that results in a report,
|
||||
it gives the reporter a continuation that defines the result type
|
||||
of the log function and a callback to be called whenever the log
|
||||
operation is over from the reporter's perspective (see {!type:reporter}).
|
||||
The typical use of the callback is to unblock the continuation given
|
||||
to the reporter. This is used by {!Logs_lwt}'s log functions to make
|
||||
sure that the threads they return proceed only once the report is over.
|
||||
In the functions of {!Logs} however the callback does nothing as there
|
||||
is no way to block the polymorphic continuation.
|
||||
|
||||
Now considering reporters, at the extreme we have:
|
||||
{ul
|
||||
{- A completely asynchronous reporter. This reporter formats the
|
||||
message in memory and immediately invoke the callback followed
|
||||
by the continuation. This provides no guarantee of persistency
|
||||
in case a crash occurs. All log functions behave asynchronously
|
||||
and return as soon as possible.}
|
||||
{- A completely synchronous reporter. This reporter formats the
|
||||
message, persist it, invoke the client callback followed by the
|
||||
continuation. All log functions behave synchronously. An
|
||||
example of such a reporter is {!Logs_fmt.reporter} with
|
||||
formatters baked by channels: when formatting returns the
|
||||
message has been written on the channel.}}
|
||||
|
||||
However a purely synchronous reporter like {!Logs_fmt.reporter}
|
||||
acting on channels does not play well with [Lwt]'s cooperative
|
||||
runtime system. It is possible to reuse {!Logs_fmt.reporter} to
|
||||
define a cooperative reporter, see {{!Logs_lwt.report_ex}this
|
||||
example}. However while this reporter makes {!Logs_lwt}'s log
|
||||
functions synchronous, those of {!Logs} behave asynchronously. For
|
||||
now it seems it that this is unfortunately the best we can do if
|
||||
we want to preserve the ability to use [Logs] with or without
|
||||
cooperative concurency.
|
||||
|
||||
{1:ex1 Example with custom reporter and tags}
|
||||
|
||||
This example uses a {{!Tag}tag} to attach {!Mtime} time spans in
|
||||
log messages. The custom reporter uses these time spans to format
|
||||
relative timings for runs of a given function. Note that as done
|
||||
below the timings do include logging time.
|
||||
{[
|
||||
let stamp_tag : Mtime.span Logs.Tag.def =
|
||||
Logs.Tag.def "stamp" ~doc:"Relative monotonic time stamp" Mtime.Span.pp
|
||||
|
||||
let stamp c = Logs.Tag.(empty |> add stamp_tag (Mtime_clock.count c))
|
||||
|
||||
let run () =
|
||||
let rec wait n = if n = 0 then () else wait (n - 1) in
|
||||
let c = Mtime_clock.counter () in
|
||||
Logs.info (fun m -> m "Starting run");
|
||||
let delay1, delay2, delay3 = 10_000, 20_000, 40_000 in
|
||||
Logs.info (fun m -> m "Start action 1 (%d)." delay1 ~tags:(stamp c));
|
||||
wait delay1;
|
||||
Logs.info (fun m -> m "Start action 2 (%d)." delay2 ~tags:(stamp c));
|
||||
wait delay2;
|
||||
Logs.info (fun m -> m "Start action 3 (%d)." delay3 ~tags:(stamp c));
|
||||
wait delay3;
|
||||
Logs.info (fun m -> m "Done." ?header:None ~tags:(stamp c));
|
||||
()
|
||||
|
||||
let reporter ppf =
|
||||
let report src level ~over k msgf =
|
||||
let k _ = over (); k () in
|
||||
let with_stamp h tags k ppf fmt =
|
||||
let stamp = match tags with
|
||||
| None -> None
|
||||
| Some tags -> Logs.Tag.find stamp_tag tags
|
||||
in
|
||||
let dt = match stamp with None -> 0. | Some s -> Mtime.Span.to_us s in
|
||||
Format.kfprintf k ppf ("%a[%0+04.0fus] @[" ^^ fmt ^^ "@]@.")
|
||||
Logs.pp_header (level, h) dt
|
||||
in
|
||||
msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt
|
||||
in
|
||||
{ Logs.report = report }
|
||||
|
||||
let main () =
|
||||
Logs.set_reporter (reporter (Format.std_formatter));
|
||||
Logs.set_level (Some Logs.Info);
|
||||
run ();
|
||||
run ();
|
||||
if Logs.err_count () > 0 then 1 else 0
|
||||
|
||||
let () = if !Sys.interactive then () else main ()
|
||||
]}
|
||||
Here is the standard output of a sample run of the program:
|
||||
{v
|
||||
[INFO][+000us] Starting run
|
||||
[INFO][+168us] Start action 1 (10000).
|
||||
[INFO][+206us] Start action 2 (20000).
|
||||
[INFO][+243us] Start action 3 (40000).
|
||||
[INFO][+303us] Done.
|
||||
[INFO][+000us] Starting run
|
||||
[INFO][+012us] Start action 1 (10000).
|
||||
[INFO][+038us] Start action 2 (20000).
|
||||
[INFO][+074us] Start action 3 (40000).
|
||||
[INFO][+133us] Done.
|
||||
v}
|
||||
|
||||
{1:ex2 Logging to multiple reporters}
|
||||
|
||||
Logging to multiple reporters can be achieved by defining a new reporter
|
||||
that simply forwards to them. The following example combines
|
||||
two reporters:
|
||||
{[
|
||||
let combine r1 r2 =
|
||||
let report = fun src level ~over k msgf ->
|
||||
let v = r1.Logs.report src level ~over:(fun () -> ()) k msgf in
|
||||
r2.Logs.report src level ~over (fun () -> v) msgf
|
||||
in
|
||||
{ Logs.report }
|
||||
|
||||
let () =
|
||||
let r1 = Logs.format_reporter () in
|
||||
let r2 = Logs_fmt.reporter () in
|
||||
Fmt_tty.setup_std_outputs ();
|
||||
Logs.set_reporter (combine r1 r2);
|
||||
Logs.err (fun m -> m "HEY HO!");
|
||||
()
|
||||
]}
|
||||
*)
|
||||
8
unikernel/duniverse/logs/src/lwt/dune
Normal file
8
unikernel/duniverse/logs/src/lwt/dune
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
(library
|
||||
(name logs_lwt)
|
||||
(public_name logs.lwt)
|
||||
(libraries lwt logs)
|
||||
(modules logs_lwt)
|
||||
(flags :standard -w -27 -safe-string)
|
||||
(optional)
|
||||
(wrapped false))
|
||||
82
unikernel/duniverse/logs/src/lwt/logs_lwt.ml
Normal file
82
unikernel/duniverse/logs/src/lwt/logs_lwt.ml
Normal file
|
|
@ -0,0 +1,82 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
type 'a log = ('a, unit Lwt.t) Logs.msgf -> unit Lwt.t
|
||||
|
||||
let kmsg k ?(src = Logs.default) level msgf =
|
||||
begin match level with
|
||||
| Logs.Error -> Logs.incr_err_count ()
|
||||
| Logs.Warning -> Logs.incr_warn_count ()
|
||||
| _ -> ()
|
||||
end;
|
||||
match Logs.Src.level src with
|
||||
| None -> k ()
|
||||
| Some current_level when level > current_level -> k ()
|
||||
| Some _ ->
|
||||
let (ret, unblock) = Lwt.wait () in
|
||||
let k () = Lwt.bind ret k in
|
||||
let over () = Lwt.wakeup unblock () in
|
||||
Logs.report src level ~over k msgf
|
||||
|
||||
let kunit _ = Lwt.return ()
|
||||
let msg ?src level msgf = kmsg kunit ?src level msgf
|
||||
let app ?src msgf = kmsg kunit ?src Logs.App msgf
|
||||
let err ?src msgf = kmsg kunit ?src Logs.Error msgf
|
||||
let warn ?src msgf = kmsg kunit ?src Logs.Warning msgf
|
||||
let info ?src msgf = kmsg kunit ?src Logs.Info msgf
|
||||
let debug ?src msgf = kmsg kunit ?src Logs.Debug msgf
|
||||
|
||||
let on_error ?src ?(level = Logs.Error) ?header ?tags ~pp ~use t =
|
||||
Lwt.bind t @@ function
|
||||
| Ok v -> Lwt.return v
|
||||
| Error e ->
|
||||
kmsg (fun () -> use e) ?src level @@ fun m ->
|
||||
m ?header ?tags "@[%a@]" pp e
|
||||
|
||||
let on_error_msg ?src ?(level = Logs.Error) ?header ?tags ~use t =
|
||||
Lwt.bind t @@ function
|
||||
| Ok v -> Lwt.return v
|
||||
| Error (`Msg e) ->
|
||||
kmsg use ?src level @@ fun m ->
|
||||
m ?header ?tags "@[%a@]" Format.pp_print_text e
|
||||
|
||||
(* Source specific functions *)
|
||||
|
||||
module type LOG = sig
|
||||
val msg : Logs.level -> 'a log
|
||||
val app : 'a log
|
||||
val err : 'a log
|
||||
val warn : 'a log
|
||||
val info : 'a log
|
||||
val debug : 'a log
|
||||
val kmsg : ?over:(unit -> unit) -> (unit -> 'b Lwt.t) ->
|
||||
Logs.level -> ('a, 'b Lwt.t) Logs.msgf -> 'b Lwt.t
|
||||
|
||||
val on_error : ?level:Logs.level -> ?header:string -> ?tags:Logs.Tag.set ->
|
||||
pp:(Format.formatter -> 'b -> unit) -> use:('b -> 'a Lwt.t) ->
|
||||
('a, 'b) result Lwt.t -> 'a Lwt.t
|
||||
|
||||
val on_error_msg : ?level:Logs.level -> ?header:string ->
|
||||
?tags:Logs.Tag.set -> use:(unit -> 'a Lwt.t) ->
|
||||
('a, [`Msg of string]) result Lwt.t -> 'a Lwt.t
|
||||
end
|
||||
|
||||
let src_log src =
|
||||
let module Log = struct
|
||||
let msg level msgf = msg ~src level msgf
|
||||
let kmsg ?over k level msgf = kmsg k ~src level msgf
|
||||
let app msgf = msg Logs.App msgf
|
||||
let err msgf = msg Logs.Error msgf
|
||||
let warn msgf = msg Logs.Warning msgf
|
||||
let info msgf = msg Logs.Info msgf
|
||||
let debug msgf = msg Logs.Debug msgf
|
||||
let on_error ?level ?header ?tags ~pp ~use =
|
||||
on_error ~src ?level ?header ?tags ~pp ~use
|
||||
|
||||
let on_error_msg ?level ?header ?tags ~use =
|
||||
on_error_msg ~src ?level ?header ?tags ~use
|
||||
end
|
||||
in
|
||||
(module Log : LOG)
|
||||
129
unikernel/duniverse/logs/src/lwt/logs_lwt.mli
Normal file
129
unikernel/duniverse/logs/src/lwt/logs_lwt.mli
Normal file
|
|
@ -0,0 +1,129 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
(** {!Lwt} logging.
|
||||
|
||||
The log functions of this module return [Lwt] threads that proceed
|
||||
only when the log operation is over, as defined by the current
|
||||
{!Logs.reporter}.
|
||||
|
||||
See a {{!report_ex}cooperative reporter example}. *)
|
||||
|
||||
(** {1 Log functions} *)
|
||||
|
||||
type 'a log = ('a, unit Lwt.t) Logs.msgf -> unit Lwt.t
|
||||
(** The type for Lwt log functions. The returned thread only proceeds
|
||||
once the log operation is over. See {!Logs.log}. *)
|
||||
|
||||
val msg : ?src:Logs.src -> Logs.level -> 'a log
|
||||
(** See {!Logs.msg}. *)
|
||||
|
||||
val app : ?src:Logs.src -> 'a log
|
||||
(** See {!Logs.app}. *)
|
||||
|
||||
val err : ?src:Logs.src -> 'a log
|
||||
(** See {!Logs.err}. *)
|
||||
|
||||
val warn : ?src:Logs.src -> 'a log
|
||||
(** See {!Logs.warn}. *)
|
||||
|
||||
val info : ?src:Logs.src -> 'a log
|
||||
(** See {!Logs.info}. *)
|
||||
|
||||
val debug : ?src:Logs.src -> 'a log
|
||||
(** See {!Logs.debug}. *)
|
||||
|
||||
val kmsg : (unit -> 'b Lwt.t) -> ?src:Logs.src ->
|
||||
Logs.level -> ('a, 'b Lwt.t) Logs.msgf -> 'b Lwt.t
|
||||
(** See {!Logs.kmsg}. *)
|
||||
|
||||
(** {2 Logging {!result} value [Error]s} *)
|
||||
|
||||
val on_error : ?src:Logs.src -> ?level:Logs.level -> ?header:string ->
|
||||
?tags:Logs.Tag.set -> pp:(Format.formatter -> 'b -> unit) ->
|
||||
use:('b -> 'a Lwt.t) -> ('a, 'b) result Lwt.t -> 'a Lwt.t
|
||||
(** See {!Logs.on_error}. *)
|
||||
|
||||
val on_error_msg : ?src:Logs.src -> ?level:Logs.level -> ?header:string ->
|
||||
?tags:Logs.Tag.set -> use:(unit -> 'a Lwt.t) ->
|
||||
('a, [`Msg of string]) result Lwt.t -> 'a Lwt.t
|
||||
(** See {!Logs.on_error_msg}. *)
|
||||
|
||||
(** {1 Source specific log functions} *)
|
||||
|
||||
module type LOG = sig
|
||||
val msg : Logs.level -> 'a log
|
||||
(** See {!Logs.msg}. *)
|
||||
|
||||
val app : 'a log
|
||||
(** See {!Logs.app}. *)
|
||||
|
||||
val err : 'a log
|
||||
(** See {!Logs.err}. *)
|
||||
|
||||
val warn : 'a log
|
||||
(** See {!Logs.warn}. *)
|
||||
|
||||
val info : 'a log
|
||||
(** See {!Logs.info}. *)
|
||||
|
||||
val debug : 'a log
|
||||
(** See {!Logs.debug}. *)
|
||||
|
||||
val kmsg : ?over:(unit -> unit) -> (unit -> 'b Lwt.t) ->
|
||||
Logs.level -> ('a, 'b Lwt.t) Logs.msgf -> 'b Lwt.t
|
||||
(** See {!Logs.kmsg}. *)
|
||||
|
||||
(** {2 Logging {!result} value [Error]s} *)
|
||||
|
||||
val on_error : ?level:Logs.level -> ?header:string ->
|
||||
?tags:Logs.Tag.set -> pp:(Format.formatter -> 'b -> unit) ->
|
||||
use:('b -> 'a Lwt.t) -> ('a, 'b) result Lwt.t -> 'a Lwt.t
|
||||
(** See {!Logs.on_error}. *)
|
||||
|
||||
val on_error_msg : ?level:Logs.level -> ?header:string ->
|
||||
?tags:Logs.Tag.set -> use:(unit -> 'a Lwt.t) -> ('a, [`Msg of
|
||||
string]) result Lwt.t -> 'a Lwt.t
|
||||
(** See {!Logs.on_error_msg}. *)
|
||||
end
|
||||
|
||||
val src_log : Logs.src -> (module LOG)
|
||||
(** [src_log src] is a {{!LOG}set of logging functions} for [src]. *)
|
||||
|
||||
(** {1:report_ex Cooperative reporter example}
|
||||
|
||||
The following reporter will play nice with [Lwt]'s runtime, it
|
||||
will behave synchronously for the log functions of this module and
|
||||
asynchronously for those of the {!Logs} module (see {!Logs.sync}).
|
||||
|
||||
It reuses {!Logs_fmt.reporter} and will produce colorful output if
|
||||
the standard formatters are setup to do so. For example it can be
|
||||
used instead of {!Logs_fmt.reporter} in the {{!Logs_cli.ex}full
|
||||
setup example}.
|
||||
{[
|
||||
let lwt_reporter () =
|
||||
let buf_fmt ~like =
|
||||
let b = Buffer.create 512 in
|
||||
Fmt.with_buffer ~like b,
|
||||
fun () -> let m = Buffer.contents b in Buffer.reset b; m
|
||||
in
|
||||
let app, app_flush = buf_fmt ~like:Fmt.stdout in
|
||||
let dst, dst_flush = buf_fmt ~like:Fmt.stderr in
|
||||
let reporter = Logs_fmt.reporter ~app ~dst () in
|
||||
let report src level ~over k msgf =
|
||||
let k () =
|
||||
let write () = match level with
|
||||
| Logs.App -> Lwt_io.write Lwt_io.stdout (app_flush ())
|
||||
| _ -> Lwt_io.write Lwt_io.stderr (dst_flush ())
|
||||
in
|
||||
let unblock () = over (); Lwt.return_unit in
|
||||
Lwt.finalize write unblock |> Lwt.ignore_result;
|
||||
k ()
|
||||
in
|
||||
reporter.Logs.report src level ~over:(fun () -> ()) k msgf;
|
||||
in
|
||||
{ Logs.report = report }
|
||||
]}
|
||||
*)
|
||||
7
unikernel/duniverse/logs/src/threaded/dune
Normal file
7
unikernel/duniverse/logs/src/threaded/dune
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
(library
|
||||
(name logs_threaded)
|
||||
(public_name logs.threaded)
|
||||
(libraries logs threads)
|
||||
(modules logs_threaded)
|
||||
(flags :standard -w -27 -safe-string)
|
||||
(wrapped false))
|
||||
9
unikernel/duniverse/logs/src/threaded/logs_threaded.ml
Normal file
9
unikernel/duniverse/logs/src/threaded/logs_threaded.ml
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2019 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
let enable () =
|
||||
let lock = Mutex.create () in
|
||||
let lock () = Mutex.lock lock and unlock () = Mutex.unlock lock in
|
||||
Logs.set_reporter_mutex ~lock ~unlock
|
||||
11
unikernel/duniverse/logs/src/threaded/logs_threaded.mli
Normal file
11
unikernel/duniverse/logs/src/threaded/logs_threaded.mli
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2019 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
(** Thread safe logging. *)
|
||||
|
||||
val enable : unit -> unit
|
||||
(** [enable ()] enables thread safe logging for OCaml {!Thread}s by
|
||||
installing mutual exclusion primitives via
|
||||
{!Logs.set_reporter_mutex}. *)
|
||||
6
unikernel/duniverse/logs/src/top/dune
Normal file
6
unikernel/duniverse/logs/src/top/dune
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
(library
|
||||
(name logs_top)
|
||||
(public_name logs.top)
|
||||
(libraries compiler-libs.toplevel logs)
|
||||
(modules logs_top)
|
||||
(wrapped false))
|
||||
6
unikernel/duniverse/logs/src/top/logs_top.ml
Normal file
6
unikernel/duniverse/logs/src/top/logs_top.ml
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
let () = ignore (Toploop.use_file Format.err_formatter "logs_top_init.ml")
|
||||
9
unikernel/duniverse/logs/src/top/logs_top_init.ml
Normal file
9
unikernel/duniverse/logs/src/top/logs_top_init.ml
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
let () =
|
||||
Logs.set_level (Some Logs.Debug);
|
||||
Logs.set_reporter (Logs.format_reporter ());
|
||||
()
|
||||
50
unikernel/duniverse/logs/test/tags.ml
Normal file
50
unikernel/duniverse/logs/test/tags.ml
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
(* This code is in the public domain. *)
|
||||
|
||||
(* Example with tags and custom reporter. *)
|
||||
|
||||
let stamp_tag : Mtime.span Logs.Tag.def =
|
||||
Logs.Tag.def "stamp" ~doc:"Relative monotonic time stamp" Mtime.Span.pp
|
||||
|
||||
let stamp c = Logs.Tag.(empty |> add stamp_tag (Mtime_clock.count c))
|
||||
|
||||
let run () =
|
||||
let rec wait n = if n = 0 then () else wait (n - 1) in
|
||||
let c = Mtime_clock.counter () in
|
||||
Logs.info (fun m -> m "Starting run");
|
||||
let delay1, delay2, delay3 = 10_000, 20_000, 40_000 in
|
||||
Logs.info (fun m -> m "Start action 1 (%d)." delay1 ~tags:(stamp c));
|
||||
wait delay1;
|
||||
Logs.info (fun m -> m "Start action 2 (%d)." delay2 ~tags:(stamp c));
|
||||
wait delay2;
|
||||
Logs.info (fun m -> m "Start action 3 (%d)." delay3 ~tags:(stamp c));
|
||||
wait delay3;
|
||||
Logs.info (fun m -> m "Done." ?header:None ~tags:(stamp c));
|
||||
()
|
||||
|
||||
let reporter ppf =
|
||||
let report src level ~over k msgf =
|
||||
let k _ = over (); k () in
|
||||
let with_stamp h tags k ppf fmt =
|
||||
let stamp = match tags with
|
||||
| None -> None
|
||||
| Some tags -> Logs.Tag.find stamp_tag tags
|
||||
in
|
||||
let dt = match stamp with
|
||||
| None -> 0.
|
||||
| Some s -> Mtime.Span.to_float_ns s *. 1000.
|
||||
in
|
||||
Format.kfprintf k ppf ("%a[%0+4.0fus] @[" ^^ fmt ^^ "@]@.")
|
||||
Logs.pp_header (level, h) dt
|
||||
in
|
||||
msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt
|
||||
in
|
||||
{ Logs.report = report }
|
||||
|
||||
let main () =
|
||||
Logs.set_reporter (reporter (Format.std_formatter));
|
||||
Logs.set_level (Some Logs.Info);
|
||||
run ();
|
||||
run ();
|
||||
()
|
||||
|
||||
let () = main ()
|
||||
21
unikernel/duniverse/logs/test/test_browser.ml
Normal file
21
unikernel/duniverse/logs/test/test_browser.ml
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
open Js_of_ocaml
|
||||
|
||||
let main _ =
|
||||
Logs.set_level @@ Some Logs.Debug;
|
||||
Logs.set_reporter @@ Logs_browser.console_reporter ();
|
||||
Logs.info (fun m -> m ~header:"START" ?tags:None "Starting main");
|
||||
Logs.warn (fun m -> m "Hey be warned by %d." 7);
|
||||
Logs.err (fun m -> m "Hey be errored.");
|
||||
Logs.debug (fun m -> m "Would you mind to be debugged a bit ?");
|
||||
Logs.app (fun m -> m "This is for the application console or stdout.");
|
||||
Logs.app (fun m -> m ~header:"HEAD" "Idem but with a header");
|
||||
Logs.err (fun m -> m "NO CARRIER");
|
||||
Logs.info (fun m -> m "Ending main");
|
||||
Js._false
|
||||
|
||||
let () = Js.Unsafe.set Dom_html.window "onload" (Dom_html.handler main)
|
||||
25
unikernel/duniverse/logs/test/test_count.ml
Normal file
25
unikernel/duniverse/logs/test/test_count.ml
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2025 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
open B0_testing
|
||||
|
||||
let test_count =
|
||||
Test.test "Logs.{err,warn}_count" @@ fun () ->
|
||||
let logit () =
|
||||
Logs.warn (fun m -> m "Hey");
|
||||
Logs.err (fun m -> m "Ho");
|
||||
Logs.warn (fun m -> m "Let's go");
|
||||
in
|
||||
logit ();
|
||||
Test.int (Logs.err_count ()) 1 ~__POS__;
|
||||
Test.int (Logs.warn_count ()) 2 ~__POS__;
|
||||
Logs.set_level None;
|
||||
logit ();
|
||||
Test.int (Logs.err_count ()) 2 ~__POS__;
|
||||
Test.int (Logs.warn_count ()) 4 ~__POS__;
|
||||
()
|
||||
|
||||
let main () = Test.main @@ fun () -> Test.autorun ()
|
||||
let () = if !Sys.interactive then () else exit (main ())
|
||||
36
unikernel/duniverse/logs/test/test_fmt.ml
Normal file
36
unikernel/duniverse/logs/test/test_fmt.ml
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
let pp_key = Format.pp_print_string
|
||||
let pp_val = Format.pp_print_string
|
||||
|
||||
|
||||
let err_invalid_kv args =
|
||||
Logs.err @@ fun m ->
|
||||
args (fun k v -> m "invalid kv (%a,%a)" pp_key k pp_val v)
|
||||
|
||||
let err_no_carrier args =
|
||||
Logs.err @@ fun m -> args (m "NO CARRIER")
|
||||
|
||||
let main () =
|
||||
Fmt_tty.setup_std_outputs ();
|
||||
Logs.set_level @@ Some Logs.Debug;
|
||||
Logs.set_reporter @@ Logs_fmt.reporter ();
|
||||
Logs.info (fun m -> m ~header:"START" ?tags:None "Starting main");
|
||||
Logs.warn (fun m -> m "Hey be warned by %d." 7);
|
||||
Logs.err (fun m -> m "Hey be errored.");
|
||||
Logs.debug (fun m -> m "Would you mind to be debugged a bit ?");
|
||||
Logs.app (fun m -> m "This is for the application console or stdout.");
|
||||
Logs.app (fun m -> m ~header:"HEAD" "Idem but with a header");
|
||||
let k = "key" in
|
||||
let v = "value" in
|
||||
Logs.err (fun m -> m "invalid kv (%a,%a)" pp_key k pp_val v);
|
||||
Logs.err (fun m -> m "NO CARRIER");
|
||||
err_invalid_kv (fun args -> args k v);
|
||||
err_no_carrier (fun () -> ());
|
||||
Logs.info (fun m -> m "Ending main");
|
||||
exit (if (Logs.err_count () > 0) then 1 else 0)
|
||||
|
||||
let () = main ()
|
||||
33
unikernel/duniverse/logs/test/test_formatter.ml
Normal file
33
unikernel/duniverse/logs/test/test_formatter.ml
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2016 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
let pp_key = Format.pp_print_string
|
||||
let pp_val = Format.pp_print_string
|
||||
|
||||
let err_invalid_kv args =
|
||||
Logs.err @@ fun m ->
|
||||
args (fun k v -> m "invalid kv (%a,%a)" pp_key k pp_val v)
|
||||
|
||||
let err_no_carrier args =
|
||||
Logs.err @@ fun m -> args (m "NO CARRIER")
|
||||
|
||||
let main () =
|
||||
Logs.set_level @@ Some Logs.Debug;
|
||||
Logs.set_reporter @@ Logs.format_reporter ();
|
||||
Logs.info (fun m -> m ~header:"START" ?tags:None "Starting main");
|
||||
Logs.warn (fun m -> m "Hey be warned by %d." 7);
|
||||
Logs.err (fun m -> m "Hey be errored.");
|
||||
Logs.debug (fun m -> m "Would you mind to be debugged a bit ?");
|
||||
Logs.app (fun m -> m "This is for the application console or stdout.");
|
||||
let k = "key" in
|
||||
let v = "value" in
|
||||
Logs.err (fun m -> m "invalid kv (%a,%a)" pp_key k pp_val v);
|
||||
Logs.err (fun m -> m "NO CARRIER");
|
||||
err_invalid_kv (fun args -> args k v);
|
||||
err_no_carrier (fun () -> ());
|
||||
Logs.info (fun m -> m "Ending main");
|
||||
if (Logs.err_count () > 0) then 1 else 0
|
||||
|
||||
let () = if !Sys.interactive then () else exit (main ())
|
||||
62
unikernel/duniverse/logs/test/test_lwt.ml
Normal file
62
unikernel/duniverse/logs/test/test_lwt.ml
Normal file
|
|
@ -0,0 +1,62 @@
|
|||
(*---------------------------------------------------------------------------
|
||||
Copyright (c) 2015 The logs programmers. All rights reserved.
|
||||
SPDX-License-Identifier: ISC
|
||||
---------------------------------------------------------------------------*)
|
||||
|
||||
open B0_testing
|
||||
|
||||
let ( >>= ) = Lwt.bind
|
||||
|
||||
let lwt_reporter () =
|
||||
let buf_fmt ~like =
|
||||
let b = Buffer.create 512 in
|
||||
Fmt.with_buffer ~like b,
|
||||
fun () -> let m = Buffer.contents b in Buffer.reset b; m
|
||||
in
|
||||
let app, app_flush = buf_fmt ~like:Fmt.stdout in
|
||||
let dst, dst_flush = buf_fmt ~like:Fmt.stderr in
|
||||
let reporter = Logs_fmt.reporter ~app ~dst () in
|
||||
let report src level ~over k msgf =
|
||||
let k () =
|
||||
let write () = match level with
|
||||
| Logs.App -> Lwt_io.write Lwt_io.stdout (app_flush ())
|
||||
| _ -> Lwt_io.write Lwt_io.stderr (dst_flush ())
|
||||
in
|
||||
let unblock () = over (); Lwt.return_unit in
|
||||
Lwt.finalize write unblock |> Lwt.ignore_result;
|
||||
k ()
|
||||
in
|
||||
reporter.Logs.report src level ~over:(fun () -> ()) k msgf;
|
||||
in
|
||||
{ Logs.report = report }
|
||||
|
||||
let test_count () =
|
||||
let logit () =
|
||||
Logs_lwt.warn (fun m -> m "Hey") >>= fun () ->
|
||||
Logs_lwt.err (fun m -> m "Ho") >>= fun () ->
|
||||
Logs_lwt.warn (fun m -> m "Let's go")
|
||||
in
|
||||
Test.int (Logs.err_count ()) 1 ~__POS__;
|
||||
Test.int (Logs.warn_count ()) 1 ~__POS__;
|
||||
Logs.set_level None;
|
||||
logit () >>= fun () ->
|
||||
Test.int (Logs.err_count ()) 2 ~__POS__;
|
||||
Test.int (Logs.warn_count ()) 3 ~__POS__;
|
||||
Lwt.return_unit
|
||||
|
||||
let main () =
|
||||
Test.main @@ fun () ->
|
||||
Fmt_tty.setup_std_outputs ();
|
||||
Logs.set_reporter @@ lwt_reporter ();
|
||||
Lwt_main.run @@ begin
|
||||
Logs.set_level (Some Logs.Debug);
|
||||
Logs_lwt.info (fun m -> m ~header:"START" ?tags:None "Starting main")
|
||||
>>= fun () -> Logs_lwt.warn (fun m -> m "Hey be warned by %d." 7)
|
||||
>>= fun () -> Logs_lwt.err (fun m -> m "Hey be errored.")
|
||||
>>= fun () -> Logs_lwt.debug (fun m -> m "Be debugged a bit ?")
|
||||
>>= fun () -> Logs_lwt.app (fun m -> m "Application console or stdout.")
|
||||
>>= fun () -> Logs_lwt.info (fun m -> m "Ending main")
|
||||
>>= fun () -> test_count ()
|
||||
end
|
||||
|
||||
let () = if !Sys.interactive then () else exit (main ())
|
||||
18
unikernel/duniverse/logs/test/test_multi.ml
Normal file
18
unikernel/duniverse/logs/test/test_multi.ml
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
(* This code is in the public domain. *)
|
||||
|
||||
(* Example for installing multiple reporters. *)
|
||||
|
||||
let combine r1 r2 =
|
||||
let report = fun src level ~over k msgf ->
|
||||
let v = r1.Logs.report src level ~over:(fun () -> ()) k msgf in
|
||||
r2.Logs.report src level ~over (fun () -> v) msgf
|
||||
in
|
||||
{ Logs.report }
|
||||
|
||||
let () =
|
||||
let r1 = Logs.format_reporter () in
|
||||
let r2 = Logs_fmt.reporter () in
|
||||
Fmt_tty.setup_std_outputs ();
|
||||
Logs.set_reporter (combine r1 r2);
|
||||
Logs.err (fun m -> m "HEY HO!");
|
||||
()
|
||||
14
unikernel/duniverse/logs/test/test_threaded.ml
Normal file
14
unikernel/duniverse/logs/test/test_threaded.ml
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
let loop s =
|
||||
for _ = 0 to 10 do
|
||||
Logs.info (fun f -> f "%s.%s" s s)
|
||||
done
|
||||
|
||||
let () =
|
||||
Logs_threaded.enable ();
|
||||
Logs.set_level (Some Logs.Debug);
|
||||
Logs.set_reporter (Logs_fmt.reporter ());
|
||||
let t1 = Thread.create loop "aaaa" in
|
||||
let t2 = Thread.create loop "bbbb" in
|
||||
loop "cccc";
|
||||
Thread.join t1;
|
||||
Thread.join t2
|
||||
7
unikernel/duniverse/logs/test/tests.itarget
Normal file
7
unikernel/duniverse/logs/test/tests.itarget
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
test_fmt.native
|
||||
test_formatter.native
|
||||
tool.native
|
||||
tags.native
|
||||
test_browser.html
|
||||
test_browser.byte
|
||||
test_lwt.native
|
||||
34
unikernel/duniverse/logs/test/tool.ml
Normal file
34
unikernel/duniverse/logs/test/tool.ml
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
(* This code is in the public domain. *)
|
||||
|
||||
(* Example setup for a simple command line tool with colorful output. *)
|
||||
|
||||
let hello _ msg =
|
||||
Logs.app (fun m -> m "%s" msg);
|
||||
Logs.info (fun m -> m "End-user information.");
|
||||
Logs.debug (fun m -> m "Developer information.");
|
||||
Logs.err (fun m -> m "Something bad happened.");
|
||||
Logs.warn (fun m -> m "Something bad may happen in the future.");
|
||||
if Logs.err_count () > 0 then 1 else 0
|
||||
|
||||
let setup_log style_renderer level =
|
||||
Fmt_tty.setup_std_outputs ?style_renderer ();
|
||||
Logs.set_level level;
|
||||
Logs.set_reporter (Logs_fmt.reporter ())
|
||||
|
||||
(* Command line interface *)
|
||||
|
||||
open Cmdliner
|
||||
|
||||
let setup_log =
|
||||
let env = Cmd.Env.info "TOOL_VERBOSITY" in
|
||||
Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ~env ())
|
||||
|
||||
let msg =
|
||||
let doc = "The message to output." in
|
||||
Arg.(value & pos 0 string "Hello horrible world!" & info [] ~doc)
|
||||
|
||||
let main () =
|
||||
let cmd = Cmd.v (Cmd.info "tool") Term.(const hello $ setup_log $ msg) in
|
||||
Cmd.eval' cmd
|
||||
|
||||
let () = if !Sys.interactive then () else exit (main ())
|
||||
Loading…
Add table
Add a link
Reference in a new issue