summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Propellor/Property/OS.hs35
1 files changed, 28 insertions, 7 deletions
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index b81b7c4e..3ed23fb4 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -18,6 +18,7 @@ import Propellor.Property.Mount
import Propellor.Property.Chroot.Util (stdPATH)
import System.Posix.Files (rename, fileExist)
+import Control.Exception (throw)
-- | Replaces whatever OS was installed before with a clean installation
-- of the OS that the Host is configured to have.
@@ -85,16 +86,20 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
return $ if null mnts then NoChange else MadeChange
flipped = property (newOSDir ++ " moved into place") $ liftIO $ do
- createDirectoryIfMissing True oldOSDir
rootcontents <- dirContents "/"
- forM_ rootcontents $ \d ->
- when (d `notElem` (oldOSDir:newOSDir:trickydirs)) $
- rename d (oldOSDir ++ d)
newrootcontents <- dirContents newOSDir
- forM_ newrootcontents $ \d -> do
+ createDirectoryIfMissing True oldOSDir
+ renamesout <- forM rootcontents $ \d ->
+ if d `notElem` (oldOSDir:newOSDir:trickydirs)
+ then return $ Just (d, oldOSDir ++ d)
+ else return Nothing
+ renamesin <- forM newrootcontents $ \d -> do
let dest = "/" ++ takeFileName d
- whenM (not <$> fileExist dest) $
- rename d dest
+ ifM (not <$> fileExist dest)
+ ( return $ Just (d, dest)
+ , return Nothing
+ )
+ massRename $ catMaybes (renamesout ++ renamesin)
removeDirectoryRecursive newOSDir
-- Prepare environment for running additional properties.
@@ -125,6 +130,22 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
, "/proc"
]
+-- Performs all the renames. If any rename fails, rolls back all
+-- previous renames. Thus, this either successfully performs all
+-- the renames, or does not change the system state at all.
+massRename :: [(FilePath, FilePath)] -> IO ()
+massRename = go []
+ where
+ go _ [] = return ()
+ go undo ((from, to):rest) =
+ tryNonAsync (rename from to)
+ >>= either
+ (rollback undo)
+ (const $ go ((to, from):undo) rest)
+ rollback undo e = do
+ mapM_ (uncurry rename) undo
+ throw e
+
data Confirmation = Confirmed HostName
confirmed :: Desc -> Confirmation -> Property