Merge pull request #30 from johnelse/sync-trunk-ring3

Sync master with the trunk-ring3 branch

.travis.yml

@@ -1,9 +1,12 @@
 language: c
-install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
-script: bash -ex .travis-opam.sh
+services: docker
+install:
+    - wget https://raw.githubusercontent.com/xenserver/xenserver-build-env/master/utils/travis-build-repo.sh
+script: bash travis-build-repo.sh
+sudo: true
 env:
-  global:
-    - PACKAGE=vhd-tool OPAM_LINT=false
-  matrix:
-    - OCAML_VERSION=4.01
-    - OCAML_VERSION=latest EXTRA_REMOTES=git://github.com/xapi-project/opam-repo-dev
+    global:
+        - REPO_PACKAGE_NAME=vhd-tool
+        - REPO_CONFIGURE_CMD=./configure
+        - REPO_BUILD_CMD=make
+        - REPO_TEST_CMD=true

_oasis

@@ -28,3 +28,11 @@ Executable "sparse_dd"
   Install:            false
   BuildDepends:       lwt, lwt.unix, lwt.syntax, lwt.preemptive, threads, vhd-format, vhd-format.lwt, cmdliner, nbd, nbd.lwt, uri, cohttp (>= 0.12.0), cohttp.lwt, xenstore, xenstore.client, xenstore.unix, xenstore_transport, xenstore_transport.unix, threads, tapctl, xcp, sha, sha.sha1, tar, io-page.unix, re.str
   CSources:           sendfile64_stubs.c
+
+Executable get_vhd_vsize
+  CompiledObject:     best
+  Path:               src
+  MainIs:             get_vhd_vsize.ml
+  Custom:             true
+  Install:            false
+  BuildDepends:       lwt, lwt.unix, vhd-format, vhd-format.lwt, cstruct, io-page.unix, threads

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 59091d3a878b9b72b98c132652e76c6b)
+# DO NOT EDIT (digest: 7b3ae22e92b5db658e74329702f2169f)
 # 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
@@ -66,22 +66,16 @@ true: annot, bin_annot
 <src/*.ml{,i,y}>: pkg_cmdliner
 <src/*.ml{,i,y}>: pkg_cohttp
 <src/*.ml{,i,y}>: pkg_cohttp.lwt
-<src/*.ml{,i,y}>: pkg_io-page.unix
-<src/*.ml{,i,y}>: pkg_lwt
 <src/*.ml{,i,y}>: pkg_lwt.preemptive
 <src/*.ml{,i,y}>: pkg_lwt.syntax
-<src/*.ml{,i,y}>: pkg_lwt.unix
 <src/*.ml{,i,y}>: pkg_nbd
 <src/*.ml{,i,y}>: pkg_nbd.lwt
 <src/*.ml{,i,y}>: pkg_re.str
 <src/*.ml{,i,y}>: pkg_sha
 <src/*.ml{,i,y}>: pkg_sha.sha1
 <src/*.ml{,i,y}>: pkg_tapctl
 <src/*.ml{,i,y}>: pkg_tar
-<src/*.ml{,i,y}>: pkg_threads
 <src/*.ml{,i,y}>: pkg_uri
-<src/*.ml{,i,y}>: pkg_vhd-format
-<src/*.ml{,i,y}>: pkg_vhd-format.lwt
 <src/*.ml{,i,y}>: pkg_xcp
 <src/*.ml{,i,y}>: pkg_xenstore
 <src/*.ml{,i,y}>: pkg_xenstore.client
@@ -114,6 +108,22 @@ true: annot, bin_annot
 "src/sendfile64_stubs.c": pkg_xenstore_transport
 "src/sendfile64_stubs.c": pkg_xenstore_transport.unix
 <src/sparse_dd.{native,byte}>: custom
+# Executable get_vhd_vsize
+<src/get_vhd_vsize.{native,byte}>: pkg_cstruct
+<src/get_vhd_vsize.{native,byte}>: pkg_io-page.unix
+<src/get_vhd_vsize.{native,byte}>: pkg_lwt
+<src/get_vhd_vsize.{native,byte}>: pkg_lwt.unix
+<src/get_vhd_vsize.{native,byte}>: pkg_threads
+<src/get_vhd_vsize.{native,byte}>: pkg_vhd-format
+<src/get_vhd_vsize.{native,byte}>: pkg_vhd-format.lwt
+<src/*.ml{,i,y}>: pkg_cstruct
+<src/*.ml{,i,y}>: pkg_io-page.unix
+<src/*.ml{,i,y}>: pkg_lwt
+<src/*.ml{,i,y}>: pkg_lwt.unix
+<src/*.ml{,i,y}>: pkg_threads
+<src/*.ml{,i,y}>: pkg_vhd-format
+<src/*.ml{,i,y}>: pkg_vhd-format.lwt
+<src/get_vhd_vsize.{native,byte}>: custom
 # OASIS_STOP
 <src/chunked.ml>: syntax_camlp4o, pkg_cstruct.syntax
 <src/input.ml>: syntax_camlp4o, pkg_lwt.syntax

setup.ml

@@ -1,7 +1,7 @@
 (* setup.ml generated for the first time by OASIS v0.4.1 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 8f97eec79b31bf661f98854d16312435) *)
+(* DO NOT EDIT (digest: 2619ef3b2c022864e532847b3063e791) *)
 (*
    Regenerated by OASIS v0.4.5
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -6839,7 +6839,39 @@ let setup_t =
                       bs_byteopt = [(OASISExpr.EBool true, [])];
                       bs_nativeopt = [(OASISExpr.EBool true, [])]
                    },
-                   {exec_custom = true; exec_main_is = "sparse_dd.ml"})
+                   {exec_custom = true; exec_main_is = "sparse_dd.ml"});
+               Executable
+                 ({
+                     cs_name = "get_vhd_vsize";
+                     cs_data = PropList.Data.create ();
+                     cs_plugin_data = []
+                  },
+                   {
+                      bs_build = [(OASISExpr.EBool true, true)];
+                      bs_install = [(OASISExpr.EBool true, false)];
+                      bs_path = "src";
+                      bs_compiled_object = Best;
+                      bs_build_depends =
+                        [
+                           FindlibPackage ("lwt", None);
+                           FindlibPackage ("lwt.unix", None);
+                           FindlibPackage ("vhd-format", None);
+                           FindlibPackage ("vhd-format.lwt", None);
+                           FindlibPackage ("cstruct", None);
+                           FindlibPackage ("io-page.unix", None);
+                           FindlibPackage ("threads", None)
+                        ];
+                      bs_build_tools = [ExternalTool "ocamlbuild"];
+                      bs_c_sources = [];
+                      bs_data_files = [];
+                      bs_ccopt = [(OASISExpr.EBool true, [])];
+                      bs_cclib = [(OASISExpr.EBool true, [])];
+                      bs_dlllib = [(OASISExpr.EBool true, [])];
+                      bs_dllpath = [(OASISExpr.EBool true, [])];
+                      bs_byteopt = [(OASISExpr.EBool true, [])];
+                      bs_nativeopt = [(OASISExpr.EBool true, [])]
+                   },
+                   {exec_custom = true; exec_main_is = "get_vhd_vsize.ml"})
             ];
           plugins = [(`Extra, "META", Some "0.4")];
           disable_oasis_section = [];
@@ -6848,14 +6880,14 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.5";
-     oasis_digest = Some "}|9=\012`\230\210]\167H3(\172\216\167";
+     oasis_digest = Some "J#\222\170z\237z)\231\128\021\241TAi[";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
   };;
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 6860 "setup.ml"
+# 6892 "setup.ml"
 (* OASIS_STOP *)
 let () = setup ();;

src/channels.ml

@@ -96,11 +96,24 @@ let of_seekable_fd fd =
     return () in
   return { c with skip }
 
-let sslctx =
-  Ssl.init ();
-  Ssl.create_context Ssl.SSLv23 Ssl.Client_context
+let _ =
+  Ssl.init ()
 
-let of_ssl_fd fd =
+let legacy_sslctx good_ciphersuites legacy_ciphersuites =
+  let ctx = Ssl.create_context Ssl.SSLv23 Ssl.Client_context in
+  Ssl.set_cipher_list ctx (good_ciphersuites ^ (match legacy_ciphersuites with "" -> "" | s -> (":" ^ s)));
+  Ssl.disable_protocols ctx [Ssl.SSLv3];
+  ctx
+
+let good_sslctx good_ciphersuites =
+  let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in
+  Ssl.set_cipher_list ctx good_ciphersuites;
+  ctx
+
+let of_ssl_fd fd ssl_legacy good_ciphersuites legacy_ciphersuites =
+  let good_ciphersuites = match good_ciphersuites with None -> failwith "good_ciphersuites not specified" | Some x -> x in
+  let legacy_ciphersuites = match legacy_ciphersuites with None -> "" | Some x -> x in
+  let sslctx = if ssl_legacy then legacy_sslctx good_ciphersuites legacy_ciphersuites else good_sslctx good_ciphersuites in
   Lwt_ssl.ssl_connect fd sslctx >>= fun sock ->
   let offset = ref 0L in
   let really_read buf =

src/cohttp_unbuffered_io.ml

@@ -125,4 +125,5 @@ let write oc x =
   Cstruct.blit_from_string x 0 buf 0 (String.length x);
   oc.Channels.really_write buf
 
-let flush oc = return ()
+let flush oc =
+  return ()

src/get_vhd_vsize.ml

@@ -0,0 +1,31 @@
+open Lwt
+
+module Impl = Vhd.F.From_file(Vhd_lwt.IO)
+open Impl
+open Vhd.F
+open Vhd_lwt.IO
+
+module In = From_input(Input)
+open In
+
+let get_vhd_vsize filename =
+  Vhd_lwt.IO.openfile filename false >>= fun fd ->
+  let rec loop = function
+    | End -> return ()
+    | Cons (hd, tl) ->
+      begin match hd with
+      | Fragment.Footer x ->
+	let size = x.Footer.current_size in
+	Printf.printf "%Ld\n" size;
+	exit 0
+      | _ ->
+	()
+      end;
+      tl () >>= fun x ->
+      loop x in
+  openstream (Input.of_fd (Vhd_lwt.IO.to_file_descr fd)) >>= fun stream ->
+  loop stream >>= fun () -> Vhd_lwt.IO.close fd
+
+let _ =
+  let t = get_vhd_vsize Sys.argv.(1) in
+  Lwt_main.run t

src/impl.ml

@@ -663,7 +663,7 @@ let make_stream common source relative_to source_format destination_format =
     Raw_input.raw t
   | _, _ -> assert false
 
-let write_stream common s destination source_protocol destination_protocol prezeroed progress tar_filename_prefix = 
+let write_stream common s destination source_protocol destination_protocol prezeroed progress tar_filename_prefix ssl_legacy good_ciphersuites legacy_ciphersuites = 
   endpoint_of_string destination >>= fun endpoint ->
   let use_ssl = match endpoint with Https _ -> true | _ -> false in
   ( match endpoint with
@@ -697,7 +697,7 @@ let write_stream common s destination source_protocol destination_protocol preze
       Lwt_unix.connect sock sockaddr >>= fun () ->
 
       let open Cohttp in
-      ( if use_ssl then Channels.of_ssl_fd sock else Channels.of_raw_fd sock ) >>= fun c ->
+      ( if use_ssl then Channels.of_ssl_fd sock ssl_legacy good_ciphersuites legacy_ciphersuites else Channels.of_raw_fd sock ) >>= fun c ->
 
       let module Request = Request.Make(Cohttp_unbuffered_io) in
       let module Response = Response.Make(Cohttp_unbuffered_io) in
@@ -782,7 +782,7 @@ let write_stream common s destination source_protocol destination_protocol preze
 
 let stream_t common args ?(progress = no_progress_bar) () =
   make_stream common args.StreamCommon.source args.StreamCommon.relative_to args.StreamCommon.source_format args.StreamCommon.destination_format >>= fun s ->
-  write_stream common s args.StreamCommon.destination args.StreamCommon.source_protocol args.StreamCommon.destination_protocol args.StreamCommon.prezeroed progress args.StreamCommon.tar_filename_prefix
+  write_stream common s args.StreamCommon.destination args.StreamCommon.source_protocol args.StreamCommon.destination_protocol args.StreamCommon.prezeroed progress args.StreamCommon.tar_filename_prefix args.StreamCommon.ssl_legacy args.StreamCommon.good_ciphersuites args.StreamCommon.legacy_ciphersuites
 
 let stream common args =
   try
@@ -874,19 +874,22 @@ let serve_chunked_to_raw _ c dest _ _ _ _ =
     end in
   loop ()
 
-let serve_raw_to_raw common size c dest _ _ _ _ =
+let serve_raw_to_raw common size c dest _ progress _ _ =
   let twomib = 2 * 1024 * 1024 in
   let buffer = IO.alloc twomib in
+  let p = progress size in
   let rec loop offset remaining =
     let this = Int64.(to_int (min remaining (of_int (Cstruct.len buffer)))) in
     let block = Cstruct.sub buffer 0 this in
     c.Channels.really_read block >>= fun () ->
     Vhd_lwt.IO.really_write dest offset block >>= fun () ->
     let offset = Int64.(add offset (of_int this)) in
-    let remaining = Int64.(sub remaining (of_int this)) in
-    if remaining > 0L
-    then loop offset remaining
-    else return () in
+    let remaining = Int64.(sub remaining (of_int this)) in begin
+      p Int64.(sub size remaining);
+      if remaining > 0L
+      then loop offset remaining
+      else return ()
+    end in
   loop 0L size
 
 let serve common_options source source_fd source_format source_protocol destination destination_fd destination_format destination_size prezeroed progress machine expected_prefix ignore_checksums =

src/main.ml

@@ -162,6 +162,18 @@ let tar_filename_prefix =
   let doc = "Filename prefix for tar/sha disk blocks" in
   Arg.(value & opt (some string) None & info ["tar-filename-prefix"] ~doc)
 
+let ssl_legacy =
+  let doc = "For TLS, allow all protocol versions instead of just TLSv1.2" in
+  Arg.(value & flag & info ["ssl-legacy"] ~doc)
+
+let good_ciphersuites =
+  let doc = "The list of ciphersuites to allow for TLS" in
+  Arg.(value & opt (some string) None & info ["good-ciphersuites"] ~doc)
+
+let legacy_ciphersuites =
+  let doc = "Additional TLS ciphersuites allowed only if ssl-legacy is set" in
+  Arg.(value & opt (some string) None & info ["legacy-ciphersuites"] ~doc)
+
 let serve_cmd =
   let doc = "serve the contents of a disk" in
   let man = [
@@ -231,7 +243,7 @@ let stream_cmd =
     let doc = "Transport protocol for the destination data." in
     Arg.(value & opt (some string) None & info [ "destination-protocol" ] ~doc) in
   let stream_args_t =
-    Term.(pure StreamCommon.make $ source $ relative_to $ source_format $ destination_format $ destination $ destination_fd $ source_protocol $ destination_protocol $ prezeroed $ progress $ machine $ tar_filename_prefix) in
+    Term.(pure StreamCommon.make $ source $ relative_to $ source_format $ destination_format $ destination $ destination_fd $ source_protocol $ destination_protocol $ prezeroed $ progress $ machine $ tar_filename_prefix $ ssl_legacy $ good_ciphersuites $ legacy_ciphersuites) in
   Term.(ret(pure Impl.stream $ common_options_t $ stream_args_t)),
   Term.info "stream" ~sdocs:_common_options ~doc ~man
 

src/sparse_dd.ml

@@ -40,6 +40,10 @@ let set_machine_logging = ref false
 let experimental_reads_bypass_tapdisk = ref false
 let experimental_writes_bypass_tapdisk = ref false
 
+let ssl_legacy = ref false
+let good_ciphersuites = ref None
+let legacy_ciphersuites = ref None
+
 let string_opt = function
   | None -> "None"
   | Some x -> x
@@ -65,6 +69,9 @@ let options =
     "size", Arg.String (fun x -> size := Int64.of_string x), (fun () -> Int64.to_string !size), "number of bytes to copy";
     "prezeroed", Arg.Set prezeroed, (fun () -> string_of_bool !prezeroed), "assume the destination disk has been prezeroed";
     "machine", Arg.Set machine_readable_progress, (fun () -> string_of_bool !machine_readable_progress), "emit machine-readable output";
+    "ssl-legacy", Arg.Set ssl_legacy, (fun () -> string_of_bool !ssl_legacy), " for TLS, allow all protocol versions instead of just TLSv1.2";
+    "good-ciphersuites", Arg.String (fun x -> good_ciphersuites := Some x), (fun () -> string_opt !good_ciphersuites), " the list of ciphersuites to allow for TLS";
+    "legacy-ciphersuites", Arg.String (fun x -> legacy_ciphersuites := Some x), (fun () -> string_opt !legacy_ciphersuites), " additional TLS ciphersuites allowed only if ssl-legacy is set";
 ]
 
 let ( +* ) = Int64.add
@@ -368,7 +375,7 @@ let _ =
           progress_cb fraction in
         let t =
         	stream_t >>= fun s ->
-		Impl.write_stream common s destination (Some "none") None !prezeroed progress None in
+		Impl.write_stream common s destination (Some "none") None !prezeroed progress None !ssl_legacy !good_ciphersuites !legacy_ciphersuites in
 	if destination_format = "vhd"
 	then with_paused_tapdisk dest (fun () -> Lwt_main.run t)
 	else Lwt_main.run t;

src/streamCommon.ml

@@ -41,9 +41,12 @@ type t = {
   progress: bool;
   machine: bool;
   tar_filename_prefix: string option;
+  ssl_legacy: bool;
+  good_ciphersuites: string option;
+  legacy_ciphersuites: string option;
 }
 
-let make source relative_to source_format destination_format destination destination_fd source_protocol destination_protocol prezeroed progress machine tar_filename_prefix =
+let make source relative_to source_format destination_format destination destination_fd source_protocol destination_protocol prezeroed progress machine tar_filename_prefix ssl_legacy good_ciphersuites legacy_ciphersuites =
   let source_protocol = protocol_of_string (require "source-protocol" source_protocol) in
   let destination_protocol = match destination_protocol with
     | None -> None
@@ -56,5 +59,5 @@ let make source relative_to source_format destination_format destination destina
     | None -> destination
     | Some fd -> "fd://" ^ (string_of_int fd) in
 
-  { source; relative_to; source_format; destination_format; destination; source_protocol; destination_protocol; prezeroed; progress; machine; tar_filename_prefix }
+  { source; relative_to; source_format; destination_format; destination; source_protocol; destination_protocol; prezeroed; progress; machine; tar_filename_prefix; ssl_legacy; good_ciphersuites; legacy_ciphersuites }