more work on OS takeover

config-joey.hs

@@ -54,11 +54,11 @@ hosts =                --                  (o)  `
 
 testvm :: Host
 testvm = host "testvm.kitenet.net"
-	& Chroot.provisioned (Chroot.debootstrapped (System (Debian Unstable) "amd64") Debootstrap.DefaultConfig "/new-os")
-	-- & OS.cleanInstall (OS.Confirmed "foo.example.com") []
-	-- 	`onChange` propertyList "fixing up after clean install"
-	-- 		[
-	-- 		]
+	& os (System (Debian Unstable) "amd64")
+	& OS.cleanInstallOnce (OS.Confirmed "testvm.kitenet.net")
+	 	`onChange` propertyList "fixing up after clean install"
+	 		[ OS.preserveRootSshAuthorized
+	 		]
 
 darkstar :: Host
 darkstar = host "darkstar.kitenet.net"

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/Chroot/Util.hs

@@ -9,7 +9,8 @@ import Control.Applicative
 standardPathEnv :: IO [(String, String)]
 standardPathEnv = do
 	path <- getEnvDefault "PATH" "/bin"
-	addEntry "PATH" (path ++ std)
+	addEntry "PATH" (path ++ stdPATH)
 		<$> getEnvironment
-  where
-	std = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin"
+
+stdPATH :: String
+stdPATH = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin"

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 ->
-			unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ do
-				errorMessage $ "failed unmounting " ++ mnt
+		forM_ submnts umountLazy
 		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/OS.hs

@@ -1,20 +1,22 @@
 module Propellor.Property.OS (
 	cleanInstallOnce,
-	Confirmed(..),
+	Confirmation(..),
 	preserveNetworkInterfaces,
 	preserveRootSshAuthorized,
 	grubBoots,
 	GrubDev(..),
+	oldOSKernelPreserved,
 	kernelInstalled,
 	oldOSRemoved,
 ) where
 
 import Propellor
-import qualified Propellor.Property.Chroot as Chroot
 import qualified Propellor.Property.Debootstrap as Debootstrap
-import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Ssh as Ssh
-import Utility.FileMode
+import qualified Propellor.Property.User as User
+import Propellor.Property.Mount
+
+import System.Posix.Files (rename, fileExist)
 
 -- | Replaces whatever OS was installed before with a clean installation
 -- of the OS that the Host is configured to have.
@@ -22,8 +24,10 @@ import Utility.FileMode
 -- This can replace one Linux distribution with different one.
 -- But, it can also fail and leave the system in an unbootable state.
 --
+-- The files from the old os will be left in /old-os
+--
 -- To avoid this property being accidentially used, you have to provide
--- a Confirmed containing the name of the host that you intend to apply the
+-- a Confirmation containing the name of the host that you intend to apply the
 -- property to.
 --
 -- This property only runs once. The cleanly installed system will have
@@ -35,52 +39,95 @@ import Utility.FileMode
 -- working system. For example:
 --
 -- > & os (System (Debian Unstable) "amd64")
--- > & cleanInstall (Confirmed "foo.example.com") [BackupOldOS, UseOldKernel]
+-- > & cleanInstall (Confirmed "foo.example.com")
 -- >    `onChange` propertyList "fixing up after clean install"
 -- >        [ preserveNetworkInterfaces
 -- >        , preserverRootSshAuthorized
+-- >        , oldOSKernelPreserved
 -- >        -- , kernelInstalled
 -- >        -- , grubBoots "hd0"
+-- >        -- , oldOsRemoved
 -- >        ]
 -- > & Apt.installed ["ssh"]
 -- > & User.hasSomePassword "root"
 -- > & User.accountFor "joey"
 -- > & User.hasSomePassword "joey"
 -- > -- rest of system properties here
-cleanInstallOnce :: Confirmed -> [Tweak] -> Property
-cleanInstallOnce confirmed tweaks = check (not <$> doesFileExist flagfile) $
-	property "OS cleanly installed" $ do
-		checkConfirmed confirmed
-		error "TODO"
-		-- debootstrap /new-os chroot, but don't run propellor
-		--   inside the chroot.
-		-- unmount all mounts
-		-- move all directories to /old-os,
-		--   except for /boot and /lib/modules when UseOldKernel
-		--   (or, delete when not BackupOldOS)
-		-- move /new-os to /
-		-- touch flagfile
+cleanInstallOnce :: Confirmation -> Property
+cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
+	go `requires` confirmed "clean install confirmed" confirmation
+  where
+	go = 
+		finalized
+			`requires`
+		propellorbootstrapped
+			`requires`
+		User.shadowConfig True
+			`requires`
+		flipped
+			`requires`
+		umountall
+			`requires`
+		osbootstrapped
+
+	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 newOSDir targetos Debootstrap.DefaultConfig
+	
+	umountall = property "mount points unmounted" $ liftIO $ do
+		mnts <- filter (`notElem` ("/": trickydirs)) <$> mountPoints
+		-- reverse so that deeper mount points come first
+		forM_ (reverse mnts) umountLazy
+		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
+			let dest = "/" ++ takeFileName d
+			whenM (not <$> fileExist dest) $
+				rename d dest
+		removeDirectoryRecursive newOSDir
+		return MadeChange
+	
+	trickydirs = 
+		-- /tmp can contain X's sockets, which prevent moving it
+		-- so it's left as-is.
+		[ "/tmp"
+		-- /proc is left mounted
+		, "/proc"
+		]
+
+	propellorbootstrapped = property "propellor re-debootstrapped in new os" $
+		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)
-		-- enable shadow passwords (to avoid foot-shooting)
-		-- return MadeChange
-  where
+	
+	finalized = property "clean OS installed" $ do
+		liftIO $ writeFile flagfile ""
+		return MadeChange
+
 	flagfile = "/etc/propellor-cleaninstall"
 
-data Confirmed = Confirmed HostName
+data Confirmation = Confirmed HostName
 
-checkConfirmed :: Confirmed -> Propellor ()
-checkConfirmed (Confirmed c) = do
+confirmed :: Desc -> Confirmation -> Property
+confirmed desc (Confirmed c) = property desc $ do
 	hostname <- asks hostName
-	when (hostname /= c) $
-		errorMessage "Run with a bad confirmation, not matching hostname."
-
--- | Sometimes you want an almost clean install, but with some tweaks.
-data Tweak
-	= UseOldKernel -- ^ Leave /boot and /lib/modules from old OS, so the system can boot using them as before
-	| BackupOldOS -- ^ Back up old OS to /old-os, to avoid losing any important files
+	if hostname /= c
+		then do
+			warningMessage "Run with a bad confirmation, not matching hostname."
+			return FailedChange
+		else return NoChange
 
 -- /etc/network/interfaces is configured to bring up all interfaces that
 -- are currently up, using the same IP addresses.
@@ -97,12 +144,19 @@ 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
 kernelInstalled = undefined
 
+-- Copies kernel images, initrds, and modules from /old-os
+-- into the new system.
+--
+-- TODO: grub config?
+oldOSKernelPreserved :: Property
+oldOSKernelPreserved = undefined
+
 -- Installs grub onto a device to boot the system.
 --
 -- You may want to install grub to multiple devices; eg for a system
@@ -113,12 +167,16 @@ grubBoots = undefined
 type GrubDev = String
 
 -- Removes the old OS's backup from /old-os
-oldOSRemoved :: Confirmed -> Property
-oldOSRemoved confirmed = check (doesDirectoryExist oldOsDir) $
-	property "old OS backup removed" $ do
-		checkConfirmed confirmed
-		liftIO $ removeDirectoryRecursive oldOsDir
+oldOSRemoved :: Confirmation -> Property
+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
 		return MadeChange
 
-oldOsDir :: FilePath
-oldOsDir = "/old-os"
+oldOSDir :: FilePath
+oldOSDir = "/old-os"
+
+newOSDir :: FilePath
+newOSDir = "/new-os"

src/Propellor/Property/User.hs

@@ -84,3 +84,15 @@ hasGroup user group' = check test $ cmdProperty "adduser"
 	`describe` unwords ["user", user, "in group", group']
   where
 	test = not . elem group' . words <$> readProcess "groups" [user]
+
+-- | Controls whether shadow passwords are enabled or not.
+shadowConfig :: Bool -> Property
+shadowConfig True = check (not <$> shadowExists) $
+	cmdProperty "shadowconfig" ["on"]
+		`describe` "shadow passwords enabled"
+shadowConfig False = check shadowExists $
+	cmdProperty "shadowconfig" ["off"]
+		`describe` "shadow passwords disabled"
+
+shadowExists :: IO Bool
+shadowExists = doesFileExist "/etc/shadow"