propellor 4.8.1 → 4.9.0

raw patch · 22 files changed

+162/−59 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +26/−0
• debian/changelog +26/−0
• debian/control +0/−2
• propellor.cabal +1/−1
• src/Propellor/Bootstrap.hs +1/−1
• src/Propellor/Info.hs +18/−8
• src/Propellor/Property/Attic.hs +1/−1
• src/Propellor/Property/Borg.hs +1/−1
• src/Propellor/Property/Chroot.hs +2/−2
• src/Propellor/Property/Chroot/Util.hs +0/−5
• src/Propellor/Property/Debootstrap.hs +1/−1
• src/Propellor/Property/Dns.hs +3/−3
• src/Propellor/Property/Fstab.hs +2/−1
• src/Propellor/Property/Obnam.hs +1/−1
• src/Propellor/Property/PropellorRepo.hs +19/−11
• src/Propellor/Property/Restic.hs +1/−1
• src/Propellor/Property/Sbuild.hs +2/−2
• src/Propellor/Property/SiteSpecific/JoeySites.hs +1/−1
• src/Propellor/Spin.hs +9/−4
• src/Propellor/Types/Dns.hs +27/−6
• src/Propellor/Types/Info.hs +3/−5
• src/Utility/Directory.hs +17/−2

@@ -1,3 +1,29 @@+propellor (4.9.0) unstable; urgency=medium++  * When the ipv4 and ipv6 properties are used with a container, avoid+    propagating the address out to the host.+  * DnsInfo has been replaced with DnsInfoPropagated and+    DnsInfoUnpropagated. (API change)+  * Code that used fromDnsInfo . fromInfo changes to use getDnsInfo.+  * addDNS takes an additional Bool parameter to control whether+    the DNS info should propagate out of containers. (API change)+  * Made the PropellorRepo.hasOriginUrl property override the repository+    url that --spin passes to a host.+  * PropellorRepo.hasOriginUrl type changed to include HasInfo. (API change)+  * Fstab.mounted: Create mount point if necessary, and mount it+    if it's not already mounted.+    Thanks, Nicolas Schodet+  * Properties that check for an empty directory now treat a directory+    containing only "lost+found" as effectively empty, to support+    situations where the directory is a mount point of an EXT* filesystem.+    Thanks, Nicolas Schodet+  * Make addInfo accumulate Info in order properties appear, not+    reverse order.+    This fixes a bug involving reverting Systemd.resolvConfed or+    Systemd.linkJournal.++ -- Joey Hess <id@joeyh.name>  Wed, 25 Oct 2017 13:02:14 -0400+ propellor (4.8.1) unstable; urgency=medium    * Borg: Fix propigation of exit status of borg backup.

@@ -1,3 +1,29 @@+propellor (4.9.0) unstable; urgency=medium++  * When the ipv4 and ipv6 properties are used with a container, avoid+    propagating the address out to the host.+  * DnsInfo has been replaced with DnsInfoPropagated and+    DnsInfoUnpropagated. (API change)+  * Code that used fromDnsInfo . fromInfo changes to use getDnsInfo.+  * addDNS takes an additional Bool parameter to control whether+    the DNS info should propagate out of containers. (API change)+  * Made the PropellorRepo.hasOriginUrl property override the repository+    url that --spin passes to a host.+  * PropellorRepo.hasOriginUrl type changed to include HasInfo. (API change)+  * Fstab.mounted: Create mount point if necessary, and mount it+    if it's not already mounted.+    Thanks, Nicolas Schodet+  * Properties that check for an empty directory now treat a directory+    containing only "lost+found" as effectively empty, to support+    situations where the directory is a mount point of an EXT* filesystem.+    Thanks, Nicolas Schodet+  * Make addInfo accumulate Info in order properties appear, not+    reverse order.+    This fixes a bug involving reverting Systemd.resolvConfed or+    Systemd.linkJournal.++ -- Joey Hess <id@joeyh.name>  Wed, 25 Oct 2017 13:02:14 -0400+ propellor (4.8.1) unstable; urgency=medium    * Borg: Fix propigation of exit status of borg backup.

@@ -19,7 +19,6 @@ 	libghc-stm-dev, 	libghc-text-dev, 	libghc-hashable-dev,-	libghc-concurrent-output-dev, Maintainer: Joey Hess <id@joeyh.name> Standards-Version: 3.9.8 Vcs-Git: git://git.joeyh.name/propellor@@ -44,7 +43,6 @@ 	libghc-stm-dev, 	libghc-text-dev, 	libghc-hashable-dev,-	libghc-concurrent-output-dev, 	git, Description: property-based host configuration management in haskell  Propellor ensures that the system it's run in satisfies a list of

@@ -1,5 +1,5 @@ Name: propellor-Version: 4.8.1+Version: 4.9.0 Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>

@@ -133,9 +133,9 @@ 	pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p 	pacmaninstall p = "pacman -S --noconfirm --needed " ++ p -	-- This is the same deps listed in debian/control. 	debdeps Cabal = 		[ "gnupg"+		-- Below are the same deps listed in debian/control. 		, "ghc" 		, "cabal-install" 		, "libghc-async-dev"

@@ -128,11 +128,11 @@ -- if the host's IP Property matches the DNS. If the DNS is missing or -- out of date, the host will instead be contacted directly by IP address. ipv4 :: String -> Property (HasInfo + UnixLike)-ipv4 = addDNS . Address . IPv4+ipv4 = addDNS False . Address . IPv4  -- | Indicate that a host has an AAAA record in the DNS. ipv6 :: String -> Property (HasInfo + UnixLike)-ipv6 = addDNS . Address . IPv6+ipv6 = addDNS False . Address . IPv6  -- | Indicates another name for the host in the DNS. --@@ -145,19 +145,29 @@ 	`addInfo` toAliasesInfo [d] 	-- A CNAME is added here, but the DNS setup code converts it to an 	-- IP address when that makes sense.-	`addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d)+	`addInfo` (toDnsInfoPropagated $ S.singleton $ CNAME $ AbsDomain d) -addDNS :: Record -> Property (HasInfo + UnixLike)-addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r))+-- | Add a DNS Record.+addDNS+	:: Bool+	-- ^ When used in a container, the DNS info will only+	-- propagate out the the Host when this is True.+	-> Record+	-> Property (HasInfo + UnixLike)+addDNS prop r+	| prop = pureInfoProperty (rdesc r) (toDnsInfoPropagated s)+	| otherwise = pureInfoProperty (rdesc r) (toDnsInfoUnpropagated s)   where+	s = S.singleton r+ 	rdesc (CNAME d) = unwords ["alias", ddesc d] 	rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr] 	rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr] 	rdesc (MX n d) = unwords ["MX", show n, ddesc d] 	rdesc (NS d) = unwords ["NS", ddesc d]-	rdesc (TXT s) = unwords ["TXT", s]+	rdesc (TXT t) = unwords ["TXT", t] 	rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d]-	rdesc (SSHFP x y s) = unwords ["SSHFP", show x, show y, s]+	rdesc (SSHFP x y t) = unwords ["SSHFP", show x, show y, t] 	rdesc (INCLUDE f) = unwords ["$INCLUDE", f] 	rdesc (PTR x) = unwords ["PTR", x] @@ -182,7 +192,7 @@ findAlias l hn = M.lookup hn (aliasMap l)  getAddresses :: Info -> [IPAddr]-getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo+getAddresses = mapMaybe getIPAddr . S.toList . getDnsInfo  hostAddresses :: HostName -> [Host] -> [IPAddr] hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn)

@@ -59,7 +59,7 @@ 		, noChange 		) -	needsRestore = null <$> catchDefaultIO [] (dirContents dir)+	needsRestore = isUnpopulated dir  	restore = withTmpDirIn (takeDirectory dir) "attic-restore" $ \tmpdir -> do 		ok <- boolSystem "attic" $

@@ -95,7 +95,7 @@ 		, noChange 		) -	needsRestore = null <$> catchDefaultIO [] (dirContents dir)+	needsRestore = isUnpopulated dir  	restore = withTmpDirIn (takeDirectory dir) "borg-restore" $ \tmpdir -> do 		ok <- runBorg repo $

@@ -77,7 +77,7 @@ 		tightenTargets $ extractTarball loc tb  extractTarball :: FilePath -> FilePath -> Property UnixLike-extractTarball target src = check (unpopulated target) $+extractTarball target src = check (isUnpopulated target) $ 	cmdProperty "tar" params 		`assume` MadeChange 		`requires` File.dirExists target@@ -151,7 +151,7 @@ 	cantbuild e = property (chrootDesc c "built") (error e)  	teardown :: Property Linux-	teardown = check (not <$> unpopulated loc) $+	teardown = check (not <$> isUnpopulated loc) $ 		property ("removed " ++ loc) $ 			makeChange (removeChroot loc) 

@@ -2,7 +2,6 @@  import Propellor.Property.Mount -import Utility.Exception import Utility.Env import Utility.Directory @@ -27,7 +26,3 @@ removeChroot c = do 	unmountBelow c 	removeDirectoryRecursive c---- | Returns true if a chroot directory is empty.-unpopulated :: FilePath -> IO Bool-unpopulated d = null <$> catchDefaultIO [] (dirContents d)

@@ -54,7 +54,7 @@ built' installprop target system@(System _ arch) config =  	go `before` oldpermfix   where-	go = check (unpopulated target <||> ispartial) setupprop+	go = check (isUnpopulated target <||> ispartial) setupprop 		`requires` installprop  	setupprop :: Property Linux

@@ -468,7 +468,7 @@ 	-- So we can just use the IPAddrs. 	addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] 	addcnames h = concatMap gen $ filter (inDomain zdomain) $-		mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info+		mapMaybe getCNAME $ S.toList $ getDnsInfo info 	  where 		info = hostInfo h 		gen c = case getAddresses info of@@ -483,7 +483,7 @@ 	  where 		info = hostInfo h 		l = zip (repeat $ AbsDomain $ hostName h)-			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info))+			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (getDnsInfo info))  	-- Simplifies the list of hosts. Remove duplicate entries. 	-- Also, filter out any CHAMES where the same domain has an@@ -531,7 +531,7 @@ 	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 $ fromDnsInfo $ fromInfo info+	cnames = mapMaybe getCNAME $ S.toList $ getDnsInfo info 	hostname = hostName h 	info = hostInfo h 

@@ -26,7 +26,8 @@ mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux mounted fs src mnt opts = tightenTargets $  	listed fs src mnt opts-		`onChange` mountnow+		`before` mountnow+		`requires` File.dirExists mnt   where 	-- This use of mountPoints, which is linux-only, is why this 	-- property currently only supports linux.

@@ -113,7 +113,7 @@ 		, noChange 		) -	needsRestore = null <$> catchDefaultIO [] (dirContents dir)+	needsRestore = isUnpopulated dir  	restore = withTmpDirIn (takeDirectory dir) "obnam-restore" $ \tmpdir -> do 		ok <- boolSystem "obnam" $

@@ -2,18 +2,26 @@  import Propellor.Base import Propellor.Git.Config+import Propellor.Types.Info  -- | Sets the url to use as the origin of propellor's git repository. ----- When propellor --spin is used to update a host, the url is taken from--- the repository that --spin is run in, and passed to the host. So, you--- don't need to specifiy this property then. +-- By default, the url is taken from the deploy or origin remote of+-- the repository that propellor --spin is run in. Setting this property+-- overrides that default behavior with a different url. ----- This property is useful when hosts are being updated without using--- --spin, eg when using the `Propellor.Property.Cron.runPropellor` cron job.-hasOriginUrl :: String -> Property UnixLike-hasOriginUrl u = property ("propellor repo url " ++ u) $ do-	curru <- liftIO getRepoUrl-	if curru == Just u-		then return NoChange-		else makeChange $ setRepoUrl u+-- When hosts are being updated without using -- --spin, eg when using+-- the `Propellor.Property.Cron.runPropellor` cron job, this property can+-- be set to redirect them to a new git repository url.+hasOriginUrl :: String -> Property (HasInfo + UnixLike)+hasOriginUrl u = setInfoProperty p (toInfo (InfoVal (OriginUrl u)))+  where+	p :: Property UnixLike+	p = property ("propellor repo url " ++ u) $ do+		curru <- liftIO getRepoUrl+		if curru == Just u+			then return NoChange+			else makeChange $ setRepoUrl u++newtype OriginUrl = OriginUrl String+	deriving (Show)

@@ -97,7 +97,7 @@ 		, noChange 		) -	needsRestore = null <$> catchDefaultIO [] (dirContents dir)+	needsRestore = isUnpopulated dir  	restore = withTmpDirIn (takeDirectory dir) "restic-restore" $ \tmpdir -> do 		ok <- boolSystem "restic"

@@ -147,7 +147,7 @@ 	<!> deleted   where 	go :: Property DebianLike-	go = check (unpopulated (schrootRoot s) <||> ispartial) $+	go = check (isUnpopulated (schrootRoot s) <||> ispartial) $ 		property' ("built sbuild schroot for " ++ val s) make 	make w = do 		de <- liftIO standardPathEnv@@ -166,7 +166,7 @@ 			) 	-- TODO we should kill any sessions still using the chroot 	-- before destroying it (as suggested by sbuild-destroychroot)-	deleted = check (not <$> unpopulated (schrootRoot s)) $+	deleted = check (not <$> isUnpopulated (schrootRoot s)) $ 		property ("no sbuild schroot for " ++ val s) $ do 			liftIO $ removeChroot $ schrootRoot s 			liftIO $ nukeFile

@@ -912,7 +912,7 @@ homePowerMonitor :: IsContext c => User -> c -> (SshKeyType, Ssh.PubKeyText) -> Property (HasInfo + DebianLike) homePowerMonitor user ctx sshkey = propertyList "home power monitor" $ props 	& Apache.installed-	& Apt.installed ["python2", "python-pymodbus"]+	& Apt.installed ["python", "python-pymodbus"] 	& File.ownerGroup "/var/www/html" user (userGroup user) 	& Git.cloned user "git://git.kitenet.net/joey/homepower" d Nothing 		`onChange` buildpoller

@@ -29,6 +29,7 @@ import Propellor.Bootstrap import Propellor.Types.CmdLine import Propellor.Types.Info+import Propellor.Property.PropellorRepo (OriginUrl(..)) import qualified Propellor.Shim as Shim import Utility.FileMode import Utility.SafeCommand@@ -173,7 +174,7 @@ 					return ip  	configips = map val $ mapMaybe getIPAddr $-		S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst+		S.toList $ getDnsInfo $ hostInfo hst  -- Update the privdata, repo url, and git repo over the ssh -- connection, talking to the user's local propellor instance which is@@ -220,7 +221,7 @@ 		v <- maybe Nothing readish <$> getMarked fromh statusMarker 		case v of 			(Just NeedRepoUrl) -> do-				sendRepoUrl toh+				sendRepoUrl hst toh 				loop 			(Just NeedPrivData) -> do 				sendPrivData hn toh privdata@@ -242,8 +243,12 @@ 				done 			Nothing -> done -sendRepoUrl :: Handle -> IO ()-sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)+sendRepoUrl :: Host -> Handle -> IO ()+sendRepoUrl hst toh = sendMarked toh repoUrlMarker =<< geturl+  where+	geturl = case fromInfoVal (fromInfo (hostInfo hst)) of+		Nothing -> fromMaybe "" <$> getRepoUrl+		Just (OriginUrl u) -> return u  sendPrivData :: HostName -> Handle -> PrivMap -> IO () sendPrivData hn toh privdata = void $ actionMessage msg $ do

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}  module Propellor.Types.Dns where @@ -36,16 +37,36 @@ fromAliasesInfo :: AliasesInfo -> [HostName] fromAliasesInfo (AliasesInfo s) = S.toList s -newtype DnsInfo = DnsInfo { fromDnsInfo :: S.Set Record }+-- | Use this for DNS Info that should propagate from a container to a+-- host. For example, this can be used for CNAME to make aliases+-- of the containers in the host be reflected in the DNS.+newtype DnsInfoPropagated = DnsInfoPropagated+	{ fromDnsInfoPropagated :: S.Set Record } 	deriving (Show, Eq, Ord, Monoid, Typeable) -toDnsInfo :: S.Set Record -> DnsInfo-toDnsInfo = DnsInfo+toDnsInfoPropagated :: S.Set Record -> DnsInfoPropagated+toDnsInfoPropagated = DnsInfoPropagated --- | DNS Info is propagated, so that eg, aliases of a container--- are reflected in the dns for the host where it runs.-instance IsInfo DnsInfo where+instance IsInfo DnsInfoPropagated where 	propagateInfo _ = PropagateInfo True++-- | Use this for DNS Info that should not propagate from a container to a+-- host. For example, an IP address of a container should not influence+-- the host.+newtype DnsInfoUnpropagated = DnsInfoUnpropagated+	{ fromDnsInfoUnpropagated :: S.Set Record }+	deriving (Show, Eq, Ord, Monoid, Typeable)++toDnsInfoUnpropagated :: S.Set Record -> DnsInfoUnpropagated+toDnsInfoUnpropagated = DnsInfoUnpropagated++-- | Get all DNS Info.+getDnsInfo :: Info -> S.Set Record+getDnsInfo i = fromDnsInfoUnpropagated (fromInfo i)+	`S.union` fromDnsInfoPropagated (fromInfo i)++instance IsInfo DnsInfoUnpropagated where+	propagateInfo _ = PropagateInfo False  -- | Represents a bind 9 named.conf file. data NamedConf = NamedConf

@@ -44,8 +44,7 @@ -- as info, especially type aliases which coud easily lead to bugs. -- We want a little bit of dynamic types here, but not too far.. class (Typeable v, Monoid v, Show v) => IsInfo v where-	-- | Should info of this type be propagated out of a-	-- container to its Host?+	-- | Should this info be propagated out of a container to its Host? 	propagateInfo :: v -> PropagateInfo  data PropagateInfo@@ -56,16 +55,15 @@  -- | Any value in the `IsInfo` type class can be added to an Info. addInfo :: IsInfo v => Info -> v -> Info-addInfo (Info l) v = Info (InfoEntry v:l)+addInfo (Info l) v = Info (l++[InfoEntry v])  -- | Converts any value in the `IsInfo` type class into an Info, -- which is otherwise empty. toInfo :: IsInfo v => v -> Info toInfo = addInfo mempty --- The list is reversed here because addInfo builds it up in reverse order. fromInfo :: IsInfo v => Info -> v-fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l))+fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry l)  -- | Maps a function over all values stored in the Info that are of the -- appropriate type.

@@ -42,6 +42,10 @@ dirCruft ".." = True dirCruft _ = False +fsCruft :: FilePath -> Bool+fsCruft "lost+found" = True+fsCruft d = dirCruft d+ {- Lists the contents of a directory.  - Unlike getDirectoryContents, paths are not relative to the directory. -} dirContents :: FilePath -> IO [FilePath]@@ -236,12 +240,23 @@ -- True only when directory exists and contains nothing. -- Throws exception if directory does not exist. isDirectoryEmpty :: FilePath -> IO Bool-isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check+isDirectoryEmpty d = testDirectory d dirCruft++-- | True if the directory does not exist or contains nothing.+-- Ignores "lost+found" which can exist in an empty filesystem.+isUnpopulated :: FilePath -> IO Bool+isUnpopulated d = catchDefaultIO True $ testDirectory d fsCruft++-- | Run test on entries found in directory, return False as soon as the+-- test returns False, else return True.  Throws exception if directory does+-- not exist.+testDirectory :: FilePath -> (FilePath -> Bool) -> IO Bool+testDirectory d test = bracket (openDirectory d) closeDirectory check   where 	check h = do 		v <- readDirectory h 		case v of 			Nothing -> return True 			Just f-				| not (dirCruft f) -> return False+				| not (test f) -> return False 				| otherwise -> check h