more work; builds now

src/Propellor/Property/OS.hs

@@ -1,10 +1,10 @@
 module Propellor.Property.OS (
 	cleanInstallOnce,
-	Confirmation
-	confirm,
-	fixupNetworkAddresses,
+	Confirmed(..),
+	fixupNetworkInterfaces,
 	rootSshAuthorized,
 	grubBoots,
+	GrubDev(..),
 	kernelInstalled,
 	oldOSRemoved,
 ) where
@@ -12,6 +12,10 @@ module Propellor.Property.OS (
 import Propellor
 import qualified Propellor.Property.Chroot as Chroot
 import qualified Propellor.Property.Debootstrap as Debootstrap
+import qualified Propellor.Property.File as File
+import Utility.FileMode
+
+import Utility.PosixFiles
 
 -- | Replaces whatever OS was installed before with a clean installation
 -- of the OS that the Host is configured to have.
@@ -20,7 +24,7 @@ import qualified Propellor.Property.Debootstrap as Debootstrap
 -- 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 Context containing the name of the host that you intend to apply the
+-- a Confirmed 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
@@ -32,7 +36,7 @@ import qualified Propellor.Property.Debootstrap as Debootstrap
 -- working system. For example:
 --
 -- > & os (System (Debian Unstable) "amd64")
--- > & cleanInstall (Context "foo.example.com") (BackupOldOS <> UseOldKernel)
+-- > & cleanInstall (Confirmed "foo.example.com") [BackupOldOS, UseOldKernel]
 -- >    `onChange` propertyList "fixing up after clean install"
 -- >        [ fixupNetworkInterfaces
 -- >        , rootSshAuthorized
@@ -44,18 +48,17 @@ import qualified Propellor.Property.Debootstrap as Debootstrap
 -- > & User.accountFor "joey"
 -- > & User.hasSomePassword "joey"
 -- > -- rest of system properties here
-cleanInstallOnce :: Context -> Exceptions -> Property
-cleanInstallOnce (Context c) = check (not <$> doesFileExist flagfile) $
-	Property "OS cleanly installed" $ do
-		hostname <- asks hostName
-		when (hostname /= c) $
-			error "Run with bad context, not matching hostname. Not running cleanInstalOnce!"
+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
+		--   except for /boot and /lib/modules when UseOldKernel
+		--   (or, delete when not BackupOldOS)
 		-- move /new-os to /
 		-- touch flagfile
 		-- re-bootstrap propellor in /usr/local/propellor,
@@ -67,42 +70,60 @@ cleanInstallOnce (Context c) = check (not <$> doesFileExist flagfile) $
   where
 	flagfile = "/etc/propellor-cleaninstall"
 
--- | Sometimes you want an almost clean install, but with some exceptions.
-data Exceptions
+data Confirmed = Confirmed HostName
+
+checkConfirmed :: Confirmed -> Propellor ()
+checkConfirmed (Confirmed c) = 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
-	| NoExceptions
-	| CombinedExceptions Exceptions Exceptions
-
-instance Monoid Exceptions where
-	mempty = NoExceptions
-	mappend = CombinedExceptions
 
 -- /etc/network/interfaces is configured to bring up all interfaces that
 -- are currently up, using the same IP addresses.
---
--- This property only does anything if it comes after cleanInstall,
--- in the same propellor run where cleanInstall has made a change.
 fixupNetworkInterfaces :: Property
 fixupNetworkInterfaces = undefined
 
--- /root/.ssh/authorized_keys is copied from the old os
+-- 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.
 rootSshAuthorized :: Property
-rootSshAuthorized = undefined
+rootSshAuthorized = check (doesDirectoryExist oldloc) $
+	property (newloc ++ " copied from old OS") $ do
+		ks <- liftIO $ lines <$> readFile oldloc
+		ensureProperty $
+			newloc `File.containsLines` ks
+				`requires` File.dirExists (takeDirectory newloc)
+				`onChange` File.mode newloc mode
+  where
+	newloc = "/root/.ssh/authorized_keys"
+	oldloc = oldOsDir ++ newloc
+	-- ssh requires the file mode be locked down
+	mode = combineModes [ownerWriteMode, ownerReadMode]
 
--- Installs an appropriate kernel from the distribution.
+-- Installs an appropriate kernel from the OS distribution.
 kernelInstalled :: Property
 kernelInstalled = undefined
 
--- Installs grub to boot the system.
+-- Installs grub onto a device to boot the 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
+
 -- Removes the old OS's backup from /old-os
-oldOSRemoved :: Property
-oldOSRemoved = check (doesDirectoryExist oldOsDir) $
-	Property "old OS backup removed" $ liftIO $ do
-		removeDirectoryRecursive oldOsDir
+oldOSRemoved :: Confirmed -> Property
+oldOSRemoved confirmed = check (doesDirectoryExist oldOsDir) $
+	property "old OS backup removed" $ do
+		checkConfirmed confirmed
+		liftIO $ removeDirectoryRecursive oldOsDir
 		return MadeChange
 
 oldOsDir :: FilePath