Merge branch 'joeyconfig'

8 files changed, 161 insertions, 42 deletions

diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index ded108bc..0cbc8642 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -15,6 +15,7 @@ module Propellor.Property.Chroot (
 import Propellor
 import Propellor.Types.CmdLine
 import Propellor.Types.Chroot
+import Propellor.Types.Info
 import Propellor.Property.Chroot.Util
 import qualified Propellor.Property.Debootstrap as Debootstrap
 import qualified Propellor.Property.Systemd.Core as Systemd
@@ -91,8 +92,8 @@ propigateChrootInfo c p = propigateContainer c p'
 		(propertyChildren p)
 
 chrootInfo :: Chroot -> Info
-chrootInfo (Chroot loc _ _ h) =
-	mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } }
+chrootInfo (Chroot loc _ _ h) = mempty `addInfo` 
+	mempty { _chroots = M.singleton loc h }
 
 -- | Propellor is run inside the chroot to provision it.
 propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo
@@ -143,7 +144,7 @@ chain :: [Host] -> CmdLine -> IO ()
 chain hostlist (ChrootChain hn loc systemdonly onconsole) = 
 	case findHostNoAlias hostlist hn of
 		Nothing -> errorMessage ("cannot find host " ++ hn)
-		Just parenthost -> case M.lookup loc (_chroots $ _chrootinfo $ hostInfo parenthost) of
+		Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of
 			Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn)
 			Just h -> go h
   where
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 5a41edd0..7a3460cb 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -1,6 +1,10 @@
 -- | Disk image generation. 
 --
 -- 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 (
 	-- * Properties
@@ -41,8 +45,11 @@ import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import Propellor.Property.Parted
 import Propellor.Property.Mount
+import Propellor.Property.Partition
+import Propellor.Property.Rsync
 import Utility.Path
 
+import Data.List (isPrefixOf)
 import qualified Data.Map.Strict as M
 import qualified Data.ByteString.Lazy as L
 import System.Posix.Files
@@ -64,8 +71,10 @@ type DiskImage = FilePath
 -- > 		& Apt.installed ["linux-image-amd64"]
 -- >		& ...
 -- > in imageBuilt "/srv/images/foo.img" chroot MSDOS 
--- >		[ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag
--- >		, partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100
+-- >		[ 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
@@ -100,27 +109,52 @@ imageBuilt' rebuild img mkchroot tabletype partspec final =
 -- | Builds a disk image from the contents of a chroot.
 --
 -- The passed property is run inside the mounted disk image.
---
--- TODO copy in
--- TODO run final
 imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty
 imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
   where
-	mkimg = property (img ++ " built from " ++ chrootdir) $ do
+	desc = img ++ " built from " ++ chrootdir
+	mkimg = property desc $ do
 		-- unmount helper filesystems such as proc from the chroot
 		-- before getting sizes
 		liftIO $ unmountBelow chrootdir
 		szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize 
 			<$> liftIO (dirSizes chrootdir)
-		let calcsz = \mnts -> fromMaybe defSz . getMountSz szm mnts
+		let calcsz = \mnts -> maybe defSz fudge . getMountSz szm mnts
 		-- tie the knot!
 		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)
 	rmimg = File.notPresent img
 
+partitionsPopulated :: FilePath -> [MountPoint] -> [FilePath] -> Property NoInfo
+partitionsPopulated chrootdir mnts devs = property desc $
+	mconcat $ map (uncurry go) (zip mnts devs)
+  where
+	desc = "partitions populated from " ++ chrootdir
+
+	go Nothing _ = noChange
+	go (Just mnt) dev = withTmpDir "mnt" $ \tmpdir -> bracket
+		(liftIO $ mount "auto" dev tmpdir)
+		(const $ liftIO $ umountLazy tmpdir)
+		$ \mounted -> if mounted
+			then ensureProperty $
+				syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
+			else return FailedChange
+
+	filtersfor mnt = 
+		let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $
+			filter (\m -> m /= mnt && addTrailingPathSeparator mnt `isPrefixOf` m)
+				(catMaybes mnts)
+		in concatMap (\m -> 
+			-- Include the child mount point, but exclude its contents.
+			[ Include (Pattern m)
+			, Exclude (filesUnder m)
+			]) childmnts
+
 -- | Ensures that a disk image file of the specified size exists.
 -- 
 -- If the file doesn't exist, or is too small, creates a new one, full of 0's.
@@ -161,22 +195,19 @@ dirSizes top = go M.empty top [top]
 			else go (M.insertWith (+) dir sz m) dir is
 	subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent
 
--- | Gets the size to allocate for a particular mount point, given the
--- map of sizes.
---
--- A list of all mount points is provided, so that when eg calculating
--- the size for /, if /boot is a mount point, its size can be subtracted.
 getMountSz :: (M.Map FilePath PartSize) -> [MountPoint] -> MountPoint -> Maybe PartSize
 getMountSz _ _ Nothing = Nothing
 getMountSz szm l (Just mntpt) = 
 	fmap (`reducePartSize` childsz) (M.lookup mntpt szm)
   where
 	childsz = mconcat $ catMaybes $
-		map (getMountSz szm l) (filter childmntpt l)
-	childmntpt Nothing = False
-	childmntpt (Just d) 
-		| d `equalFilePath` mntpt = False
-		| otherwise = mntpt `dirContains` d
+		map (getMountSz szm l) (filter (isChild mntpt) l)
+
+isChild :: FilePath -> MountPoint -> Bool
+isChild mntpt (Just d)
+	| d `equalFilePath` mntpt = False
+	| otherwise = mntpt `dirContains` d
+isChild _ Nothing = False
 
 -- | From a location in a chroot (eg, /tmp/chroot/usr) to
 -- the corresponding location inside (eg, /usr).
@@ -191,11 +222,19 @@ type MountPoint = Maybe FilePath
 defSz :: PartSize
 defSz = MegaBytes 128
 
+-- Add 2% for filesystem overhead. Rationalle for picking 2%:
+-- A filesystem with 1% overhead might just sneak by as acceptable.
+-- Double that just in case. Add an additional 3 mb to deal with
+-- non-scaling overhead, of filesystems (eg, superblocks).
+fudge :: PartSize -> PartSize
+fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3)
+
 -- | Specifies a mount point and a constructor for a Partition.
 -- 
 -- The size that is eventually provided is the amount of space needed to 
 -- hold the files that appear in the directory where the partition is to be
--- mounted.
+-- mounted. Plus a fudge factor, since filesystems have some space
+-- overhead.
 --
 -- (Partitions that are not to be mounted (ie, LinuxSwap), or that have
 -- no corresponding directory in the chroot will have 128 MegaBytes
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index a7dbf86a..6051ba63 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -15,6 +15,7 @@ module Propellor.Property.Dns (
 
 import Propellor
 import Propellor.Types.Dns
+import Propellor.Types.Info
 import Propellor.Property.File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Ssh as Ssh
@@ -78,7 +79,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
 	
 	(partialzone, zonewarnings) = genZone indomain hostmap domain soa
 	baseprop = infoProperty ("dns primary for " ++ domain) satisfy
-		(addNamedConf conf) []
+		(mempty `addInfo` addNamedConf conf) []
 	satisfy = do
 		sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
 		let zone = partialzone
@@ -207,7 +208,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
 otherServers wantedtype hosts domain =
 	M.keys $ M.filter wanted $ hostMap hosts
   where
-	wanted h = case M.lookup domain (fromNamedConfMap $ _namedconf $ hostInfo h) of
+	wanted h = case M.lookup domain (fromNamedConfMap $ getInfo $ hostInfo h) of
 		Nothing -> False
 		Just conf -> confDnsServerType conf == wantedtype
 			&& confDomain conf == domain
@@ -459,7 +460,7 @@ genZone inzdomain hostmap zdomain soa =
 	-- So we can just use the IPAddrs.
 	addcnames :: Host -> [Either WarningMessage (BindDomain, Record)]
 	addcnames h = concatMap gen $ filter (inDomain zdomain) $
-		mapMaybe getCNAME $ S.toList (_dns info)
+		mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info
 	  where
 		info = hostInfo h
 		gen c = case getAddresses info of
@@ -474,7 +475,7 @@ genZone inzdomain hostmap zdomain soa =
 	  where
 		info = hostInfo h
 		l = zip (repeat $ AbsDomain $ hostName h)
-			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns info))
+			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ getInfo info))
 
 	-- Simplifies the list of hosts. Remove duplicate entries.
 	-- Also, filter out any CHAMES where the same domain has an
@@ -503,13 +504,13 @@ domainHost base (AbsDomain d)
   where
 	dotbase = '.':base
 
-addNamedConf :: NamedConf -> Info
-addNamedConf conf = mempty { _namedconf = NamedConfMap (M.singleton domain conf) }
+addNamedConf :: NamedConf -> NamedConfMap
+addNamedConf conf = NamedConfMap (M.singleton domain conf)
   where
 	domain = confDomain conf
 
 getNamedConf :: Propellor (M.Map Domain NamedConf)
-getNamedConf = asks $ fromNamedConfMap . _namedconf . hostInfo
+getNamedConf = asks $ fromNamedConfMap . getInfo . hostInfo
 
 -- | Generates SSHFP records for hosts in the domain (or with CNAMES
 -- in the domain) that have configured ssh public keys.
@@ -522,7 +523,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get)
 	gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty
 	mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing)
 		(AbsDomain hostname : cnames)
-	cnames = mapMaybe getCNAME $ S.toList $ _dns info
+	cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info
 	hostname = hostName h
 	info = hostInfo h
 
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 05f25c31..e24d58d4 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -49,6 +49,7 @@ import Propellor hiding (init)
 import Propellor.Types.Docker
 import Propellor.Types.Container
 import Propellor.Types.CmdLine
+import Propellor.Types.Info
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Cmd as Cmd
@@ -186,7 +187,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
   where
 	runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
 		(_dockerRunParams info)
-	info = _dockerinfo $ hostInfo h'
+	info = getInfo $ hostInfo h'
 	h' = h
 		-- Restart by default so container comes up on
 		-- boot or when docker is upgraded.
@@ -572,7 +573,7 @@ chain hostlist hn s = case toContainerId s of
 	Nothing -> errorMessage "bad container id"
 	Just cid -> case findHostNoAlias hostlist hn of
 		Nothing -> errorMessage ("cannot find host " ++ hn)
-		Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ _dockerinfo $ hostInfo parenthost) of
+		Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ getInfo $ hostInfo parenthost) of
 			Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn)
 			Just h -> go cid h
   where
@@ -643,17 +644,17 @@ listImages :: IO [ImageUID]
 listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
 
 runProp :: String -> RunParam -> Property HasInfo
-runProp field val = pureInfoProperty (param) $ dockerInfo $
+runProp field val = pureInfoProperty (param) $
 	mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
   where
 	param = field++"="++val
 
 genProp :: String -> (HostName -> RunParam) -> Property HasInfo
-genProp field mkval = pureInfoProperty field $ dockerInfo $
+genProp field mkval = pureInfoProperty field $
 	mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
 
-dockerInfo :: DockerInfo Host -> Info
-dockerInfo i = mempty { _dockerinfo = i }
+dockerInfo :: DockerInfo -> Info
+dockerInfo i = mempty `addInfo` i
 
 -- | The ContainerIdent of a container is written to
 -- </.propellor-ident> inside it. This can be checked to see if
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index d45969a8..5ca7a6bc 100644
--- a/src/Propellor/Property/Reboot.hs
+++ b/src/Propellor/Property/Reboot.hs
@@ -8,7 +8,7 @@ now = cmdProperty "reboot" []
 
 -- | Schedules a reboot at the end of the current propellor run.
 --
--- The Result code of the endire propellor run can be checked;
+-- The `Result` code of the entire propellor run can be checked;
 -- the reboot proceeds only if the function returns True.
 --
 -- The reboot can be forced to run, which bypasses the init system. Useful
diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
new file mode 100644
index 00000000..8423eff6
--- /dev/null
+++ b/src/Propellor/Property/Rsync.hs
@@ -0,0 +1,59 @@
+module Propellor.Property.Rsync where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+
+type Src = FilePath
+type Dest = FilePath
+
+class RsyncParam p where
+	toRsync :: p -> String
+
+-- | A pattern that matches all files under a directory, but does not
+-- match the directory itself.
+filesUnder :: FilePath -> Pattern
+filesUnder d = Pattern (d ++ "/*")
+
+-- | Ensures that the Dest directory exists and has identical contents as
+-- the Src directory.
+syncDir :: Src -> Dest -> Property NoInfo
+syncDir = syncDirFiltered []
+
+data Filter 
+	= Include Pattern
+	| Exclude Pattern
+
+instance RsyncParam Filter where
+	toRsync (Include (Pattern p)) = "--include=" ++ p
+	toRsync (Exclude (Pattern p)) = "--exclude=" ++ p
+
+-- | A pattern to match against files that rsync is going to transfer.
+--
+-- See "INCLUDE/EXCLUDE PATTERN RULES" in the rsync(1) man page.
+--
+-- For example, Pattern "/foo/*" matches all files under the "foo"
+-- directory, relative to the 'Src' that rsync is acting on.
+newtype Pattern = Pattern String
+
+-- | Like syncDir, but avoids copying anything that the filter list
+-- excludes. Anything that's filtered out will be deleted from Dest.
+--
+-- Rsync checks each name to be transferred against its list of Filter
+-- rules, and the first matching one is acted on. If no matching rule
+-- is found, the file is processed.
+syncDirFiltered :: [Filter] -> Src -> Dest -> Property NoInfo
+syncDirFiltered filters src dest = rsync $
+	[ "-av"
+	-- Add trailing '/' to get rsync to sync the Dest directory,
+	-- rather than a subdir inside it, which it will do without a
+	-- trailing '/'.
+	, addTrailingPathSeparator src
+	, addTrailingPathSeparator dest
+	, "--delete"
+	, "--delete-excluded"
+	, "--quiet"
+	] ++ map toRsync filters
+
+rsync :: [String] -> Property NoInfo
+rsync ps = cmdProperty "rsync" ps
+	`requires` Apt.installed ["rsync"]
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index fca7d037..c85694db 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
 module Propellor.Property.Ssh (
 	PubKeyText,
 	sshdConfig,
@@ -27,6 +29,7 @@ import Propellor
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Service as Service
 import Propellor.Property.User
+import Propellor.Types.Info
 import Utility.FileMode
 
 import System.PosixCompat
@@ -169,11 +172,25 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++
 -- configure the host to use it. Normally this does not need to be used;
 -- use 'hostKey' instead.
 pubKey :: SshKeyType -> PubKeyText -> Property HasInfo
-pubKey t k = pureInfoProperty ("ssh pubkey known") $
-	mempty { _sshPubKey = M.singleton t k }
+pubKey t k = pureInfoProperty ("ssh pubkey known")
+	(SshPubKeyInfo (M.singleton t k))
+
+getPubKey :: Propellor (M.Map SshKeyType PubKeyText)
+getPubKey = fromSshPubKeyInfo <$> askInfo
+
+newtype SshPubKeyInfo = SshPubKeyInfo 
+	{ fromSshPubKeyInfo :: M.Map SshKeyType PubKeyText }
+	deriving (Eq, Ord, Typeable)
+
+instance IsInfo SshPubKeyInfo where
+	propigateInfo _ = False
 
-getPubKey :: Propellor (M.Map SshKeyType String)
-getPubKey = asks (_sshPubKey . hostInfo)
+instance Monoid SshPubKeyInfo where
+	mempty = SshPubKeyInfo M.empty
+	mappend (SshPubKeyInfo old) (SshPubKeyInfo new) = 
+		-- new first because union prefers values from the first
+		-- parameter when there is a duplicate key
+		SshPubKeyInfo (new `M.union` old)
 
 -- | Sets up a user with a ssh private key and public key pair from the
 -- PrivData.
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 4da5b3f2..e44ef717 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -43,6 +43,7 @@ module Propellor.Property.Systemd (
 import Propellor
 import Propellor.Types.Chroot
 import Propellor.Types.Container
+import Propellor.Types.Info
 import qualified Propellor.Property.Chroot as Chroot
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.File as File
@@ -209,7 +210,7 @@ nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
   where
 	p = enterScript c
 		`before` chrootprovisioned
-		`before` nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h)
+		`before` nspawnService c (_chrootCfg $ getInfo $ hostInfo h)
 		`before` containerprovisioned
 
 	-- Chroot provisioning is run in systemd-only mode,
@@ -328,7 +329,7 @@ containerCfg :: String -> RevertableProperty
 containerCfg p = RevertableProperty (mk True) (mk False)
   where
 	mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $
-		mempty { _chrootinfo = mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] } }
+		mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] }
 	p' = case p of
 		('-':_) -> p
 		_ -> "--" ++ p