unison

Fork of Unison, a bi-directional file synchronization tool
git clone git://git.laack.co/unison.git
Log | Files | Refs | README | LICENSE

trace.ml (10417B)

      1 (* Unison file synchronizer: src/ubase/trace.ml *)
      2 (* Copyright 1999-2020, Benjamin C. Pierce
      3 
      4     This program is free software: you can redistribute it and/or modify
      5     it under the terms of the GNU General Public License as published by
      6     the Free Software Foundation, either version 3 of the License, or
      7     (at your option) any later version.
      8 
      9     This program is distributed in the hope that it will be useful,
     10     but WITHOUT ANY WARRANTY; without even the implied warranty of
     11     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     12     GNU General Public License for more details.
     13 
     14     You should have received a copy of the GNU General Public License
     15     along with this program.  If not, see <http://www.gnu.org/licenses/>.
     16 *)
     17 
     18 
     19 (* ---------------------------------------------------------------------- *)
     20 (* Choosing where messages go *)
     21 
     22 type trace_printer_choices = [`Stdout | `Stderr | `FormatStdout]
     23 
     24 let traceprinter = ref (`Stderr : trace_printer_choices)
     25 
     26 let redirect x = (traceprinter := x)
     27 
     28 (* ---------------------------------------------------------------------- *)
     29 (* Debugging messages *)
     30 
     31 let debugmods =
     32   Prefs.createStringList "debug"
     33     ~category:`Expert
     34     "debug module xxx ('all' -> everything, 'verbose' -> more)"
     35     ("This preference is used to make Unison print various sorts of "
     36      ^ "information about what it is doing internally on the standard "
     37      ^ "error stream.  It can be used many times, each time with the name "
     38      ^ "of a module for which debugging information should be printed.  "
     39      ^ "Possible arguments for \\verb|debug| can be found "
     40      ^ "by looking for calls to \\verb|Util.debug| in the "
     41      ^ "sources (using, e.g., \\verb|grep|).  "
     42      ^ "Setting \\verb|-debug all| causes information from {\\em all} "
     43      ^ "modules to be printed (this mode of usage is the first one to try, "
     44      ^ "if you are trying to understand something that Unison seems to be "
     45      ^ "doing wrong); \\verb|-debug verbose| turns on some additional "
     46      ^ "debugging output from some modules (e.g., it will show exactly "
     47      ^ "what bytes are being sent across the network).")
     48 
     49 let debugtimes =
     50   Prefs.createBool "debugtimes" false
     51     ~category:(`Internal `Devel)
     52     "*annotate debugging messages with timestamps" ""
     53 
     54 let runningasserver = ref false
     55 
     56 let debugging() = (Prefs.read debugmods) <> []
     57 
     58 let enabled modname =
     59   let m = Prefs.read debugmods in
     60   let en =
     61     m <> [] && (   (* tracing labeled "" is enabled if anything is *)
     62                    (modname = "")
     63                 || (* '-debug verbose' enables everything *)
     64                    (Safelist.mem "verbose" m)
     65                 || (* '-debug all+' likewise *)
     66                    (Safelist.mem "all+" m)
     67                 || (* '-debug all' enables all tracing not marked + *)
     68                    (Safelist.mem "all" m && not (Util.endswith modname "+"))
     69                 || (* '-debug m' enables m and '-debug m+' enables m+ *)
     70                    (Safelist.mem modname m)
     71                 || (* '-debug m+' also enables m *)
     72                    (Safelist.mem (modname ^ "+") m)
     73                ) in
     74   en
     75 
     76 let enable modname onoff =
     77   let m = Prefs.read debugmods in
     78   let m' = if onoff then (modname::m) else (Safelist.remove modname m) in
     79   Prefs.set debugmods m'
     80 
     81 let debug modname thunk =
     82   if enabled modname then begin
     83     let s = if !runningasserver then "server: " else "" in
     84     let time =
     85       if Prefs.read debugtimes then
     86         let tm = Util.localtime (Util.time()) in
     87         Printf.sprintf "%02d:%02d:%02d"
     88           tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
     89       else "" in
     90     if time<>"" || s<>"" || modname<>"" then begin
     91       let time = if time="" || (s=""&&modname="") then time else time^": " in
     92       match !traceprinter with
     93       | `Stdout -> Printf.printf "[%s%s%s] " time s modname
     94       | `Stderr -> Printf.eprintf "[%s%s%s] " time s modname
     95       | `FormatStdout -> Format.printf "[%s%s%s] " time s modname
     96       end;
     97     thunk();
     98     flush stderr
     99   end
    100 
    101 (* We set the debugPrinter variable in the Util module so that other modules
    102    lower down in the module dependency graph (so that they can't just
    103    import Trace) can also print debugging messages. *)
    104 let _ = Util.debugPrinter := Some(debug)
    105 
    106 
    107 (* ---------------------------------------------------------------------- *)
    108 (* Logging *)
    109 
    110 let logging =
    111   Prefs.createBool "log" true
    112     ~category:(`Advanced `General)
    113     "record actions in logfile"
    114     "When this flag is set, Unison will log all changes to the filesystems
    115      on a file."
    116 
    117 let logfile =
    118   Prefs.createString "logfile"
    119     "unison.log"
    120     ~category:(`Advanced `General)
    121     "logfile name"
    122     "By default, logging messages will be appended to the file
    123      \\verb|unison.log| in your .unison directory.  Set this preference if
    124      you prefer another file.  It can be a path relative to your .unison directory.
    125      Sending SIGUSR1 will close the logfile; the logfile will be re-opened (and
    126      created, if needed) automatically, to allow for log rotation."
    127 
    128 let logch = ref None
    129 
    130 let closelog _ =
    131   match !logch with
    132     None -> ()
    133   | Some(ch,file) ->
    134       close_out ch;
    135       logch := None
    136 
    137 let _ =
    138   if Sys.unix || Sys.cygwin then
    139     try
    140       ignore (Sys.signal Sys.sigusr1 (Signal_handle closelog))
    141     with e ->
    142       Printf.eprintf "Warning: SIGUSR1 handler not set: %s\n"
    143         (Printexc.to_string e)
    144 
    145 let rec getLogch() =
    146   Util.convertUnixErrorsToFatal "getLogch" (fun() ->
    147   match !logch with
    148     None ->
    149       let prefstr = Prefs.read logfile in
    150       let file = Util.fileMaybeRelToUnisonDir prefstr in
    151       let ch =
    152         System.open_out_gen [Open_wronly; Open_creat; Open_append] 0o600 file in
    153       logch := Some (ch, file);
    154       ch
    155   | Some(ch, file) ->
    156       if Prefs.read logfile = file then ch else begin
    157         close_out ch;
    158         logch := None; getLogch ()
    159       end)
    160 
    161 let ansiColorRegexp = Str.regexp "\027\\[[0-9;:]*m"
    162 
    163 let stripColorEscapes s =
    164   Str.global_replace ansiColorRegexp "" s
    165 
    166 let sendLogMsgsToStderr = ref true
    167 
    168 let writeLog s stripColor =
    169   if !sendLogMsgsToStderr then begin
    170       match !traceprinter with
    171       | `Stdout -> Printf.printf "%s" s
    172       | `Stderr -> Util.msg "%s" s
    173       | `FormatStdout -> Format.printf "%s " s
    174   end else debug "" (fun() ->
    175       match !traceprinter with
    176       | `Stdout -> Printf.printf "%s" s
    177       | `Stderr -> Util.msg "%s" s
    178       | `FormatStdout -> Format.printf "%s " s);
    179   if Prefs.read logging then begin
    180     let clean = if stripColor then stripColorEscapes s else s in
    181     let ch = getLogch() in
    182     begin try
    183       output_string ch clean;
    184       flush ch
    185     with Sys_error _ -> () end
    186   end
    187 
    188 (* ---------------------------------------------------------------------- *)
    189 (* Formatting and displaying messages *)
    190 
    191 let terse =
    192   Prefs.createBool "terse" false
    193     ~category:(`Basic `Syncprocess_CLI)
    194     "suppress status messages"
    195     ("When this preference is set to {\\tt true}, the user "
    196      ^ "interface will not print status messages.")
    197 
    198 type msgtype = Msg | StatusMajor | StatusMinor | Log | LogColor
    199 type msg = msgtype * string
    200 
    201 let mmsgtype = Umarshal.(sum5 unit unit unit unit unit
    202                            (function
    203                             | Msg -> I51 ()
    204                             | StatusMajor -> I52 ()
    205                             | StatusMinor -> I53 ()
    206                             | Log -> I54 ()
    207                             | LogColor -> I55 ())
    208                            (function
    209                             | I51 () -> Msg
    210                             | I52 () -> StatusMajor
    211                             | I53 () -> StatusMinor
    212                             | I54 () -> Log
    213                             | I55 () -> LogColor))
    214 
    215 let mmsg = Umarshal.(prod2 mmsgtype string id id)
    216 
    217 let defaultMessageDisplayer s =
    218   if not (Prefs.read terse) then begin
    219     let show() = if s<>"" then Util.msg "%s\n" s in
    220     if enabled "" then debug "" show
    221     else if not !runningasserver then show()
    222   end
    223 
    224 let messageDisplayer = ref defaultMessageDisplayer
    225 
    226 let defaultStatusFormatter s1 s2 = s1 ^ " " ^ s2
    227 
    228 let statusFormatter = ref defaultStatusFormatter
    229 
    230 let statusMsgMajor = ref ""
    231 let statusMsgMinor = ref ""
    232 
    233 let displayMessageLocally (mt,s) =
    234   let display = !messageDisplayer in
    235   let displayStatus() =
    236     display (!statusFormatter !statusMsgMajor !statusMsgMinor) in
    237   match mt with
    238     Msg -> display s
    239   | StatusMajor -> statusMsgMajor := s; statusMsgMinor := ""; displayStatus()
    240   | StatusMinor -> statusMsgMinor := s; displayStatus()
    241   | Log      -> writeLog s false
    242   | LogColor -> writeLog s true
    243 
    244 let messageForwarder = ref None
    245 
    246 let displayMessage m =
    247   match !messageForwarder with
    248     None -> displayMessageLocally m
    249   | Some(f) -> f m
    250 
    251 (* ---------------------------------------------------------------------- *)
    252 (* Convenience functions for displaying various kinds of messages *)
    253 
    254 let message s = displayMessage (Msg, s)
    255 
    256 let status s =
    257   displayMessage (StatusMajor, s)
    258 
    259 let statusMinor s = displayMessage (StatusMinor, s)
    260 
    261 let statusDetail s =
    262   let ss = if not !runningasserver then s else (Util.padto 30 s) ^ " [server]" in
    263   displayMessage (StatusMinor, ss)
    264 
    265 let log s = displayMessage (Log, s)
    266 
    267 let log_color s = displayMessage (LogColor, s)
    268 
    269 let logonly s =
    270   let temp = !sendLogMsgsToStderr in
    271   sendLogMsgsToStderr := false;
    272   displayMessage (Log, s);
    273   sendLogMsgsToStderr := temp
    274 
    275 let logverbose s =
    276   let temp = !sendLogMsgsToStderr in
    277   sendLogMsgsToStderr := !sendLogMsgsToStderr && not (Prefs.read terse);
    278   displayMessage (Log, s);
    279   sendLogMsgsToStderr := temp
    280 
    281 (* ---------------------------------------------------------------------- *)
    282 (* Timing *)
    283 
    284 let printTimers =
    285   Prefs.createBool "timers" false
    286     ~category:(`Internal `Devel)
    287     "*print timing information" ""
    288 
    289 type timer = string * float
    290 
    291 let gettime () = Unix.gettimeofday()
    292 
    293 let startTimer desc =
    294   if Prefs.read(printTimers) then
    295     (message (desc ^ "..."); (desc, gettime()))
    296   else
    297     (desc,0.0)
    298 
    299 let startTimerQuietly desc =
    300   if Prefs.read(printTimers) then
    301     (desc, gettime())
    302   else
    303     (desc,0.0)
    304 
    305 let showTimer (desc, t1) =
    306   (* Showing timer values from the server process does not work at the moment:
    307      it confuses the RPC mechanism *)
    308   if not !runningasserver then
    309     if Prefs.read(printTimers) then
    310       let t2 = gettime() in
    311       message (Printf.sprintf "%s (%.2f seconds)" desc (t2 -. t1))