mirage · Apr 20, 2016 · Apr 27, 2016 · Apr 27, 2016 · Apr 27, 2016 · Apr 27, 2016
diff --git a/.merlin b/.merlin
@@ -3,7 +3,7 @@ S lib/*
 S lib_runtime/*
 S lib_test/*
 PKG ipaddr unix dynlink lwt cmdliner mirage-types.lwt functoria rresult fmt
-PKG astring
+PKG astring logs
 
 FLG -w +A-4-6-7-9-40-42-44-48
 FLG -strict_sequence -safe_string
diff --git a/.travis.yml b/.travis.yml
@@ -4,7 +4,7 @@ install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/ma
 script: bash -ex .travis-ci.sh
 env:
   global:
-          - PINS="mirage-skeleton.dev:https://github.com/yomimono/mirage-skeleton.git#charrua-0.3 tcpip:https://github.com/mirage/mirage-tcpip.git mirage-types:https://github.com/mirage/mirage.git mirage:https://github.com/mirage/mirage.git"
+  - PINS="functoria mirage-skeleton.dev:https://github.com/yomimono/mirage-skeleton.git#dev mirage-types:https://github.com/mirage/mirage.git mirage:https://github.com/mirage/mirage.git mirage-logs:https://github.com/sammoht/mirage-logs.git"
   matrix:
   - UPDATE_GCC_BINUTILS=1 OCAML_VERSION=4.02 PACKAGE=mirage
   - UPDATE_GCC_BINUTILS=1 OCAML_VERSION=4.02 PACKAGE=mirage-types
diff --git a/_oasis b/_oasis
@@ -12,15 +12,15 @@ Library "mirage-runtime"
   Findlibparent:      mirage
   Findlibname:        runtime
   Modules:            Mirage_runtime, Mirage_info
-  BuildDepends:       functoria.runtime, ipaddr, astring
+  BuildDepends:       functoria.runtime, ipaddr, astring, logs
 
 Library mirage
   CompiledObject:     best
   Path:               lib
   Findlibname:        mirage
   Modules:            Mirage, Mirage_key
   InternalModules:    Mirage_version
-  BuildDepends:       ipaddr, functoria, mirage.runtime, functoria.app
+  BuildDepends:       ipaddr, functoria, mirage.runtime, functoria.app, logs
 
 Executable mirage
   CompiledObject:     best

diff --git a/_tags b/_tags
@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 4e91f4fbdf06d99d4c740d67793a5f80)
+# DO NOT EDIT (digest: 1a42a65f41f3b4dd1e37a462f0e017cf)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -19,6 +19,7 @@ true: annot, bin_annot
 <lib_runtime/*.ml{,i,y}>: pkg_astring
 <lib_runtime/*.ml{,i,y}>: pkg_functoria.runtime
 <lib_runtime/*.ml{,i,y}>: pkg_ipaddr
+<lib_runtime/*.ml{,i,y}>: pkg_logs
 # Library mirage
 "lib/mirage.cmxs": use_mirage
 # Executable mirage
@@ -27,13 +28,15 @@ true: annot, bin_annot
 <lib/main.{native,byte}>: pkg_functoria.app
 <lib/main.{native,byte}>: pkg_functoria.runtime
 <lib/main.{native,byte}>: pkg_ipaddr
+<lib/main.{native,byte}>: pkg_logs
 <lib/main.{native,byte}>: use_mirage
 <lib/main.{native,byte}>: use_mirage-runtime
 <lib/*.ml{,i,y}>: pkg_astring
 <lib/*.ml{,i,y}>: pkg_functoria
 <lib/*.ml{,i,y}>: pkg_functoria.app
 <lib/*.ml{,i,y}>: pkg_functoria.runtime
 <lib/*.ml{,i,y}>: pkg_ipaddr
+<lib/*.ml{,i,y}>: pkg_logs
 <lib/*.ml{,i,y}>: use_mirage
 <lib/*.ml{,i,y}>: use_mirage-runtime
 # OASIS_STOP

diff --git a/lib/META b/lib/META
@@ -1,8 +1,8 @@
 # OASIS_START
-# DO NOT EDIT (digest: 371d216c898653b3bb6e1e62ec252d5a)
+# DO NOT EDIT (digest: ab220cb895cf759b43882124f815d3d4)
 version = "2.8.0"
 description = "Mirage configuration tool"
-requires = "ipaddr functoria mirage.runtime functoria.app"
+requires = "ipaddr functoria mirage.runtime functoria.app logs"
 archive(byte) = "mirage.cma"
 archive(byte, plugin) = "mirage.cma"
 archive(native) = "mirage.cmxa"
@@ -11,7 +11,7 @@ exists_if = "mirage.cma"
 package "runtime" (
  version = "2.8.0"
  description = "Mirage configuration tool"
- requires = "functoria.runtime ipaddr astring"
+ requires = "functoria.runtime ipaddr astring logs"
  archive(byte) = "mirage-runtime.cma"
  archive(byte, plugin) = "mirage-runtime.cma"
  archive(native) = "mirage-runtime.cmxa"

diff --git a/lib/mirage.ml b/lib/mirage.ml
@@ -949,9 +949,68 @@ let argv_xen = impl @@ object
 
 let argv_dynamic = if_impl Key.is_xen argv_xen argv_unix
 
+(** Log reporting *)
+
+type reporter = job
+let reporter = job
+
+let pp_level ppf = function
+  | Logs.Error    -> Fmt.string ppf "Logs.Error"
+  | Logs.Warning  -> Fmt.string ppf "Logs.Warning"
+  | Logs.Info     -> Fmt.string ppf "Logs.Info"
+  | Logs.Debug    -> Fmt.string ppf "Logs.Debug"
+  | Logs.App      -> Fmt.string ppf "Logs.App"
+
+let mirage_log ?ring_size ~default =
+  let logs = Key.logs in
+  impl @@ object
+    inherit base_configurable
+    method ty = clock @-> reporter
+    method name = "mirage_logs"
+    method module_name = "Mirage_logs.Make"
+    method packages = Key.pure ["mirage-logs"]
+    method libraries = Key.pure ["mirage-logs"]
+    method keys = [ Key.abstract logs ]
+    method connect info modname _ =
+      let pp_console_threshold ppf () =
+        match Key.get (Info.context info) logs with
+        | [] -> Fmt.string ppf "None"
+        | _  ->
+          Fmt.pf ppf "Some (Mirage_runtime.threshold ~default:%a %a)"
+            pp_level default pp_key logs
+      in
+      let pp_ring_buffer ppf () =
+        match ring_size with
+        | None   -> Fmt.string ppf "None"
+        | Some i -> Fmt.pf ppf "Some %d" i
+      in
+      Fmt.strf
+        "@[<v 2>\
+         let console_threshold =@,@[<v 2>%a@]@,in@ \
+         let ring_size = %a in@ \
+         let reporter = %s.create ?ring_size ?console_threshold () in@ \
+         let level = match %a with@ \
+        \  | [] -> None@ \
+        \  | l  -> Some (Mirage_runtime.log_level l)@ \
+         in@ \
+         Logs.set_level level;@ \
+         %s.set_reporter reporter;@ \
+         Lwt.return (`Ok ())"
+        pp_console_threshold ()
+        pp_ring_buffer ()
+        modname
+        pp_key logs
+        modname
+  end
+
+let default_reporter
+    ?(clock=default_clock) ?ring_size ?(level=Logs.Warning) () =
+  mirage_log ?ring_size ~default:level $ clock
+
 (** Tracing *)
 
-type tracing = job impl
+type tracing = job
+let tracing = job
 
 let mprof_trace ~size () =
   let unix_trace_file = "trace.ctf" in
@@ -1470,7 +1529,7 @@ module Project = struct
     "open Lwt\n\
      let run = OS.Main.run"
   let driver_error = driver_error
-  let argv = argv_dynamic
+  let init = [Functoria_app.keys argv_dynamic]
 
   let create jobs = impl @@ object
       inherit base_configurable
@@ -1503,6 +1562,18 @@ end
 
 include Functoria_app.Make (Project)
 
+let in_parallel = function
+  | [singleton] -> singleton
+  | jobs ->
+    impl @@ object
+      inherit base_configurable
+      method ty = job
+      method name = "group"
+      method module_name = "Functoria_runtime"
+      method connect _ _mod _names = "Lwt.return (`Ok ())"
+      method deps = List.map abstract jobs
+    end
+
 (** {Deprecated functions} *)
 
 let get_mode () = Key.(get (get_base_context ()) target)
@@ -1517,12 +1588,17 @@ let add_to_opam_packages l =
 
 (** {Custom registration} *)
 
-let register ?tracing ?keys ?(libraries=[]) ?(packages=[]) name jobs =
+let register
+    ?tracing ?(reporter=Some (default_reporter ()))
+    ?keys ?(libraries=[]) ?(packages=[])
+    name jobs =
   let libraries = !libraries_ref @ libraries in
   let packages = !packages_ref @ packages in
-  let jobs = match tracing with
-    | None -> jobs
-    | Some tracing ->
-      tracing :: jobs
+  let jobs = in_parallel jobs in
+  let jobs = match reporter, tracing with
+    | None  , None   -> [jobs]
+    | None  , Some t -> [t; jobs]
+    | Some r, None   -> [r; jobs]
+    | Some r, Some t -> [r; t; jobs]
   in
   register ?keys ~libraries ~packages name jobs
diff --git a/lib/mirage.mli b/lib/mirage.mli
@@ -30,29 +30,16 @@ include Functoria_app.DSL
 (** {2 General mirage devices} *)
 
 type tracing
+(** The type for tracing. *)
 
-val mprof_trace : size:int -> unit -> tracing
-(** Use mirage-profile to trace the unikernel.
-    On Unix, this creates and mmaps a file called "trace.ctf".
-    On Xen, it shares the trace buffer with dom0.
-    @param size: size of the ring buffer to use
-*)
-
-(** {3 Application registering} *)
+val tracing: tracing typ
+(** Implementation of the {!tracing} type. *)
 
-val register :
-  ?tracing:tracing ->
-  ?keys:Key.t list ->
-  ?libraries:string list ->
-  ?packages:string list -> string -> job impl list -> unit
-(** [register name jobs] registers the application named by [name]
-    which will executes the given [jobs].
-    @param libraries The ocamlfind libraries needed by this module.
-    @param packages The opam packages needed by this module.
-    @param keys The keys related to this module.
+val mprof_trace : size:int -> unit -> tracing impl
+(** Use mirage-profile to trace the unikernel. On Unix, this creates
+    and mmaps a file called "trace.ctf". On Xen, it shares the trace
+    buffer with dom0.  @param size: size of the ring buffer to use. *)
 
-    @param tracing Enable tracing and give a default depth.
-*)
 
 
 (** {2 Time} *)
@@ -81,6 +68,25 @@ val default_clock: clock impl
 
 
 
+(** {2 Log reporters} *)
+
+type reporter
+(** The type for log reporters. *)
+
+val reporter: reporter typ
+(** Implementation of the log {!reporter} type. *)
+
+val default_reporter:
+  ?clock:clock impl -> ?ring_size:int -> ?level:Logs.level ->
+  unit -> reporter impl
+(** [default_reporter ?clock ?level ()] is the log reporter that
+    prints log messages to the console, timestampted with [clock]. If
+    not provided, the default clock is {!default_clock]}. [level] is
+    the default log threshold. It is [Logs.Warning] is not
+    specified. *)
+
+
+
 (** {2 Random} *)
 
 type random
@@ -93,6 +99,7 @@ val default_random: random impl
 (** Passthrough to the OCaml Random generator. *)
 
 
+
 (** {2 Consoles} *)
 
 type console
@@ -432,6 +439,28 @@ val add_to_ocamlfind_libraries : string list -> unit
     @deprecated Use the [~libraries] argument from {!register}.
 *)
 
+
+(** {2 Application registering} *)
+
+val register :
+  ?tracing:tracing impl ->
+  ?reporter:reporter impl option ->
+  ?keys:Key.t list ->
+  ?libraries:string list ->
+  ?packages:string list -> string -> job impl list -> unit
+(** [register name jobs] registers the application named by [name]
+    which will executes the given [jobs].
+    @param libraries The ocamlfind libraries needed by this module.
+    @param packages The opam packages needed by this module.
+    @param keys The keys related to this module.
+
+    @param tracing Enable tracing.
+
+    @param reporter Configure logging. The default log reporter is
+    [Some {!default_reporter}]. To disable logging, use the [None].
+*)
+
+
 (**/**)
 
 val run : unit -> unit
diff --git a/lib/mirage_key.ml b/lib/mirage_key.ml
@@ -264,6 +264,39 @@ module V6 = struct
 
 end
 
+let pp_level ppf = function
+  | Logs.Error    -> Fmt.string ppf "Logs.Error"
+  | Logs.Warning  -> Fmt.string ppf "Logs.Warning"
+  | Logs.Info     -> Fmt.string ppf "Logs.Info"
+  | Logs.Debug    -> Fmt.string ppf "Logs.Debug"
+  | Logs.App      -> Fmt.string ppf "Logs.App"
+
+let pp_pattern ppf = function
+  | `All   -> Fmt.string ppf "`All"
+  | `Src s -> Fmt.pf ppf "`Src %S" s
+
+let pp_threshold ppf (pattern, level) =
+  Fmt.pf ppf "(%a,@ %a)" pp_pattern pattern pp_level level
+
+let logs =
+  let env = "MIRAGE_LOGS" in
+  let docs = unikernel_section in
+  let conv = Cmdliner.Arg.list Mirage_runtime.Arg.log_threshold in
+  let serialize ppf levels =
+    Fmt.(pf ppf "[%a]" (list ~sep:(const string ";@ ") pp_threshold) levels)
+  in
+  let runtime_conv = "(Cmdliner.Arg.list Mirage_runtime.Arg.log_threshold)" in
+  let doc =
+    strf "Be more or less verbose. $(docv) must be of the form@ \
+          $(b,*:info,foo:debug) means that that the log threshold is set to@ \
+          $(b,info) for every log sources but the $(b,foo) which is set to@ \
+          $(b,debug)."
+  in
+  let logs = Key.Arg.conv ~conv ~serialize ~runtime_conv in
+  let info = Key.Arg.info ~env ~docv:"LEVEL" ~doc ~docs ["l";"logs"] in
+  let arg = Key.Arg.(opt logs []) info in
+  Key.create "logs" arg
+
 (* FIXME: this is a crazy *)
 include (Key: module type of struct include Functoria_key end
          with module Arg := Arg and module Alias := Alias)
diff --git a/lib/mirage_key.mli b/lib/mirage_key.mli
@@ -121,3 +121,5 @@ module V6 : sig
   (** A list of gateways. *)
 
 end
+
+val logs: Mirage_runtime.log_threshold list key
Original file line number	Diff line number	Diff line change
		@@ -121,3 +121,5 @@ module V6 : sig
		(** A list of gateways. *)

		end

		val logs: Mirage_runtime.log_threshold list key