Merge branch 'joeyconfig'

config-joey.hs

@@ -54,11 +54,20 @@ 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"
+	 		[ User.shadowConfig True
+			, OS.preserveRootSshAuthorized
+			, OS.preserveResolvConf
+			, Apt.update
+			, Grub.boots "/dev/sda"
+				`requires` Grub.installed Grub.PC
+	 		]
+	& Hostname.sane
+	& Hostname.searchDomain
+	& Apt.installed ["linux-image-amd64"]
+	& Apt.installed ["ssh"]
 
 darkstar :: Host
 darkstar = host "darkstar.kitenet.net"

debian/changelog

@@ -1,27 +1,31 @@
 propellor (1.1.0) UNRELEASED; urgency=medium
 
-  * propellor --spin can now deploy propellor to hosts that do not have 
-    git, ghc, or apt-get. This is accomplished by uploading a fairly
-    portable precompiled tarball of propellor.
   * --spin target --via relay causes propellor to bounce through an
     intermediate relay host, which handles any necessary uploads
     when provisioning the target host.
   * --spin can be passed multiple hosts, and it will provision each host
     in turn.
+  * Add --merge, to combine multiple --spin commits into a single, more useful
+    commit.
   * Hostname parameters not containing dots are looked up in the DNS to
     find the full hostname.
+  * propellor --spin can now deploy propellor to hosts that do not have 
+    git, ghc, or apt-get. This is accomplished by uploading a fairly
+    portable precompiled tarball of propellor.
+  * Propellor.Property.OS contains properties that can be used to do a clean
+    reinstall of the OS of an existing host. This can be used, for example,
+    to do an in-place conversion from Fedora to Debian. Use with caution!
   * Added group-related properties. Thanks, Félix Sipma.
   * Added Git.barerepo. Thanks, Félix Sipma.
+  * Added Grub.installed and Grub.boots properties.
   * hasSomePassword and hasPassword now default to using the name of the
     host as the Context for the password. To specify a different context,
     use hasSomePassword' and hasPassword' (API change)
-  * Add --merge, to combine multiple --spin commits into a single, more useful
-    commit.
   * cron.runPropellor now runs propellor, rather than using its Makefile.
     This is more robust.
   * propellor.debug can be set in the git config to enable more persistent
     debugging output.
-  * Run apt-cache policy with LANG=C.
+  * Run apt-cache policy with LANG=C so it works on other locales.
 
  -- Joey Hess <joeyh@debian.org>  Sat, 22 Nov 2014 00:12:35 -0400
 

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/Grub.hs

@@ -7,8 +7,46 @@ import qualified Propellor.Property.Apt as Apt
 -- | Eg, hd0,0 or xen/xvda1
 type GrubDevice = String
 
+-- | Eg, /dev/sda
+type OSDevice = String
+
 type TimeoutSecs = Int
 
+-- | Types of machines that grub can boot.
+data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
+
+-- | Installs the grub package. This does not make grub be used as the
+-- bootloader.
+--
+-- This includes running update-grub, so that the grub boot menu is
+-- created. It will be automatically updated when kernel packages are
+-- installed.
+installed :: BIOS -> Property
+installed bios = 
+	Apt.installed [pkg] `describe` "grub package installed"
+		`before`
+	cmdProperty "update-grub" []
+  where
+	pkg = case bios of
+		PC -> "grub-pc"
+		EFI64 -> "grub-efi-amd64"
+		EFI32 -> "grub-efi-ia32"
+		Coreboot -> "grub-coreboot"
+		Xen -> "grub-xen"
+
+-- | Installs grub onto a device, so the system can boot from that device.
+--
+-- You may want to install grub to multiple devices; eg for a system
+-- that uses software RAID.
+--
+-- Note that this property does not check if grub is already installed
+-- on the device; it always does the work to reinstall it. It's a good idea
+-- to arrange for this property to only run once, by eg making it be run
+-- onChange after OS.cleanInstallOnce.
+boots :: OSDevice -> Property
+boots dev = cmdProperty "grub-install" [dev]
+	`describe` ("grub boots " ++ dev)
+
 -- | Use PV-grub chaining to boot
 --
 -- Useful when the VPS's pv-grub is too old to boot a modern kernel image.
@@ -31,8 +69,8 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc
 		]
 	, "/boot/load.cf" `File.hasContent`
 		[ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ]
-	, Apt.installed ["grub-xen"]
-	, flagFile (scriptProperty ["update-grub; grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]) "/boot/xen-shim"
+	, installed Xen
+	, flagFile (scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]) "/boot/xen-shim"
 			`describe` "/boot-xen-shim"
 	]
   where

src/Propellor/Property/OS.hs

@@ -1,20 +1,23 @@
 module Propellor.Property.OS (
 	cleanInstallOnce,
-	Confirmed(..),
+	Confirmation(..),
 	preserveNetworkInterfaces,
+	preserveResolvConf,
 	preserveRootSshAuthorized,
-	grubBoots,
-	GrubDev(..),
-	kernelInstalled,
+	rebootForced,
 	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.File as File
+import Propellor.Property.Mount
+import Propellor.Property.Chroot.Util (stdPATH)
+import Utility.SafeCommand
+
+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.
@@ -23,102 +26,194 @@ import Utility.FileMode
 -- But, it can also fail and leave the system in an unbootable state.
 --
 -- 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
--- property to.
+-- 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
 -- a file /etc/propellor-cleaninstall, which indicates it was cleanly
 -- installed.
 -- 
+-- The files from the old os will be left in /old-os
+--
+-- TODO: A forced reboot should be schedued to run after propellor finishes
+-- ensuring all properties of the host.
+--
 -- You will typically want to run some more properties after the clean
--- install, to bootstrap from the cleanly installed system to a fully
--- working system. For example:
+-- install succeeds, to bootstrap from the cleanly installed system to
+-- a fully working system. For example:
 --
 -- > & os (System (Debian Unstable) "amd64")
--- > & cleanInstall (Confirmed "foo.example.com") [BackupOldOS, UseOldKernel]
+-- > & cleanInstallOnce (Confirmed "foo.example.com")
 -- >    `onChange` propertyList "fixing up after clean install"
--- >        [ preserveNetworkInterfaces
+-- >        [ User.shadowConfig True
+-- >        , preserveNetworkInterfaces
+-- >        , preserveResolvConf
 -- >        , preserverRootSshAuthorized
--- >        -- , kernelInstalled
--- >        -- , grubBoots "hd0"
+-- >        , Apt.update
+-- >        -- , Grub.boots "/dev/sda"
+-- >        --   `requires` Grub.installed Grub.PC
+-- >        -- , oldOsRemoved (Confirmed "foo.example.com")
 -- >        ]
+-- > & Hostname.sane
+-- > & Apt.installed ["linux-image-amd64"]
 -- > & 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`
+		flipped
+			`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
+	
+	flipped = property (newOSDir ++ " moved into place") $ liftIO $ do
+		-- First, unmount most mount points, lazily, so
+		-- they don't interfere with moving things around.
+		devfstype <- fromMaybe "devtmpfs" <$> getFsType "/dev"
+		mnts <- filter (`notElem` ("/": trickydirs)) <$> mountPoints
+		-- reverse so that deeper mount points come first
+		forM_ (reverse mnts) umountLazy
+
+		renamesout <- map (\d -> (d, oldOSDir ++ d, pure $ d `notElem` (oldOSDir:newOSDir:trickydirs)))
+			<$> dirContents "/"
+		renamesin <- map (\d -> let dest = "/" ++ takeFileName d in (d, dest, not <$> fileExist dest))
+			<$> dirContents newOSDir
+		createDirectoryIfMissing True oldOSDir
+		massRename (renamesout ++ renamesin)
+		removeDirectoryRecursive newOSDir
+		
+		-- Prepare environment for running additional properties,
+		-- overriding old OS's environment.
+		void $ setEnv "PATH" stdPATH True
+		void $ unsetEnv "LANG"
+
+		-- Remount /dev, so that block devices etc are
+		-- available for other properties to use.
+		unlessM (mount devfstype devfstype "/dev") $ do
+			warningMessage $ "failed mounting /dev using " ++ devfstype ++ "; falling back to MAKEDEV generic"
+			void $ boolSystem "sh" [Param "-c", Param "cd /dev && /sbin/MAKEDEV generic"]
+
+		-- Mount /sys too, needed by eg, grub-mkconfig.
+		unlessM (mount "sysfs" "sysfs" "/sys") $
+			warningMessage "failed mounting /sys"
+
+		-- And /dev/pts, used by apt.
+		unlessM (mount "devpts" "devpts" "/dev/pts") $
+			warningMessage "failed mounting /dev/pts"
+
+		liftIO $ writeFile flagfile ""
+		return MadeChange
+
+	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
+		-- TODO
+	
+	-- Ensure that MadeChange is returned by the overall property,
+	-- so that anything hooking in onChange will run afterwards.
+	finalized = property "clean OS installed" $ return MadeChange
+
 	flagfile = "/etc/propellor-cleaninstall"
 	
-data Confirmed = Confirmed HostName
+	trickydirs = 
+		-- /tmp can contain X's sockets, which prevent moving it
+		-- so it's left as-is.
+		[ "/tmp"
+		-- /proc is left mounted
+		, "/proc"
+		]
 
-checkConfirmed :: Confirmed -> Propellor ()
-checkConfirmed (Confirmed c) = do
+-- 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 Bool)] -> IO ()
+massRename = go []
+  where
+	go _ [] = return ()
+	go undo ((from, to, test):rest) = ifM test
+		( tryNonAsync (rename from to)
+			>>= either
+				(rollback undo)
+				(const $ go ((to, from):undo) rest)
+		, go undo rest
+		)
+	rollback undo e = do
+		mapM_ (uncurry rename) undo
+		throw e
+
+data Confirmation = Confirmed HostName
+
+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."
+	if hostname /= c
+		then do
+			warningMessage "Run with a bad confirmation, not matching hostname."
+			return FailedChange
+		else return NoChange
 
--- | 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
-
--- /etc/network/interfaces is configured to bring up all interfaces that
+-- | /etc/network/interfaces is configured to bring up all interfaces that
 -- are currently up, using the same IP addresses.
 preserveNetworkInterfaces :: Property
 preserveNetworkInterfaces = undefined
 
--- Root's .ssh/authorized_keys has added to it any ssh keys that
+-- | /etc/resolv.conf is copied the from the old OS
+preserveResolvConf :: Property
+preserveResolvConf = check (fileExist oldloc) $
+	property (newloc ++ " copied from old OS") $ do
+		ls <- liftIO $ lines <$> readFile oldloc
+		ensureProperty $ newloc `File.hasContent` ls
+  where
+	newloc = "/etc/resolv.conf"
+	oldloc = oldOSDir ++ newloc
+
+-- | Root's .ssh/authorized_keys has added to it any ssh keys that
 -- were authorized in the old OS. Any other contents of the file are
 -- retained.
 preserveRootSshAuthorized :: Property
-preserveRootSshAuthorized = check (doesDirectoryExist oldloc) $
+preserveRootSshAuthorized = check (fileExist oldloc) $
 	property (newloc ++ " copied from old OS") $ do
 		ks <- liftIO $ lines <$> readFile 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
-
--- Installs grub onto a device to boot the system.
+-- | Forces an immediate reboot, without contacting the init system.
 --
--- You may want to install grub to multiple devices; eg for a system
--- that uses software RAID.
-grubBoots :: GrubDev -> Property
-grubBoots = undefined
-
-type GrubDev = String
+-- Can be used after cleanInstallOnce.
+rebootForced :: Property
+rebootForced = cmdProperty "reboot" [ "--force" ]
 
 -- 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"