diff --git a/idl/log.ml b/idl/log.ml index 1a971bb..5a9d557 100644 --- a/idl/log.ml +++ b/idl/log.ml @@ -1,3 +1,27 @@ +open Sexplib.Std + +type traced_operation = [ + | `Set of string * string * [ `Producer | `Consumer | `Suspend | `Suspend_ack ] * [ `Int64 of int64 | `Bool of bool ] + | `Get of string * string * [ `Producer | `Consumer | `Suspend | `Suspend_ack ] * [ `Int64 of int64 | `Bool of bool ] +] with sexp +type traced_operation_list = traced_operation list with sexp + let debug fmt = Printf.ksprintf (fun s -> print_endline s) fmt let info fmt = Printf.ksprintf (fun s -> print_endline s) fmt let error fmt = Printf.ksprintf (fun s -> print_endline s) fmt + +let trace ts = + let string_of_key = function + | `Producer -> "producer" + | `Consumer -> "consumer" + | `Suspend -> "suspend" + | `Suspend_ack -> "suspend_ack" in + let string_of_value = function + | `Int64 x -> Int64.to_string x + | `Bool b -> string_of_bool b in + let one = function + | `Set (_, queue, key, value) -> + Printf.sprintf "%s.%s := %s" queue (string_of_key key) (string_of_value value) + | `Get (__, queue, key, value) -> + Printf.sprintf "%s.%s == %s" queue (string_of_key key) (string_of_value value) in + info "%s" (String.concat ", " (List.map one ts)) diff --git a/idl/xenvm_interface.ml b/idl/xenvm_interface.ml index 9600779..f25543e 100644 --- a/idl/xenvm_interface.ml +++ b/idl/xenvm_interface.ml @@ -42,6 +42,7 @@ external shutdown : unit -> int = "" type queue = { lv: string; suspended: bool; + debug_info: (string * string) list; } type connection_state = diff --git a/test/common.ml b/test/common.ml index b653708..e1d7d37 100644 --- a/test/common.ml +++ b/test/common.ml @@ -20,12 +20,6 @@ open Lwt (* Mock kernel devices so we can run as a regular user *) let use_mock = ref true -module Log = struct - let debug fmt = Printf.ksprintf (fun s -> print_endline s) fmt - let info fmt = Printf.ksprintf (fun s -> print_endline s) fmt - let error fmt = Printf.ksprintf (fun s -> print_endline s) fmt -end - module Time = struct type 'a io = 'a Lwt.t let sleep = Lwt_unix.sleep diff --git a/xenvm-local-allocator/local_allocator.ml b/xenvm-local-allocator/local_allocator.ml index 2511dc0..44c8df3 100644 --- a/xenvm-local-allocator/local_allocator.ml +++ b/xenvm-local-allocator/local_allocator.ml @@ -28,7 +28,6 @@ let rec try_forever msg f = >>= function | `Ok x -> return (`Ok x) | `Error `Retry -> - debug "%s: retrying after 5s" msg; Lwt_unix.sleep 5. >>= fun () -> try_forever msg f @@ -85,7 +84,6 @@ module FromLVM = struct >>= function | `Suspended -> return () | `Running -> - debug "FromLVM.suspend got `Running; sleeping"; Lwt_unix.sleep 5. >>= fun () -> wait () in @@ -99,7 +97,6 @@ module FromLVM = struct fatal_error "reading state of FromLVM" (R.Consumer.state t) >>= function | `Suspended -> - debug "FromLVM.resume got `Suspended; sleeping"; Lwt_unix.sleep 5. >>= fun () -> wait () @@ -122,7 +119,6 @@ module ToLVM = struct >>= function | `Ok x -> return x | _ -> - debug "ToLVM.attach got `Error; sleeping"; Lwt_unix.sleep 5. >>= fun () -> attach ~disk () @@ -130,7 +126,6 @@ module ToLVM = struct fatal_error "querying ToLVM state" (R.Producer.state t) let rec push t item = R.Producer.push ~t ~item () >>= function | `Error (`Retry | `Suspended) -> - debug "ToLVM.push got `Error; sleeping"; Lwt_unix.sleep 5. >>= fun () -> push t item @@ -216,7 +211,6 @@ module FreePool = struct >>= fun (pos, ts) -> let open FreeAllocation in ( if ts = [] then begin - debug "No free blocks, sleeping for 5s"; Lwt_unix.sleep 5. end else return () ) >>= fun () -> @@ -390,7 +384,7 @@ let main use_mock config daemon socket journal fromLVM toLVM = ) >>= fun device -> (* We must replay the journal before resynchronising free blocks *) - J.start device perform + J.start ~client:"xenvm-local-allocator" ~name:"local allocator journal" device perform >>|= fun j -> FreePool.start config vg diff --git a/xenvm/xenvm.ml b/xenvm/xenvm.ml index 0d8d81e..18c2fdd 100644 --- a/xenvm/xenvm.ml +++ b/xenvm/xenvm.ml @@ -112,7 +112,7 @@ let host_list copts (vg_name,_) = let table_of_queue q = [ [ "lv"; q.lv ]; [ "suspended"; string_of_bool q.suspended ] - ] in + ] @ (List.map (fun (k, v) -> [ k; v ]) q.debug_info) in let table_of_host h = let connection_state = [ "state"; match h.connection_state with Some x -> Jsonrpc.to_string (rpc_of_connection_state x) | None -> "None" ] in let fromLVM = add_prefix "fromLVM" (table_of_queue h.fromLVM) in diff --git a/xenvmd/xenvmd.ml b/xenvmd/xenvmd.ml index 4ff86e9..e79a56e 100644 --- a/xenvmd/xenvmd.ml +++ b/xenvmd/xenvmd.ml @@ -47,13 +47,14 @@ module ToLVM = struct fatal_error "attaching to ToLVM queue" (R.Consumer.attach ~queue:(name ^ " ToLVM Consumer") ~client:"xenvmd" ~disk ()) let state t = fatal_error "querying ToLVM state" (R.Consumer.state t) + let debug_info t = + fatal_error "querying ToLVM debug_info" (R.Consumer.debug_info t) let rec suspend t = R.Consumer.suspend t >>= function | `Error (`Msg msg) -> fatal_error_t msg | `Error `Suspended -> return () | `Error `Retry -> - debug "ToLVM.suspend got `Retry; sleeping"; Lwt_unix.sleep 5. >>= fun () -> suspend t @@ -63,7 +64,6 @@ module ToLVM = struct >>= function | `Error _ -> fatal_error_t "reading state of ToLVM" | `Ok `Running -> - debug "ToLVM.suspend got `Running; sleeping"; Lwt_unix.sleep 5. >>= fun () -> wait () @@ -74,7 +74,6 @@ module ToLVM = struct >>= function | `Error (`Msg msg) -> fatal_error_t msg | `Error `Retry -> - debug "ToLVM.resume got `Retry; sleeping"; Lwt_unix.sleep 5. >>= fun () -> resume t @@ -85,7 +84,6 @@ module ToLVM = struct >>= function | `Error _ -> fatal_error_t "reading state of ToLVM" | `Ok `Suspended -> - debug "ToLVM.resume got `Suspended; sleeping"; Lwt_unix.sleep 5. >>= fun () -> wait () @@ -108,7 +106,6 @@ module FromLVM = struct let initial_state = ref `Running in let rec loop () = R.Producer.attach ~queue:(name ^ " FromLVM Producer") ~client:"xenvmd" ~disk () >>= function | `Error `Suspended -> - debug "FromLVM.attach got `Suspended; sleeping"; Lwt_unix.sleep 5. >>= fun () -> initial_state := `Suspended; @@ -118,15 +115,15 @@ module FromLVM = struct >>= fun x -> return (!initial_state, x) let state t = fatal_error "FromLVM.state" (R.Producer.state t) + let debug_info t = + fatal_error "querying FromLVM debug_info" (R.Producer.debug_info t) let rec push t item = R.Producer.push ~t ~item () >>= function | `Error (`Msg x) -> fatal_error_t (Printf.sprintf "Error pushing to the FromLVM queue: %s" x) | `Error `Retry -> - debug "FromLVM.push got `Retry; sleeping"; Lwt_unix.sleep 5. >>= fun () -> push t item | `Error `Suspended -> - debug "FromLVM.push got `Suspended; sleeping"; Lwt_unix.sleep 5. >>= fun () -> push t item @@ -435,13 +432,17 @@ module VolumeManager = struct ( ToLVM.state t >>= function | `Suspended -> return true | `Running -> return false ) >>= fun suspended -> - let toLVM = { Xenvm_interface.lv; suspended } in + ToLVM.debug_info t + >>= fun debug_info -> + let toLVM = { Xenvm_interface.lv; suspended; debug_info } in let lv = fromLVM name in let t = List.assoc name !from_LVMs in ( FromLVM.state t >>= function | `Suspended -> return true | `Running -> return false ) >>= fun suspended -> - let fromLVM = { Xenvm_interface.lv; suspended } in + FromLVM.debug_info t + >>= fun debug_info -> + let fromLVM = { Xenvm_interface.lv; suspended; debug_info } in read (fun vg -> try let lv = Lvm.Vg.LVs.find_by_name (freeLVM name) vg.Lvm.Vg.lvs in @@ -537,7 +538,7 @@ module FreePool = struct | `Error _ -> fatal_error_t ("open " ^ name) | `Ok x -> return x ) >>= fun device -> - J.start device perform + J.start ~client:"xenvmd" ~name:"allocation journal" device perform >>|= fun j' -> journal := Some j'; return () @@ -570,7 +571,6 @@ module FreePool = struct FromLVM.state from_lvm >>= function | `Suspended -> - debug "FromLVM.state got `Suspended; sleeping"; Lwt_unix.sleep 5. >>= fun () -> wait () @@ -753,7 +753,6 @@ let run port sock_path config = VolumeManager.flush_all () >>= fun () -> - debug "sleeping for 5s"; Lwt_unix.sleep 5. >>= fun () -> service_queues () in