remove created files/dirs on exception in initial disk image creation

1 files changed, 29 insertions, 23 deletions

diff --git a/fsmgr.hs b/fsmgr.hs
index fa114ec..0dc1790 100644
--- a/fsmgr.hs
+++ b/fsmgr.hs
@@ -33,37 +33,18 @@ noParent (EmptyImageOfBytes _)     = True
 noParent (ParentImageConfigFile _) = False
 
 buildRoot :: DiskImageConfig -> FilePath -> Action ()
-buildRoot DiskImageConfig{..} finalOut = do
+buildRoot config@DiskImageConfig{..} finalOut = do
   let out        = finalOut <.> "tmp"
       mountpoint = finalOut <.> "mnt"
   cmd_ "sh -c" ["! mountpoint -q \"$0\" || umount \"$0\" ", mountpoint]
-  case initialImage of
-    ParentImageConfigFile f -> do
-      let parent = "_build" </> f -<.> "btrfs"
-      need [parent]
-      cmd_ "cp --reflink" [parent, out]
-      cmd_ "btrfstune -f -S0" [out]
-      cmd_ "mkdir -p" [mountpoint]
-      cmd_ "mount -t btrfs" [out] mountpoint
-    EmptyImageOfBytes n -> do
-      cmd_ "truncate -s" [show n] [out]
-      cmd_ "mkfs.btrfs" [out]
-      cmd_ "mkdir -p" [mountpoint]
-      cmd_ "mount -t btrfs" [out] mountpoint
-
-      -- create new default subvolume, and then remount with it
-      createDefaultSubvolume mountpoint
-      cmd_ "umount" [mountpoint]
-      cmd_ "mount -t btrfs" [out, mountpoint]
 
-      cmd_ (Cwd mountpoint) "mkdir -p var/cache/apt"
-      cmd_ (Cwd mountpoint) "mkdir -p var/cache/debconf"
-      cmd_ (Cwd mountpoint) "btrfs subvolume create var/cache/apt/archives"
-  -- TODO: catch errors and umount, rmdir mountpoint
   let (abortion :: IO ()) = do
         cmd_ "umount" [mountpoint]
         cmd_ "rmdir" [mountpoint]
         cmd_ "rm -f" [out]
+
+  handle' abortion $ buildInitialImage config mountpoint out
+
   handle' abortion $ do
     {- 1. debconf -}
     forM_ debconfConfig $
@@ -97,6 +78,31 @@ buildRoot DiskImageConfig{..} finalOut = do
     cmd_ "btrfstune -S1" [out]
     cmd_ "mv" [out, finalOut]
 
+buildInitialImage :: DiskImageConfig -> FilePath -> FilePath -> Action ()
+buildInitialImage DiskImageConfig{..} mountpoint out = do
+  case initialImage of
+    ParentImageConfigFile f -> do
+      let parent = "_build" </> f -<.> "btrfs"
+      need [parent]
+      cmd_ "cp --reflink" [parent, out]
+      cmd_ "btrfstune -f -S0" [out]
+      cmd_ "mkdir -p" [mountpoint]
+      cmd_ "mount -t btrfs" [out] mountpoint
+    EmptyImageOfBytes n -> do
+      cmd_ "truncate -s" [show n] [out]
+      cmd_ "mkfs.btrfs" [out]
+      cmd_ "mkdir -p" [mountpoint]
+      cmd_ "mount -t btrfs" [out] mountpoint
+
+      -- create new default subvolume, and then remount with it
+      createDefaultSubvolume mountpoint
+      cmd_ "umount" [mountpoint]
+      cmd_ "mount -t btrfs" [out, mountpoint]
+
+      cmd_ (Cwd mountpoint) "mkdir -p var/cache/apt"
+      cmd_ (Cwd mountpoint) "mkdir -p var/cache/debconf"
+      cmd_ (Cwd mountpoint) "btrfs subvolume create var/cache/apt/archives"
+
 ignoreErrors :: Action () -> Action ()
 ignoreErrors = flip actionCatch (\(SomeException _) -> return ())