Merge pull request #226 from mseri/master

xcp-idl: port to safe-strings without changing the interface

Author: mseri

lib/cohttp_posix_io.ml

@@ -44,15 +44,15 @@ module Unbuffered_IO = struct
     let buf = Buffer.create 128 in
     (* We can safely read everything up to this marker: *)
     let end_of_headers = "\r\n\r\n" in
-    let tmp = String.make (String.length end_of_headers) '\000' in
+    let tmp = Bytes.make (String.length end_of_headers) '\000' in
     let module Scanner = struct
       type t = {
         marker: string;
         mutable i: int;
       }
       let make x = { marker = x; i = 0 }
       let input x c =
-        if c = x.marker.[x.i] then x.i <- x.i + 1 else x.i <- 0
+        if c = String.get x.marker x.i then x.i <- x.i + 1 else x.i <- 0
       let remaining x = String.length x.marker - x.i
       let matched x = x.i = String.length x.marker
     end in
@@ -68,8 +68,8 @@ module Unbuffered_IO = struct
       if n = 0 then raise End_of_file;
 
       for j = 0 to n - 1 do
-        Scanner.input marker tmp.[j];
-        Buffer.add_char buf tmp.[j]
+        Scanner.input marker (Bytes.get tmp j);
+        Buffer.add_char buf (Bytes.get tmp j)
       done;
     done;
     Buffer.contents buf
@@ -110,13 +110,15 @@ module Unbuffered_IO = struct
     | false -> return None
 
   let read ic n =
-    let buf = String.make n '\000' in
+    let buf = Bytes.make n '\000' in
     let actually_read = Unix.read ic.fd buf 0 n in
     if actually_read = n
-    then buf
-    else String.sub buf 0 actually_read
+    then Bytes.unsafe_to_string buf
+    else Bytes.sub_string buf 0 actually_read
 
-  let write oc x = ignore(Unix.write oc x 0 (String.length x))
+  let write oc x =
+    Unix.write oc (Bytes.unsafe_of_string x) 0 (String.length x)
+    |> ignore
 
   let flush _oc = ()
 end
@@ -152,11 +154,11 @@ module Buffered_IO = struct
     | false -> return None
 
   let read ic n =
-    let buf = String.make n '\000' in
+    let buf = Bytes.make n '\000' in
     let actually_read = input ic buf 0 n in
     if actually_read = n
-    then buf
-    else String.sub buf 0 actually_read
+    then Bytes.unsafe_to_string buf
+    else Bytes.sub_string buf 0 actually_read
 
   let write oc x = output_string oc x; flush oc
 

lib/posix_channel.ml

@@ -6,7 +6,7 @@ exception Channel_setup_failed
 module CBuf = struct
   (** A circular buffer constructed from a string *)
   type t = {
-    mutable buffer: string; 
+    mutable buffer: bytes; 
     mutable len: int;       (** bytes of valid data in [buffer] *)
     mutable start: int;     (** index of first valid byte in [buffer] *)
     mutable r_closed: bool; (** true if no more data can be read due to EOF *)
@@ -23,11 +23,11 @@ module CBuf = struct
 
   let drop (x: t) n =
     if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len);
-    x.start <- (x.start + n) mod (String.length x.buffer);
+    x.start <- (x.start + n) mod (Bytes.length x.buffer);
     x.len <- x.len - n
 
   let should_read (x: t) =
-    not x.r_closed && (x.len < (String.length x.buffer - 1))
+    not x.r_closed && (x.len < (Bytes.length x.buffer - 1))
   let should_write (x: t) =
     not x.w_closed && (x.len > 0)
 
@@ -36,18 +36,18 @@ module CBuf = struct
 
   let write (x: t) fd =
     (* Offset of the character after the substring *)
-    let next = min (String.length x.buffer) (x.start + x.len) in
+    let next = min (Bytes.length x.buffer) (x.start + x.len) in
     let len = next - x.start in
     let written = try Unix.single_write fd x.buffer x.start len with _e -> x.w_closed <- true; len in
     drop x written
 
   let read (x: t) fd =
     (* Offset of the next empty character *)
-    let next = (x.start + x.len) mod (String.length x.buffer) in
-    let len = min (String.length x.buffer - next) (String.length x.buffer - x.len) in
+    let next = (x.start + x.len) mod (Bytes.length x.buffer) in
+    let len = min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) in
     let read = Unix.read fd x.buffer next len in
     if read = 0 then x.r_closed <- true;
-    x.len <- x.len + read    
+    x.len <- x.len + read
 end
 
 let proxy (a: Unix.file_descr) (b: Unix.file_descr) =
@@ -145,9 +145,9 @@ let send proxy_socket =
             if List.mem s_unix readable then begin
               let fd, _peer = Unix.accept s_unix in
               to_close := fd :: !to_close;
-              let buffer = String.make (String.length token) '\000' in
-              let n = Unix.recv fd buffer 0 (String.length buffer) [] in
-              let token' = String.sub buffer 0 n in
+              let buffer = Bytes.make (String.length token) '\000' in
+              let n = Unix.recv fd buffer 0 (Bytes.length buffer) [] in
+              let token' = Bytes.sub_string buffer 0 n in
               if token = token' then begin
                 let (_: int) = Fd_send_recv.send_fd fd token 0 (String.length token) [] proxy_socket in
                 ()
@@ -203,7 +203,7 @@ let receive protocols =
     finally
       (fun () ->
         Unix.connect s (Unix.ADDR_UNIX path);
-        let (_: int) = Unix.send s token 0 (String.length token) [] in
+        let (_: int) = Unix.send s (Bytes.unsafe_of_string token) 0 (String.length token) [] in
         let (_, _, fd) = Fd_send_recv.recv_fd s token 0 (String.length token) [] in
         fd
       ) (fun () -> Unix.close s)

lib/scheduler.ml

@@ -91,7 +91,7 @@ module Delay = struct
     mutex_execute x.m
       (fun () ->
          match x.pipe_in with
-         | Some fd -> ignore(Unix.write fd "X" 0 1)
+         | Some fd -> ignore(Unix.write fd (Bytes.of_string "X") 0 1)
          | None -> x.signalled <- true 	 (* If the wait hasn't happened yet then store up the signal *)
       )
 end

lib/xcp_client.ml

@@ -112,12 +112,12 @@ let binary_rpc string_of_call response_of_string ?(srcstr="unset") ?(dststr="uns
 			output_string oc len;
 			output_string oc msg_buf;
 			flush oc;
-			let len_buf = String.make 16 '\000' in
+			let len_buf = Bytes.make 16 '\000' in
 			really_input ic len_buf 0 16;
-			let len = int_of_string len_buf in
-			let msg_buf = String.make len '\000' in
+			let len = int_of_string (Bytes.unsafe_to_string len_buf) in
+			let msg_buf = Bytes.make len '\000' in
 			really_input ic msg_buf 0 len;
-			let (response: Rpc.response) = response_of_string msg_buf in
+			let (response: Rpc.response) = response_of_string (Bytes.unsafe_to_string msg_buf) in
 			response
 		)
 

lib/xcp_service.ml

@@ -389,9 +389,9 @@ let http_handler call_of_string string_of_response process s =
 				debug "Failed to read content-length"
 			| Some content_length ->
 				let content_length = int_of_string content_length in
-				let request_txt = String.make content_length '\000' in
+				let request_txt = Bytes.make content_length '\000' in
 				really_input ic request_txt 0 content_length;
-				let rpc_call = call_of_string request_txt in
+				let rpc_call = call_of_string (Bytes.unsafe_to_string request_txt) in
 				debug "%s" (Rpc.string_of_call rpc_call);
 				let rpc_response = process rpc_call in
 				debug "   %s" (Rpc.string_of_response rpc_response);
@@ -493,8 +493,11 @@ let pidfile_write filename =
 	finally
 	(fun () ->
 		let pid = Unix.getpid () in
-		let buf = string_of_int pid ^ "\n" in
-		let len = String.length buf in
+		let buf =
+			string_of_int pid ^ "\n" 
+			|> Bytes.of_string
+		in
+		let len = Bytes.length buf in
 		if Unix.write fd buf 0 len <> len
 		then failwith "pidfile_write failed")
 	(fun () -> Unix.close fd)

lib_test/idl_test_common.ml

@@ -23,7 +23,7 @@ let read_str filename =
   let s = Bytes.create n in
   really_input ic s 0 n;
   close_in ic;
-  s
+  Bytes.unsafe_to_string s
 
 open Idl
 

network/network_stats.ml

@@ -90,7 +90,7 @@ module File_helpers = struct
     let rec fold acc = 
       let n = Unix.read fd block 0 block_size in
       (* Consider making the interface explicitly use Substrings *)
-      let s = if n = block_size then block else String.sub block 0 n in
+      let s = if n = block_size then (Bytes.to_string block) else Bytes.sub_string block 0 n in
       if n = 0 then acc else fold (f acc s) in
     fold start