Replace logging code with Netlog

The Netlog logger is a bit simpler to use, and supports printf-style
logging, which cleans up the uses.

TODO.org

@@ -102,6 +102,9 @@
     data itself to be on something, such as sshfs, whereas the cache
     data would be local.
 
+    Also, investigate whether sftp has advanced sufficiently to allow
+    it to do backups.
+
 **** Enhanced config
      - [X] Move config to separate file
      - [X] Change pool to an option (ask on Stackoverflow)

backup.ml

@@ -62,7 +62,7 @@ let block_size = 256 * 1024
 let decode_atts atts =
   let each att =
     try String.split att "=" with
-      | Not_found -> Log.failure ("attribute has no '='", ["attr", att]) in
+      | Not_found -> Log.failf "attribute has no '=': %S" att in
   StringMap.of_enum (Enum.map each (List.enum atts))
 
 (* Read a chunk-sized block from [fd].  Returns the data read, and
@@ -115,8 +115,7 @@ end = struct
       | Some node ->
 	let ctime = Dbunix.get_time "ctime" child_stat in
 	if node.Seendb.n_ctime = ctime then begin
-	  Log.debug (fun () -> "cache", ["ino", Int64.to_string cino;
-					 "hash", Hash.to_string node.Seendb.n_hash]);
+	  Log.debugf "cache: ino=%Ld hash=%S" cino (Hash.to_string node.Seendb.n_hash);
 	  c.add_skip (Dbunix.get_int64 "size" child_stat);
 	  let stat' = StringMap.add "hash" (Hash.to_string node.Seendb.n_hash) child_stat in
 	  (node.Seendb.n_hash, stat')
@@ -151,7 +150,7 @@ let save' pool cache backup_path atts =
   let atts = decode_atts atts in
   let root_stat = match Dbunix.lstat backup_path with
     | ("DIR", stat) -> stat
-    | (kind, _) -> Log.failure ("Root of backup is not a DIR", ["kind", kind]) in
+    | (kind, _) -> Log.failf "Root of backup is not a DIR: %S" kind in
 
   let rec walk path kind props =
     let props = match kind with
@@ -182,7 +181,7 @@ let save' pool cache backup_path atts =
 	(fun () ->
 	  let path = Filename.concat path name in
 	  walk path child_kind child_props) in
-      Log.debug (fun () -> "add", ["name", name; "hash", Hash.to_string hash]);
+      Log.debugf "add name=%S hash=%S" name (Hash.to_string hash);
       Indirect.Dir.add buf name hash) children;
     Cache.flush dircache;
     let child_hashes = Indirect.Dir.finish buf in
@@ -197,7 +196,7 @@ let save' pool cache backup_path atts =
   let hash = Nodes.try_put pool (Nodes.BackupNode (now, atts)) in
   pool#finish;
   Seendb.commit cache;
-  Log.info (fun () -> "Completed backup", ["hash", Hash.to_string hash])
+  Log.infof "Completed backup: %s" (Hash.to_string hash)
 
 let save pool cache_dir backup_path atts =
   Seendb.with_cache cache_dir (fun cache -> save' pool cache backup_path atts)

chunk.ml

@@ -29,11 +29,11 @@ let uncompress src dest_len =
     src_offset := !src_offset + count;
     count in
   let flush buf count =
-    if !dest_offset + count > dest_len then Log.failure ("uncompress overflow", []);
+    if !dest_offset + count > dest_len then Log.fail "uncompress overflow";
     String.blit buf 0 dest !dest_offset count;
     dest_offset := !dest_offset + count in
   Zlib.uncompress ~header:true refill flush;
-  if !dest_offset <> dest_len then Log.failure ("uncompress underflow", []);
+  if !dest_offset <> dest_len then Log.fail "uncompress underflow";
   dest
 
 (* Try compressing a block of data.  Return (Some bytes) if the
@@ -178,7 +178,7 @@ type info = {
 let get_header chan =
   let buf = read_buffer chan header_size in
   let magic = String.sub buf 0 16 in
-  if magic <> pool_magic then Log.failure ("Invalid magic", []); (* TODO: Proper exception. *)
+  if magic <> pool_magic then Log.fail "Invalid magic"; (* TODO: Proper exception. *)
   let clen = get32le buf 16 in
   let len = get32le buf 20 in
   let kind = String.sub buf 24 4 in
@@ -207,8 +207,9 @@ let read chan =
   if !verify_hashes then begin
     let computed_hash = Hash.of_data [chunk#kind; chunk#data] in
     if header.h_hash <> computed_hash then
-      Log.failure ("Incorrect SHA1 reading chunk", ["hash", Hash.to_string header.h_hash;
-						    "got", Hash.to_string computed_hash])
+      Log.failf "Incorrect SHA1 reading chunk, hash=%s, got=%s"
+	(Hash.to_string header.h_hash)
+	(Hash.to_string computed_hash)
   end;
   chunk
 

config.ml

@@ -61,6 +61,6 @@ let clients = new C.list_cp client_wrappers
    ignore the Sys_error. *)
 let load_config path =
   (try group#read path with
-    | Sys_error (msg) -> Log.warn (fun () -> "Unable to write default config file", ["message", msg]))
+    | Sys_error (msg) -> Log.warnf "Unable to write default config file (%s) %S" msg path)
 
 let bogus_client = { client_name = ""; client_command = "", []; client_db_dir = "" }

db.ml

@@ -14,7 +14,7 @@ type t = Sqlite3.db
 
 let must result =
   if result <> Sqlite3.Rc.OK then
-    Log.failure ("sqlite error", ["code", Sqlite3.Rc.to_string result])
+    Log.failf "sqlite error: %s" (Sqlite3.Rc.to_string result)
 
 (* Perform an sql statement, installing arguments as appropriate. *)
 let sql_fold db f a0 text args =
@@ -27,8 +27,8 @@ let sql_fold db f a0 text args =
 	loop (f accum data)
       | Sqlite3.Rc.DONE -> accum
       | err ->
-	Log.failure ("sqlite error", ["query", text;
-				      "code", Sqlite3.Rc.to_string err])
+	Log.failf "sqlite error: %s, query='%S'"
+	  (Sqlite3.Rc.to_string err) text
     end in
   let result = loop a0 in
   must (Sqlite3.finalize stmt);
@@ -41,17 +41,17 @@ let sqln db text args =
 
 (* Run a query, expecting no results. *)
 let sql0 db text args =
-  sql_fold db (fun _ x -> Log.failure ("not expecing SQL rows", ["query", text])) () text args
+  sql_fold db (fun _ x -> Log.failf "not expecing SQL rows: %S" text) () text args
 
 (* Run a query, expecting a single result. *)
 let sql1 db text args =
   match sqln db text args with
     | [a] -> a
-    | rows -> Log.failure ("expecting only a single row", ["count", string_of_int (List.length rows)])
+    | rows -> Log.failf "expecting only a single row: %d" (List.length rows)
 
 (* Determine the schema version from this database. *)
 let get_schema_version db =
-  let fail () = Log.failure ("unexpected result from table query", []) in
+  let fail () = Log.fail "unexpected result from table query" in
   match sql1 db "select count(*) from sqlite_master where type = 'table' and name = 'schema_version'" [] with
     | [| Data.INT 0L |] -> None
     | [| Data.INT 1L |] ->
@@ -75,12 +75,11 @@ let connect path info =
     | None -> install_schema db info
     | Some version when version = info.schema_version -> ()
     | Some version ->
-      Log.failure ("Schema mismatch on database", ["path", path;
-						   "found", version;
-						   "expect", info.schema_version])
+      Log.failf "Schema mismatch on database at %S, found %S, expecting %S"
+	path version info.schema_version
   end;
   db
 
 let close db =
   if not (Sqlite3.db_close db) then
-    Log.failure ("Error closing database", [])
+    Log.fail "Error closing database"

dbunix.ml

@@ -68,13 +68,11 @@ let decode_time time =
 	  nsec ^ String.make (9-len) ' '
 	else nsec in
       (Int64.of_string sec, Int64.of_string nsec)
-    | _ -> Log.failure ("Invalid time data", ["time", time])
+    | _ -> Log.failf "Invalid time data: '%S'" time
 
 let float_of_time time =
   let (sec, nsec) = decode_time time in
-  Log.debug (fun () -> "float_of_time", ["time", time;
-					 "sec", Int64.to_string sec;
-					 "nsec", Int64.to_string nsec]);
+  Log.debugf "float_of_time %s, sec=%Ld, nsec=%Ld" time sec nsec;
   (Int64.to_float sec (* +. Int64.to_float nsec /. 1.0e9 *))
 
 let get_time key map = float_of_time (SM.find key map)
@@ -102,8 +100,7 @@ let restore_stat path kind props = match kind with
   | "CHR" | "BLK" | "FIFO" | "SOCK" ->
     let is_dev = SM.mem "rdev" props in
     if is_dev && not (is_root ()) then
-      Log.warn (fun () ->
-	"Cannot restore device as non-root", ["path", path])
+      Log.warnf "Cannot restore device node as non-root: %S" path
     else begin
       let dev = if is_dev then get_int64 "rdev" props else 0L in
       with_umask 0 (make_special path kind (get_int "mode" props)) dev;
@@ -113,7 +110,7 @@ let restore_stat path kind props = match kind with
     end
 
   | _ ->
-    Log.warn (fun () -> "TODO: Restore kind", ["kind", kind; "path", path])
+    Log.warnf "TODO: Restore kind '%s %S" kind path
 
 external realpath : string -> string = "db_realpath"
 
@@ -135,6 +132,6 @@ let mountpoint_of path =
       if astat.Unix.st_dev = bstat.Unix.st_dev then
 	loop rest
       else a
-    | [] -> Log.failure ("Empty path", ["path", path; "rpath", rpath]) in
+    | [] -> Log.failf "Empty path: path=%S, rpath=%S" path rpath in
   let stats = List.map Unix.lstat parts in
   loop (List.combine parts stats)

file_index.ml

@@ -265,7 +265,7 @@ object (self)
 
   method add hash pos kind =
     if HashMap.mem hash ram then
-      Log.failure ("Attempt to add duplicate key", []);
+      Log.fail "Attempt to add duplicate key";
     ram <- HashMap.add hash (pos, kind) ram
 
   method mem hash = match self#find_option hash with

file_pool.ml

@@ -34,7 +34,7 @@ let get_uuid () =
 
 let create_file_pool ?(limit=default_limit) ?(newfile=false) path =
   if limit < limit_lower_bound || limit > limit_upper_bound then
-    Log.failure ("Pool size limit out of range", []);
+    Log.fail "Pool size limit out of range";
   Misc.ensure_empty_directory ~what:"pool" path;
   let metadata = Filename.concat path "metadata" in
   let props_name = Filename.concat metadata "props.txt" in
@@ -59,7 +59,7 @@ let read_flat_properties filename =
     if String.length line > 0 && line.[0] == '#' then map
     else begin
       match String.Exceptionless.split line "=" with
-	  None -> Log.failure ("Invalid line in property file", ["line", line])
+	  None -> Log.failf "Invalid line in property file: %S" line
 	| Some (key, value) -> StringMap.add key value map
     end in
   let get inp = fold decode StringMap.empty (IO.lines_of inp) in
@@ -81,7 +81,7 @@ let to_index_name path =
   if String.ends_with path ".data" then
     String.sub path 0 (String.length path - 5) ^ ".idx"
   else
-    Log.failure ("Malformed datafile name", ["path", path])
+    Log.failf "Malformed datafile name: '%S'" path
 
 let data_re = Str.regexp "^pool-data-\\([0-9][0-9][0-9][0-9]\\)\\.data$"
 (* Note that Str doesn't appear to be reentrant. *)
@@ -95,7 +95,7 @@ type node = {
 
 (* Attempt to regenerate the index for this pool file. *)
 let recover_index name file index =
-  Log.warn (fun () -> "Index recovery", ["file", name]);
+  Log.warnf "Index recovery for %S" name;
   index#clear;
   let limit = file#size in
   let rec loop pos =
@@ -143,8 +143,7 @@ let open_lock path =
   (* Wait? *)
   begin try Unix.lockf fd Unix.F_TLOCK 0 with
     | Unix.Unix_error (e, _, _) ->
-      Log.failure ("Unable to get pool lock", ["path", path;
-					       "error", Unix.error_message e])
+      Log.failf "Unable to get pool lock in %S, %s" path (Unix.error_message e)
   end;
   fd
 

hash.ml

@@ -10,7 +10,7 @@ let of_data lst =
   h#result
 
 let of_raw item =
-  if String.length item <> 20 then Log.failure ("Hash must be 20 bytes", ["item", item]);
+  if String.length item <> 20 then Log.failf "Hash must be 20 bytes: %S" item;
   String.copy item
 
 (* Note that this doesn't copy the string, so be careful. *)
@@ -24,7 +24,7 @@ let to_string hash =
   Buffer.contents buf
 
 let of_string text =
-  if String.length text <> 40 then Log.failure ("Expect 40 character string", ["text", text]);
+  if String.length text <> 40 then Log.failf "Expect 40 character string: %S" text;
   let result = String.create 20 in
   let get pos = int_of_string ("0x" ^ String.sub text (pos*2) 2) in
   for i = 0 to 19 do

indirect.ml

@@ -26,7 +26,7 @@ let push ind hash =
 let summarize ind buffer level =
   if Buffer.length buffer = 0 then begin
     if level > 0 then
-      Log.failure ("Empty has at non-zero level", []);
+      Log.fail "Empty has at non-zero level";
     (* An empty chunk is allowed, but only at level 0. *)
     let chunk = Chunk.chunk_of_string "null" "" in
     ind.pool#add chunk;

log.ml

@@ -2,17 +2,24 @@
 
 open Batteries_uni
 
-include Logger
+let log = Netlog.log
+let logf = Netlog.logf
 
-let odump = Logger.make_log "odump"
+let log_level = ref `Info
 
-let failure event =
-  log odump FATAL (fun () -> event);
+let fail message =
+  log `Crit message;
   exit 1
 
-let warn event_fun = log odump WARN event_fun
-let info event_fun = log odump INFO event_fun
-let debug event_fun = log odump DEBUG event_fun
+let failf fmt =
+  Printf.ksprintf fail fmt
+
+let info msg = log `Info msg
+let infof fmt = Printf.ksprintf info fmt
+let warn msg = log `Warning msg
+let warnf fmt = Printf.ksprintf warn fmt
+let debug msg = log `Debug msg
+let debugf fmt = Printf.ksprintf debug fmt
 
 let has_console = Unix.isatty Unix.stderr
 
@@ -62,24 +69,16 @@ let with_output f =
 
 let message text = with_output (fun () -> output_string stderr text; output_char stderr '\n')
 
-(* 'Format' based formatter. *)
-let event_to_string log level (desc, parms) time =
-  let out = IO.output_string () in
-  let fmt = Format.formatter_of_output out in
-  let nice_time = Netdate.format "%Y%m%d-%H%M%.3S" (Netdate.create ~localzone:true time) in
-  Format.fprintf fmt "%s: @[%s@," nice_time desc;
-  let each (key, value) = Format.fprintf fmt "@ %s:%s" key value in
-  List.iter each parms;
-  Format.fprintf fmt "@.";
-  IO.close_out out
-
-let mingled_formatter log level event time =
-  let text = event_to_string log level event time in
-  with_output (fun () -> output_string stderr text)
+let mingled_logger level message =
+  if Netlog.level_weight level <= Netlog.level_weight !log_level then
+    with_output (fun () ->
+      let now = Unix.gettimeofday () in
+      let nice_time = Netdate.format "%Y-%m-%d-%H:%M:%.3S" (Netdate.create ~localzone:true now) in
+      Printf.fprintf stderr "%s [%-5s]\n    %s\n%!" nice_time (Netlog.string_of_level level) message)
 
 (* Register a formater that intermingles correctly with the progress
    meter. *)
-let _ = init ["odump", INFO] mingled_formatter
+let () = Netlog.current_logger := mingled_logger
 
 let last_update = ref (Unix.gettimeofday ())
 

log.mli

@@ -2,18 +2,20 @@
 
 open Batteries_uni
 
-(* The logger to use within the program. *)
-val odump : Logger.log
-type event = Logger.event
-type log = Logger.log
-type level = Logger.level
-val log : log -> level -> (unit -> event) -> unit
+val log : Netlog.level -> string -> unit
+val logf : Netlog.level -> ('a, unit, string, unit) format4 -> 'a
 
 (* Log failure, and then exit. *)
-val failure : event -> 'a
-val info : (unit -> event) -> unit
-val warn : (unit -> event) -> unit
-val debug : (unit -> event) -> unit
+val fail : string -> 'a
+val failf : ('a, unit, string, 'b) format4 -> 'a
+
+(* Wrappers for the various levels. *)
+val info : string -> unit
+val infof : ('a, unit, string, unit) format4 -> 'a
+val warn : string -> unit
+val warnf : ('a, unit, string, unit) format4 -> 'a
+val debug : string -> unit
+val debugf : ('a, unit, string, unit) format4 -> 'a
 
 val message : string -> unit
 val with_output : (unit -> unit) -> unit

misc.ml

@@ -2,12 +2,12 @@
 
 let ensure_directory ?(what="Unknown") path =
   if not (Sys.file_exists path && Sys.is_directory path) then
-    Log.failure ("Pathname is not a directory", ["operation", what; "path", path])
+    Log.failf "Pathname for %s is not a directory: %S" what path
 
 let ensure_empty_directory ?(what="Unknown") path =
   ensure_directory ~what:what path;
   if Sys.readdir path <> [| |] then
-    Log.failure ("Pathname is not an empty directory", ["operation", what; "path", path])
+    Log.failf "Pathname for %s is not an empty directory: %S" what path
 
 let mkdir_safely path =
   try Unix.mkdir path 0o755