Merge pull request #35 from cfcs/safe-string

compile with -safe_string to make it ready for ocaml 4.06

client_lwt/jbuild

@@ -3,4 +3,5 @@
   (public_name xenstore.client)
   (wrapped false)
   (libraries (lwt xenstore))
+  (flags (:standard -safe-string))
 ))

client_lwt/xs_client_lwt.ml

@@ -28,7 +28,7 @@ module type IO = sig
   type channel
   val create: unit -> channel t
   val destroy: channel -> unit t
-  val read: channel -> string -> int -> int -> int t
+  val read: channel -> bytes -> int -> int -> int t
   val write: channel -> string -> int -> int -> unit t
 end
 

client_lwt/xs_client_lwt.mli

@@ -25,7 +25,7 @@ module type IO = sig
   type channel
   val create: unit -> channel t
   val destroy: channel -> unit t
-  val read: channel -> string -> int -> int -> int t
+  val read: channel -> bytes -> int -> int -> int t
   val write: channel -> string -> int -> int -> unit t
 end
 

client_unix/jbuild

@@ -3,4 +3,5 @@
   (public_name xenstore.unix)
   (wrapped false)
   (libraries (unix threads xenstore))
+  (flags (:standard -safe-string))
 ))

client_unix/xs_client_unix.ml

@@ -41,7 +41,7 @@ module type IO = sig
   type channel
   val create: unit -> channel t
   val destroy: channel -> unit t
-  val read: channel -> string -> int -> int -> int t
+  val read: channel -> bytes -> int -> int -> int t
   val write: channel -> string -> int -> int -> unit t
 end
 

client_unix/xs_client_unix.mli

@@ -22,7 +22,7 @@ module type IO = sig
   type channel
   val create: unit -> channel t
   val destroy: channel -> unit t
-  val read: channel -> string -> int -> int -> int t
+  val read: channel -> bytes -> int -> int -> int t
   val write: channel -> string -> int -> int -> unit t
 end
 

core/jbuild

@@ -4,5 +4,6 @@
   (wrapped false)
   (libraries (cstruct))
   (preprocess (pps (cstruct.ppx)))
+  (flags (:standard -safe-string))
 ))
 

core/xs_protocol.ml

@@ -183,11 +183,11 @@ module Parser = struct
     | Packet of t
 
   type parse =
-    | ReadingHeader of int * string
+    | ReadingHeader of int * bytes
     | ReadingBody of t
     | Finished of state
 
-  let start () = ReadingHeader (0, String.make header_size '\000')
+  let start () = ReadingHeader (0, Bytes.make header_size '\000')
 
   let state = function
     | ReadingHeader(got_already, _) -> Need_more_data (header_size - got_already)
@@ -224,21 +224,21 @@ module Parser = struct
     | None -> Finished (Unknown_operation ty)
     end
 
-  let input state bytes =
+  let input state (bytes : string) =
     match state with
-      | ReadingHeader(got_already, str) ->
-  String.blit bytes 0 str got_already (String.length bytes);
-  let got_already = got_already + (String.length bytes) in
-  if got_already < header_size
-  then ReadingHeader(got_already, str)
-  else parse_header str
-      | ReadingBody x ->
-  Buffer.add_string x.data bytes;
-  let needed = x.len - (Buffer.length x.data) in
-  if needed > 0
-  then ReadingBody x
-  else Finished (Packet x)
-      | Finished f -> Finished f
+    | ReadingHeader(got_already, (str : bytes)) ->
+      Bytes.blit_string bytes 0 str got_already (String.length bytes);
+      let got_already = got_already + (String.length bytes) in
+      if got_already < header_size
+      then ReadingHeader(got_already, str)
+      else parse_header (Bytes.to_string str)
+    | ReadingBody x ->
+      Buffer.add_string x.data bytes;
+      let needed = x.len - (Buffer.length x.data) in
+      if needed > 0
+      then ReadingBody x
+      else Finished (Packet x)
+    | Finished f -> Finished f
 end
 
 (* Should we switch to an explicit stream abstraction here? *)
@@ -248,7 +248,7 @@ module type IO = sig
   val ( >>= ): 'a t -> ('a -> 'b t) -> 'b t
 
   type channel
-  val read: channel -> string -> int -> int -> int t
+  val read: channel -> bytes -> int -> int -> int t
   val write: channel -> string -> int -> int -> unit t
 end
 
@@ -281,12 +281,12 @@ module PacketStream = functor(IO: IO) -> struct
       t.incoming_pkt <- start ();
       return (Ok pkt)
     | Need_more_data x ->
-      let buf = String.make x '\000' in
+      let buf = Bytes.make x '\000' in
       IO.read t.channel buf 0 x
       >>= (function
       | 0 -> return (Exception EOF)
       | n ->
-        let fragment = String.sub buf 0 n in
+        let fragment = Bytes.sub_string buf 0 n in
 	    t.incoming_pkt <- input t.incoming_pkt fragment;
 	    recv t)
     | Unknown_operation x -> return (Exception (Unknown_xenstore_operation x))

core/xs_protocol.mli

@@ -102,7 +102,7 @@ module type IO = sig
   val ( >>= ): 'a t -> ('a -> 'b t) -> 'b t
 
   type channel
-  val read: channel -> string -> int -> int -> int t
+  val read: channel -> bytes -> int -> int -> int t
   val write: channel -> string -> int -> int -> unit t
 end
 

core_test/jbuild

@@ -1,6 +1,7 @@
 (executables
  ((names (xs_test))
   (libraries (lwt lwt.unix xenstore oUnit))
+  (flags (:standard -safe-string))
 ))
 (alias
  ((name    runtest)

server/jbuild

@@ -2,4 +2,5 @@
  ((name xenstore_server)
   (public_name xenstore.server)
   (libraries (lwt xenstore))
+  (flags (:standard -safe-string))
 ))

server/junk.ml

@@ -20,7 +20,7 @@ type ('a, 'b) either = Right of 'a | Left of 'b
 (** apply the clean_f function after fct function has been called.
  * Even if fct raises an exception, clean_f is applied
  *)
-let exnhook = ref None 
+let exnhook = ref None
 
 let finally' fct clean_f =
 	let result = try
@@ -89,23 +89,23 @@ let list_tl_multi n l =
 
 let hexify s =
 	let hexseq_of_char c = Printf.sprintf "%02x" (Char.code c) in
-	let hs = String.create (String.length s * 2) in
+	let hs = Bytes.create (String.length s * 2) in
 	for i = 0 to String.length s - 1
 	do
 		let seq = hexseq_of_char s.[i] in
-		hs.[i * 2] <- seq.[0];
-		hs.[i * 2 + 1] <- seq.[1];
+		Bytes.set hs (i * 2) seq.[0];
+		Bytes.set hs (i * 2 + 1) seq.[1];
 	done;
-	hs
+	Bytes.to_string hs
 
 let unhexify hs =
 	let char_of_hexseq seq0 seq1 = Char.chr (int_of_string (Printf.sprintf "0x%c%c" seq0 seq1)) in
-	let s = String.create (String.length hs / 2) in
-	for i = 0 to String.length s - 1
+	let s = Bytes.create (String.length hs / 2) in
+	for i = 0 to Bytes.length s - 1
 	do
-		s.[i] <- char_of_hexseq hs.[i * 2] hs.[i * 2 + 1]
+		Bytes.set s i @@ char_of_hexseq hs.[i * 2] hs.[i * 2 + 1]
 	done;
-	s
+	Bytes.to_string s
 
 let trim_path path =
 	try

server/logging.ml

@@ -157,13 +157,13 @@ let access_type_disabled = function
 let access_type_enabled x = not(access_type_disabled x)
 
 let sanitize_data data =
-	let data = String.copy data in
-	for i = 0 to String.length data - 1
+	let data = Bytes.of_string data in
+	for i = 0 to Bytes.length data - 1
 	do
-		if data.[i] = '\000' then
-			data.[i] <- ' '
+		if Bytes.get data i = '\000' then
+			Bytes.set data i ' '
 	done;
-	String.escaped data
+	String.escaped (Bytes.to_string data)
 
 let access_logging ~con ~tid ?(data="") access_type =
 	if access_type_enabled access_type then begin

server/quota.ml

@@ -12,8 +12,6 @@
  * GNU Lesser General Public License for more details.
  *)
 
-let debug fmt = Logging.debug "quota" fmt
-let info  fmt = Logging.info  "quota" fmt
 let warn  fmt = Logging.warn  "quota" fmt
 
 exception Limit_reached
@@ -67,7 +65,7 @@ let create () =
 
 let copy quota = { cur = (Hashtbl.copy quota.cur) }
 
-let del quota id = Hashtbl.remove quota.cur id
+(*let del quota id = Hashtbl.remove quota.cur id*)
 
 let check quota id size =
 	if size > !maxsize then (

server/xs_server.ml

@@ -40,7 +40,7 @@ module type TRANSPORT = sig
   val listen: unit -> server Lwt.t
 
   type channel
-  val read: channel -> string -> int -> int -> int Lwt.t
+  val read: channel -> bytes -> int -> int -> int Lwt.t
   val write: channel -> string -> int -> int -> unit Lwt.t
   val destroy: channel -> unit Lwt.t
   val address_of: channel -> Xs_protocol.address Lwt.t

server_test/jbuild

@@ -1,6 +1,7 @@
 (executables
  ((names (server_test))
   (libraries (lwt lwt.unix xenstore xenstore.server oUnit))
+  (flags (:standard -safe-string))
 ))
 (alias
  ((name    runtest)