add a crypto layer on top of vhd.

diff --git a/xenvm/vmact.ml b/xenvm/vmact.ml
index d00548cb877ff66c072f218819c3f8b79d39d6cc..7375ae62cf26cbad15669a180e40bdfe489ccfab 100644 (file)
--- 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 a370f9dd03c322ae9af8bbec9cbd49004e7eb82e..1f58b7e85168904d2b9018fb738602e5090e3d68 100644 (file)
--- 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;