Skip to content

Commit

Permalink
Merge e7d10bc into 7060017
Browse files Browse the repository at this point in the history
  • Loading branch information
Jon Ludlam committed Mar 28, 2017
2 parents 7060017 + e7d10bc commit c11fbe8
Show file tree
Hide file tree
Showing 19 changed files with 1,949 additions and 126 deletions.
11 changes: 9 additions & 2 deletions _oasis
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,13 @@ Library xcp
CSources: syslog_stubs.c
BuildDepends: cmdliner, uri, re, cohttp, xmlm, unix, ppx_sexp_conv, sexplib, ppx_deriving_rpc, rpclib, rpclib.xml, threads, message_switch (>= 0.11.0), message_switch.unix, fd-send-recv, xcp-inventory, xapi-backtrace

Library xcp_updates
CompiledObject: best
Path: lib
Findlibname: updates
Findlibparent: xcp
Modules: Updates, Task_server, Scheduler

Library xcp_storage
CompiledObject: best
Path: storage
Expand Down Expand Up @@ -84,10 +91,10 @@ Executable lib_test
MainIs: test.ml
Custom: true
Install: false
BuildDepends: lwt, lwt.unix, xcp, xcp.xen, threads, rpclib, oUnit
BuildDepends: lwt, lwt.unix, xcp, xcp.xen, threads, rpclib, oUnit, xcp.updates

Test lib_test
Command: ./test.native
Command: ./test.native -runner sequential
Run: true

Executable example
Expand Down
6 changes: 5 additions & 1 deletion _tags
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 84bd6ed57b3561ce9ac6edd2793b3d1b)
# DO NOT EDIT (digest: 602453b3fb6b3d0b87012f531fd91c7d)
# 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
Expand Down Expand Up @@ -34,6 +34,8 @@ true: annot, bin_annot
"lib/syslog_stubs.c": pkg_xapi-backtrace
"lib/syslog_stubs.c": pkg_xcp-inventory
"lib/syslog_stubs.c": pkg_xmlm
# Library xcp_updates
"lib/xcp_updates.cmxs": use_xcp_updates
# Library xcp_storage
"storage/xcp_storage.cmxs": use_xcp_storage
# Executable storage_test
Expand Down Expand Up @@ -242,6 +244,7 @@ true: annot, bin_annot
<lib_test/test.{native,byte}>: pkg_xcp-inventory
<lib_test/test.{native,byte}>: pkg_xmlm
<lib_test/test.{native,byte}>: use_xcp
<lib_test/test.{native,byte}>: use_xcp_updates
<lib_test/test.{native,byte}>: use_xcp_xen
<lib_test/*.ml{,i,y}>: pkg_cmdliner
<lib_test/*.ml{,i,y}>: pkg_cohttp
Expand All @@ -264,6 +267,7 @@ true: annot, bin_annot
<lib_test/*.ml{,i,y}>: pkg_xcp-inventory
<lib_test/*.ml{,i,y}>: pkg_xmlm
<lib_test/*.ml{,i,y}>: use_xcp
<lib_test/*.ml{,i,y}>: use_xcp_updates
<lib_test/*.ml{,i,y}>: use_xcp_xen
<lib_test/test.{native,byte}>: custom
# Executable example
Expand Down
13 changes: 12 additions & 1 deletion lib/META
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: d61b4e5a5c0d213787a9ffd3db8cee24)
# DO NOT EDIT (digest: 8768846be18e97edf6faf163a4fb6e66)
version = "1.2.0"
description =
"Interface definitions and common boilerplate for the xapi toolstack"
Expand Down Expand Up @@ -34,6 +34,17 @@ package "v6" (
exists_if = "xapi_v6.cma"
)

package "updates" (
version = "1.2.0"
description =
"Interface definitions and common boilerplate for the xapi toolstack"
archive(byte) = "xcp_updates.cma"
archive(byte, plugin) = "xcp_updates.cma"
archive(native) = "xcp_updates.cmxa"
archive(native, plugin) = "xcp_updates.cmxs"
exists_if = "xcp_updates.cma"
)

package "storage" (
version = "1.2.0"
description =
Expand Down
165 changes: 83 additions & 82 deletions lib/debug.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,32 +38,32 @@ module Cache = struct
let invalidate t =
Mutex.execute t.m
(fun () ->
t.item <- None;
t.item <- None;
)

let get t =
Mutex.execute t.m
(fun () ->
match t.item with
| Some x -> x
| None ->
let x = t.fn () in
t.item <- Some x;
x
match t.item with
| Some x -> x
| None ->
let x = t.fn () in
t.item <- Some x;
x
)
end

let hostname = Cache.make
(fun () ->
let h = Unix.gethostname () in
Backtrace.set_my_name (Filename.basename(Sys.argv.(0)) ^ " @ " ^ h);
h
)
(fun () ->
let h = Unix.gethostname () in
Backtrace.set_my_name (Filename.basename(Sys.argv.(0)) ^ " @ " ^ h);
h
)

let invalidate_hostname_cache () = Cache.invalidate hostname

let get_thread_id () =
try Thread.id (Thread.self ()) with _ -> -1
try Thread.id (Thread.self ()) with _ -> -1

module ThreadLocalTable = struct
type 'a t = {
Expand All @@ -83,14 +83,15 @@ module ThreadLocalTable = struct
let remove t =
let id = get_thread_id () in
Mutex.execute t.m (fun () -> Hashtbl.remove t.tbl id)

let find t =
let id = get_thread_id () in
Mutex.execute t.m (fun () ->
if Hashtbl.mem t.tbl id
then Some (Hashtbl.find t.tbl id)
else None
)
try
Some (Hashtbl.find t.tbl id)
with
| _ -> None
)
end

let names = ThreadLocalTable.make ()
Expand Down Expand Up @@ -127,21 +128,21 @@ let loglevel = ref default_loglevel

let disabled_modules () =
Mutex.execute loglevel_m (fun () ->
Hashtbl.fold (fun key _ acc -> key :: acc) logging_disabled_for []
)
Hashtbl.fold (fun key _ acc -> key :: acc) logging_disabled_for []
)

let is_disabled brand level =
Mutex.execute loglevel_m (fun () ->
Syslog.is_masked ~threshold:!loglevel level ||
Syslog.is_masked ~threshold:!loglevel level ||
Hashtbl.mem logging_disabled_for (brand, level)
)
)

let reset_levels () =
Mutex.execute loglevel_m (fun () ->
loglevel := default_loglevel;
Hashtbl.clear logging_disabled_for
)
loglevel := default_loglevel;
Hashtbl.clear logging_disabled_for
)


let facility = ref Syslog.Daemon
let facility_m = Mutex.create ()
Expand Down Expand Up @@ -196,9 +197,9 @@ let with_thread_named name f x =
raise e

module StringSet = Set.Make(struct type t=string let compare=Pervasives.compare end)
let debug_keys = ref StringSet.empty
let debug_keys = ref StringSet.empty
let get_all_debug_keys () =
StringSet.fold (fun key keys -> key::keys) !debug_keys []
StringSet.fold (fun key keys -> key::keys) !debug_keys []

let dkmutex = Mutex.create ()

Expand All @@ -209,78 +210,78 @@ end
let all_levels = [Syslog.Debug; Syslog.Info; Syslog.Warning; Syslog.Err]

let add_to_stoplist brand level =
Hashtbl.replace logging_disabled_for (brand, level) ()
Hashtbl.replace logging_disabled_for (brand, level) ()

let remove_from_stoplist brand level =
Hashtbl.remove logging_disabled_for (brand, level)
Hashtbl.remove logging_disabled_for (brand, level)

let disable ?level brand =
let levels = match level with
| None -> all_levels
| Some l -> [l]
in
Mutex.execute loglevel_m (fun () ->
List.iter (add_to_stoplist brand) levels
)
let levels = match level with
| None -> all_levels
| Some l -> [l]
in
Mutex.execute loglevel_m (fun () ->
List.iter (add_to_stoplist brand) levels
)

let enable ?level brand =
let levels = match level with
| None -> all_levels
| Some l -> [l]
in
Mutex.execute loglevel_m (fun () ->
List.iter (remove_from_stoplist brand) levels
)
let levels = match level with
| None -> all_levels
| Some l -> [l]
in
Mutex.execute loglevel_m (fun () ->
List.iter (remove_from_stoplist brand) levels
)

let set_level level =
Mutex.execute loglevel_m (fun () ->
loglevel := level
)
Mutex.execute loglevel_m (fun () ->
loglevel := level
)

module type DEBUG = sig
val debug : ('a, unit, string, unit) format4 -> 'a
val debug : ('a, unit, string, unit) format4 -> 'a

val warn : ('a, unit, string, unit) format4 -> 'a
val warn : ('a, unit, string, unit) format4 -> 'a

val info : ('a, unit, string, unit) format4 -> 'a
val info : ('a, unit, string, unit) format4 -> 'a

val error : ('a, unit, string, unit) format4 -> 'a
val error : ('a, unit, string, unit) format4 -> 'a

val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a
val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a

val log_backtrace : unit -> unit
val log_backtrace : unit -> unit

val log_and_ignore_exn : (unit -> unit) -> unit
val log_and_ignore_exn : (unit -> unit) -> unit
end

module Make = functor(Brand: BRAND) -> struct
let _ =
Mutex.execute dkmutex (fun () ->
debug_keys := StringSet.add Brand.name !debug_keys)

let output level priority (fmt: ('a, unit, string, 'b) format4) =
Printf.kprintf
(fun s ->
if not(is_disabled Brand.name level)
then output_log Brand.name level priority s
) fmt
let debug fmt = output Syslog.Debug "debug" fmt
let warn fmt = output Syslog.Warning "warn" fmt
let info fmt = output Syslog.Info "info" fmt
let error fmt = output Syslog.Err "error" fmt
let audit ?(raw=false) (fmt: ('a, unit, string, 'b) format4) =
Printf.kprintf
(fun s ->
let msg = if raw then s else format true Brand.name "audit" s in
Syslog.log Syslog.Local6 Syslog.Info msg;
msg
) fmt

let log_backtrace () =
let backtrace = Printexc.get_backtrace () in
debug "%s" (String.escaped backtrace)

let log_and_ignore_exn f =
try f () with _ -> log_backtrace ()
Mutex.execute dkmutex (fun () ->
debug_keys := StringSet.add Brand.name !debug_keys)

let output level priority (fmt: ('a, unit, string, 'b) format4) =
Printf.kprintf
(fun s ->
if not(is_disabled Brand.name level)
then output_log Brand.name level priority s
) fmt

let debug fmt = output Syslog.Debug "debug" fmt
let warn fmt = output Syslog.Warning "warn" fmt
let info fmt = output Syslog.Info "info" fmt
let error fmt = output Syslog.Err "error" fmt
let audit ?(raw=false) (fmt: ('a, unit, string, 'b) format4) =
Printf.kprintf
(fun s ->
let msg = if raw then s else format true Brand.name "audit" s in
Syslog.log Syslog.Local6 Syslog.Info msg;
msg
) fmt

let log_backtrace () =
let backtrace = Printexc.get_backtrace () in
debug "%s" (String.escaped backtrace)

let log_and_ignore_exn f =
try f () with _ -> log_backtrace ()
end
Loading

0 comments on commit c11fbe8

Please sign in to comment.