Skip to content

Commit 66f6f3a

Browse files
johnelsejohnelse
authored
Merge pull request xapi-project#30 from johnelse/sync-trunk-ring3
Sync master with the trunk-ring3 branch
2 parents 5ae39f9 + f29c0a5 commit 66f6f3a

File tree

12 files changed

+158
-65
lines changed

12 files changed

+158
-65
lines changed

‎.travis-ci.sh‎

Lines changed: 0 additions & 30 deletions
This file was deleted.

‎.travis.yml‎

Lines changed: 10 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,12 @@
11
language: c
2-
install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
3-
script: bash -ex .travis-opam.sh
2+
services: docker
3+
install:
4+
- wget https://raw.githubusercontent.com/xenserver/xenserver-build-env/master/utils/travis-build-repo.sh
5+
script: bash travis-build-repo.sh
6+
sudo: true
47
env:
5-
global:
6-
- PACKAGE=vhd-tool OPAM_LINT=false
7-
matrix:
8-
- OCAML_VERSION=4.01
9-
- OCAML_VERSION=latest EXTRA_REMOTES=git://github.com/xapi-project/opam-repo-dev
8+
global:
9+
- REPO_PACKAGE_NAME=vhd-tool
10+
- REPO_CONFIGURE_CMD=./configure
11+
- REPO_BUILD_CMD=make
12+
- REPO_TEST_CMD=true

‎_oasis‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,3 +28,11 @@ Executable "sparse_dd"
2828
Install: false
2929
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
3030
CSources: sendfile64_stubs.c
31+
32+
Executable get_vhd_vsize
33+
CompiledObject: best
34+
Path: src
35+
MainIs: get_vhd_vsize.ml
36+
Custom: true
37+
Install: false
38+
BuildDepends: lwt, lwt.unix, vhd-format, vhd-format.lwt, cstruct, io-page.unix, threads

‎_tags‎

Lines changed: 17 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
# OASIS_START
2-
# DO NOT EDIT (digest: 59091d3a878b9b72b98c132652e76c6b)
2+
# DO NOT EDIT (digest: 7b3ae22e92b5db658e74329702f2169f)
33
# Ignore VCS directories, you can use the same kind of rule outside
44
# OASIS_START/STOP if you want to exclude directories that contains
55
# useless stuff for the build process
@@ -66,22 +66,16 @@ true: annot, bin_annot
6666
<src/*.ml{,i,y}>: pkg_cmdliner
6767
<src/*.ml{,i,y}>: pkg_cohttp
6868
<src/*.ml{,i,y}>: pkg_cohttp.lwt
69-
<src/*.ml{,i,y}>: pkg_io-page.unix
70-
<src/*.ml{,i,y}>: pkg_lwt
7169
<src/*.ml{,i,y}>: pkg_lwt.preemptive
7270
<src/*.ml{,i,y}>: pkg_lwt.syntax
73-
<src/*.ml{,i,y}>: pkg_lwt.unix
7471
<src/*.ml{,i,y}>: pkg_nbd
7572
<src/*.ml{,i,y}>: pkg_nbd.lwt
7673
<src/*.ml{,i,y}>: pkg_re.str
7774
<src/*.ml{,i,y}>: pkg_sha
7875
<src/*.ml{,i,y}>: pkg_sha.sha1
7976
<src/*.ml{,i,y}>: pkg_tapctl
8077
<src/*.ml{,i,y}>: pkg_tar
81-
<src/*.ml{,i,y}>: pkg_threads
8278
<src/*.ml{,i,y}>: pkg_uri
83-
<src/*.ml{,i,y}>: pkg_vhd-format
84-
<src/*.ml{,i,y}>: pkg_vhd-format.lwt
8579
<src/*.ml{,i,y}>: pkg_xcp
8680
<src/*.ml{,i,y}>: pkg_xenstore
8781
<src/*.ml{,i,y}>: pkg_xenstore.client
@@ -114,6 +108,22 @@ true: annot, bin_annot
114108
"src/sendfile64_stubs.c": pkg_xenstore_transport
115109
"src/sendfile64_stubs.c": pkg_xenstore_transport.unix
116110
<src/sparse_dd.{native,byte}>: custom
111+
# Executable get_vhd_vsize
112+
<src/get_vhd_vsize.{native,byte}>: pkg_cstruct
113+
<src/get_vhd_vsize.{native,byte}>: pkg_io-page.unix
114+
<src/get_vhd_vsize.{native,byte}>: pkg_lwt
115+
<src/get_vhd_vsize.{native,byte}>: pkg_lwt.unix
116+
<src/get_vhd_vsize.{native,byte}>: pkg_threads
117+
<src/get_vhd_vsize.{native,byte}>: pkg_vhd-format
118+
<src/get_vhd_vsize.{native,byte}>: pkg_vhd-format.lwt
119+
<src/*.ml{,i,y}>: pkg_cstruct
120+
<src/*.ml{,i,y}>: pkg_io-page.unix
121+
<src/*.ml{,i,y}>: pkg_lwt
122+
<src/*.ml{,i,y}>: pkg_lwt.unix
123+
<src/*.ml{,i,y}>: pkg_threads
124+
<src/*.ml{,i,y}>: pkg_vhd-format
125+
<src/*.ml{,i,y}>: pkg_vhd-format.lwt
126+
<src/get_vhd_vsize.{native,byte}>: custom
117127
# OASIS_STOP
118128
<src/chunked.ml>: syntax_camlp4o, pkg_cstruct.syntax
119129
<src/input.ml>: syntax_camlp4o, pkg_lwt.syntax

‎setup.ml‎

Lines changed: 36 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
(* setup.ml generated for the first time by OASIS v0.4.1 *)
22

33
(* OASIS_START *)
4-
(* DO NOT EDIT (digest: 8f97eec79b31bf661f98854d16312435) *)
4+
(* DO NOT EDIT (digest: 2619ef3b2c022864e532847b3063e791) *)
55
(*
66
Regenerated by OASIS v0.4.5
77
Visit http://oasis.forge.ocamlcore.org for more information and
@@ -6839,7 +6839,39 @@ let setup_t =
68396839
bs_byteopt = [(OASISExpr.EBool true, [])];
68406840
bs_nativeopt = [(OASISExpr.EBool true, [])]
68416841
},
6842-
{exec_custom = true; exec_main_is = "sparse_dd.ml"})
6842+
{exec_custom = true; exec_main_is = "sparse_dd.ml"});
6843+
Executable
6844+
({
6845+
cs_name = "get_vhd_vsize";
6846+
cs_data = PropList.Data.create ();
6847+
cs_plugin_data = []
6848+
},
6849+
{
6850+
bs_build = [(OASISExpr.EBool true, true)];
6851+
bs_install = [(OASISExpr.EBool true, false)];
6852+
bs_path = "src";
6853+
bs_compiled_object = Best;
6854+
bs_build_depends =
6855+
[
6856+
FindlibPackage ("lwt", None);
6857+
FindlibPackage ("lwt.unix", None);
6858+
FindlibPackage ("vhd-format", None);
6859+
FindlibPackage ("vhd-format.lwt", None);
6860+
FindlibPackage ("cstruct", None);
6861+
FindlibPackage ("io-page.unix", None);
6862+
FindlibPackage ("threads", None)
6863+
];
6864+
bs_build_tools = [ExternalTool "ocamlbuild"];
6865+
bs_c_sources = [];
6866+
bs_data_files = [];
6867+
bs_ccopt = [(OASISExpr.EBool true, [])];
6868+
bs_cclib = [(OASISExpr.EBool true, [])];
6869+
bs_dlllib = [(OASISExpr.EBool true, [])];
6870+
bs_dllpath = [(OASISExpr.EBool true, [])];
6871+
bs_byteopt = [(OASISExpr.EBool true, [])];
6872+
bs_nativeopt = [(OASISExpr.EBool true, [])]
6873+
},
6874+
{exec_custom = true; exec_main_is = "get_vhd_vsize.ml"})
68436875
];
68446876
plugins = [(`Extra, "META", Some "0.4")];
68456877
disable_oasis_section = [];
@@ -6848,14 +6880,14 @@ let setup_t =
68486880
};
68496881
oasis_fn = Some "_oasis";
68506882
oasis_version = "0.4.5";
6851-
oasis_digest = Some "}|9=\012`\230\210]\167H3(\172\216\167";
6883+
oasis_digest = Some "J#\222\170z\237z)\231\128\021\241TAi[";
68526884
oasis_exec = None;
68536885
oasis_setup_args = [];
68546886
setup_update = false
68556887
};;
68566888

68576889
let setup () = BaseSetup.setup setup_t;;
68586890

6859-
# 6860 "setup.ml"
6891+
# 6892 "setup.ml"
68606892
(* OASIS_STOP *)
68616893
let () = setup ();;

‎src/channels.ml‎

Lines changed: 17 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -96,11 +96,24 @@ let of_seekable_fd fd =
9696
return () in
9797
return { c with skip }
9898

99-
let sslctx =
100-
Ssl.init ();
101-
Ssl.create_context Ssl.SSLv23 Ssl.Client_context
99+
let _ =
100+
Ssl.init ()
102101

103-
let of_ssl_fd fd =
102+
let legacy_sslctx good_ciphersuites legacy_ciphersuites =
103+
let ctx = Ssl.create_context Ssl.SSLv23 Ssl.Client_context in
104+
Ssl.set_cipher_list ctx (good_ciphersuites ^ (match legacy_ciphersuites with "" -> "" | s -> (":" ^ s)));
105+
Ssl.disable_protocols ctx [Ssl.SSLv3];
106+
ctx
107+
108+
let good_sslctx good_ciphersuites =
109+
let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in
110+
Ssl.set_cipher_list ctx good_ciphersuites;
111+
ctx
112+
113+
let of_ssl_fd fd ssl_legacy good_ciphersuites legacy_ciphersuites =
114+
let good_ciphersuites = match good_ciphersuites with None -> failwith "good_ciphersuites not specified" | Some x -> x in
115+
let legacy_ciphersuites = match legacy_ciphersuites with None -> "" | Some x -> x in
116+
let sslctx = if ssl_legacy then legacy_sslctx good_ciphersuites legacy_ciphersuites else good_sslctx good_ciphersuites in
104117
Lwt_ssl.ssl_connect fd sslctx >>= fun sock ->
105118
let offset = ref 0L in
106119
let really_read buf =

‎src/cohttp_unbuffered_io.ml‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -125,4 +125,5 @@ let write oc x =
125125
Cstruct.blit_from_string x 0 buf 0 (String.length x);
126126
oc.Channels.really_write buf
127127

128-
let flush oc = return ()
128+
let flush oc =
129+
return ()

‎src/get_vhd_vsize.ml‎

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
open Lwt
2+
3+
module Impl = Vhd.F.From_file(Vhd_lwt.IO)
4+
open Impl
5+
open Vhd.F
6+
open Vhd_lwt.IO
7+
8+
module In = From_input(Input)
9+
open In
10+
11+
let get_vhd_vsize filename =
12+
Vhd_lwt.IO.openfile filename false >>= fun fd ->
13+
let rec loop = function
14+
| End -> return ()
15+
| Cons (hd, tl) ->
16+
begin match hd with
17+
| Fragment.Footer x ->
18+
let size = x.Footer.current_size in
19+
Printf.printf "%Ld\n" size;
20+
exit 0
21+
| _ ->
22+
()
23+
end;
24+
tl () >>= fun x ->
25+
loop x in
26+
openstream (Input.of_fd (Vhd_lwt.IO.to_file_descr fd)) >>= fun stream ->
27+
loop stream >>= fun () -> Vhd_lwt.IO.close fd
28+
29+
let _ =
30+
let t = get_vhd_vsize Sys.argv.(1) in
31+
Lwt_main.run t

‎src/impl.ml‎

Lines changed: 11 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -663,7 +663,7 @@ let make_stream common source relative_to source_format destination_format =
663663
Raw_input.raw t
664664
| _, _ -> assert false
665665

666-
let write_stream common s destination source_protocol destination_protocol prezeroed progress tar_filename_prefix =
666+
let write_stream common s destination source_protocol destination_protocol prezeroed progress tar_filename_prefix ssl_legacy good_ciphersuites legacy_ciphersuites =
667667
endpoint_of_string destination >>= fun endpoint ->
668668
let use_ssl = match endpoint with Https _ -> true | _ -> false in
669669
( match endpoint with
@@ -697,7 +697,7 @@ let write_stream common s destination source_protocol destination_protocol preze
697697
Lwt_unix.connect sock sockaddr >>= fun () ->
698698

699699
let open Cohttp in
700-
( if use_ssl then Channels.of_ssl_fd sock else Channels.of_raw_fd sock ) >>= fun c ->
700+
( if use_ssl then Channels.of_ssl_fd sock ssl_legacy good_ciphersuites legacy_ciphersuites else Channels.of_raw_fd sock ) >>= fun c ->
701701

702702
let module Request = Request.Make(Cohttp_unbuffered_io) in
703703
let module Response = Response.Make(Cohttp_unbuffered_io) in
@@ -782,7 +782,7 @@ let write_stream common s destination source_protocol destination_protocol preze
782782

783783
let stream_t common args ?(progress = no_progress_bar) () =
784784
make_stream common args.StreamCommon.source args.StreamCommon.relative_to args.StreamCommon.source_format args.StreamCommon.destination_format >>= fun s ->
785-
write_stream common s args.StreamCommon.destination args.StreamCommon.source_protocol args.StreamCommon.destination_protocol args.StreamCommon.prezeroed progress args.StreamCommon.tar_filename_prefix
785+
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
786786

787787
let stream common args =
788788
try
@@ -874,19 +874,22 @@ let serve_chunked_to_raw _ c dest _ _ _ _ =
874874
end in
875875
loop ()
876876

877-
let serve_raw_to_raw common size c dest _ _ _ _ =
877+
let serve_raw_to_raw common size c dest _ progress _ _ =
878878
let twomib = 2 * 1024 * 1024 in
879879
let buffer = IO.alloc twomib in
880+
let p = progress size in
880881
let rec loop offset remaining =
881882
let this = Int64.(to_int (min remaining (of_int (Cstruct.len buffer)))) in
882883
let block = Cstruct.sub buffer 0 this in
883884
c.Channels.really_read block >>= fun () ->
884885
Vhd_lwt.IO.really_write dest offset block >>= fun () ->
885886
let offset = Int64.(add offset (of_int this)) in
886-
let remaining = Int64.(sub remaining (of_int this)) in
887-
if remaining > 0L
888-
then loop offset remaining
889-
else return () in
887+
let remaining = Int64.(sub remaining (of_int this)) in begin
888+
p Int64.(sub size remaining);
889+
if remaining > 0L
890+
then loop offset remaining
891+
else return ()
892+
end in
890893
loop 0L size
891894

892895
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‎

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -162,6 +162,18 @@ let tar_filename_prefix =
162162
let doc = "Filename prefix for tar/sha disk blocks" in
163163
Arg.(value & opt (some string) None & info ["tar-filename-prefix"] ~doc)
164164

165+
let ssl_legacy =
166+
let doc = "For TLS, allow all protocol versions instead of just TLSv1.2" in
167+
Arg.(value & flag & info ["ssl-legacy"] ~doc)
168+
169+
let good_ciphersuites =
170+
let doc = "The list of ciphersuites to allow for TLS" in
171+
Arg.(value & opt (some string) None & info ["good-ciphersuites"] ~doc)
172+
173+
let legacy_ciphersuites =
174+
let doc = "Additional TLS ciphersuites allowed only if ssl-legacy is set" in
175+
Arg.(value & opt (some string) None & info ["legacy-ciphersuites"] ~doc)
176+
165177
let serve_cmd =
166178
let doc = "serve the contents of a disk" in
167179
let man = [
@@ -231,7 +243,7 @@ let stream_cmd =
231243
let doc = "Transport protocol for the destination data." in
232244
Arg.(value & opt (some string) None & info [ "destination-protocol" ] ~doc) in
233245
let stream_args_t =
234-
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
246+
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
235247
Term.(ret(pure Impl.stream $ common_options_t $ stream_args_t)),
236248
Term.info "stream" ~sdocs:_common_options ~doc ~man
237249

0 commit comments

Comments
 (0)