Merge pull request #36 from djs55/safe-string2

Use `bytes` in `write`; prepare to release 2.0.0

.travis.yml

@@ -9,3 +9,5 @@ env:
    - PACKAGE="xenstore"
  matrix:
    - DISTRO=alpine OCAML_VERSION=4.04.0
+   - DISTRO=alpine OCAML_VERSION=4.05.0
+   - DISTRO=alpine OCAML_VERSION=4.06.0

CHANGES.md

@@ -1,3 +1,9 @@
+## 2.0.0 (2017-12-06):
+* Fix build with OCaml 4.04 (and `-safe-string`)
+* Remove unnecessary dependency on `ocamlfind` and make `ounit` a test
+  dependency
+* Ensure the CI runs the unit tests
+
 ## 1.4.0 (2017-06-08):
 * Add terminating replacements for transaction function
 * Switch to jbuilder

client_lwt/xs_client_lwt.ml

@@ -29,7 +29,7 @@ module type IO = sig
   val create: unit -> channel t
   val destroy: channel -> unit t
   val read: channel -> bytes -> int -> int -> int t
-  val write: channel -> string -> int -> int -> unit t
+  val write: channel -> bytes -> int -> int -> unit t
 end
 
 module type S = sig
@@ -59,9 +59,6 @@ module type S = sig
   val set_target : handle -> int -> int -> unit Lwt.t
 end
 
-let ( |> ) a b = b a
-let ( ++ ) f g x = f (g x)
-
 let finally f g =
   Lwt.catch
     (fun () ->
@@ -171,7 +168,7 @@ module Client = functor(IO: IO with type 'a t = 'a Lwt.t) -> struct
     Printf.fprintf stderr "Caught: %s\n%!" (Printexc.to_string e);
     begin 
       match e with
-      | Xs_protocol.Response_parser_failed x ->
+      | Xs_protocol.Response_parser_failed _ ->
       (* Lwt_io.hexdump Lwt_io.stderr x *)
          return ()
       | _ -> return ()

client_lwt/xs_client_lwt.mli

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

client_unix/xs_client_unix.ml

@@ -14,7 +14,6 @@
 
 (** A multiplexing xenstore protocol client over a byte-level transport *)
 
-open Thread
 open Xs_protocol
 
 let finally f g =
@@ -42,12 +41,9 @@ module type IO = sig
   val create: unit -> channel t
   val destroy: channel -> unit t
   val read: channel -> bytes -> int -> int -> int t
-  val write: channel -> string -> int -> int -> unit t
+  val write: channel -> bytes -> int -> int -> unit t
 end
 
-let ( |> ) a b = b a
-let ( ++ ) f g x = f (g x)
-
 module StringSet = Xs_handle.StringSet
 
 exception Watch_overflow
@@ -187,7 +183,7 @@ module Client = functor(IO: IO with type 'a t = 'a) -> struct
   let handle_exn t e =
     error "Caught: %s\n%!" (Printexc.to_string e);
     begin match e with
-      | Xs_protocol.Response_parser_failed x ->
+      | Xs_protocol.Response_parser_failed _ ->
       (* Lwt_io.hexdump Lwt_io.stderr x *)
          ()
       | _ -> ()

client_unix/xs_client_unix.mli

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

core/xs_protocol.ml

@@ -127,7 +127,7 @@ module ACL = struct
       match l with
         | (owner, other) :: l -> Some { owner = owner; other = other; acl = l }
         | [] -> Some { owner = 0; other = NONE; acl = [] }
-      with e ->
+      with _ ->
       None
 end
 
@@ -148,15 +148,20 @@ type header = {
 } [@@little_endian]
 ]
 
-let to_string pkt =
+let _ = hexdump_header (* autogenerated by cstruct, triggers warning 32 *)
+
+let to_bytes pkt =
   let header = Cstruct.create sizeof_header in
   let len = Int32.of_int (Buffer.length pkt.data) in
   let ty = Op.to_int32 pkt.ty in
   set_header_ty header ty;
   set_header_rid header pkt.rid;
   set_header_tid header pkt.tid;
   set_header_len header len;
-  Cstruct.to_string header ^ (Buffer.contents pkt.data)
+  let result = Buffer.create 64 in
+  Buffer.add_bytes result (Cstruct.to_bytes header);
+  Buffer.add_buffer result pkt.data;
+  Buffer.to_bytes result
 
 let get_tid pkt = pkt.tid
 let get_ty pkt = pkt.ty
@@ -249,7 +254,7 @@ module type IO = sig
 
   type channel
   val read: channel -> bytes -> int -> int -> int t
-  val write: channel -> string -> int -> int -> unit t
+  val write: channel -> bytes -> int -> int -> unit t
 end
 
 exception Unknown_xenstore_operation of int32
@@ -294,28 +299,10 @@ module PacketStream = functor(IO: IO) -> struct
 
   (* [send client pkt] sends [pkt] and returns (), or fails *)
   let send t request =
-    let req = to_string request in
-	IO.write t.channel req 0 (String.length req)
+    let req = to_bytes request in
+	IO.write t.channel req 0 (Bytes.length req)
 end
 
-(** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT watches)  *)
-let is_valid_path path =
-  (* Paths shouldn't have a "//" in the middle *)
-  let result = ref true in
-  let bad = "//" in
-  for offset = 0 to String.length path - (String.length bad) do
-    if String.sub path offset (String.length bad) = bad then result := false
-  done;
-  (* Paths shouldn't have a "/" at the end, except for the root *)
-  if path <> "/" && path <> "" && path.[String.length path - 1] = '/'
-  then result := false;
-  !result
-
-(** Check to see if a path is suitable for watches *)
-let is_valid_watch_path path =
-  (* Check for stuff like @releaseDomain etc first *)
-  (path <> "" && path.[0] = '@') || (is_valid_path path)
-
 module Token = struct
   type t = string
 
@@ -342,12 +329,6 @@ let create tid rid ty data =
     data = b;
   }
 
-let set_data pkt (data: string) =
-  let len = String.length data in
-  let b = Buffer.create len in
-  Buffer.add_string b data;
-  { pkt with len = len; data = b }
-
 module Response = struct
 
   type payload =
@@ -400,7 +381,7 @@ module Response = struct
   let ty_of_payload = function
     | Read _ -> Op.Read
     | Directory _ -> Op.Directory
-    | Getperms perms -> Op.Getperms
+    | Getperms _ -> Op.Getperms
     | Getdomainpath _ -> Op.Getdomainpath
     | Transaction_start _ -> Op.Transaction_start
     | Debug _ -> Op.Debug
@@ -535,7 +516,7 @@ module Request = struct
 	let bool = function
 		| "F" -> false
 		| "T" -> true
-		| data ->
+		| _ ->
 			raise Parse_failure
 
 	let parse_exn request =
@@ -615,7 +596,9 @@ module Request = struct
 		| PathOp(_, Setperms _) -> Op.Setperms
 		| Set_target (_, _) -> Op.Set_target
 		| Restrict _ -> Op.Restrict
-		| Isintroduced _ -> Op.Isintroduced
+    | Isintroduced _ -> Op.Isintroduced
+    | Error _ -> Op.Error
+    | Watchevent _ -> Op.Watchevent
 
 	let transactional_of_payload = function
 		| PathOp(_, _)
@@ -647,6 +630,10 @@ module Request = struct
 			data_concat [ Printf.sprintf "%u" domid; ]
 		| Set_target (mine, yours) ->
 			data_concat [ Printf.sprintf "%u" mine; Printf.sprintf "%u" yours; ]
+    | Error _ ->
+      failwith "Unimplemented: data_of_payload (Error)"
+    | Watchevent _ ->
+      failwith "Unimplemented: data_of_payload (Watchevent)"
 
 	let print x tid rid =
 		create

core/xs_protocol.mli

@@ -103,7 +103,7 @@ module type IO = sig
 
   type channel
   val read: channel -> bytes -> int -> int -> int t
-  val write: channel -> string -> int -> int -> unit t
+  val write: channel -> bytes -> int -> int -> unit t
 end
 
 exception Unknown_xenstore_operation of int32
@@ -120,7 +120,7 @@ module PacketStream : functor(IO: IO) -> sig
   val send: stream -> t -> unit IO.t
 end
 
-val to_string : t -> string
+val to_bytes : t -> bytes
 val get_tid : t -> int32
 val get_ty : t -> Op.t
 val get_data : t -> string

core_test/xs_test.ml

@@ -52,7 +52,7 @@ let acl_parser _ =
 let test_packet_parser choose pkt () =
     let open Xs_protocol in
     let p = ref (Parser.start ()) in
-    let s = to_string pkt in
+    let s = Bytes.to_string @@ to_bytes pkt in
     let i = ref 0 in
     let finished = ref false in
     while not !finished do
@@ -211,7 +211,7 @@ let _ =
 	  "packet_printing" >:::
 		  (List.map (fun example ->
 			  let description = Xs_protocol.Op.to_string example.op in
-			  description >:: (fun () -> assert_equal ~msg:description ~printer:hexstring example.wire_fmt (Xs_protocol.to_string example.packet))
+			  description >:: (fun () -> assert_equal ~msg:description ~printer:hexstring example.wire_fmt (Bytes.to_string @@ Xs_protocol.to_bytes example.packet))
 		  ) example_packets) in
   let suite = "xenstore" >:::
     [

server/call.ml

@@ -12,12 +12,10 @@
  * GNU Lesser General Public License for more details.
  *)
 
-open Lwt
 open Xs_protocol
 open Junk
 
 let ( |> ) a b = b a
-let ( ++ ) f g x = f (g x)
 
 let debug fmt = Logging.debug "call" fmt
 let error fmt = Logging.error "call" fmt
@@ -42,7 +40,7 @@ let get_namespace_implementation path = match Store.Path.to_string_list path wit
 
 (* Perform a 'simple' operation (not a Transaction_start or Transaction_end)
    and create a response. *)
-let op_exn store c t (payload: Request.payload) : Response.payload =
+let op_exn _store c t (payload: Request.payload) : Response.payload =
 	let connection_path = c.Connection.domainpath in
 	let resolve data = Store.Path.create data connection_path in
 
@@ -145,7 +143,7 @@ let reply_exn store c (request: t) : Response.payload =
 		else Connection.get_transaction c tid in
 	let payload : Xs_protocol.Request.payload = match Xs_protocol.Request.parse (request: t) with
 		| None ->
- 			error "Failed to parse request: got %s" (hexify (Xs_protocol.to_string request));
+ 			error "Failed to parse request: got %s" (hexify (Bytes.to_string @@ Xs_protocol.to_bytes request));
 			raise Parse_failure
 		| Some x -> x in
 
@@ -191,11 +189,11 @@ let reply_exn store c (request: t) : Response.payload =
 			Introduce.(introduce { domid = domid; mfn = mfn; remote_port = remote_port });
 			Connection.fire (Xs_protocol.Op.Write, Store.Name.introduceDomain);
 			Response.Introduce
-		| Request.Resume(domid) ->
+		| Request.Resume _ ->
 			Perms.has c.Connection.perm Perms.RESUME;
 			(* register domain *)
 			Response.Resume
-		| Request.Release(domid) ->
+		| Request.Release _ ->
 			Perms.has c.Connection.perm Perms.RELEASE;
 			(* unregister domain *)
 			Connection.fire (Xs_protocol.Op.Write, Store.Name.releaseDomain);
@@ -212,7 +210,7 @@ let reply_exn store c (request: t) : Response.payload =
 			Perms.has c.Connection.perm Perms.RESTRICT;
 			c.Connection.perm <- Perms.restrict c.Connection.perm domid;
 			Response.Restrict
-		| Request.Isintroduced domid ->
+		| Request.Isintroduced _ ->
 			Perms.has c.Connection.perm Perms.ISINTRODUCED;
 			Response.Isintroduced false
 		| Request.Error msg ->
@@ -263,7 +261,7 @@ let reply store c request =
 				| Quota.Limit_reached              -> reply "EQUOTA", default
 				| Quota.Data_too_big               -> reply "E2BIG",  default
 				| Quota.Transaction_opened         -> reply "EQUOTA", default
-				| (Failure "int_of_string")        -> reply "EINVAL", default
+				| Failure _												 -> reply "EINVAL", default
 				| Namespace.Unsupported            -> reply "ENOTSUP",default
 				| _                                -> reply "EIO",    default
 			end in

server/connection.ml

@@ -12,7 +12,6 @@
  * GNU Lesser General Public License for more details.
  *)
 
-let debug fmt = Logging.debug "connection" fmt
 let info  fmt = Logging.info  "connection" fmt
 let error fmt = Logging.debug "connection" fmt
 
@@ -342,7 +341,7 @@ module Interface = struct
 		| [ "watch" ] ->
 			let all = Hashtbl.fold (fun _ w acc -> w @ acc) c.watches [] in
 			List.map string_of_int (between 0 (List.length all - 1))
-		| [ "watch"; n ] -> [ "name"; "token"; "total-events" ]
+		| [ "watch"; _ ] -> [ "name"; "token"; "total-events" ]
 		| "backend" :: rest ->
 			begin match c.interface with
 			| None -> []

server/heap_debug_interface.ml

@@ -4,7 +4,7 @@ let debug fmt = Logging.debug "memory_interface" fmt
 
 let ( |> ) a b = b a
 
-let read t (perms: Perms.t) (path: Store.Path.t) =
+let read _t (perms: Perms.t) (path: Store.Path.t) =
 	Perms.has perms Perms.CONFIGURE;
 	match Store.Path.to_string_list path with
 	| [] -> ""
@@ -16,7 +16,7 @@ let read t (perms: Perms.t) (path: Store.Path.t) =
 
 let exists t perms path = try ignore(read t perms path); true with Store.Path.Doesnt_exist _ -> false
 
-let list t perms path =
+let list _t perms path =
 	Perms.has perms Perms.CONFIGURE;
 	match Store.Path.to_string_list path with
 	| [] -> [ "heap_words"; "live_words"; "free_words"; "symbols" ]

server/logging_interface.ml

@@ -13,7 +13,7 @@ let general_params = [
 	"transaction", disable_transaction;
 ]
 
-let read t (perms: Perms.t) (path: Store.Path.t) =
+let read _t (perms: Perms.t) (path: Store.Path.t) =
 	Perms.has perms Perms.CONFIGURE;
 	match Store.Path.to_string_list path with
 		| [] -> ""
@@ -31,7 +31,7 @@ let read t (perms: Perms.t) (path: Store.Path.t) =
 
 let exists t perms path = try ignore(read t perms path); true with Store.Path.Doesnt_exist _ -> false
 
-let write t creator perms path value =
+let write _t _creator perms path value =
 	Perms.has perms Perms.CONFIGURE;
 	let f list value key = match value with
 		| "1" -> if not(List.mem key !list) then list := key :: !list
@@ -49,7 +49,7 @@ let write t creator perms path value =
 			end
 		| _ -> Store.Path.doesnt_exist path
 
-let list t perms path =
+let list _t perms path =
 	Perms.has perms Perms.CONFIGURE;
 	match Store.Path.to_string_list path with
 		| [] -> [ "request"; "reply-ok"; "reply-err" ] @ (List.map fst (List.filter (fun (_, b) -> !b) general_params))
@@ -58,7 +58,7 @@ let list t perms path =
 		| "reply-err" :: [] -> !disable_reply_err
 		| _ -> []
 
-let rm t perms path =
+let rm _t perms path =
 	Perms.has perms Perms.CONFIGURE;
 	let f list key = list := List.filter (fun x -> x <> key) !list in
 	match Store.Path.to_string_list path with

server/namespace.ml

@@ -14,7 +14,7 @@ exception Unsupported
 
 module Unsupported = struct
 	let exists _ _ _ = raise Unsupported
-	let mkdir ?with_watch _ _ _ _ = raise Unsupported
+	let mkdir ?with_watch:_ _ _ _ _ = raise Unsupported
 	let read _ _ _ = raise Unsupported
 	let write _ _ _ _ _ = raise Unsupported
 	let list _ _ _ = raise Unsupported