factor out Json-rpc and socket implementations

src/core/jsonRpc.ml

@@ -0,0 +1,70 @@
+open Json
+
+let jsonrpc_field = "jsonrpc", JString "2.0"
+
+let notification method_name params =
+	let fl = [
+		jsonrpc_field;
+		"method", JString method_name;
+	] in
+	let fl = Option.map_default (fun params -> ("params",params) :: fl) fl params in
+	JObject fl
+
+let result id data =
+	JObject [
+		jsonrpc_field;
+		"id", id;
+		"result", data;
+	]
+
+let error id code message =
+	JObject [
+		jsonrpc_field;
+		"id", id;
+		"error", JObject [
+			"code", JInt code;
+			"message", JString message;
+		];
+	]
+
+type json_rpc_error =
+	| Parse_error of string
+	| Invalid_request of string
+	| Method_not_found of Json.t * string (* id->methodname *)
+	| Invalid_params of Json.t
+	| Custom of Json.t * int * string (* id->code->message *)
+
+exception JsonRpc_error of json_rpc_error
+
+let handle_jsonrpc_error f output =
+	try f () with JsonRpc_error e ->
+		match e with
+		| Parse_error s -> output (error JNull (-32700) s)
+		| Invalid_request s -> output (error JNull (-32600) s)
+		| Method_not_found (id,meth) -> output (error id (-32601) (Printf.sprintf "Method `%s` not found" meth))
+		| Invalid_params id -> output (error id (-32602) "Invalid params")
+		| Custom (id,code,msg) -> output (error id code msg)
+
+let process_request input handle output =
+	let open Json.Reader in
+	let lexbuf = Sedlexing.Utf8.from_string input in
+	let json = try read_json lexbuf with Json_error s -> raise (JsonRpc_error (Parse_error s)) in
+	let fields = match json with JObject fl -> fl | _ -> raise (JsonRpc_error (Invalid_request "not an object")) in
+	let get_field name map =
+		let field = try List.find (fun (n,_) -> n = name) fields with Not_found -> raise (JsonRpc_error (Invalid_request ("no `" ^ name ^ "` field"))) in
+		let value = map (snd field) in
+		match value with
+		| None -> raise (JsonRpc_error (Invalid_request (Printf.sprintf "`%s` field has invalid data" name)))
+		| Some v -> v
+	in
+	let id = get_field "id" (fun v -> Some v) in
+	let meth = get_field "method" (function JString s -> Some s | _ -> None) in
+	let params =
+		try
+			let f = List.find (fun (n,_) -> n = "params") fields in
+			Some (snd f)
+		with Not_found ->
+			None
+	in
+	let res = handle id meth params in
+	output id res

src/core/jsonRpcSocket.ml

@@ -0,0 +1,9 @@
+open Json
+
+let send_json socket json =
+	let b = Buffer.create 0 in
+	write_json (Buffer.add_string b) json;
+	Socket.send_string socket (Buffer.contents b)
+
+let send_event socket event data =
+	send_json socket (JsonRpc.notification event data)

src/core/socket.ml

@@ -0,0 +1,49 @@
+open Unix
+
+type t = {
+	addr : Unix.inet_addr;
+	port : int;
+	mutable socket : Unix.file_descr option;
+}
+
+let create host port =
+	let host = Unix.inet_addr_of_string host in
+	let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+	Unix.connect socket (Unix.ADDR_INET (host,port));
+	{
+		addr = host;
+		port = port;
+		socket = Some socket;
+	}
+
+let read_byte this i = int_of_char (Bytes.get this i)
+
+let read_ui16 this i =
+	let ch1 = read_byte this i in
+	let ch2 = read_byte this (i + 1) in
+	ch1 lor (ch2 lsl 8)
+
+let read_string socket =
+	match socket.socket with
+		| None ->
+			failwith "no socket" (* TODO: reconnect? *)
+		| Some socket ->
+			let buf = Bytes.create 2 in
+			let _ = recv socket buf 0 2 [] in
+			let i = read_ui16 buf 0 in
+			let buf = Bytes.create i in
+			let _ = recv socket buf 0 i [] in
+			Bytes.to_string buf
+
+let send_string socket s =
+	match socket.socket with
+	| None ->
+		failwith "no socket" (* TODO: reconnect? *)
+	| Some socket ->
+		let l = String.length s in
+		assert (l < 0xFFFF);
+		let buf = Bytes.make 2 ' ' in
+		Bytes.set buf 0 (Char.unsafe_chr l);
+		Bytes.set buf 1 (Char.unsafe_chr (l lsr 8));
+		ignore(send socket buf 0 2 []);
+		ignore(send socket (Bytes.unsafe_of_string s) 0 (String.length s) [])

src/macro/eval/evalContext.ml

@@ -98,12 +98,6 @@ type builtins = {
 	empty_constructor_builtins : (int,unit -> value) Hashtbl.t;
 }
 
-type debug_socket = {
-	addr : Unix.inet_addr;
-	port : int;
-	mutable socket : Unix.file_descr option;
-}
-
 type exception_mode =
 	| CatchAll
 	| CatchUncaught
@@ -117,7 +111,7 @@ type debug = {
 	mutable breakpoint : breakpoint;
 	caught_types : (int,bool) Hashtbl.t;
 	mutable environment_offset_delta : int;
-	mutable debug_socket : debug_socket option;
+	mutable debug_socket : Socket.t option;
 	mutable exception_mode : exception_mode;
 }
 

src/macro/eval/evalDebugSocket.ml

@@ -3,7 +3,7 @@ open Ast
 open Type
 open Globals
 open MacroApi
-open Unix
+open JsonRpcSocket
 open Json
 open EvalContext
 open EvalValue
@@ -12,122 +12,8 @@ open EvalPrinting
 open EvalMisc
 open EvalDebugMisc
 
-module JsonRpc = struct
-	let jsonrpc_field = "jsonrpc", JString "2.0"
-
-	let notification method_name params =
-		let fl = [
-			jsonrpc_field;
-			"method", JString method_name;
-		] in
-		let fl = Option.map_default (fun params -> ("params",params) :: fl) fl params in
-		JObject fl
-
-	let result id data =
-		JObject [
-			jsonrpc_field;
-			"id", id;
-			"result", data;
-		]
-
-	let error id code message =
-		JObject [
-			jsonrpc_field;
-			"id", id;
-			"error", JObject [
-				"code", JInt code;
-				"message", JString message;
-			];
-		]
-
-	type json_rpc_error =
-		| Parse_error of string
-		| Invalid_request of string
-		| Method_not_found of Json.t * string (* id->methodname *)
-		| Invalid_params of Json.t
-		| Custom of Json.t * int * string (* id->code->message *)
-
-	exception JsonRpc_error of json_rpc_error
-
-	let handle_jsonrpc_error f output =
-		try f () with JsonRpc_error e ->
-			match e with
-			| Parse_error s -> output (error JNull (-32700) s)
-			| Invalid_request s -> output (error JNull (-32600) s)
-			| Method_not_found (id,meth) -> output (error id (-32601) (Printf.sprintf "Method `%s` not found" meth))
-			| Invalid_params id -> output (error id (-32602) "Invalid params")
-			| Custom (id,code,msg) -> output (error id code msg)
-
-	let process_request input handle output =
-		let open Json.Reader in
-		let lexbuf = Sedlexing.Utf8.from_string input in
-		let json = try read_json lexbuf with Json_error s -> raise (JsonRpc_error (Parse_error s)) in
-		let fields = match json with JObject fl -> fl | _ -> raise (JsonRpc_error (Invalid_request "not an object")) in
-		let get_field name map =
-			let field = try List.find (fun (n,_) -> n = name) fields with Not_found -> raise (JsonRpc_error (Invalid_request ("no `" ^ name ^ "` field"))) in
-			let value = map (snd field) in
-			match value with
-			| None -> raise (JsonRpc_error (Invalid_request (Printf.sprintf "`%s` field has invalid data" name)))
-			| Some v -> v
-		in
-		let id = get_field "id" (fun v -> Some v) in
-		let meth = get_field "method" (function JString s -> Some s | _ -> None) in
-		let params =
-			try
-				let f = List.find (fun (n,_) -> n = "params") fields in
-			 	Some (snd f)
-			with Not_found ->
-				None
-		in
-		let res = handle id meth params in
-		output id res
-end
-
-module Transport = struct
-	let read_byte this i = int_of_char (Bytes.get this i)
-
-	let read_ui16 this i =
-		let ch1 = read_byte this i in
-		let ch2 = read_byte this (i + 1) in
-		ch1 lor (ch2 lsl 8)
-
-	let read_string socket =
-		match socket.socket with
-			| None ->
-				failwith "no socket" (* TODO: reconnect? *)
-			| Some socket ->
-				let buf = Bytes.create 2 in
-				let _ = recv socket buf 0 2 [] in
-				let i = read_ui16 buf 0 in
-				let buf = Bytes.create i in
-				let _ = recv socket buf 0 i [] in
-				Bytes.to_string buf
-
-	let send_string socket s =
-		match socket.socket with
-		| None ->
-			failwith "no socket" (* TODO: reconnect? *)
-		| Some socket ->
-			let l = String.length s in
-			assert (l < 0xFFFF);
-			let buf = Bytes.make 2 ' ' in
-			Bytes.set buf 0 (Char.unsafe_chr l);
-			Bytes.set buf 1 (Char.unsafe_chr (l lsr 8));
-			ignore(send socket buf 0 2 []);
-			ignore(send socket (Bytes.unsafe_of_string s) 0 (String.length s) [])
-end
-
 (* Printing *)
 
-
-let print_json socket json =
-	let b = Buffer.create 0 in
-	write_json (Buffer.add_string b) json;
-	Transport.send_string socket (Buffer.contents b)
-
-let output_event socket event data =
-	print_json socket (JsonRpc.notification event data)
-
 let var_to_json name value access =
 	let jv t v structured =
 		JObject ["name",JString name;"type",JString t;"value",JString v;"structured",JBool structured;"access",JString access]
@@ -549,7 +435,7 @@ let make_connection socket =
 					raise (JsonRpc_error (Method_not_found (id, meth)))
 			in
 			let process_outcome id outcome =
-				let output j = print_json socket (JsonRpc.result id j) in
+				let output j = send_json socket (JsonRpc.result id j) in
 				match outcome with
 				| Loop result ->
 					output result;
@@ -562,18 +448,18 @@ let make_connection socket =
 					wait ctx run env;
 			in
 			let send_output_and_continue json =
-				print_json socket json;
+				send_json socket json;
 				loop ();
 			in
-			JsonRpc.handle_jsonrpc_error (fun () -> JsonRpc.process_request (Transport.read_string socket) handle_request process_outcome) send_output_and_continue;
+			JsonRpc.handle_jsonrpc_error (fun () -> JsonRpc.process_request (Socket.read_string socket) handle_request process_outcome) send_output_and_continue;
 		in
 		loop ()
 	in
 	let output_breakpoint_stop _ _ =
-		output_event socket "breakpointStop" None
+		send_event socket "breakpointStop" None
 	in
 	let output_exception_stop _ v _ =
-		output_event socket "exceptionStop" (Some (JObject ["text",JString (value_string v)]))
+		send_event socket "exceptionStop" (Some (JObject ["text",JString (value_string v)]))
 	in
 	{
 		wait = wait;

src/macro/eval/evalMain.ml

@@ -71,11 +71,8 @@ let create com api is_macro =
 					let s = Common.defined_value com Define.EvalDebugger in
 					if s = "1" then raise Exit;
 					let host,port = try ExtString.String.split s ":" with _ -> fail "Invalid host format, expected host:port" in
-					let host = try Unix.inet_addr_of_string host with exc -> fail (Printexc.to_string exc) in
 					let port = try int_of_string port with _ -> fail "Invalid port, expected int" in
-					let socket = try (Unix.socket Unix.PF_INET Unix.SOCK_STREAM) 0 with exc -> fail (Printexc.to_string exc) in
-					Unix.connect socket (Unix.ADDR_INET (host,port));
-					Some {addr = host; port = port; socket = Some socket}
+					Some (try Socket.create host port with exc -> fail (Printexc.to_string exc))
 				with _ ->
 					None
 			in