propellor spin

propellor.cabal

@@ -85,6 +85,7 @@ Library
     Propellor.Property.Gpg
     Propellor.Property.Group
     Propellor.Property.Grub
+    Propellor.Property.Mount
     Propellor.Property.Network
     Propellor.Property.Nginx
     Propellor.Property.Obnam

src/Propellor/Property/Debootstrap.hs

@@ -9,6 +9,7 @@ module Propellor.Property.Debootstrap (
 import Propellor
 import qualified Propellor.Property.Apt as Apt
 import Propellor.Property.Chroot.Util
+import Propellor.Property.Mount
 import Utility.Path
 import Utility.SafeCommand
 import Utility.FileMode
@@ -95,9 +96,7 @@ built target system@(System _ arch) config =
 		submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
 			. filter (dirContains target)
 			<$> mountPoints
-		forM_ submnts $ \mnt ->
+		forM_ submnts umountLazy
-			unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ do
-				errorMessage $ "failed unmounting " ++ mnt
 		removeDirectoryRecursive target
 
 	-- A failed debootstrap run will leave a debootstrap directory;
@@ -109,9 +108,6 @@ built target system@(System _ arch) config =
 		, return False
 		)
 
-mountPoints :: IO [FilePath]
-mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
-
 extractSuite :: System -> Maybe String
 extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
 extractSuite (System (Ubuntu r) _) = Just r

src/Propellor/Property/Mount.hs

@@ -0,0 +1,12 @@
+module Propellor.Property.Mount where
+
+import Propellor
+import Utility.SafeCommand
+
+mountPoints :: IO [FilePath]
+mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
+
+umountLazy :: FilePath -> IO ()
+umountLazy mnt =  
+	unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
+		errorMessage $ "failed unmounting " ++ mnt

src/Propellor/Property/OS.hs

@@ -14,6 +14,7 @@ import Propellor
 import qualified Propellor.Property.Debootstrap as Debootstrap
 import qualified Propellor.Property.Ssh as Ssh
 import qualified Propellor.Property.User as User
+import Propellor.Property.Mount
 
 -- | Replaces whatever OS was installed before with a clean installation
 -- of the OS that the Host is configured to have.
@@ -63,30 +64,42 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 			`requires`
 		flipped
 			`requires`
+		umountall
+			`requires`
 		osbootstrapped
 
-	osbootstrapped = withOS "/new-os bootstrapped" $ \o -> case o of
+	osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \o -> case o of
 		(Just d@(System (Debian _) _)) -> debootstrap d
 		(Just u@(System (Ubuntu _) _)) -> debootstrap u
 		_ -> error "os is not declared to be Debian or Ubuntu"
 	debootstrap targetos = ensureProperty $ toProp $
-		Debootstrap.built "/new-os" targetos Debootstrap.DefaultConfig
+		Debootstrap.built newOSDir targetos Debootstrap.DefaultConfig
 	
-	flipped = property "/new-os moved into place" $
+	umountall = property "all mount points unmounted" $ liftIO $ do
-		return FailedChange
+		mnts <- filter (/= "/") <$> mountPoints
-		-- unmount all mounts
+		forM_ mnts umountLazy
-		-- move all directories to /old-os,
+		return $ if null mnts then NoChange else MadeChange
-		-- move /new-os to /
+
-		-- touch flagfile
+	flipped = property (newOSDir ++ " moved into place") $ liftIO $ do
+		createDirectoryIfMissing True oldOSDir
+		rootcontents <- dirContents "/"
+		forM_ rootcontents $ \d ->
+			when (d /= oldOSDir && d /= newOSDir) $
+				renameDirectory d (oldOSDir ++ d)
+		newrootcontents <- dirContents newOSDir
+		forM_ newrootcontents $ \d ->
+			renameDirectory d ("/" ++ takeFileName d)
+		removeDirectory newOSDir
+		return MadeChange
 	
 	propellorbootstrapped = property "propellor re-debootstrapped in new os" $
-		return FailedChange
+		return NoChange
 		-- re-bootstrap propellor in /usr/local/propellor,
 		--   (using git repo bundle, privdata file, and possibly
 		--   git repo url, which all need to be arranged to
 		--   be present in /old-os's /usr/local/propellor)
 	
-	finalized = property "clean install finalized" $ do
+	finalized = property "clean OS installed" $ do
 		liftIO $ writeFile flagfile ""
 		return MadeChange
 
@@ -118,7 +131,7 @@ preserveRootSshAuthorized = check (doesDirectoryExist oldloc) $
 		ensureProperties (map (Ssh.authorizedKey "root") ks)
   where
 	newloc = "/root/.ssh/authorized_keys"
-	oldloc = oldOsDir ++ newloc
+	oldloc = oldOSDir ++ newloc
 
 -- Installs an appropriate kernel from the OS distribution.
 kernelInstalled :: Property
@@ -142,12 +155,15 @@ type GrubDev = String
 
 -- Removes the old OS's backup from /old-os
 oldOSRemoved :: Confirmation -> Property
-oldOSRemoved confirmation = check (doesDirectoryExist oldOsDir) $
+oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $
 	go `requires` confirmed "old OS backup removal confirmed" confirmation
   where
 	go = property "old OS backup removed" $ do
-		liftIO $ removeDirectoryRecursive oldOsDir
+		liftIO $ removeDirectoryRecursive oldOSDir
 		return MadeChange
 
-oldOsDir :: FilePath
+oldOSDir :: FilePath
-oldOsDir = "/old-os"
+oldOSDir = "/old-os"
+
+newOSDir :: FilePath
+newOSDir = "/new-os"