From 38eab123baec9518e0e0e049c27767f38cda49db Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 14 Nov 2017 23:15:31 +0100 Subject: [PATCH] compile with -safe_string to make it ready for ocaml 4.06 --- client_lwt/jbuild | 1 + client_lwt/xs_client_lwt.ml | 2 +- client_lwt/xs_client_lwt.mli | 2 +- client_unix/jbuild | 1 + client_unix/xs_client_unix.ml | 2 +- client_unix/xs_client_unix.mli | 2 +- core/jbuild | 1 + core/xs_protocol.ml | 38 +++++++++++++++++----------------- core/xs_protocol.mli | 2 +- core_test/jbuild | 1 + server/jbuild | 1 + server/junk.ml | 18 ++++++++-------- server/logging.ml | 10 ++++----- server/quota.ml | 4 +--- server/xs_server.ml | 2 +- server_test/jbuild | 1 + 16 files changed, 46 insertions(+), 42 deletions(-) diff --git a/client_lwt/jbuild b/client_lwt/jbuild index b9d23baa..7ec2cf14 100644 --- a/client_lwt/jbuild +++ b/client_lwt/jbuild @@ -3,4 +3,5 @@ (public_name xenstore.client) (wrapped false) (libraries (lwt xenstore)) + (flags (:standard -safe-string)) )) diff --git a/client_lwt/xs_client_lwt.ml b/client_lwt/xs_client_lwt.ml index dd3ebe65..5d424348 100644 --- a/client_lwt/xs_client_lwt.ml +++ b/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 diff --git a/client_lwt/xs_client_lwt.mli b/client_lwt/xs_client_lwt.mli index 4e62df4e..f3ea6d3d 100644 --- a/client_lwt/xs_client_lwt.mli +++ b/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 diff --git a/client_unix/jbuild b/client_unix/jbuild index 854d8ca9..6f20f68a 100644 --- a/client_unix/jbuild +++ b/client_unix/jbuild @@ -3,4 +3,5 @@ (public_name xenstore.unix) (wrapped false) (libraries (unix threads xenstore)) + (flags (:standard -safe-string)) )) diff --git a/client_unix/xs_client_unix.ml b/client_unix/xs_client_unix.ml index 3a4c7d8c..24b9f198 100644 --- a/client_unix/xs_client_unix.ml +++ b/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 diff --git a/client_unix/xs_client_unix.mli b/client_unix/xs_client_unix.mli index 2232dd4e..03fcb162 100644 --- a/client_unix/xs_client_unix.mli +++ b/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 diff --git a/core/jbuild b/core/jbuild index 49e28b8d..c4e1a006 100644 --- a/core/jbuild +++ b/core/jbuild @@ -4,5 +4,6 @@ (wrapped false) (libraries (cstruct)) (preprocess (pps (cstruct.ppx))) + (flags (:standard -safe-string)) )) diff --git a/core/xs_protocol.ml b/core/xs_protocol.ml index e80fa441..4b115786 100644 --- a/core/xs_protocol.ml +++ b/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)) diff --git a/core/xs_protocol.mli b/core/xs_protocol.mli index 607b41cd..4b1f2fba 100644 --- a/core/xs_protocol.mli +++ b/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 diff --git a/core_test/jbuild b/core_test/jbuild index 53b868fb..8e2a12e6 100644 --- a/core_test/jbuild +++ b/core_test/jbuild @@ -1,6 +1,7 @@ (executables ((names (xs_test)) (libraries (lwt lwt.unix xenstore oUnit)) + (flags (:standard -safe-string)) )) (alias ((name runtest) diff --git a/server/jbuild b/server/jbuild index daaa0d46..d0d24088 100644 --- a/server/jbuild +++ b/server/jbuild @@ -2,4 +2,5 @@ ((name xenstore_server) (public_name xenstore.server) (libraries (lwt xenstore)) + (flags (:standard -safe-string)) )) diff --git a/server/junk.ml b/server/junk.ml index c3f5c5fd..99eb8846 100644 --- a/server/junk.ml +++ b/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 diff --git a/server/logging.ml b/server/logging.ml index aaac421c..15365dcf 100644 --- a/server/logging.ml +++ b/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 diff --git a/server/quota.ml b/server/quota.ml index 175c9bbc..6ad04a45 100644 --- a/server/quota.ml +++ b/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 ( diff --git a/server/xs_server.ml b/server/xs_server.ml index aa955743..22be2c08 100644 --- a/server/xs_server.ml +++ b/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 diff --git a/server_test/jbuild b/server_test/jbuild index 01352a06..9aa868b5 100644 --- a/server_test/jbuild +++ b/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)