From: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
Date: Mon, 16 Nov 2009 09:10:04 +0000 (+0000)
Subject: add a crypto layer on top of vhd.
X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=0de86c67a9c68d657d1531bce22cad815ba6e940;p=xenclient%2Ftoolstack.git

add a crypto layer on top of vhd.
---

diff --git a/xenvm/vmact.ml b/xenvm/vmact.ml
index d00548c..7375ae6 100644
--- a/xenvm/vmact.ml
+++ b/xenvm/vmact.ml
@@ -93,12 +93,51 @@ let devproto_of_state state =
 	| Domain.Arch_X32                      -> Device_common.Protocol_X86_32
 	| Domain.Arch_X64                      -> Device_common.Protocol_X86_64
 
+exception Cryptsetup_failure of string * string * string
+
+let string_of_unix_process process =
+	match process with
+	| Unix.WEXITED i -> sprintf "exited(%d)" i
+	| Unix.WSIGNALED i -> sprintf "signaled(%d)" i
+	| Unix.WSTOPPED i -> sprintf "stopped(%d)" i
+
+let cryptsetup_create name device cipher keysize keyfile =
+	let opts = [
+		"create"; name; device;
+		"--cipher"; cipher;
+		"--key-size"; string_of_int keysize;
+		"--key-file"; keyfile
+	] in
+	let _ =
+		try Forkhelpers.execute_command_get_output ~withpath:false "cryptsetup" opts
+		with Forkhelpers.Spawn_internal_error (log, output, status) ->
+			let s = sprintf "output=%S status=%s" output (string_of_unix_process status) in
+			raise (Cryptsetup_failure ("create", name, s))
+		in
+	name
+
+let cryptsetup_remove name =
+	let opts = [ "remove"; name ] in
+	let _ =
+		try Forkhelpers.execute_command_get_output ~withpath:false "cryptsetup" opts
+		with Forkhelpers.Spawn_internal_error (log, output, status) ->
+			let s = sprintf "output=%S status=%s" output (string_of_unix_process status) in
+			raise (Cryptsetup_failure ("remove", name, s))
+		in
+	()
+
 let add_disk_to_vm ~xs state disk =
 	let protocol = devproto_of_state state in
 	let physpath, phystype = match disk.disk_physty, use_blktap2 with
 	| Device.Vbd.Vhd, true ->
 		let tap2dev = Device.Tap2.mount "vhd" disk.disk_physpath in
-		state.vm_tap2_disks <- (disk, tap2dev) :: state.vm_tap2_disks;
+		let cryptdev = may (fun dc ->
+			let randomdev = Filename.basename tap2dev ^ ".crypt" in
+			cryptsetup_create randomdev tap2dev dc.disk_crypt_cipher
+			                  dc.disk_crypt_key_size
+			                  dc.disk_crypt_key_file
+		) disk.disk_crypt in
+		state.vm_tap2_disks <- (disk, tap2dev, cryptdev) :: state.vm_tap2_disks;
 		tap2dev, Device.Vbd.Phys
 	| _ ->
 		disk.disk_physpath, disk.disk_physty
@@ -317,7 +356,9 @@ let stop_vm xc xs state =
 	);
 
 	info "cleaning up tap2 devices";
-	List.iter (fun (d, path) ->
+	List.iter (fun (d, path, cryptpath) ->
+		(try maybe (cryptsetup_remove) cryptpath;
+		with exn -> warn "unmounting cryptsetup exception: %s" (Printexc.to_string exn));
 		try Device.Tap2.unmount path
 		with exn -> info "unmounting tap2 exception: %s" (Printexc.to_string exn)
 	) state.vm_tap2_disks;
diff --git a/xenvm/vmstate.ml b/xenvm/vmstate.ml
index a370f9d..1f58b7e 100644
--- a/xenvm/vmstate.ml
+++ b/xenvm/vmstate.ml
@@ -64,7 +64,7 @@ type vm_state = {
 	mutable vm_domid: int;
 	mutable vm_vnc_port: int;
 	mutable vm_lifestate: vmlifestate;
-	mutable vm_tap2_disks: (Vmconfig.config_disk * string) list;
+	mutable vm_tap2_disks: (Vmconfig.config_disk * string * string option) list;
         mutable vm_nics: nic_state list;
 	mutable vm_on_suspend_action: Vmconfig.action;
 	mutable vm_cfg: Vmconfig.config;