Merge d1b349f into 8aa88e5

lib/client.ml

@@ -26,7 +26,7 @@ let get_handle =
     this
 
 module NbdRpc = struct
-  type transport = channel
+  type transport = generic_channel
   type id = int64
   type request_hdr = Request.t
   type request_body = Cstruct.t option
@@ -87,6 +87,7 @@ type t = {
 type id = unit
 
 let make channel size_bytes flags =
+  let channel = generic_of_cleartext_channel channel in
   Rpc.create channel
   >>= fun client ->
   let read_write = not (List.mem PerExportFlag.Read_only flags) in
@@ -98,13 +99,13 @@ let make channel size_bytes flags =
 
 let list channel =
   let buf = Cstruct.create Announcement.sizeof in
-  channel.read buf
+  channel.read_clear buf
   >>= fun () ->
   match Announcement.unmarshal buf with
   | `Error e -> Lwt.fail e
   | `Ok kind ->
     let buf = Cstruct.create (Negotiate.sizeof kind) in
-    channel.read buf
+    channel.read_clear buf
     >>= fun () ->
     begin match Negotiate.unmarshal buf kind with
       | `Error e -> Lwt.fail e
@@ -114,15 +115,15 @@ let list channel =
         let buf = Cstruct.create NegotiateResponse.sizeof in
         let flags = if List.mem GlobalFlag.Fixed_newstyle x then [ ClientFlag.Fixed_newstyle ] else [] in
         NegotiateResponse.marshal buf flags;
-        channel.write buf
+        channel.write_clear buf
         >>= fun () ->
         let buf = Cstruct.create OptionRequestHeader.sizeof in
         OptionRequestHeader.(marshal buf { ty = Option.List; length = 0l });
-        channel.write buf
+        channel.write_clear buf
         >>= fun () ->
         let buf = Cstruct.create OptionResponseHeader.sizeof in
         let rec loop acc =
-          channel.read buf
+          channel.read_clear buf
           >>= fun () ->
           match OptionResponseHeader.unmarshal buf with
           | `Error e -> Lwt.fail e
@@ -131,7 +132,7 @@ let list channel =
             Lwt.return (`Error `Policy)
           | `Ok { OptionResponseHeader.response_type = OptionResponse.Server; length } ->
             let buf' = Cstruct.create (Int32.to_int length) in
-            channel.read buf'
+            channel.read_clear buf'
             >>= fun () ->
             begin match Server.unmarshal buf' with
               | `Ok server ->
@@ -145,13 +146,13 @@ let list channel =
 
 let negotiate channel export =
   let buf = Cstruct.create Announcement.sizeof in
-  channel.read buf
+  channel.read_clear buf
   >>= fun () ->
   match Announcement.unmarshal buf with
   | `Error e -> Lwt.fail e
   | `Ok kind ->
     let buf = Cstruct.create (Negotiate.sizeof kind) in
-    channel.read buf
+    channel.read_clear buf
     >>= fun () ->
     begin match Negotiate.unmarshal buf kind with
       | `Error e -> Lwt.fail e
@@ -163,18 +164,18 @@ let negotiate channel export =
         let buf = Cstruct.create NegotiateResponse.sizeof in
         let flags = if List.mem GlobalFlag.Fixed_newstyle x then [ ClientFlag.Fixed_newstyle ] else [] in
         NegotiateResponse.marshal buf flags;
-        channel.write buf
+        channel.write_clear buf
         >>= fun () ->
         let buf = Cstruct.create OptionRequestHeader.sizeof in
         OptionRequestHeader.(marshal buf { ty = Option.ExportName; length = Int32.of_int (String.length export) });
-        channel.write buf
+        channel.write_clear buf
         >>= fun () ->
         let buf = Cstruct.create (ExportName.sizeof export) in
         ExportName.marshal buf export;
-        channel.write buf
+        channel.write_clear buf
         >>= fun () ->
         let buf = Cstruct.create DiskInfo.sizeof in
-        channel.read buf
+        channel.read_clear buf
         >>= fun () ->
         begin match DiskInfo.unmarshal buf with
           | `Error e -> Lwt.fail e

lib/s.ml

@@ -25,13 +25,13 @@ module type CLIENT = sig
   type size = int64
   (** The size of a remote disk *)
 
-  val list: channel -> [ `Ok of string list | `Error of [ `Policy | `Unsupported ] ] Lwt.t
+  val list: cleartext_channel -> [ `Ok of string list | `Error of [ `Policy | `Unsupported ] ] Lwt.t
   (** [list channel] returns a list of exports known by the server.
       [`Error `Policy] means the server has this function disabled deliberately.
       [`Error `Unsupported] means the server is old and does not support the query
       function. *)
 
-  val negotiate: channel -> string -> (t * size * Protocol.PerExportFlag.t list) Lwt.t
+  val negotiate: cleartext_channel -> string -> (t * size * Protocol.PerExportFlag.t list) Lwt.t
   (** [negotiate channel export] takes an already-connected channel,
       performs the initial protocol negotiation and connects to
       the named export. Returns [disk * remote disk size * flags] *)

lib_test/protocol_test.ml

@@ -95,7 +95,7 @@ let make_client_channel test_sequence =
       else write buf
     | [] -> Lwt.fail_with "Client tried to write but the stream was empty" in
   let close () = Lwt.return () in
-  Channel.{ read; write; close; is_tls=false }
+  Channel.{ read_clear=read; write_clear=write; close_clear=close; make_tls_channel=None }
 
 let client_negotiation =
   "Perform a negotiation using the second version of the protocol from the

lwt/nbd_lwt_unix.ml

@@ -99,7 +99,7 @@ let connect hostname port =
   let server_address = host_info.Lwt_unix.h_addr_list.(0) in
   Lwt_unix.connect socket (Lwt_unix.ADDR_INET (server_address, port))
   >>= fun () ->
-  (generic_channel_of_fd socket None)
+  Lwt.return (cleartext_channel_of_fd socket None)
 
 let init_tls_get_ctx ~certfile ~ciphersuites =
   Ssl_threads.init ();

lwt/nbd_lwt_unix.mli

@@ -20,7 +20,7 @@ type tls_role =
   | TlsClient of Ssl.context
   | TlsServer of Ssl.context
 
-val connect: string -> int -> Channel.channel Lwt.t
+val connect: string -> int -> Channel.cleartext_channel Lwt.t
 (** [connect hostname port] connects to host:port and returns
     a [generic_channel] with no TLS ability or potential. *)