better error handling

1 files changed, 30 insertions, 25 deletions

diff --git a/fsmgr.hs b/fsmgr.hs
index c1813d7..6d559aa 100644
--- a/fsmgr.hs
+++ b/fsmgr.hs
@@ -58,31 +58,36 @@ buildRoot DiskImageConfig{..} finalOut = do
       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
-  {- 1. debconf -}
-  forM_ debconfConfig $
-    readFile' >=> liftIO . appendFile (mountpoint </> "var/cache/debconf/config.dat")
-  {- 2. dpkg installs -}
-  let (debs, packageNames) = partitionPackages $ unpack . coerce <$> toList packages
-  when (noParent initialImage || not (null packageNames)) $
-    -- When there is no parent, selfstrap should install packages marked
-    -- "Required" even if no packages are specified. When there is a parent,
-    -- assume that this has already happened.
-    cmd_ "selfstrap --skip-update" (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) packageNames
-  forM_ debs $ \pkg -> do cmd_ "dpkg -i --root" [mountpoint, pkg]
-  {- 2.5. install apt package cache -}
-  -- TODO
-  {- 3. binaries -}
-  forM_ (unpack <$> binaries) $ \b -> do
-    p <- fromMaybe (fail $ "not found in ${PATH}: " ++ b) <$> liftIO (pathLocate b)
-    cmd_ "cp -L" [p] [mountpoint </> "usr/local/bin" </> b]
-  {- 4. custom setup commands -}
-  forM_ chrootCommands $ \c -> do
-    cmd_ "chroot" [mountpoint] "/bin/sh -c" [unpack c]
-  -- cleanup
-  cmd_ "umount" [mountpoint]
-  cmd_ "rmdir" [mountpoint]
-  cmd_ "btrfstune -S1" [out]
-  cmd_ "mv" [out, finalOut]
+  let (abortion :: IO ()) = do
+        cmd_ "umount" [mountpoint]
+        cmd_ "rmdir" [mountpoint]
+        cmd_ "rm -f" [out]
+  handle' abortion $ do
+    {- 1. debconf -}
+    forM_ debconfConfig $
+      readFile' >=> liftIO . appendFile (mountpoint </> "var/cache/debconf/config.dat")
+    {- 2. dpkg installs -}
+    let (debs, packageNames) = partitionPackages $ unpack . coerce <$> toList packages
+    when (noParent initialImage || not (null packageNames)) $
+      -- When there is no parent, selfstrap should install packages marked
+      -- "Required" even if no packages are specified. When there is a parent,
+      -- assume that this has already happened.
+      cmd_ "selfstrap --skip-update" (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) packageNames
+    forM_ debs $ \pkg -> do cmd_ "dpkg -i --root" [mountpoint, pkg]
+    {- 2.5. install apt package cache -}
+    -- TODO
+    {- 3. binaries -}
+    forM_ (unpack <$> binaries) $ \b -> do
+      p <- fromMaybe (fail $ "not found in ${PATH}: " ++ b) <$> liftIO (pathLocate b)
+      cmd_ "cp -L" [p] [mountpoint </> "usr/local/bin" </> b]
+    {- 4. custom setup commands -}
+    forM_ chrootCommands $ \c -> do
+      cmd_ "chroot" [mountpoint] "/bin/sh -c" [unpack c]
+    -- cleanup
+    cmd_ "umount" [mountpoint]
+    cmd_ "rmdir" [mountpoint]
+    cmd_ "btrfstune -S1" [out]
+    cmd_ "mv" [out, finalOut]
 
 partitionPackages :: [String] -> ([String], [String])
 partitionPackages = partition (elem '/')