[server] start on replay logging

src/compiler/haxe.ml

@@ -49,6 +49,6 @@ Sys.catch_break true;
 let args = List.tl (Array.to_list Sys.argv) in
 set_binary_mode_out stdout true;
 set_binary_mode_out stderr true;
-let sctx = ServerCompilationContext.create false in
+let sctx = ServerCompilationContext.create false false in
 Server.process sctx (Communication.create_stdio ()) args;
 other()

src/compiler/replay.ml

@@ -0,0 +1,90 @@
+type replay_kind =
+	| InitCompilation of string list
+	| CompileContext of string list
+
+type replay_entry = {
+	replay_time : float;
+	replay_kind : replay_kind;
+}
+
+type replay = {
+	replay_out : out_channel;
+	mutable replay_has_entry : bool;
+}
+
+let cleanup () =
+	(* Cleanup old logs so we don't get mysqled *)
+	let num_keep = 5 in
+	let dir = "dump/replay" in
+	if Sys.file_exists dir then begin
+		let entries = Sys.readdir dir in
+		let l = Array.fold_left (fun acc file ->
+			let path = dir ^ "/" ^ file in
+			(path :: acc)
+		) [] entries in
+		let l = List.sort compare l in
+		let l = List.rev l in
+		let rec loop i l = match l with
+			| [] ->
+				()
+			| x :: l ->
+				if i >= num_keep then Sys.remove x;
+				loop (i + 1) l
+		in
+		loop 0 l
+	end
+
+let create () =
+	(* We shouldn't have to call that here if we can find a way to make sure each server run
+	   calls close upon exiting. It's not obvious how to do that in all cases though... *)
+	cleanup();
+	let open Unix in
+	let t = localtime (Unix.time()) in
+	let file_name = Printf.sprintf "%.4d%.2d%.2d_%.2d-%.2d-%.2d.replay" (t.tm_year + 1900) (t.tm_mon + 1) t.tm_mday t.tm_hour t.tm_min t.tm_sec in
+	let ch = Path.create_file false ".log" [] ["dump";"replay";file_name] in
+	output_string ch "[";
+	{
+		replay_out = ch;
+		replay_has_entry = false;
+	}
+
+let close replay =
+	output_string replay.replay_out "\n]";
+	close_out replay.replay_out;
+	cleanup()
+
+let create_entry time kind = {
+	replay_time = time;
+	replay_kind = kind;
+}
+
+let create_entry_now kind =
+	create_entry (Sys.time()) kind
+
+open Json
+
+let entry_to_json entry =
+	let kind_to_json kind =
+		let name,args = match kind with
+			| InitCompilation args ->
+				"InitCompilation",List.map (fun s -> JString s) args
+			| CompileContext args ->
+				"CompileContext",List.map (fun s -> JString s) args
+		in
+		[
+			"kind",JString name;
+			"args",JArray args;
+		]
+	in
+	let l = kind_to_json entry.replay_kind in
+	let l = ("time",JFloat entry.replay_time) :: l in
+	JObject l
+
+let add_entry replay entry =
+	if not replay.replay_has_entry then begin
+		replay.replay_has_entry <- true;
+	end else
+		output_string replay.replay_out ",";
+	output_string replay.replay_out "\n\t";
+	output_string replay.replay_out (string_of_json (entry_to_json entry));
+	flush replay.replay_out

src/compiler/server.ml

@@ -102,9 +102,20 @@ module ServerCompilationContext = struct
 		mutable was_compilation : bool;
 		(* True if the macro context has been set up *)
 		mutable macro_context_setup : bool;
+		(* Replay information *)
+		replay : Replay.replay option;
+		(* Things to run when the server stops *)
+		mutable atexit : (unit -> unit) list;
 	}
 
-	let create verbose = {
+	let create verbose enable_replay =
+	let replay,atexit = if enable_replay then begin
+		let replay = Replay.create() in
+		Some replay,[fun () -> Replay.close replay]
+	end else
+		None,[]
+	in
+	{
 		verbose = verbose;
 		cs = new CompilationCache.cache;
 		class_paths = Hashtbl.create 0;
@@ -114,6 +125,8 @@ module ServerCompilationContext = struct
 		delays = [];
 		was_compilation = false;
 		macro_context_setup = false;
+		replay = replay;
+		atexit = atexit;
 	}
 
 	let add_delay sctx f =
@@ -155,6 +168,11 @@ module ServerCompilationContext = struct
 	let cleanup () = match !MacroContext.macro_interp_cache with
 		| Some interp -> EvalContext.GlobalState.cleanup interp
 		| None -> ()
+
+	let close sctx =
+		let l = sctx.atexit in
+		sctx.atexit <- [];
+		List.iter (fun f -> f()) l
 end
 
 open ServerCompilationContext
@@ -504,6 +522,10 @@ let type_module sctx (ctx:Typecore.typer) mpath p =
 		None
 
 let before_anything sctx ctx =
+	begin match sctx.replay with
+		| None -> ()
+		| Some replay -> Replay.add_entry replay (Replay.create_entry_now (CompileContext ctx.com.args));
+	end;
 	ensure_macro_setup sctx
 
 let after_arg_parsing sctx ctx =
@@ -678,6 +700,10 @@ let rec process sctx comm args =
 		wait_loop = wait_loop;
 		do_connect = do_connect;
 	} in
+	begin match sctx.replay with
+		| None -> ()
+		| Some replay -> Replay.add_entry replay (Replay.create_entry_now (InitCompilation args));
+	end;
 	Compiler.HighLevel.entry api comm args;
 	run_delays sctx;
 	ServerMessage.stats stats (get_time() -. t0)
@@ -688,7 +714,8 @@ and wait_loop verbose accept =
 	if verbose then ServerMessage.enable_all ();
 	Sys.catch_break false; (* Sys can never catch a break *)
 	(* Create server context and set up hooks for parsing and typing *)
-	let sctx = ServerCompilationContext.create verbose in
+	let sctx = ServerCompilationContext.create verbose true in
+	at_exit (fun () -> close sctx);
 	let cs = sctx.cs in
 	enable_cache_mode sctx;
 	let ring = Ring.create 10 0. in

src/core/path.ml

@@ -299,7 +299,7 @@ let find_directories target recursive paths =
 	List.fold_left (fun acc dir -> loop acc dir) [] paths
 
 let make_valid_filename s =
-	let r = Str.regexp "[^A-Za-z0-9_\\-\\.,]" in
+	let r = Str.regexp "[^-A-Za-z0-9_\\.,]" in
 	Str.global_substitute r (fun s -> "_") s
 
 let module_name_of_file file =