Merge pull request #51 from samoht/mirage3

Mirage3

.merlin

@@ -0,0 +1,4 @@
+PKG mirage-time-lwt mirage-flow-lwt bos logs duration cmdliner
+S lwt
+B +threads
+B _build/**

.travis.yml

@@ -9,10 +9,10 @@ env:
    - PRE_INSTALL_HOOK="cd /home/opam/opam-repository && git pull origin master && opam update -u -y"
    - PACKAGE="hvsock"
  matrix:
-   - DISTRO=debian-stable OCAML_VERSION=4.02.3
+   - DISTRO=debian-stable OCAML_VERSION=4.04.0
    - DISTRO=debian-testing OCAML_VERSION=4.03.0
-   - DISTRO=debian-unstable OCAML_VERSION=4.02.3
+   - DISTRO=debian-unstable OCAML_VERSION=4.04.0
    - DISTRO=ubuntu-16.04 OCAML_VERSION=4.03.0
-   - DISTRO=centos-7 OCAML_VERSION=4.02.3
-   - DISTRO=fedora-24 OCAML_VERSION=4.02.3
+   - DISTRO=centos-7 OCAML_VERSION=4.04.0
+   - DISTRO=fedora-24 OCAML_VERSION=4.04.0
    - DISTRO=alpine-3.4 OCAML_VERSION=4.03.0

_oasis

@@ -1,4 +1,4 @@
-OASISFormat: 0.3
+OASISFormat: 0.4
 Name:        hvsock
 Version:     0.13.0
 Synopsis:    Hyper-V sockets
@@ -24,8 +24,8 @@ Library "hvsock_lwt"
   Findlibname:        lwt
   Findlibparent:      hvsock
   Modules:            Lwt_hvsock, Flow_lwt_hvsock, Flow_lwt_hvsock_shutdown
-  BuildDepends:       lwt, hvsock, bytes, mirage-types.lwt, cstruct,
-    mirage-flow, logs, threads, duration
+  BuildDepends:       lwt, hvsock, bytes, mirage-time-lwt, mirage-flow-lwt,
+                      cstruct, mirage-flow, logs, threads, duration, bos
 
 Library "hvsock_lwt_unix"
   Pack:               false
@@ -35,8 +35,9 @@ Library "hvsock_lwt_unix"
   Findlibparent:      hvsock
   Modules:            Flow_lwt_unix_hvsock, Flow_lwt_unix_hvsock_shutdown,
     Flow_lwt_unix_time, Lwt_hvsock_detach, Lwt_hvsock_main_thread
-  BuildDepends:       lwt, hvsock, hvsock.lwt, bytes, mirage-types.lwt, cstruct,
-    mirage-flow, logs, threads, lwt.preemptive
+  BuildDepends:       lwt, hvsock, hvsock.lwt, bytes, mirage-time-lwt,
+                      mirage-flow-lwt, cstruct, mirage-flow, logs, threads,
+                      lwt.preemptive, bos
 
 Document api
   Title:              Documentation and API reference

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 35d789b68413d5cf2bfe5a9b602e2bbd)
+# DO NOT EDIT (digest: 2e439513ca5b6e49b029f2a1191974e3)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -21,31 +21,36 @@ true: annot, bin_annot
 "lib/hvsock_stubs.c": package(unix)
 # Library hvsock_lwt
 "lwt/hvsock_lwt.cmxs": use_hvsock_lwt
+<lwt/*.ml{,i,y}>: package(bos)
 <lwt/*.ml{,i,y}>: package(bytes)
 <lwt/*.ml{,i,y}>: package(cstruct)
 <lwt/*.ml{,i,y}>: package(duration)
 <lwt/*.ml{,i,y}>: package(logs)
 <lwt/*.ml{,i,y}>: package(lwt)
 <lwt/*.ml{,i,y}>: package(mirage-flow)
-<lwt/*.ml{,i,y}>: package(mirage-types.lwt)
+<lwt/*.ml{,i,y}>: package(mirage-flow-lwt)
+<lwt/*.ml{,i,y}>: package(mirage-time-lwt)
 <lwt/*.ml{,i,y}>: package(threads)
 <lwt/*.ml{,i,y}>: package(unix)
 <lwt/*.ml{,i,y}>: use_hvsock
 # Library hvsock_lwt_unix
 "lwt_unix/hvsock_lwt_unix.cmxs": use_hvsock_lwt_unix
+<lwt_unix/*.ml{,i,y}>: package(bos)
 <lwt_unix/*.ml{,i,y}>: package(bytes)
 <lwt_unix/*.ml{,i,y}>: package(cstruct)
 <lwt_unix/*.ml{,i,y}>: package(duration)
 <lwt_unix/*.ml{,i,y}>: package(logs)
 <lwt_unix/*.ml{,i,y}>: package(lwt)
 <lwt_unix/*.ml{,i,y}>: package(lwt.preemptive)
 <lwt_unix/*.ml{,i,y}>: package(mirage-flow)
-<lwt_unix/*.ml{,i,y}>: package(mirage-types.lwt)
+<lwt_unix/*.ml{,i,y}>: package(mirage-flow-lwt)
+<lwt_unix/*.ml{,i,y}>: package(mirage-time-lwt)
 <lwt_unix/*.ml{,i,y}>: package(threads)
 <lwt_unix/*.ml{,i,y}>: package(unix)
 <lwt_unix/*.ml{,i,y}>: use_hvsock
 <lwt_unix/*.ml{,i,y}>: use_hvsock_lwt
 # Executable hvcat
+<src/hvcat.{native,byte}>: package(bos)
 <src/hvcat.{native,byte}>: package(bytes)
 <src/hvcat.{native,byte}>: package(cmdliner)
 <src/hvcat.{native,byte}>: package(cstruct)
@@ -55,12 +60,14 @@ true: annot, bin_annot
 <src/hvcat.{native,byte}>: package(lwt.preemptive)
 <src/hvcat.{native,byte}>: package(lwt.unix)
 <src/hvcat.{native,byte}>: package(mirage-flow)
-<src/hvcat.{native,byte}>: package(mirage-types.lwt)
+<src/hvcat.{native,byte}>: package(mirage-flow-lwt)
+<src/hvcat.{native,byte}>: package(mirage-time-lwt)
 <src/hvcat.{native,byte}>: package(threads)
 <src/hvcat.{native,byte}>: package(unix)
 <src/hvcat.{native,byte}>: use_hvsock
 <src/hvcat.{native,byte}>: use_hvsock_lwt
 <src/hvcat.{native,byte}>: use_hvsock_lwt_unix
+<src/*.ml{,i,y}>: package(bos)
 <src/*.ml{,i,y}>: package(bytes)
 <src/*.ml{,i,y}>: package(cmdliner)
 <src/*.ml{,i,y}>: package(cstruct)
@@ -70,14 +77,16 @@ true: annot, bin_annot
 <src/*.ml{,i,y}>: package(lwt.preemptive)
 <src/*.ml{,i,y}>: package(lwt.unix)
 <src/*.ml{,i,y}>: package(mirage-flow)
-<src/*.ml{,i,y}>: package(mirage-types.lwt)
+<src/*.ml{,i,y}>: package(mirage-flow-lwt)
+<src/*.ml{,i,y}>: package(mirage-time-lwt)
 <src/*.ml{,i,y}>: package(threads)
 <src/*.ml{,i,y}>: package(unix)
 <src/*.ml{,i,y}>: use_hvsock
 <src/*.ml{,i,y}>: use_hvsock_lwt
 <src/*.ml{,i,y}>: use_hvsock_lwt_unix
 # Executable test
 <lib_test/test.{native,byte}>: package(alcotest)
+<lib_test/test.{native,byte}>: package(bos)
 <lib_test/test.{native,byte}>: package(bytes)
 <lib_test/test.{native,byte}>: package(cstruct)
 <lib_test/test.{native,byte}>: package(duration)
@@ -86,13 +95,15 @@ true: annot, bin_annot
 <lib_test/test.{native,byte}>: package(lwt)
 <lib_test/test.{native,byte}>: package(lwt.preemptive)
 <lib_test/test.{native,byte}>: package(mirage-flow)
-<lib_test/test.{native,byte}>: package(mirage-types.lwt)
+<lib_test/test.{native,byte}>: package(mirage-flow-lwt)
+<lib_test/test.{native,byte}>: package(mirage-time-lwt)
 <lib_test/test.{native,byte}>: package(threads)
 <lib_test/test.{native,byte}>: package(unix)
 <lib_test/test.{native,byte}>: use_hvsock
 <lib_test/test.{native,byte}>: use_hvsock_lwt
 <lib_test/test.{native,byte}>: use_hvsock_lwt_unix
 <lib_test/*.ml{,i,y}>: package(alcotest)
+<lib_test/*.ml{,i,y}>: package(bos)
 <lib_test/*.ml{,i,y}>: package(bytes)
 <lib_test/*.ml{,i,y}>: package(cstruct)
 <lib_test/*.ml{,i,y}>: package(duration)
@@ -101,7 +112,8 @@ true: annot, bin_annot
 <lib_test/*.ml{,i,y}>: package(lwt)
 <lib_test/*.ml{,i,y}>: package(lwt.preemptive)
 <lib_test/*.ml{,i,y}>: package(mirage-flow)
-<lib_test/*.ml{,i,y}>: package(mirage-types.lwt)
+<lib_test/*.ml{,i,y}>: package(mirage-flow-lwt)
+<lib_test/*.ml{,i,y}>: package(mirage-time-lwt)
 <lib_test/*.ml{,i,y}>: package(threads)
 <lib_test/*.ml{,i,y}>: package(unix)
 <lib_test/*.ml{,i,y}>: use_hvsock

lib/META

@@ -1,6 +1,6 @@
 # OASIS_START
-# DO NOT EDIT (digest: 80e28a42ba0dd0c6122b1eaa36b2b05e)
-version = "0.12.0"
+# DO NOT EDIT (digest: ee4dffd9e1bb1ae955e02d70806ea045)
+version = "0.13.0"
 description = "Hyper-V sockets"
 requires = "unix"
 archive(byte) = "hvsock.cma"
@@ -9,10 +9,10 @@ archive(native) = "hvsock.cmxa"
 archive(native, plugin) = "hvsock.cmxs"
 exists_if = "hvsock.cma"
 package "lwt-unix" (
- version = "0.12.0"
+ version = "0.13.0"
  description = "Hyper-V sockets"
  requires =
- "lwt hvsock hvsock.lwt bytes mirage-types.lwt cstruct mirage-flow logs threads lwt.preemptive"
+ "lwt hvsock hvsock.lwt bytes mirage-time-lwt mirage-flow-lwt cstruct mirage-flow logs threads lwt.preemptive bos"
  archive(byte) = "hvsock_lwt_unix.cma"
  archive(byte, plugin) = "hvsock_lwt_unix.cma"
  archive(native) = "hvsock_lwt_unix.cmxa"
@@ -21,10 +21,10 @@ package "lwt-unix" (
 )
 
 package "lwt" (
- version = "0.12.0"
+ version = "0.13.0"
  description = "Hyper-V sockets"
  requires =
- "lwt hvsock bytes mirage-types.lwt cstruct mirage-flow logs threads duration"
+ "lwt hvsock bytes mirage-time-lwt mirage-flow-lwt cstruct mirage-flow logs threads duration bos"
  archive(byte) = "hvsock_lwt.cma"
  archive(byte, plugin) = "hvsock_lwt.cma"
  archive(native) = "hvsock_lwt.cmxa"

lwt/flow_lwt_hvsock.ml

@@ -16,15 +16,15 @@
  *
  *)
 
+open Lwt.Infix
+
 let src =
   let src = Logs.Src.create "flow_lwt_hvsock" ~doc:"AF_HYPERV flow" in
   Logs.Src.set_level src (Some Logs.Debug);
   src
 
 module Log = (val Logs.src_log src : Logs.LOG)
 
-open Lwt
-
 type buffer = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
 external stub_ba_send: Unix.file_descr -> buffer -> int -> int -> int = "stub_hvsock_ba_send"
 let cstruct_write fd b = stub_ba_send fd b.Cstruct.buffer b.Cstruct.off b.Cstruct.len
@@ -99,7 +99,7 @@ module Histogram = struct
     Printf.printf "%!"
 end
 
-module Make(Time: V1_LWT.TIME)(Fn: Lwt_hvsock.FN) = struct
+module Make(Time: Mirage_time_lwt.S)(Fn: Lwt_hvsock.FN) = struct
 
 module Blocking_hvsock = Hvsock
 module Hvsock = Lwt_hvsock.Make(Time)(Fn)
@@ -108,7 +108,12 @@ type 'a io = 'a Lwt.t
 
 type buffer = Cstruct.t
 
-type error = Unix.error
+type error = [ `Unix of Unix.error ]
+let pp_error = Bos.OS.U.pp_error
+type write_error = [ Mirage_flow.write_error | error ]
+let pp_write_error ppf = function
+  |#Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e
+  |#error as e -> pp_error ppf e
 
 let error_message = Unix.error_message
 
@@ -266,7 +271,7 @@ let wait_for_data flow n =
   Mutex.unlock flow.read_buffers_m
 
 let read flow =
-  if flow.closed || flow.read_error then return `Eof
+  if flow.closed || flow.read_error then Lwt.return (Ok `Eof)
   else begin
     Mutex.lock flow.read_buffers_m;
     let take () =
@@ -277,17 +282,16 @@ let read flow =
       result in
     if flow.read_buffers = [] then begin
       Mutex.unlock flow.read_buffers_m;
-      detach (wait_for_data flow) 1
-      >>= fun () ->
+      detach (wait_for_data flow) 1 >|= fun () ->
       (* Assume for now there's only one reader so no-one will steal the data *)
       Mutex.lock flow.read_buffers_m;
       let result = take () in
       Mutex.unlock flow.read_buffers_m;
-      return (`Ok result)
+      Ok (`Data result)
     end else begin
       let result = take () in
       Mutex.unlock flow.read_buffers_m;
-      return (`Ok result)
+      Lwt.return (Ok (`Data result))
     end
   end
 
@@ -304,7 +308,7 @@ let wait_for_space flow n =
   Mutex.unlock flow.write_buffers_m
 
 let writev flow bufs =
-  if flow.closed || flow.write_error then return `Eof else begin
+  if flow.closed || flow.write_error then Lwt.return (Error `Closed) else begin
     let len = List.fold_left (+) 0 (List.map Cstruct.len bufs) in
     Mutex.lock flow.write_buffers_m;
     let put () =
@@ -313,17 +317,16 @@ let writev flow bufs =
       Condition.broadcast flow.write_buffers_c in
     if flow.write_buffers_len + len > flow.write_buffers_max then begin
       Mutex.unlock flow.write_buffers_m;
-      detach (wait_for_space flow) len
-      >>= fun () ->
+      detach (wait_for_space flow) len >|= fun () ->
       (* Assume for now there's only one writer so no-one will steal the space *)
       Mutex.lock flow.write_buffers_m;
       put ();
       Mutex.unlock flow.write_buffers_m;
-      Lwt.return (`Ok ())
+      Ok ()
     end else begin
       put ();
       Mutex.unlock flow.write_buffers_m;
-      Lwt.return (`Ok ())
+      Lwt.return (Ok ())
     end
   end
 

lwt/flow_lwt_hvsock.mli

@@ -16,8 +16,11 @@
  *
  *)
 
-module Make(Time: V1_LWT.TIME)(Fn: Lwt_hvsock.FN): sig
-  include V1_LWT.FLOW
+module Make(Time: Mirage_time_lwt.S)(Fn: Lwt_hvsock.FN): sig
+
+  type error = [ `Unix of Unix.error ]
+
+  include Mirage_flow_lwt.S with type error := error
 
   module Hvsock: Lwt_hvsock.HVSOCK
 
@@ -30,5 +33,5 @@ module Make(Time: V1_LWT.TIME)(Fn: Lwt_hvsock.FN): sig
       `readv` will retain references to the passed buffers. They must not be
       used again by the calling application. *)
 
-  val read_into: flow -> Cstruct.t -> [ `Eof | `Error of error | `Ok of unit ] Lwt.t
+  val read_into: flow -> Cstruct.t -> (unit Mirage_flow.or_eof, error) result Lwt.t
 end