Permalink
Browse files

Split the NBD library into Lwt and non-Lwt versions.

Signed-off-by: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
  • Loading branch information...
1 parent 040b10d commit a751c38199bb354f7eda5e77c314df1a1cf35d00 @jonludlam jonludlam committed Apr 25, 2012
Showing with 287 additions and 164 deletions.
  1. +8 −0 nbd/META.in
  2. +22 −8 nbd/Makefile
  3. +0 −121 nbd/nbd.ml
  4. +34 −20 nbd/nbd.mli
  5. +121 −0 nbd/nbd_lwt.ml
  6. +52 −0 nbd/nbd_lwt.mli
  7. BIN nbd/nbd_test
  8. +14 −15 nbd/nbd_test.ml
  9. +36 −0 nbd/nbd_test_lwt.ml
View
@@ -3,3 +3,11 @@ description = "NBD client library"
requires = "bitstring,stdext"
archive(byte) = "nbd.cma"
archive(native) = "nbd.cmxa"
+
+package "lwt" (
+ version = "@VERSION@"
+ description = "Lwt version of the NBD client library"
+ requires = "nbd,lwt,lwt.unix"
+ archive(byte) = "nbd_lwt.cma"
+ archive(native) = "nbd_lwt.cmxa"
+)
View
@@ -1,8 +1,8 @@
include ../config.mk
-OBJS = lwt_mux nbd
+OBJS = lwt_mux nbd_lwt nbd
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
-LIBS = nbd.cma nbd.cmxa
+LIBS = nbd.cma nbd.cmxa nbd_lwt.cma nbd_lwt.cmxa
FLAGS = -package bitstring.syntax,lwt -syntax camlp4o -I ../stdext
LWTFLAGS = -package bitstring,lwt,lwt.syntax,lwt.unix -I ../stdext -I ../uuid -syntax camlp4o
PROGRAMS = nbd_test
@@ -13,14 +13,20 @@ bins: $(PROGRAMS)
libs: $(LIBS)
-nbd_test: nbd.cmxa nbd_test.ml
+nbd_test: nbd.cmxa nbd_lwt.cmxa nbd_test.ml
$(OCAMLFIND) $(OCAMLOPT) $(LWTFLAGS) -o $@ -linkpkg uuid.cmxa stdext.cmxa $^
-nbd.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
- $(OCAMLOPT) $(FLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
+nbd.cmxa: nbd.cmx
+ $(OCAMLOPT) $(FLAGS) -a -o $@ nbd.cmx
-nbd.cma: $(foreach obj,$(OBJS),$(obj).cmo)
- $(OCAMLC) $(FLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+nbd.cma: nbd.cmo
+ $(OCAMLC) $(FLAGS) -a -o $@ nbd.cmo
+
+nbd_lwt.cmxa: lwt_mux.cmx nbd_lwt.cmx
+ $(OCAMLOPT) $(LWTFLAGS) -a -o $@ $^
+
+nbd_lwt.cma: lwt_mux.cmo nbd_lwt.cmo
+ $(OCAMLC) $(LWTFLAGS) -a -o $@ $^
lwt_mux.cmx : lwt_mux.ml
$(OCAMLFIND) $(OCAMLOPT) -c $(LWTFLAGS) -o $@ $<
@@ -29,7 +35,15 @@ lwt_mux.cmo : lwt_mux.ml
$(OCAMLFIND) $(OCAMLC) -c $(LWTFLAGS) -o $@ $<
lwt_mux.cmi : lwt_mux.ml
- $(OCAMLFIND) $(OCAMLC) -c $(LWTFLAGS) $<
+ $(OCAMLFIND) $(OCAMLC) -c $(LWTFLAGS) lwt_mux.ml
+
+nbd_lwt.cmo : nbd.cmi nbd_lwt.ml
+ $(OCAMLFIND) $(OCAMLC) -c $(LWTFLAGS) nbd_lwt.ml
+
+nbd_lwt.cmx : nbd.cmi nbd_lwt.ml
+ $(OCAMLFIND) $(OCAMLOPT) -c $(LWTFLAGS) nbd_lwt.ml
+
+nbd_lwt.mli : nbd.cmi
%.cmo: %.ml
$(OCAMLFIND) $(OCAMLC) -c $(FLAGS) -o $@ $<
View
@@ -176,125 +176,4 @@ let connect hostname port =
(socket, sz, flags)
-module Lwt = struct
- let (>>=) = Lwt.bind
-
- let global_id = ref 0L
- let global_mutex = Lwt_mutex.create ()
- let get_id () = Lwt_mutex.with_lock global_mutex
- (fun () ->
- let x = !global_id in
- global_id := Int64.add 1L !global_id;
- Lwt.return x)
-
- let really_read_string sock len =
- let str = String.make len '\000' in
- let rec inner left =
- Lwt_unix.read sock str (len - left) left >>= fun n ->
- if n=left then Lwt.return str else inner (left - n)
- in
- inner len
-
- let bitstring_of_file_descr_max sock max =
- really_read_string sock max >>= fun s -> Lwt.return (Bitstring.bitstring_of_string s)
-
- module NbdRpc = struct
- type transport = Lwt_unix.file_descr
- type id = int64
- type request_hdr = Request.t
- type request_body = string option
- type response_hdr = Reply.t
- type response_body = string option
-
- let recv_hdr sock =
- really_read_string sock 16 >>= fun str ->
- let reply = parse_reply (Bitstring.bitstring_of_string str) in
- Lwt.return (Some reply.Reply.handle, reply)
-
- let recv_body sock req_hdr res_hdr =
- if res_hdr.Reply.error <> 0l then Lwt.fail (Failure "Error returned") else
- match req_hdr.Request.ty with
- | NBD_cmd_read -> really_read_string sock (Int32.to_int req_hdr.Request.len) >>= fun s -> Lwt.return (Some s)
- | _ -> Lwt.return None
-
- let send_one sock req_hdr req_body =
- let msg = construct_request req_hdr in
- Lwt_unix.write sock msg 0 (String.length msg) >>= fun n ->
- if n<>String.length msg then Lwt.fail (Failure "Short write!") else
- match req_body with
- | None -> Lwt.return ()
- | Some b -> begin Lwt_unix.write sock b 0 (String.length b) >>= fun n ->
- if n <> String.length b then Lwt.fail (Failure "Short write!") else
- Lwt.return ()
- end
-
- let id_of_request req = req.Request.handle
-
- let handle_unrequested_packet t reply =
- Lwt.return ()
- end
-
- module Mux = Lwt_mux.Mux(NbdRpc)
-
- type t = Mux.client
-
- let negotiate sock =
- let buf = String.make 256 in
- really_read_string sock 8 >>= fun str ->
- Printf.printf "Read init_passwd\n%!";
- if str <> init_passwd then Lwt.fail (Failure "Bad magic in negotiate") else
- bitstring_of_file_descr_max sock 8 >>= fun bs ->
- Printf.printf "Read magic\n%!";
- let magic = get_int64 bs in
- if magic=opts_magic then Lwt.fail (Failure "Unhandled opts_magic")
- else if magic <> cliserv_magic then Lwt.fail (Failure "Bad magic") else
- bitstring_of_file_descr_max sock 8 >>= fun bs ->
- Printf.printf "Read size\n%!";
- let sz = get_int64 bs in
- bitstring_of_file_descr_max sock 4 >>= fun bs ->
- let flags = get_int32 bs in
- Printf.printf "Read flags\n%!";
- bitstring_of_file_descr_max sock 124 >>= fun bs ->
- Mux.create sock >>= fun t ->
- Lwt.return (t, sz, flags_of_flags (Int32.to_int flags))
-
- let connect hostname port =
- let socket = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in
- Printf.printf "Created socket\n%!";
- Printf.printf "Looking up host: %s\n%!" hostname;
- let x = Lwt_unix.gethostbyname hostname in
- Printf.printf "here...\n%!";
- x >>= fun host_info ->
- Printf.printf "Gothostbyname\n%!";
- let server_address = host_info.Lwt_unix.h_addr_list.(0) in
- Lwt_unix.connect socket (Lwt_unix.ADDR_INET (server_address, port)) >>= fun () ->
- Printf.printf "Connected\n%!";
- negotiate socket
-
- let write t str from =
- get_id () >>= fun id ->
- let req_hdr = {
- Request.ty = NBD_cmd_write;
- handle=id;
- from=from;
- len=Int32.of_int (String.length str);
- } in
- let req_body = Some str in
- Mux.rpc req_hdr req_body t >>= fun _ -> Lwt.return ()
-
- let read t from len =
- get_id () >>= fun id ->
- let req_hdr = {
- Request.ty = NBD_cmd_read;
- handle=id;
- from=from;
- len=len
- } in
- let req_body = None in
- Mux.rpc req_hdr req_body t >>= fun res ->
- match res with
- | (_,Some res) -> Lwt.return res
- | _ -> Lwt.fail (Failure "No response!?")
-
-end
View
@@ -1,30 +1,44 @@
+val nbd_cmd_read : int32
+val nbd_cmd_write : int32
+val nbd_cmd_disc : int32
+val nbd_cmd_flush : int32
+val nbd_cmd_trim : int32
+val nbd_request_magic : int32
+val nbd_reply_magic : int32
+val nbd_flag_has_flags : int
+val nbd_flag_read_only : int
+val nbd_flag_send_flush : int
+val nbd_flag_send_fua : int
+val nbd_flag_rotational : int
+val nbd_flag_send_trim : int
+val init_passwd : string
+val opts_magic : int64
+val cliserv_magic : int64
type flag =
NBD_read_only
| NBD_send_flush
| NBD_send_fua
| NBD_rotational
| NBD_send_trim
-
+type cmd =
+ NBD_cmd_read
+ | NBD_cmd_write
+ | NBD_cmd_disc
+ | NBD_cmd_flush
+ | NBD_cmd_trim
+val flags_of_flags : int -> flag list
+module Request :
+ sig type t = { ty : cmd; handle : int64; from : int64; len : int32; } end
+module Reply : sig type t = { error : int32; handle : int64; } end
+val ty_of_int32 : int32 -> cmd
+val int32_of_ty : cmd -> int32
+val parse_request : string * int * int -> Request.t
+val parse_reply : string * int * int -> Reply.t
+val construct_request : Request.t -> string
+val construct_reply : Reply.t -> string
+val get_int64 : string * int * int -> int64
+val get_int32 : string * int * int -> int32
val negotiate : Unix.file_descr -> int64 * flag list
-
val read : Unix.file_descr -> int64 -> int32 -> string option
-
val write : Unix.file_descr -> string -> int64 -> int32 option
-
val connect : string -> int -> Unix.file_descr * int64 * flag list
-
-
-module Lwt :
- sig
- type t
-
- val negotiate : Lwt_unix.file_descr -> (t * int64 * flag list) Lwt.t
-
- val connect :
- string -> int -> (t * int64 * flag list) Lwt.t
-
- val write : t -> string -> int64 -> unit Lwt.t
-
- val read : t -> int64 -> int32 -> string Lwt.t
- end
-
View
@@ -0,0 +1,121 @@
+open Nbd
+
+let global_id = ref 0L
+let global_mutex = Lwt_mutex.create ()
+let get_id () = Lwt_mutex.with_lock global_mutex
+ (fun () ->
+ let x = !global_id in
+ global_id := Int64.add 1L !global_id;
+ Lwt.return x)
+
+let really_read_string sock len =
+ let str = String.make len '\000' in
+ let rec inner left =
+ lwt n = Lwt_unix.read sock str (len - left) left in
+ if n=left then Lwt.return str else inner (left - n)
+ in
+ inner len
+
+let bitstring_of_file_descr_max sock max =
+ lwt s = really_read_string sock max in
+ Lwt.return (Bitstring.bitstring_of_string s)
+
+module NbdRpc = struct
+ type transport = Lwt_unix.file_descr
+ type id = int64
+ type request_hdr = Request.t
+ type request_body = string option
+ type response_hdr = Reply.t
+ type response_body = string option
+
+ let recv_hdr sock =
+ lwt str = really_read_string sock 16 in
+ let reply = parse_reply (Bitstring.bitstring_of_string str) in
+ Lwt.return (Some reply.Reply.handle, reply)
+
+ let recv_body sock req_hdr res_hdr =
+ if res_hdr.Reply.error <> 0l then Lwt.fail (Failure "Error returned") else
+ match req_hdr.Request.ty with
+ | NBD_cmd_read ->
+ lwt s = really_read_string sock (Int32.to_int req_hdr.Request.len) in
+ Lwt.return (Some s)
+ | _ ->
+ Lwt.return None
+
+ let send_one sock req_hdr req_body =
+ let msg = construct_request req_hdr in
+ lwt n = Lwt_unix.write sock msg 0 (String.length msg) in
+ if n<>String.length msg then Lwt.fail (Failure "Short write!") else
+ match req_body with
+ | None -> Lwt.return ()
+ | Some b -> begin
+ lwt n = Lwt_unix.write sock b 0 (String.length b) in
+ if n <> String.length b then Lwt.fail (Failure "Short write!") else
+ Lwt.return ()
+ end
+
+ let id_of_request req = req.Request.handle
+
+ let handle_unrequested_packet t reply =
+ Lwt.return ()
+end
+
+module Mux = Lwt_mux.Mux(NbdRpc)
+
+type t = Mux.client
+
+let negotiate sock =
+ lwt str = really_read_string sock 8 in
+ Printf.printf "Read init_passwd\n%!";
+ if str <> init_passwd then Lwt.fail (Failure "Bad magic in negotiate") else
+ lwt bs = bitstring_of_file_descr_max sock 8 in
+ Printf.printf "Read magic\n%!";
+ let magic = get_int64 bs in
+ if magic=opts_magic then Lwt.fail (Failure "Unhandled opts_magic")
+ else if magic <> cliserv_magic then Lwt.fail (Failure "Bad magic") else
+ lwt bs = bitstring_of_file_descr_max sock 8 in
+ Printf.printf "Read size\n%!";
+ let sz = get_int64 bs in
+ lwt bs = bitstring_of_file_descr_max sock 4 in
+ let flags = get_int32 bs in
+ Printf.printf "Read flags\n%!";
+ lwt bs = bitstring_of_file_descr_max sock 124 in
+ lwt t = Mux.create sock in
+ Lwt.return (t, sz, flags_of_flags (Int32.to_int flags))
+
+let connect hostname port =
+ let socket = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in
+ Printf.printf "Created socket\n%!";
+ Printf.printf "Looking up host: %s\n%!" hostname;
+ lwt host_info = Lwt_unix.gethostbyname hostname in
+ Printf.printf "Gothostbyname\n%!";
+ let server_address = host_info.Lwt_unix.h_addr_list.(0) in
+ lwt () = Lwt_unix.connect socket (Lwt_unix.ADDR_INET (server_address, port)) in
+ Printf.printf "Connected\n%!";
+ negotiate socket
+
+let write t str from =
+ lwt id = get_id () in
+ let req_hdr = {
+ Request.ty = NBD_cmd_write;
+ handle=id;
+ from=from;
+ len=Int32.of_int (String.length str);
+ } in
+ let req_body = Some str in
+ lwt _ = Mux.rpc req_hdr req_body t in
+ Lwt.return ()
+
+let read t from len =
+ lwt id = get_id () in
+ let req_hdr = {
+ Request.ty = NBD_cmd_read;
+ handle=id;
+ from=from;
+ len=len
+ } in
+ let req_body = None in
+ lwt res = Mux.rpc req_hdr req_body t in
+ match res with
+ | (_,Some res) -> Lwt.return res
+ | _ -> Lwt.fail (Failure "No response!?")
Oops, something went wrong.

0 comments on commit a751c38

Please sign in to comment.