Merge branch 'joeyconfig'

9 files changed, 193 insertions, 50 deletions

diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 7ec2010c..d17edae7 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -4,6 +4,7 @@ module Propellor.Property.Chroot (
 	Chroot(..),
 	ChrootBootstrapper(..),
 	Debootstrapped(..),
+	ChrootTarball(..),
 	debootstrapped,
 	bootstrapped,
 	provisioned,
@@ -22,6 +23,7 @@ import Propellor.Types.Info
 import Propellor.Property.Chroot.Util
 import qualified Propellor.Property.Debootstrap as Debootstrap
 import qualified Propellor.Property.Systemd.Core as Systemd
+import qualified Propellor.Property.File as File
 import qualified Propellor.Shim as Shim
 import Propellor.Property.Mount
 
@@ -52,7 +54,31 @@ class ChrootBootstrapper b where
 	-- If the operating System is not supported, return Nothing.
 	buildchroot :: b -> System -> FilePath -> Maybe (Property HasInfo)
 
--- | Use to bootstrap a chroot with debootstrap.
+-- | Use this to bootstrap a chroot by extracting a tarball.
+--
+-- The tarball is expected to contain a root directory (no top-level
+-- directory, also known as a "tarbomb").
+-- It may be optionally compressed with any format `tar` knows how to
+-- detect automatically.
+data ChrootTarball = ChrootTarball FilePath
+
+instance ChrootBootstrapper ChrootTarball where
+	buildchroot (ChrootTarball tb) _ loc = Just $ extractTarball loc tb
+
+extractTarball :: FilePath -> FilePath -> Property HasInfo
+extractTarball target src = toProp .
+	check (unpopulated target) $
+		cmdProperty "tar" params
+			`requires` File.dirExists target
+  where
+	params =
+		[ "-C"
+		, target
+		, "-xf"
+		, src
+		]
+
+-- | Use this to bootstrap a chroot with debootstrap.
 data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig
 
 instance ChrootBootstrapper Debootstrapped where
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 8d503e28..1e3a5407 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -2,8 +2,6 @@
 --
 -- This module is designed to be imported unqualified.
 --
--- TODO run final
--- 
 -- TODO avoid starting services while populating chroot and running final
 
 module Propellor.Property.DiskImage (
@@ -49,7 +47,8 @@ import Propellor.Property.Partition
 import Propellor.Property.Rsync
 import Utility.Path
 
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, sortBy)
+import Data.Function (on)
 import qualified Data.Map.Strict as M
 import qualified Data.ByteString.Lazy as L
 import System.Posix.Files
@@ -70,25 +69,26 @@ type DiskImage = FilePath
 -- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
 -- > 		& Apt.installed ["linux-image-amd64"]
 -- >		& ...
--- > in imageBuilt "/srv/images/foo.img" chroot MSDOS 
+-- > in imageBuilt "/srv/images/foo.img" chroot
+-- >		MSDOS (grubBooted PC)
 -- >		[ partition EXT2 `mountedAt` "/boot"
 -- >			`setFlag` BootFlag
 -- >		, partition EXT4 `mountedAt` "/"
 -- >			`addFreeSpace` MegaBytes 100
 -- >		, swapPartition (MegaBytes 256)
--- >		] (grubBooted PC)
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
+-- >		]
+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty
 imageBuilt = imageBuilt' False
 
 -- | Like 'built', but the chroot is deleted and rebuilt from scratch each
 -- time. This is more expensive, but useful to ensure reproducible results
 -- when the properties of the chroot have been changed.
-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty
 imageRebuilt = imageBuilt' True
 
-imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
-imageBuilt' rebuild img mkchroot tabletype partspec final = 
-	imageBuiltFrom img chrootdir tabletype partspec (snd final)
+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty
+imageBuilt' rebuild img mkchroot tabletype final partspec = 
+	imageBuiltFrom img chrootdir tabletype final partspec
 		`requires` Chroot.provisioned chroot
 		`requires` (cleanrebuild <!> doNothing)
 		`describe` desc
@@ -107,10 +107,8 @@ imageBuilt' rebuild img mkchroot tabletype partspec final =
 		& Apt.cacheCleaned
 
 -- | Builds a disk image from the contents of a chroot.
---
--- The passed property is run inside the mounted disk image.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty
-imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty
+imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
   where
 	desc = img ++ " built from " ++ chrootdir
 	mkimg = property desc $ do
@@ -121,25 +119,30 @@ imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
 			<$> liftIO (dirSizes chrootdir)
 		let calcsz mnts = maybe defSz fudge . getMountSz szm mnts
 		-- tie the knot!
-		let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts)
+		let (mnts, t) = fitChrootSize tabletype partspec $
+			map (calcsz mnts) mnts
 		ensureProperty $
 			imageExists img (partTableSize t)
 				`before`
 			partitioned YesReallyDeleteDiskContents img t
 				`before`
-			kpartx img (partitionsPopulated chrootdir mnts)
+			kpartx img (mkimg' mnts)
+	mkimg' mnts devs =
+		partitionsPopulated chrootdir mnts devs
+			`before`
+		imageFinalized final mnts devs
 	rmimg = File.notPresent img
 
-partitionsPopulated :: FilePath -> [MountPoint] -> [FilePath] -> Property NoInfo
+partitionsPopulated :: FilePath -> [MountPoint] -> [LoopDev] -> Property NoInfo
 partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go mnts devs
   where
 	desc = "partitions populated from " ++ chrootdir
 
 	go Nothing _ = noChange
-	go (Just mnt) dev = withTmpDir "mnt" $ \tmpdir -> bracket
-		(liftIO $ mount "auto" dev tmpdir)
+	go (Just mnt) loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
+		(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir)
 		(const $ liftIO $ umountLazy tmpdir)
-		$ \mounted -> if mounted
+		$ \ismounted -> if ismounted
 			then ensureProperty $
 				syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
 			else return FailedChange
@@ -284,15 +287,76 @@ fitChrootSize tt l basesizes = (mounts, parttable)
 
 -- | A pair of properties. The first property is satisfied within the
 -- chroot, and is typically used to download the boot loader.
--- The second property is satisfied chrooted into the resulting
--- disk image, and will typically take care of installing the boot loader
--- to the disk image.
-type Finalization = (Property NoInfo, Property NoInfo)
+--
+-- The second property is run after the disk image is created,
+-- with its populated partition tree mounted in the provided
+-- location from the provided loop devices. This will typically
+-- take care of installing the boot loader to the image.
+-- 
+-- It's ok if the second property leaves additional things mounted
+-- in the partition tree.
+type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))
+
+imageFinalized :: Finalization -> [MountPoint] -> [LoopDev] -> Property NoInfo
+imageFinalized (_, final) mnts devs = property "disk image finalized" $ 
+	withTmpDir "mnt" $ \top -> 
+		go top `finally` liftIO (unmountall top)
+  where
+	go mnt = do
+		liftIO $ mountall mnt
+		ensureProperty $ final mnt devs
+	
+	-- Ordered lexographically by mount point, so / comes before /usr
+	-- comes before /usr/local
+	orderedmntsdevs :: [(MountPoint, LoopDev)]
+	orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts devs
+
+	mountall top = forM_ orderedmntsdevs $ \(mp, loopdev) -> case mp of
+		Nothing -> noop
+		Just p -> do
+			let mnt = top ++ p
+			createDirectoryIfMissing True mnt
+			unlessM (mount "auto" (partitionLoopDev loopdev) mnt) $
+				error $ "failed mounting " ++ mnt
+
+	unmountall top = do
+		unmountBelow top
+		umountLazy top
+
+noFinalization :: Finalization
+noFinalization = (doNothing, \_ _ -> doNothing)
 
 -- | Makes grub be the boot loader of the disk image.
--- TODO not implemented
 grubBooted :: Grub.BIOS -> Finalization
-grubBooted bios = (Grub.installed bios, undefined)
+grubBooted bios = (Grub.installed' bios, boots)
+  where
+	boots mnt loopdevs = combineProperties "disk image boots using grub"
+		-- bind mount host /dev so grub can access the loop devices
+		[ bindMount "/dev" (inmnt "/dev")
+		, mounted "proc" "proc" (inmnt "/proc")
+		, mounted "sysfs" "sys" (inmnt "/sys")
+		-- work around for http://bugs.debian.org/802717
+		 , check haveosprober $ inchroot "chmod" ["-x", osprober]
+		, inchroot "update-grub" []
+		, check haveosprober $ inchroot "chmod" ["+x", osprober]
+		, inchroot "grub-install" [wholediskloopdev]
+		-- sync all buffered changes out to the disk image
+		-- may not be necessary, but seemed needed sometimes
+		-- when using the disk image right away.
+		, cmdProperty "sync" []
+		]
+	  where
+	  	-- cannot use </> since the filepath is absolute
+		inmnt f = mnt ++ f
 
-noFinalization :: Finalization
-noFinalization = (doNothing, doNothing)
+		inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
+
+		haveosprober = doesFileExist (inmnt osprober)
+		osprober = "/etc/grub.d/30_os-prober"
+
+		-- It doesn't matter which loopdev we use; all
+		-- come from the same disk image, and it's the loop dev
+		-- for the whole disk image we seek.
+		wholediskloopdev = case loopdevs of
+			(l:_) -> wholeDiskLoopDev l
+			[] -> error "No loop devs provided!"
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 6b763d08..ea54295b 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -18,14 +18,19 @@ 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.
+-- This includes running update-grub.
 installed :: BIOS -> Property NoInfo
-installed bios = 
-	Apt.installed [pkg] `describe` "grub package installed"
-		`before`
-	cmdProperty "update-grub" []
+installed bios = installed' bios `before` mkConfig
+
+-- Run update-grub, to generate the grub boot menu. It will be
+-- automatically updated when kernel packages are
+--   -- installed.
+mkConfig :: Property NoInfo
+mkConfig = cmdProperty "update-grub" []
+
+-- | Installs grub; does not run update-grub.
+installed' :: BIOS -> Property NoInfo
+installed' bios = Apt.installed [pkg] `describe` "grub package installed"
   where
 	pkg = case bios of
 		PC -> "grub-pc"
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 30d057f5..09016011 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -36,5 +36,15 @@ unmountBelow d = do
 	forM_ submnts umountLazy
 
 -- | Mounts a device.
+mounted :: FsType -> Source -> FilePath -> Property NoInfo
+mounted fs src mnt = property (mnt ++ " mounted") $ 
+	toResult <$> liftIO (mount fs src mnt)
+
+-- | Bind mounts the first directory so its contents also appear
+-- in the second directory.
+bindMount :: FilePath -> FilePath -> Property NoInfo
+bindMount src dest = cmdProperty "mount" ["--bind", src, dest]
+	`describe` ("bind mounted " ++ src ++ " to " ++ dest)
+
 mount :: FsType -> Source -> FilePath -> IO Bool
 mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 7bd38a65..834b6c7d 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -160,7 +160,7 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do
 		[ parted eep disk partedparams
 		, if isdev
 			then formatl (map (\n -> disk ++ show n) [1 :: Int ..])
-			else Partition.kpartx disk formatl
+			else Partition.kpartx disk (formatl . map Partition.partitionLoopDev)
 		]
   where
 	desc = disk ++ " partitioned"
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index 56bc1575..fd3c7930 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -4,6 +4,10 @@ module Propellor.Property.Partition where
 
 import Propellor.Base
 import qualified Propellor.Property.Apt as Apt
+import Utility.Applicative
+
+import System.Posix.Files
+import Data.List
 
 -- | Filesystems etc that can be used for a partition.
 data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap
@@ -41,20 +45,44 @@ formatted' opts YesReallyFormatPartition fs dev =
 	-- Be quiet.
 	q l = "-q":l
 
+data LoopDev = LoopDev
+	{ partitionLoopDev :: FilePath -- ^ device for a loop partition
+	, wholeDiskLoopDev :: FilePath -- ^ corresponding device for the whole loop disk
+	} deriving (Show)
+
+isLoopDev :: LoopDev -> IO Bool
+isLoopDev l = isLoopDev' (partitionLoopDev l) <&&> isLoopDev' (wholeDiskLoopDev l)
+
+isLoopDev' :: FilePath -> IO Bool
+isLoopDev' f
+	| "loop" `isInfixOf` f = catchBoolIO $
+		isBlockDevice <$> getFileStatus f
+	| otherwise = return False
+
 -- | Uses the kpartx utility to create device maps for partitions contained
--- within a disk image file. The resulting devices are passed to the
+-- within a disk image file. The resulting loop devices are passed to the
 -- property, which can operate on them. Always cleans up after itself,
 -- by removing the device maps after the property is run.
-kpartx :: FilePath -> ([FilePath] -> Property NoInfo) -> Property NoInfo
+kpartx :: FilePath -> ([LoopDev] -> Property NoInfo) -> Property NoInfo
 kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
   where
 	go = property (propertyDesc (mkprop [])) $ do
 		cleanup -- idempotency
-		s <- liftIO $ readProcess "kpartx" ["-avs", diskimage]
-		r <- ensureProperty (mkprop (devlist s))
+		loopdevs <- liftIO $ kpartxParse
+			<$> readProcess "kpartx" ["-avs", diskimage]
+		bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs
+		unless (null bad) $
+			error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad
+		r <- ensureProperty (mkprop loopdevs)
 		cleanup
 		return r
-	devlist = mapMaybe (finddev . words) . lines
-	finddev ("add":"map":s:_) = Just ("/dev/mapper/" ++ s)
-	finddev _ = Nothing
 	cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]
+
+kpartxParse :: String -> [LoopDev]
+kpartxParse = mapMaybe (finddev . words) . lines
+  where
+	finddev ("add":"map":ld:_:_:_:_:wd:_) = Just $ LoopDev 
+		{ partitionLoopDev = "/dev/mapper/" ++ ld
+		, wholeDiskLoopDev = wd
+		}
+	finddev _ = Nothing
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index e8d8aef3..70d5884f 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -15,6 +15,7 @@ import qualified Propellor.Property.User as User
 import qualified Propellor.Property.Obnam as Obnam
 import qualified Propellor.Property.Apache as Apache
 import qualified Propellor.Property.Postfix as Postfix
+import qualified Propellor.Property.Systemd as Systemd
 import Utility.FileMode
 
 import Data.List
@@ -346,6 +347,7 @@ gitAnnexDistributor = combineProperties "git-annex distributor, including rsync
 		`onChange` Service.restarted "rsync"
 	& "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true"
 		`onChange` Service.running "rsync"
+	& Systemd.enabled "rsync"
 	& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild"
 	& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-yosemite"
 	& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/windows"
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 5ba069e3..60121336 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -4,6 +4,7 @@ module Propellor.Property.Ssh (
 	installed,
 	restarted,
 	PubKeyText,
+	SshKeyType(..),
 	-- * Daemon configuration
 	sshdConfig,
 	ConfigKeyword,
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index c3314738..78e606ac 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -58,14 +58,21 @@ hasPassword' (User u) context = go `requires` shadowConfig True
 setPassword :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result
 setPassword getpassword = getpassword $ go
   where
-	go (Password user, password) = set user (privDataVal password) []
-	go (CryptPassword user, hash) = set user (privDataVal hash) ["--encrypted"]
+	go (Password user, password) = chpasswd (User user) (privDataVal password) []
+	go (CryptPassword user, hash) = chpasswd (User user) (privDataVal hash) ["--encrypted"]
 	go (f, _) = error $ "Unexpected type of privdata: " ++ show f
 
-	set user v ps = makeChange $ withHandle StdinHandle createProcessSuccess
-		(proc "chpasswd" ps) $ \h -> do
-			hPutStrLn h $ user ++ ":" ++ v
-			hClose h
+-- | Makes a user's password be the passed String. Highly insecure:
+-- The password is right there in your config file for anyone to see!
+hasInsecurePassword :: User -> String -> Property NoInfo
+hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $
+	chpasswd u p []
+
+chpasswd :: User -> String -> [String] -> Propellor Result
+chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuccess
+	(proc "chpasswd" ps) $ \h -> do
+		hPutStrLn h $ user ++ ":" ++ v
+		hClose h
 
 lockedPassword :: User -> Property NoInfo
 lockedPassword user@(User u) = check (not <$> isLockedPassword user) $ cmdProperty "passwd"