Log events in machine-readable format, and dump them via `infer events` command

Reviewed By: mbouaziz, jvillard

Differential Revision: D6259580

fbshipit-source-id: 9289d2f

infer/src/backend/Tasks.ml

@@ -43,6 +43,7 @@ let run t =
 
 
 let fork_protect ~f x =
+  EventLogger.prepare () ;
   L.reset_formatters () ;
   ResultsDatabase.new_database_connection () ;
   f x
@@ -56,6 +57,8 @@ module Runner = struct
   let start runner ~tasks =
     let pool = runner.pool in
     Queue.enqueue_all runner.all_continuations (Queue.to_list tasks.continuations) ;
+    (* Flush here all buffers to avoid passing unflushed data to forked processes, leading to duplication *)
+    Pervasives.flush_all () ;
     List.iter
       ~f:(fun x -> ProcessPool.start_child ~f:(fun f -> fork_protect ~f ()) ~pool x)
       tasks.closures

infer/src/backend/infer.ml

@@ -43,6 +43,8 @@ let setup () =
       ResultsDir.create_results_dir ()
   | Explore ->
       ResultsDir.assert_results_dir "please run an infer analysis first"
+  | Events ->
+      ResultsDir.assert_results_dir "have you run infer before?"
 
 
 let print_active_checkers () =
@@ -72,6 +74,17 @@ let log_environment_info () =
   print_active_checkers ()
 
 
+let prepare_events_logging () =
+  (* there's no point in logging data from the events command. To fetch them we'd need to run events again... *)
+  if CLOpt.equal_command Config.command CLOpt.Events then ()
+  else (
+    L.environment_info "Infer log identifier is %s\n" (EventLogger.get_log_identifier ()) ;
+    let log_uncaught_exn exn ~exitcode =
+      EventLogger.log (EventLogger.UncaughtException (exn, exitcode))
+    in
+    L.set_log_uncaught_exception_callback log_uncaught_exn )
+
+
 let () =
   ( if Config.linters_validate_syntax_only then
       match CTLParserHelper.validate_al_files () with
@@ -82,6 +95,7 @@ let () =
   if Config.print_builtins then Builtin.print_and_exit () ;
   setup () ;
   log_environment_info () ;
+  prepare_events_logging () ;
   if Config.debug_mode && CLOpt.is_originator then
     L.progress "Logs in %s@." (Config.results_dir ^/ Config.log_file) ;
   ( match Config.command with
@@ -126,5 +140,9 @@ let () =
       if is_error (Unix.waitpid (Unix.fork_exec ~prog ~argv:(prog :: args) ())) then
         L.external_error
           "** Error running the reporting script:@\n**   %s %s@\n** See error above@." prog
-          (String.concat ~sep:" " args) ) ;
+          (String.concat ~sep:" " args)
+  | Events ->
+      EventLogger.dump () ) ;
+  (* to make sure the exitcode=0 case is logged, explicitly invoke exit *)
   L.exit 0
+

infer/src/base/CommandDoc.ml

@@ -238,6 +238,17 @@ let reportdiff =
     ~see_also:CLOpt.([Report])
 
 
+let events =
+  mk_command_doc ~title:"Infer Events"
+    ~short_description:"dump all the logged events in machine readable format"
+    ~synopsis:{|$(b,infer) $(b,events)|}
+    ~description:
+      [ `P
+          "Emit to stdout one JSON object per line, each describing a logged event happened during the execution of Infer"
+      ]
+    ~see_also:CLOpt.([Report; Run])
+
+
 let run =
   mk_command_doc ~title:"Infer Analysis of a Project"
     ~short_description:"capture source files, analyze, and report"
@@ -263,6 +274,7 @@ let command_to_data =
   ; mk Capture capture
   ; mk Compile compile
   ; mk Diff diff
+  ; mk Events events
   ; mk Explore explore
   ; mk Report report
   ; mk ReportDiff reportdiff

infer/src/base/CommandLineOption.ml

@@ -95,6 +95,7 @@ type command =
   | Capture
   | Compile
   | Diff
+  | Events
   | Explore
   | Report
   | ReportDiff
@@ -110,6 +111,7 @@ let command_to_name =
   ; (Capture, "capture")
   ; (Compile, "compile")
   ; (Diff, "diff")
+  ; (Events, "events")
   ; (Explore, "explore")
   ; (Report, "report")
   ; (ReportDiff, "reportdiff")

infer/src/base/CommandLineOption.mli

@@ -30,6 +30,7 @@ type command =
       (** set up the infer environment then run the compilation commands without capturing the
                 source files *)
   | Diff  (** orchestrate a diff analysis *)
+  | Events  (** dump logged events into stdout *)
   | Explore  (** explore infer reports *)
   | Report  (** post-process infer results and reports *)
   | ReportDiff  (** compute the difference of two infer reports *)

infer/src/base/Config.ml

@@ -186,6 +186,8 @@ let dotty_output = "icfg.dot"
 
 let duplicates_filename = "duplicates.txt"
 
+let events_dir_name = "events"
+
 (** exit code to use for the --fail-on-issue option *)
 let fail_on_issue_exit_code = 2
 
@@ -563,7 +565,7 @@ let () =
     match cmd with
     | Report ->
         `Add
-    | Analyze | Capture | Compile | Diff | Explore | ReportDiff | Run ->
+    | Analyze | Capture | Compile | Diff | Events | Explore | ReportDiff | Run ->
         `Reject
   in
   (* make sure we generate doc for all the commands we know about *)
@@ -2157,8 +2159,10 @@ let post_parsing_initialization command_opt =
       ANSITerminal.(prerr_string [])
         "Run the command again with `--keep-going` to try and ignore this error." ;
       Out_channel.newline stderr ) ;
+    let exitcode = L.exit_code_of_exception exn in
+    L.log_uncaught_exception exn ~exitcode ;
     late_epilogue () ;
-    Pervasives.exit (L.exit_code_of_exception exn)
+    Pervasives.exit exitcode
   in
   Caml.Printexc.set_uncaught_exception_handler uncaught_exception_handler ;
   F.set_margin !margin ;

infer/src/base/Config.mli

@@ -143,6 +143,8 @@ val default_in_zip_results_dir : string
 
 val dotty_output : string
 
+val events_dir_name : string
+
 val etc_dir : string
 
 val fail_on_issue_exit_code : int

infer/src/base/Die.ml

@@ -29,6 +29,12 @@ let raise_error error ~msg =
       raise (InferUserError msg)
 
 
+let log_uncaught_exception_callback_ref = ref (fun _ ~exitcode:_ -> ())
+
+let set_log_uncaught_exception_callback fn = log_uncaught_exception_callback_ref := fn
+
+let log_uncaught_exception exn ~exitcode = !log_uncaught_exception_callback_ref exn ~exitcode
+
 let die error fmt = F.kasprintf (fun msg -> raise_error error ~msg) fmt
 
 let exit exitcode = raise (InferExit exitcode)

infer/src/base/Die.mli

@@ -27,6 +27,10 @@ val exit : int -> 'a
 
 val exit_code_of_exception : Exn.t -> int
 
+val set_log_uncaught_exception_callback : (exn -> exitcode:int -> unit) -> unit
+
+val log_uncaught_exception : exn -> exitcode:int -> unit
+
 val die : error -> ('a, Format.formatter, unit, _) format4 -> 'a
 (** Raise the corresponding exception. *)
 

infer/src/base/Epilogues.ml

@@ -36,3 +36,4 @@ let register ~f desc =
   Pervasives.at_exit f_no_exn ;
   (* Register signal masking. *)
   Lazy.force activate_run_epilogues_on_signal
+

infer/src/base/EventLogger.ml

@@ -0,0 +1,118 @@
+(*
+ * Copyright (c) 2017 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+open! IStd
+module CLOpt = CommandLineOption
+
+module IO = struct
+  let log_file_extension = ".log"
+
+  let events_dir =
+    Option.value (Sys.getenv Config.infer_top_results_dir_env_var) ~default:Config.results_dir
+    ^/ Config.events_dir_name
+
+
+  let out_chan = ref None
+
+  let close () =
+    match !out_chan with
+    | None ->
+        ()
+    | Some chan ->
+        Out_channel.close chan ;
+        out_chan := None
+
+
+  let prepare () =
+    close () ;
+    let fname = events_dir ^/ (Unix.getpid () |> Pid.to_string) ^ log_file_extension in
+    let oc = Pervasives.open_out_gen [Open_append; Open_creat] 0o666 fname in
+    out_chan := Some oc
+
+
+  let write fmt =
+    match !out_chan with Some oc -> Printf.fprintf oc fmt | _ -> Printf.ifprintf stdout fmt
+
+
+  let dump () =
+    let dump_file_to_stdout fname =
+      let ic = In_channel.create fname in
+      In_channel.iter_lines ic ~f:print_endline
+    in
+    let log_files = Utils.find_files ~path:events_dir ~extension:log_file_extension in
+    List.iter log_files ~f:dump_file_to_stdout
+
+
+  let () = Config.register_late_epilogue close
+end
+
+module Random_id : sig
+  val get : unit -> string
+end = struct
+  let () = Random.self_init ()
+
+  let generate () = Random.int64 1_000_000_000_000L |> Int64.to_string
+
+  let infer_run_identifier_env_var = "INFER_RUN_IDENTIFIER"
+
+  let get () =
+    match Sys.getenv infer_run_identifier_env_var with
+    | Some id ->
+        id
+    | None ->
+        let new_id = generate () in
+        Unix.putenv ~key:infer_run_identifier_env_var ~data:new_id ;
+        new_id
+
+end
+
+let get_log_identifier () = Random_id.get ()
+
+type event = UncaughtException of exn * int
+
+let string_of_event event = match event with UncaughtException _ -> "UncaughtException"
+
+let sequence_ctr = ref 0
+
+let pid () = Pid.to_int (Unix.getpid ())
+
+let sysname =
+  try
+    Utils.with_process_in "uname 2>/dev/null" (fun chan ->
+        Scanf.bscanf (Scanf.Scanning.from_channel chan) "%s" (fun n -> n) )
+    |> fst
+  with _ -> "Unknown"
+
+
+let create_row event =
+  incr sequence_ctr ;
+  let open JsonBuilder in
+  let base =
+    empty |> add_string ~key:"command" ~data:(CLOpt.name_of_command Config.command)
+    |> add_string ~key:"event_tag" ~data:(string_of_event event)
+    |> add_string ~key:"hostname" ~data:(Unix.gethostname ())
+    |> add_string ~key:"infer_commit" ~data:Version.commit
+    |> add_int ~key:"is_originator" ~data:(if CLOpt.is_originator then 1 else 0)
+    |> add_int ~key:"pid" ~data:(pid ())
+    |> add_string ~key:"run_identifier" ~data:(get_log_identifier ())
+    |> add_int ~key:"sequence" ~data:(!sequence_ctr - 1) |> add_string ~key:"sysname" ~data:sysname
+    |> add_int ~key:"time" ~data:(int_of_float (Unix.time ()))
+  in
+  ( match event with UncaughtException (exn, exitcode) ->
+      base |> add_string ~key:"exception" ~data:(Caml.Printexc.exn_slot_name exn)
+      |> add_string ~key:"exception_info" ~data:(Exn.to_string exn)
+      |> add_int ~key:"exitcode" ~data:exitcode )
+  |> JsonBuilder.to_json
+
+
+let prepare = IO.prepare
+
+let log event = IO.write "%s\n" (create_row event)
+
+let dump = IO.dump

infer/src/base/EventLogger.mli

@@ -0,0 +1,18 @@
+(*
+ * Copyright (c) 2017 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+type event = UncaughtException of exn * int  (** exception, exitcode *)
+
+val get_log_identifier : unit -> string
+
+val prepare : unit -> unit
+
+val log : event -> unit
+
+val dump : unit -> unit

infer/src/base/ResultsDir.ml

@@ -42,20 +42,25 @@ let remove_results_dir () =
     Utils.rmtree Config.results_dir )
 
 
-let create_results_dir () =
-  Unix.mkdir_p Config.results_dir ;
+let prepare_logging_and_db () =
   L.setup_log_file () ;
+  EventLogger.prepare () ;
   if Sys.is_file ResultsDatabase.database_fullpath <> `Yes then ResultsDatabase.create_db () ;
-  ResultsDatabase.new_database_connection () ;
-  List.iter ~f:Unix.mkdir_p results_dir_dir_markers
+  ResultsDatabase.new_database_connection ()
+
+
+let create_results_dir () =
+  Unix.mkdir_p Config.results_dir ;
+  Unix.mkdir_p (Config.results_dir ^/ Config.events_dir_name) ;
+  List.iter ~f:Unix.mkdir_p results_dir_dir_markers ;
+  prepare_logging_and_db ()
 
 
 let assert_results_dir advice =
   Result.iter_error (is_results_dir ~check_correct_version:true ()) ~f:(fun err ->
       L.(die UserError)
         "ERROR: No results directory at '%s': %s@\nERROR: %s@." Config.results_dir err advice ) ;
-  L.setup_log_file () ;
-  ResultsDatabase.new_database_connection ()
+  prepare_logging_and_db ()
 
 
 let delete_capture_and_analysis_data () =
@@ -66,4 +71,3 @@ let delete_capture_and_analysis_data () =
   List.iter ~f:Utils.rmtree dirs_to_delete ;
   List.iter ~f:Unix.mkdir_p dirs_to_delete ;
   ()
-

infer/src/opensource/JsonBuilder.ml

@@ -0,0 +1,18 @@
+(*
+ * Copyright (c) 2017 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+type t = (string * Yojson.Basic.json) list
+
+let empty = []
+
+let add_string t ~key ~data = (key, `String data) :: t
+
+let add_int t ~key ~data = (key, `Int data) :: t
+
+let to_json t = Yojson.Basic.to_string (`Assoc t)

infer/src/opensource/JsonBuilder.mli

@@ -0,0 +1,18 @@
+(*
+ * Copyright (c) 2017 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+type t
+
+val empty : t
+
+val add_string : t -> key:string -> data:string -> t
+
+val add_int : t -> key:string -> data:int -> t
+
+val to_json : t -> string