Merge pull request #114 from mirage/mirage-dev

Update to Mirage 3 APIs

.merlin

@@ -1,7 +1,9 @@
 PKG cstruct
 PKG sexplib
-PKG result
-PKG mirage-types.lwt
+PKG result rresult
+PKG mirage-flow-lwt
+PKG mirage-kv-lwt
+PKG mirage-channel-lwt
 PKG lwt
 PKG cmdliner
 PKG astring

.travis.yml

@@ -8,3 +8,4 @@ env:
     - PACKAGE="protocol-9p"
     - OCAML_VERSION=4.03
     - DEPOPTS="named-pipe"
+    - EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git"

Makefile

@@ -1,8 +1,5 @@
 all:
-	ocaml pkg/pkg.ml build
-
-test:
-	ocaml pkg/pkg.ml build --tests true
+	ocaml pkg/pkg.ml build --tests true -q
 	ocaml pkg/pkg.ml test
 
 clean:

_tags

@@ -1,5 +1,5 @@
-true: warn(@5@8@10@11@12@14@23@24@26@29@40), bin_annot, safe_string, debug
-true: package(logs)
+true: warn(@5@8@10@11@12@14@23@24@26@29@40), annot, bin_annot, safe_string, debug
+true: package(logs rresult)
 
 "lib": include
 "unix": include

appveyor.yml

@@ -4,12 +4,12 @@ platform:
 environment:
   CYG_ROOT: "C:\\cygwin"
   CYG_BASH: "%CYG_ROOT%\\bin\\bash -lc"
-  PINS: "named-pipe.0.4.0:https://github.com/mirage/ocaml-named-pipe.git#0.4.0"
-  OPAM_SWITCH: "4.03.0+mingw64c"
+  EXTRA_REMOTES: "https://github.com/mirage/mirage-dev.git"
 
 install:
   - appveyor DownloadFile https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/appveyor-opam.sh
-  - "%CYG_ROOT%\\setup-x86.exe -qnNdO -R %CYG_ROOT% -s http://cygwin.mirror.constant.com -l C:/cygwin/var/cache/setup -P rsync -P patch -P make -P unzip -P git -P m4 -P perl -P mingw64-x86_64-gcc-core"
+  - "%CYG_ROOT%\\setup-x86.exe -qnNdO -R %CYG_ROOT% -s http://cygwin.mirror.constant.com -l C:/cygwin/var/cache/setup -P rsync -P patch -P make -P unzip -P git -P perl -P mingw64-x86_64-gcc-core"
+  - curl -L -o C:/cygwin/bin/jq https://github.com/stedolan/jq/releases/download/jq-1.5/jq-win32.exe
 
 build_script:
   - "%CYG_BASH% '${APPVEYOR_BUILD_FOLDER}/appveyor-opam.sh'"

lib/_tags

@@ -1,4 +1,4 @@
 <*.*>: package(result), package(cstruct), package(cstruct.lwt)
 <*.*>: package(sexplib), package(ppx_deriving), package(ppx_sexp_conv)
-<*.*>: package(lwt), package(mirage-types.lwt)
-<*.*>: package(astring), package(fmt), package(channel)
+<*.*>: package(lwt), package(mirage-flow-lwt mirage-channel-lwt mirage-kv-lwt)
+<*.*>: package(astring), package(fmt)

lib/protocol_9p_buffered9PReader.ml

@@ -15,14 +15,14 @@
  *
  *)
 
-open Result
+open Rresult
 open Protocol_9p_error
 open Lwt.Infix
 
 let max_message_size = 655360l       (* 640 KB should be enough... Linux limit is 32 KB *)
 
-module Make(Log: Protocol_9p_s.LOG)(FLOW: V1_LWT.FLOW) = struct
-  module C = Channel.Make(FLOW)
+module Make(Log: Protocol_9p_s.LOG)(FLOW: Mirage_flow_lwt.S) = struct
+  module C = Mirage_channel_lwt.Make(FLOW)
   type t = {
     channel: C.t;
     read_m: Lwt_mutex.t;
@@ -35,33 +35,35 @@ module Make(Log: Protocol_9p_s.LOG)(FLOW: V1_LWT.FLOW) = struct
     let input_buffer = Cstruct.create 0 in
     { channel; read_m; input_buffer }
 
-  let read_exactly ~len t =
-    let rec loop acc = function
-      | 0 -> Lwt.return @@ Cstruct.concat @@ List.rev acc
-      | len ->
-        C.read_some ~len t
-        >>= fun buffer ->
-        loop (buffer :: acc) (len - (Cstruct.len buffer)) in
-    loop [] len
+  let read_exactly ~len c =
+    C.read_exactly ~len c >>= function
+    | Ok (`Data bufs) -> Lwt.return (Ok (Cstruct.concat bufs))
+    | Ok `Eof -> Lwt.return (Error `Eof)
+    | Error e -> Lwt.return (Error (`Msg (Fmt.strf "%a" C.pp_error e)))
 
   let read_must_have_lock t =
     let len_size = 4 in
-    Lwt.catch
-      (fun () ->
-        read_exactly ~len:len_size t.channel
-        >>= fun length_buffer ->
+    read_exactly ~len:len_size t.channel >>= function
+    | Ok length_buffer -> begin
         match Cstruct.LE.get_uint32 length_buffer 0 with
         | bad_length when bad_length < Int32.of_int len_size
                        || bad_length > max_message_size ->
             Lwt.return (error_msg "Message size %lu out of range" bad_length)
-        | length ->
-        read_exactly ~len:(Int32.to_int length - len_size) t.channel
-        >>= fun packet_buffer ->
-        Lwt.return (Ok packet_buffer)
-      ) (function
-        | End_of_file -> Lwt.return (error_msg "Caught EOF on underlying FLOW")
-        | C.Read_error e -> Lwt.return (error_msg "Unexpected error on underlying FLOW: %s" (FLOW.error_message e))
-        | e -> Lwt.fail e
-      )
-  let read t = Lwt_mutex.with_lock t.read_m (fun () -> read_must_have_lock t)
+        | length -> begin
+          read_exactly ~len:(Int32.to_int length - len_size) t.channel >>= function
+          | Ok packet_buffer -> Lwt.return (Ok packet_buffer)
+          | err -> Lwt.return err
+        end
+    end
+    | Error e -> Lwt.return (Error e)
+
+  let read t =
+    Lwt_mutex.with_lock t.read_m (fun () ->
+      read_must_have_lock t >|= function
+      | Ok _ as ok -> ok
+      | Error `Eof -> error_msg "Caught EOF on underlying FLOW"
+      | Error (`Msg _) as err ->
+        R.reword_error_msg (fun msg ->
+            R.msgf "Unexpected error on underlying FLOW: %s" msg) err
+    )
 end

lib/protocol_9p_buffered9PReader.mli

@@ -18,7 +18,7 @@
 val max_message_size : int32
 (** Messages longer than this will be rejected. *)
 
-module Make(Log: Protocol_9p_s.LOG)(FLOW: V1_LWT.FLOW) : sig
+module Make(Log: Protocol_9p_s.LOG)(FLOW: Mirage_flow_lwt.S): sig
 
   type t
   (** A buffered 9P message reader over a FLOW *)

lib/protocol_9p_client.ml

@@ -41,7 +41,7 @@ module type S = sig
   val readdir: t -> string list -> Types.Stat.t list Error.t Lwt.t
   val stat: t -> string list -> Types.Stat.t Error.t Lwt.t
 
-  module KV_RO : V1_LWT.KV_RO with type t = t
+  module KV_RO : Mirage_kv_lwt.RO with type t = t
 
   module LowLevel : sig
     val maximum_write_payload: t -> int32
@@ -66,7 +66,7 @@ module type S = sig
   val with_fid: t -> (Types.Fid.t -> 'a Error.t Lwt.t) -> 'a Error.t Lwt.t
 end
 
-module Make(Log: Protocol_9p_s.LOG)(FLOW: V1_LWT.FLOW) = struct
+module Make(Log: Protocol_9p_s.LOG)(FLOW: Mirage_flow_lwt.S) = struct
   module Reader = Protocol_9p_buffered9PReader.Make(Log)(FLOW)
 
   open Log
@@ -98,9 +98,11 @@ module Make(Log: Protocol_9p_s.LOG)(FLOW: V1_LWT.FLOW) = struct
   let (>>|=) m f =
     let open Lwt in
     m >>= function
-    | `Ok x -> f x
-    | `Eof -> return (error_msg "Caught EOF on underlying FLOW")
-    | `Error e -> return (error_msg "Unexpected error on underlying FLOW: %s" (FLOW.error_message e))
+    | Ok x -> f x
+    | Error `Closed -> return (error_msg "Writing to closed FLOW")
+    | Error e       ->
+      return (error_msg "Unexpected error on underlying FLOW: %a"
+                FLOW.pp_write_error e)
 
   let read_one_packet reader =
     Reader.read reader
@@ -499,30 +501,34 @@ module Make(Log: Protocol_9p_s.LOG)(FLOW: V1_LWT.FLOW) = struct
 
     type t = connection
 
-    type error =
-      | Unknown_key of string
-
-    type id = unit
+    type error = Mirage_kv.error
+    let pp_error = Mirage_kv.pp_error
 
     type page_aligned_buffer = Cstruct.t
 
     let parse_path x = String.cuts x ~sep:"/"
 
     let read t key offset length =
       let path = parse_path key in
-      let offset = Int64.of_int offset in
-      let count = Int32.of_int length in
+      let count = Int64.to_int32 length in (* FIXME: Error on overflow? *)
       read t path offset count
       >>= function
-      | Ok bufs -> return (`Ok bufs)
-      | _ -> return (`Error (Unknown_key key))
+      | Ok bufs -> return (Ok bufs)
+      | _ -> return (Error (`Unknown_key key))
 
     let size t key =
       let path = parse_path key in
       stat t path
       >>= function
-      | Ok stat -> return (`Ok stat.Types.Stat.length)
-      | _ -> return (`Error (Unknown_key key))
+      | Ok stat -> return (Ok stat.Types.Stat.length)
+      | _ -> return (Error (`Unknown_key key))
+
+    let mem t key =
+      let path = parse_path key in
+      stat t path
+      >>= function
+      | Ok _ -> return (Ok true)
+      | _ -> return (Ok false)
 
     let disconnect = disconnect
   end

lib/protocol_9p_client.mli

@@ -58,7 +58,7 @@ module type S = sig
     Protocol_9p_types.Stat.t Protocol_9p_error.t Lwt.t
   (** Return information about a named directory or named file. *)
 
-  module KV_RO : V1_LWT.KV_RO with type t = t
+  module KV_RO : Mirage_kv_lwt.RO with type t = t
 
   module LowLevel : sig
     (** The functions in this module are mapped directly onto individual 9P
@@ -150,7 +150,7 @@ module type S = sig
 end
 
 (** Given a transport (a Mirage FLOW), construct a 9P client on top. *)
-module Make(Log: Protocol_9p_s.LOG)(FLOW: V1_LWT.FLOW) : sig
+module Make(Log: Protocol_9p_s.LOG)(FLOW: Mirage_flow_lwt.S) : sig
   include S
 
   val connect:

lib/protocol_9p_error.ml

@@ -24,7 +24,7 @@ type 'a t = ('a, error) result
 
 let return x = Ok x
 
-let error_msg fmt = Printf.ksprintf (fun s -> Error (`Msg s)) fmt
+let error_msg fmt = Fmt.kstrf (fun s -> Error (`Msg s)) fmt
 
 let ( >>= ) m f = match m with
   | Error x -> Error x

lib/protocol_9p_error.mli

@@ -27,6 +27,6 @@ type 'a t = ('a, error) result
 
 val return: 'a -> ('a, error) result
 
-val error_msg: ('a, unit, string, ('b, [> `Msg of string ]) result) format4 -> 'a
+val error_msg: ('a, Format.formatter, unit, ('b, [> `Msg of string ]) result) format4 -> 'a
 
 val ( >>= ) : ('a, 'b) result -> ('a -> ('c, 'b) result) -> ('c, 'b) result

lib/protocol_9p_server.ml

@@ -27,7 +27,11 @@ module Response = Protocol_9p_response
 
 type exn_converter = Protocol_9p_info.t -> exn -> Protocol_9p_response.payload
 
-module Make(Log: Protocol_9p_s.LOG)(FLOW: V1_LWT.FLOW)(Filesystem: Protocol_9p_filesystem.S) = struct
+module Make
+    (Log: Protocol_9p_s.LOG)
+    (FLOW: Mirage_flow_lwt.S)
+    (Filesystem: Protocol_9p_filesystem.S) =
+struct
   module Reader = Protocol_9p_buffered9PReader.Make(Log)(FLOW)
   open Log
 
@@ -56,9 +60,11 @@ module Make(Log: Protocol_9p_s.LOG)(FLOW: V1_LWT.FLOW)(Filesystem: Protocol_9p_f
   let (>>|=) m f =
     let open Lwt in
     m >>= function
-    | `Ok x -> f x
-    | `Eof -> return (error_msg "Caught EOF on underlying FLOW")
-    | `Error e -> return (error_msg "Unexpected error on underlying FLOW: %s" (FLOW.error_message e))
+    | Ok x -> f x
+    | Error `Closed -> return (error_msg "Writing to closed FLOW")
+    | Error  e      ->
+      return (error_msg "Unexpected error on underlying FLOW: %a"
+                FLOW.pp_write_error e)
 
   let disconnect t =
     t.please_shutdown <- true;

lib/protocol_9p_server.mli

@@ -55,7 +55,11 @@ let unix_exn_converter info exn =
 *)
 
 
-module Make(Log: Protocol_9p_s.LOG)(FLOW: V1_LWT.FLOW)(Filesystem : Protocol_9p_filesystem.S) : sig
+module Make
+    (Log: Protocol_9p_s.LOG)
+    (FLOW: Mirage_flow_lwt.S)
+    (Filesystem: Protocol_9p_filesystem.S) :
+sig
 
   type t
   (** An established connection to a 9P client *)

lib_test/_tags

@@ -2,4 +2,5 @@
 <*.*>: package(lwt), package(cstruct.lwt)
 <*.*>: package(logs.fmt)
 <*.*>: package(astring), package(named-pipe.lwt)
-<*.*>: package(channel), package(io-page.unix)
+<*.*>: package(io-page.unix)
+<*.*>: package(mirage-flow-lwt mirage-kv-lwt mirage-channel-lwt)

opam

@@ -21,8 +21,10 @@ depends: [
   "cstruct" {>= "1.9.0"}
   "sexplib" {> "113.00.00" }
   "result"
-  "mirage-types-lwt"
-  "channel" {>= "1.1.0" }
+  "rresult"
+  "mirage-flow-lwt"
+  "mirage-kv-lwt"
+  "mirage-channel-lwt"
   "lwt" {>= "2.4.7"}
   "base-unix"
   "cmdliner"

pkg/META

@@ -1,6 +1,6 @@
 description = "9P filesystem protocol"
 version = "%%VERSION_NUM%%"
-requires = "result cstruct sexplib mirage-types.lwt lwt astring fmt channel"
+requires = "result rresult cstruct sexplib mirage-kv-lwt mirage-flow-lwt mirage-channel-lwt lwt astring fmt"
 archive(byte) = "protocol-9p.cma"
 archive(native) = "protocol-9p.cmxa"
 plugin(byte) = "protocol-9p.cma"
@@ -9,7 +9,7 @@ plugin(native) = "protocol-9p.cmxs"
 package "unix" (
  version = "%%VERSION_NUM%%"
  description = "9P filesystem protocol, using Lwt-unix"
- requires = "result fmt lwt mirage-types.lwt cstruct.lwt astring protocol-9p lwt.unix named-pipe.lwt io-page.unix"
+ requires = "result rresult fmt lwt cstruct.lwt astring protocol-9p lwt.unix named-pipe.lwt io-page.unix"
  archive(byte) = "protocol-9p-unix.cma"
  archive(native) = "protocol-9p-unix.cmxa"
  plugin(byte) = "protocol-9p-unix.cma"

src/_tags

@@ -4,6 +4,6 @@
 <*.*>: package(cmdliner, logs.fmt)
 <*.*>: package(astring), package(named-pipe.lwt)
 <*.*>: package(win-error)
-<*.*>: package(channel)
 <*.*>: package(io-page.unix)
 <*.*>: package(lwt.unix)
+<*.*>: package(mirage-flow-lwt mirage-kv-lwt mirage-channel-lwt)

unix/_tags

@@ -1,4 +1,4 @@
 <*.*>: package(result), package(fmt)
-<*.*>: package(lwt), package(mirage-types.lwt)
+<*.*>: package(lwt), package(mirage-flow-lwt)
 <*.*>: package(cstruct)
 <*.*>: package(astring), package(named-pipe.lwt)

unix/client9p_unix.ml

@@ -33,9 +33,10 @@ module Make(Log: S.LOG) = struct
 
   type connection = t
 
-  let pp_addr f = function
-    | Lwt_unix.ADDR_UNIX path -> Printf.sprintf "unix:%s" path
-    | Lwt_unix.ADDR_INET (host, port) -> Printf.sprintf "tcp:%s:%d" (Unix.string_of_inet_addr host) port
+  let pp_addr ppf = function
+    | Lwt_unix.ADDR_UNIX path -> Fmt.pf ppf "unix:%s" path
+    | Lwt_unix.ADDR_INET (host, port) ->
+      Fmt.pf ppf "tcp:%s:%d" (Unix.string_of_inet_addr host) port
 
   let connect_or_close s addr =
     Lwt.catch
@@ -117,11 +118,11 @@ module Make(Log: S.LOG) = struct
 
     type t = connection
 
-    type error = KV_RO.error = Unknown_key of string
-
     type 'a io = 'a KV_RO.io
 
-    type id = KV_RO.id
+    type error = KV_RO.error
+
+    let pp_error = KV_RO.pp_error
 
     type page_aligned_buffer = KV_RO.page_aligned_buffer
 
@@ -130,6 +131,8 @@ module Make(Log: S.LOG) = struct
     let read { client } = KV_RO.read client
 
     let size { client } = KV_RO.size client
+
+    let mem { client } = KV_RO.mem client
   end
 
   module LowLevel = struct