propellor 2.7.3 → 2.8.0

raw patch · 52 files changed

+1017/−368 lines, 52 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +34/−1
• config-joey.hs +10/−5
• debian/changelog +34/−1
• debian/control +1/−1
• propellor.cabal +7/−3
• src/Propellor/CmdLine.hs +3/−0
• src/Propellor/Gpg.hs +56/−25
• src/Propellor/Info.hs +22/−21
• src/Propellor/Message.hs +1/−2
• src/Propellor/PrivData.hs +41/−24
• src/Propellor/PropAccum.hs +4/−13
• src/Propellor/Property.hs +1/−2
• src/Propellor/Property/Aiccu.hs +50/−0
• src/Propellor/Property/Apt.hs +17/−10
• src/Propellor/Property/Chroot.hs +4/−3
• src/Propellor/Property/ConfFile.hs +1/−2
• src/Propellor/Property/DebianMirror.hs +61/−0
• src/Propellor/Property/Debootstrap.hs +1/−1
• src/Propellor/Property/DiskImage.hs +59/−21
• src/Propellor/Property/Dns.hs +59/−53
• src/Propellor/Property/Docker.hs +12/−12
• src/Propellor/Property/File.hs +11/−3
• src/Propellor/Property/Gpg.hs +1/−1
• src/Propellor/Property/Reboot.hs +1/−1
• src/Propellor/Property/Rsync.hs +59/−0
• src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +20/−17
• src/Propellor/Property/SiteSpecific/IABak.hs +1/−1
• src/Propellor/Property/SiteSpecific/JoeySites.hs +3/−0
• src/Propellor/Property/Ssh.hs +38/−13
• src/Propellor/Property/Systemd.hs +3/−2
• src/Propellor/Property/Tor.hs +2/−2
• src/Propellor/Property/Unbound.hs +132/−0
• src/Propellor/Property/User.hs +2/−2
• src/Propellor/Shim.hs +1/−1
• src/Propellor/Spin.hs +5/−4
• src/Propellor/Types.hs +6/−49
• src/Propellor/Types/Chroot.hs +14/−6
• src/Propellor/Types/CmdLine.hs +1/−0
• src/Propellor/Types/Container.hs +2/−2
• src/Propellor/Types/Dns.hs +60/−2
• src/Propellor/Types/Docker.hs +12/−6
• src/Propellor/Types/Info.hs +67/−0
• src/Propellor/Types/OS.hs +4/−1
• src/Propellor/Types/PrivData.hs +26/−1
• src/Propellor/Types/Val.hs +0/−22
• src/Utility/Exception.hs +15/−6
• src/Utility/FileSystemEncoding.hs +17/−2
• src/Utility/Misc.hs +1/−1
• src/Utility/Process.hs +26/−20
• src/Utility/Scheduled.hs +1/−1
• src/Utility/Table.hs +1/−1
• src/wrapper.hs +7/−1

@@ -1,3 +1,35 @@+propellor (2.8.0) unstable; urgency=medium++  * Added Propellor.Property.Rsync.+  * Convert Info to use Data.Dynamic, so properties can export and consume+    info of any type that is Typeable and a Monoid, including data types+    private to a module. (API change)+    Thanks to Joachim Breitner for the idea.+  * Improve propellor wrapper to better handle installation cloning+    the public propellor repo, by setting that repo to be upstream,+    so propellor doesnt try to push to a read-only repo.+  * Added DebianMirror module, contributed by Félix Sipma.+  * Some hlint cleanups.+    Thanks, Mario Lang+  * Added Propellor.Property.Unbound for the caching DNS server.+    Thanks, Félix Sipma.+  * Added PTR to Dns.Record. While this is ignored by+    Propellor.Property.Dns for now, since reverse DNS setup is not+    implemented there yet, it can be used in other places, eg Unbound.+    Thanks, Félix Sipma.+  * PrivData converted to newtype (API change).+  * Stopped stripping trailing newlines when setting PrivData;+    this was previously done to avoid mistakes when pasting eg passwords+    with an unwanted newline. Instead, PrivData consumers should use either+    privDataLines or privDataVal, to extract respectively lines or a+    value (without internal newlines) from PrivData.+  * Allow storing arbitrary ByteStrings in PrivData, extracted using+    privDataByteString.+  * Added Aiccu module, contributed by Jelmer Vernooij.+  * Added --rm-key.++ -- Joey Hess <id@joeyh.name>  Tue, 22 Sep 2015 19:35:07 -0400+ propellor (2.7.3) unstable; urgency=medium    * Fix bug that caused provisioning new chroots to fail.@@ -67,7 +99,7 @@   * Add docker image related properties.     Thanks, Antoine Eiche.   * Export CommandParam, boolSystem, safeSystem, shellEscape, and-  * createProcess from Propellor.Property.Cmd, so they are available+    createProcess from Propellor.Property.Cmd, so they are available     for use in constricting your own Properties when using propellor     as a library.   * Improve enter-machine scripts for systemd-nspawn containers to unset most@@ -319,6 +351,7 @@   * Apache: Fix daemon reload when enabling a new module or site.   * Docker: Stop using docker.io; that was a compat symlink in     the Debian package which has been removed in docker.io 1.3.1~dfsg1-2.+    Closes: #769452   * Orphaned the Debian package, as I am retiring from Debian.   -- Joey Hess <joeyh@debian.org>  Sat, 08 Nov 2014 15:57:36 -0400

@@ -26,6 +26,7 @@ import qualified Propellor.Property.Systemd as Systemd import qualified Propellor.Property.Journald as Journald import qualified Propellor.Property.Chroot as Chroot+import qualified Propellor.Property.Aiccu as Aiccu import qualified Propellor.Property.OS as OS import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.HostingProvider.Linode as Linode@@ -73,7 +74,8 @@  darkstar :: Host darkstar = host "darkstar.kitenet.net"-	& ipv6 "2001:4830:1600:187::2" -- sixxs tunnel+	& ipv6 "2001:4830:1600:187::2"+	& Aiccu.hasConfig "T18376" "JHZ2-SIXXS"  	& Apt.buildDep ["git-annex"] `period` Daily @@ -83,7 +85,7 @@ 	& imageBuilt "/tmp/img" c MSDOS 		[ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag 		, partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100-		, swapPartition (MegaBytes 256)+		-- , swapPartition (MegaBytes 256) 		] noFinalization -- (grubBooted PC)   where 	c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d@@ -142,10 +144,13 @@  	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer 		GitAnnexBuilder.standardAutoBuilder-		(System (Debian Testing) "amd64") fifteenpast "2h")+		(System (Debian Unstable) "amd64") Nothing fifteenpast "2h") 	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer 		GitAnnexBuilder.standardAutoBuilder-		(System (Debian Testing) "i386") fifteenpast "2h")+		(System (Debian Unstable) "i386") Nothing fifteenpast "2h")+	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer+		GitAnnexBuilder.standardAutoBuilder+		(System (Debian (Stable "jessie")) "i386") (Just "ancient") fifteenpast "2h") 	& Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer 		(Cron.Times "1 1 * * *") "3h")   where@@ -177,7 +182,7 @@  	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer 		GitAnnexBuilder.armAutoBuilder-			(System (Debian Unstable) "armel") Cron.Daily "22h")+			(System (Debian Unstable) "armel") Nothing Cron.Daily "22h")  -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed

@@ -1,3 +1,35 @@+propellor (2.8.0) unstable; urgency=medium++  * Added Propellor.Property.Rsync.+  * Convert Info to use Data.Dynamic, so properties can export and consume+    info of any type that is Typeable and a Monoid, including data types+    private to a module. (API change)+    Thanks to Joachim Breitner for the idea.+  * Improve propellor wrapper to better handle installation cloning+    the public propellor repo, by setting that repo to be upstream,+    so propellor doesnt try to push to a read-only repo.+  * Added DebianMirror module, contributed by Félix Sipma.+  * Some hlint cleanups.+    Thanks, Mario Lang+  * Added Propellor.Property.Unbound for the caching DNS server.+    Thanks, Félix Sipma.+  * Added PTR to Dns.Record. While this is ignored by+    Propellor.Property.Dns for now, since reverse DNS setup is not+    implemented there yet, it can be used in other places, eg Unbound.+    Thanks, Félix Sipma.+  * PrivData converted to newtype (API change).+  * Stopped stripping trailing newlines when setting PrivData;+    this was previously done to avoid mistakes when pasting eg passwords+    with an unwanted newline. Instead, PrivData consumers should use either+    privDataLines or privDataVal, to extract respectively lines or a+    value (without internal newlines) from PrivData.+  * Allow storing arbitrary ByteStrings in PrivData, extracted using+    privDataByteString.+  * Added Aiccu module, contributed by Jelmer Vernooij.+  * Added --rm-key.++ -- Joey Hess <id@joeyh.name>  Tue, 22 Sep 2015 19:35:07 -0400+ propellor (2.7.3) unstable; urgency=medium    * Fix bug that caused provisioning new chroots to fail.@@ -67,7 +99,7 @@   * Add docker image related properties.     Thanks, Antoine Eiche.   * Export CommandParam, boolSystem, safeSystem, shellEscape, and-  * createProcess from Propellor.Property.Cmd, so they are available+    createProcess from Propellor.Property.Cmd, so they are available     for use in constricting your own Properties when using propellor     as a library.   * Improve enter-machine scripts for systemd-nspawn containers to unset most@@ -319,6 +351,7 @@   * Apache: Fix daemon reload when enabling a new module or site.   * Docker: Stop using docker.io; that was a compat symlink in     the Debian package which has been removed in docker.io 1.3.1~dfsg1-2.+    Closes: #769452   * Orphaned the Debian package, as I am retiring from Debian.   -- Joey Hess <joeyh@debian.org>  Sat, 08 Nov 2014 15:57:36 -0400

@@ -42,7 +42,7 @@ 	git, 	make, Description: property-based host configuration management in haskell- Propellor enures that the system it's run in satisfies a list of+ Propellor ensures that the system it's run in satisfies a list of  properties, taking action as necessary when a property is not yet met.  .  It is configured using haskell.

@@ -1,5 +1,5 @@ Name: propellor-Version: 2.7.3+Version: 2.8.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -27,7 +27,7 @@   debian/lintian-overrides Synopsis: property-based host configuration management in haskell Description:- Propellor enures that the system it's run in satisfies a list of+ Propellor ensures that the system it's run in satisfies a list of  properties, taking action as necessary when a property is not yet met.  .  It is configured using haskell.@@ -70,6 +70,7 @@   Exposed-Modules:     Propellor     Propellor.Property+    Propellor.Property.Aiccu     Propellor.Property.Apache     Propellor.Property.Apt     Propellor.Property.Cmd@@ -77,6 +78,7 @@     Propellor.Property.Chroot     Propellor.Property.ConfFile     Propellor.Property.Cron+    Propellor.Property.DebianMirror     Propellor.Property.Debootstrap     Propellor.Property.DiskImage     Propellor.Property.Dns@@ -100,6 +102,7 @@     Propellor.Property.Postfix     Propellor.Property.Prosody     Propellor.Property.Reboot+    Propellor.Property.Rsync     Propellor.Property.List     Propellor.Property.LightDM     Propellor.Property.Scheduled@@ -109,6 +112,7 @@     Propellor.Property.Systemd     Propellor.Property.Systemd.Core     Propellor.Property.Tor+    Propellor.Property.Unbound     Propellor.Property.User     Propellor.Property.HostingProvider.CloudAtCost     Propellor.Property.HostingProvider.DigitalOcean@@ -131,9 +135,9 @@     Propellor.Types.Docker     Propellor.Types.Dns     Propellor.Types.Empty+    Propellor.Types.Info     Propellor.Types.OS     Propellor.Types.PrivData-    Propellor.Types.Val     Propellor.Types.Result     Propellor.Types.CmdLine   Other-Modules:

@@ -26,6 +26,7 @@ 	, "  propellor hostname" 	, "  propellor --spin targethost [--via relayhost]" 	, "  propellor --add-key keyid"+	, "  propellor --rm-key keyid" 	, "  propellor --set field context" 	, "  propellor --dump field context" 	, "  propellor --edit field context"@@ -50,6 +51,7 @@ 			<*> pure (Just r) 		_ -> Spin <$> mapM hostname ps <*> pure Nothing 	go ("--add-key":k:[]) = return $ AddKey k+	go ("--rm-key":k:[]) = return $ RmKey k 	go ("--set":f:c:[]) = withprivfield f c Set 	go ("--unset":f:c:[]) = withprivfield f c Unset 	go ("--dump":f:c:[]) = withprivfield f c Dump@@ -100,6 +102,7 @@ 	go _ (Edit field context) = editPrivData field context 	go _ ListFields = listPrivDataFields hostlist 	go _ (AddKey keyid) = addKey keyid+	go _ (RmKey keyid) = rmKey keyid 	go _ c@(ChrootChain _ _ _ _) = Chroot.chain hostlist c 	go _ (DockerChain hn cid) = Docker.chain hostlist hn cid 	go _ (DockerInit hn) = Docker.init hn

@@ -14,6 +14,7 @@ import Utility.Monad import Utility.Misc import Utility.Tmp+import Utility.FileSystemEncoding  type KeyId = String @@ -40,10 +41,10 @@ addKey :: KeyId -> IO () addKey keyid = exitBool =<< allM (uncurry actionMessage) 	[ ("adding key to propellor's keyring", addkeyring)-	, ("staging propellor's keyring", gitadd keyring)-	, ("updating encryption of any privdata", reencryptprivdata)-	, ("configuring git signing to use key", gitconfig)-	, ("committing changes", gitcommit)+	, ("staging propellor's keyring", gitAdd keyring)+	, ("updating encryption of any privdata", reencryptPrivData)+	, ("configuring git commit signing to use key", gitconfig)+	, ("committing changes", gitCommitKeyRing "add-key") 	]   where 	addkeyring = do@@ -54,18 +55,6 @@ 				unwords (useKeyringOpts ++ ["--import"]) 			] -	reencryptprivdata = ifM (doesFileExist privDataFile)-		( do-			gpgEncrypt privDataFile =<< gpgDecrypt privDataFile-			gitadd privDataFile-		, return True-		)--	gitadd f = boolSystem "git"-		[ Param "add"-		, File f-		]- 	gitconfig = ifM (snd <$> processTranscript "gpg" ["--list-secret-keys", keyid] Nothing) 		( boolSystem "git" 			[ Param "config"@@ -77,12 +66,53 @@ 			return True 		) -	gitcommit = gitCommit-		[ File keyring-		, Param "-m"-		, Param "propellor addkey"+rmKey :: KeyId -> IO ()+rmKey keyid = exitBool =<< allM (uncurry actionMessage)+	[ ("removing key from propellor's keyring", rmkeyring)+	, ("staging propellor's keyring", gitAdd keyring)+	, ("updating encryption of any privdata", reencryptPrivData)+	, ("configuring git commit signing to not use key", gitconfig)+	, ("committing changes", gitCommitKeyRing "rm-key")+	]+  where+	rmkeyring = boolSystem "gpg" $+		(map Param useKeyringOpts) ++ +		[ Param "--batch"+		, Param "--yes"+		, Param "--delete-key", Param keyid 		]+	+	gitconfig = ifM ((==) (keyid++"\n", True) <$> processTranscript "git" ["config", "user.signingkey"] Nothing)+		( boolSystem "git"+			[ Param "config"+			, Param "--unset"+			, Param "user.signingkey"+			]+		, return True+		)	 +reencryptPrivData :: IO Bool+reencryptPrivData = ifM (doesFileExist privDataFile)+	( do+		gpgEncrypt privDataFile =<< gpgDecrypt privDataFile+		gitAdd privDataFile+	, return True+	)+	+gitAdd :: FilePath -> IO Bool+gitAdd f = boolSystem "git"+	[ Param "add"+	, File f+	]++gitCommitKeyRing :: String -> IO Bool+gitCommitKeyRing action = gitCommit+	[ File keyring+	, File privDataFile+	, Param "-m"+	, Param ("propellor " ++ action)+	]+ -- Adds --gpg-sign if there's a keyring. gpgSignParams :: [CommandParam] -> IO [CommandParam] gpgSignParams ps = ifM (doesFileExist keyring)@@ -98,7 +128,7 @@  gpgDecrypt :: FilePath -> IO String gpgDecrypt f = ifM (doesFileExist f)-	( readProcess "gpg" ["--decrypt", f]+	( writeReadProcessEnv "gpg" ["--decrypt", f] Nothing Nothing (Just fileEncoding) 	, return "" 	) @@ -112,8 +142,9 @@ 		, "--encrypt" 		, "--trust-model", "always" 		] ++ concatMap (\k -> ["--recipient", k]) keyids-	encrypted <- writeReadProcessEnv "gpg" opts-		Nothing-		(Just $ flip hPutStr s)-		Nothing+	encrypted <- writeReadProcessEnv "gpg" opts Nothing (Just writer) Nothing 	viaTmp writeFile f encrypted+  where+	writer h = do+		fileEncoding h+		hPutStr h s

@@ -3,7 +3,7 @@ module Propellor.Info where  import Propellor.Types-import Propellor.Types.Val+import Propellor.Types.Info  import "mtl" Control.Monad.Reader import qualified Data.Set as S@@ -12,23 +12,26 @@ import Data.Monoid import Control.Applicative -pureInfoProperty :: Desc -> Info -> Property HasInfo-pureInfoProperty desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty+pureInfoProperty :: (IsInfo v) => Desc -> v -> Property HasInfo+pureInfoProperty desc v = pureInfoProperty' desc (addInfo mempty v) -askInfo :: (Info -> Val a) -> Propellor (Maybe a)-askInfo f = asks (fromVal . f . hostInfo)+pureInfoProperty' :: Desc -> Info -> Property HasInfo+pureInfoProperty' desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty +-- | Gets a value from the host's Info.+askInfo :: (IsInfo v) => Propellor v+askInfo = asks (getInfo . hostInfo)+ -- | Specifies the operating system of a host. -- -- This only provides info for other Properties, so they can act--- conditional on the os.+-- conditionally on the os. os :: System -> Property HasInfo-os system = pureInfoProperty ("Operating " ++ show system) $-	mempty { _os = Val system }+os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system)  --  Gets the operating system of a host, if it has been specified. getOS :: Propellor (Maybe System)-getOS = askInfo _os+getOS = fromInfoVal <$> askInfo  -- | Indidate that a host has an A record in the DNS. --@@ -53,15 +56,14 @@ -- problems with CNAMEs, and also means that when multiple hosts have the -- same alias, a DNS round-robin is automatically set up. alias :: Domain -> Property HasInfo-alias d = pureInfoProperty ("alias " ++ d) $ mempty-	{ _aliases = S.singleton d+alias d = pureInfoProperty' ("alias " ++ d) $ mempty+	`addInfo` toAliasesInfo [d] 	-- A CNAME is added here, but the DNS setup code converts it to an 	-- IP address when that makes sense.-	, _dns = S.singleton $ CNAME $ AbsDomain d-	} +	`addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d)  addDNS :: Record -> Property HasInfo-addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r }+addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r))   where 	rdesc (CNAME d) = unwords ["alias", ddesc d] 	rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr]@@ -72,20 +74,21 @@ 	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 (INCLUDE f) = unwords ["$INCLUDE", f]+	rdesc (PTR x) = unwords ["PTR", x]  	ddesc (AbsDomain domain) = domain 	ddesc (RelDomain domain) = domain 	ddesc RootDomain = "@"  hostMap :: [Host] -> M.Map HostName Host-hostMap l = M.fromList $ zip (map hostName l) l +hostMap l = M.fromList $ zip (map hostName l) l  aliasMap :: [Host] -> M.Map HostName Host aliasMap = M.fromList . concat .-	map (\h -> map (\aka -> (aka, h)) $ S.toList $ _aliases $ hostInfo h)+	map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ getInfo $ hostInfo h)  findHost :: [Host] -> HostName -> Maybe Host-findHost l hn = maybe (findAlias l hn) Just (findHostNoAlias l hn)+findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn)  findHostNoAlias :: [Host] -> HostName -> Maybe Host findHostNoAlias l hn = M.lookup hn (hostMap l)@@ -94,9 +97,7 @@ findAlias l hn = M.lookup hn (aliasMap l)  getAddresses :: Info -> [IPAddr]-getAddresses = mapMaybe getIPAddr . S.toList . _dns+getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo  hostAddresses :: HostName -> [Host] -> [IPAddr]-hostAddresses hn hosts = case hostInfo <$> findHost hosts hn of-	Nothing -> []-	Just info -> mapMaybe getIPAddr $ S.toList $ _dns info+hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn)

@@ -112,8 +112,7 @@ 	go (Just "1") = enableDebugMode 	go (Just _) = noop 	go Nothing = whenM (doesDirectoryExist ".git") $-		whenM (any (== "1") . lines <$> getgitconfig) $-			enableDebugMode+		whenM (elem "1" . lines <$> getgitconfig) enableDebugMode 	getgitconfig = catchDefaultIO "" $ 		readProcess "git" ["config", "propellor.debug"] 

@@ -1,5 +1,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Propellor.PrivData ( 	withPrivData,@@ -14,6 +16,7 @@ 	makePrivDataDir, 	decryptPrivData, 	PrivMap,+	PrivInfo, ) where  import Control.Applicative@@ -22,14 +25,17 @@ import Data.Maybe import Data.Monoid import Data.List+import Data.Typeable import Control.Monad import Control.Monad.IfElse import "mtl" Control.Monad.Reader import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.ByteString.Lazy as L  import Propellor.Types import Propellor.Types.PrivData+import Propellor.Types.Info import Propellor.Message import Propellor.Info import Propellor.Gpg@@ -43,6 +49,7 @@ import Utility.FileMode import Utility.Env import Utility.Table+import Utility.FileSystemEncoding  -- | Allows a Property to access the value of a specific PrivDataField, -- for use in a specific Context or HostContext.@@ -51,7 +58,7 @@ -- -- > withPrivData (PrivFile pemfile) (Context "joeyh.name") $ \getdata -> -- >     property "joeyh.name ssl cert" $ getdata $ \privdata ->--- >       liftIO $ writeFile pemfile privdata+-- >       liftIO $ writeFile pemfile (privDataVal privdata) -- >   where pemfile = "/etc/ssl/certs/web.pem" --  -- Note that if the value is not available, the action is not run@@ -102,9 +109,10 @@ 	addinfo p = infoProperty 		(propertyDesc p) 		(propertySatisfy p)-		(propertyInfo p <> mempty { _privData = privset })+		(propertyInfo p `addInfo` privset) 		(propertyChildren p)-	privset = S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist+	privset = PrivInfo $ S.fromList $+		map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist 	fieldnames = map show fieldlist 	fieldlist = map privDataField srclist 	hc = asHostContext c@@ -116,8 +124,7 @@ 	putStrLn ""  addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo-addPrivData v = pureInfoProperty (show v) $-	mempty { _privData = S.singleton v }+addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v))  {- Gets the requested field's value, in the specified context if it's  - available, from the host's local privdata cache. -}@@ -127,22 +134,25 @@   where 	localcache = catchDefaultIO Nothing $ readish <$> readFile privDataLocal -type PrivMap = M.Map (PrivDataField, Context) PrivData+type PrivMap = M.Map (PrivDataField, Context) String  -- | Get only the set of PrivData that the Host's Info says it uses. filterPrivData :: Host -> PrivMap -> PrivMap filterPrivData host = M.filterWithKey (\k _v -> S.member k used)   where 	used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $-		_privData $ hostInfo host+		fromPrivInfo $ getInfo $ hostInfo host  getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData-getPrivData field context = M.lookup (field, context)+getPrivData field context m = do+	s <- M.lookup (field, context) m+	return (PrivData s)  setPrivData :: PrivDataField -> Context -> IO () setPrivData field context = do 	putStrLn "Enter private data on stdin; ctrl-D when done:"-	setPrivDataTo field context =<< hGetContentsStrict stdin+	fileEncoding stdin+	setPrivDataTo field context . PrivData =<< hGetContentsStrict stdin  unsetPrivData :: PrivDataField -> Context -> IO () unsetPrivData field context = do@@ -150,20 +160,21 @@ 	putStrLn "Private data unset."  dumpPrivData :: PrivDataField -> Context -> IO ()-dumpPrivData field context =-	maybe (error "Requested privdata is not set.") putStrLn+dumpPrivData field context = do+	maybe (error "Requested privdata is not set.")+		(L.hPut stdout . privDataByteString) 		=<< (getPrivData field context <$> decryptPrivData)  editPrivData :: PrivDataField -> Context -> IO () editPrivData field context = do 	v <- getPrivData field context <$> decryptPrivData-	v' <- withTmpFile "propellorXXXX" $ \f h -> do-		hClose h-		maybe noop (writeFileProtected f) v+	v' <- withTmpFile "propellorXXXX" $ \f th -> do+		hClose th+		maybe noop (\p -> writeFileProtected' f (`L.hPut` privDataByteString p)) v 		editor <- getEnvDefault "EDITOR" "vi" 		unlessM (boolSystem editor [File f]) $ 			error "Editor failed; aborting."-		readFile f+		PrivData <$> readFile f 	setPrivDataTo field context v'  listPrivDataFields :: [Host] -> IO ()@@ -182,29 +193,26 @@ 		showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing   where 	header = ["Field", "Context", "Used by"]-	mkrow k@(field, (Context context)) =+	mkrow k@(field, Context context) = 		[ shellEscape $ show field 		, shellEscape context 		, intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby 		] 	mkhostmap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) $-		S.toList $ _privData $ hostInfo host-	usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const $ [hostName h]) hosts+		S.toList $ fromPrivInfo $ getInfo $ hostInfo host+	usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const [hostName h]) hosts 	wantedmap = M.fromList $ zip (M.keys usedby) (repeat "")-	descmap = M.unions $ map (\h -> mkhostmap h id) hosts+	descmap = M.unions $ map (`mkhostmap` id) hosts 	section desc = putStrLn $ "\n" ++ desc 	showtable rows = do 		putStr $ unlines $ formatTable $ tableWithHeader header rows  setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()-setPrivDataTo field context value = do+setPrivDataTo field context (PrivData value) = do 	modifyPrivData set 	putStrLn "Private data set."   where-	set = M.insert (field, context) (chomp value)-	chomp s-		| end s == "\n" = chomp (beginning s)-		| otherwise = s+	set = M.insert (field, context) value  modifyPrivData :: (PrivMap -> PrivMap) -> IO () modifyPrivData f = do@@ -219,3 +227,12 @@  makePrivDataDir :: IO () makePrivDataDir = createDirectoryIfMissing False privDataDir++newtype PrivInfo = PrivInfo+	{ fromPrivInfo :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext) }+	deriving (Eq, Ord, Show, Typeable, Monoid)++-- PrivInfo is propigated out of containers, so that propellor can see which+-- hosts need it.+instance IsInfo PrivInfo where+	propigateInfo _ = True

@@ -13,6 +13,7 @@  import Propellor.Types import Propellor.Property+import Propellor.Types.Info  -- | Starts accumulating the properties of a Host. --@@ -47,7 +48,7 @@ instance PropAccum Host where 	(Host hn ps is) &  p = Host hn (ps ++ [toProp p]) 		(is <> getInfoRecursive p)-	(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps)+	(Host hn ps is) &^ p = Host hn (toProp p : ps) 		(getInfoRecursive p <> is) 	getProperties = hostProperties @@ -71,12 +72,6 @@ --  -- The Info of the propertyChildren is adjusted to only include  -- info that should be propigated out to the Property.------ DNS Info is propigated, so that eg, aliases of a PropAccum--- are reflected in the dns for the host where it runs.------ PrivData Info is propigated, so that properties used inside a--- PropAccum will have the necessary PrivData available. propigateContainer 	:: (PropAccum container) 	=> container@@ -90,10 +85,6 @@   where 	hostprops = map go $ getProperties c 	go p = -		let i = propertyInfo p-		    i' = mempty-			{ _dns = _dns i-			, _privData = _privData i-			}+		let i = propigatableInfo (propertyInfo p) 		    cs = map go (propertyChildren p)-		in infoProperty (propertyDesc p) (propertySatisfy p) i' cs+		in infoProperty (propertyDesc p) (propertySatisfy p) i cs

@@ -67,8 +67,7 @@         -> Property x         -> Property y         -> CombinedType (Property x) (Property y)-onChangeFlagOnFail flagfile p1 p2 =-	combineWith go p1 p2+onChangeFlagOnFail flagfile = combineWith go   where 	go s1 s2 = do 		r1 <- s1

@@ -0,0 +1,50 @@+module Propellor.Property.Aiccu (+	installed,+	restarted,+	confPath,+	UserName,+	TunnelId,+	hasConfig,+) where++import Propellor+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service+import qualified Propellor.Property.File as File++installed :: Property NoInfo+installed = Apt.installed ["aiccu"]++restarted :: Property NoInfo+restarted = Service.restarted "aiccu"++confPath :: FilePath+confPath = "/etc/aiccu.conf"++type TunnelId = String++config :: UserName -> TunnelId -> PrivData -> [File.Line]+config u t p = +	[ "protocol tic"+	, "server tic.sixxs.net"+	, "username " ++ u+	, "password " ++ privDataVal p+	, "ipv6_interface sixxs"+	, "tunnel_id " ++ t+	, "daemonize true"+	, "automatic true"+	, "requiretls true"+	, "makebeats true"+	]++-- | Configures an ipv6 tunnel using sixxs.net, with the given TunneId+-- and sixx.net UserName.+hasConfig :: TunnelId -> UserName -> Property HasInfo+hasConfig t u = prop  `onChange` restarted+  where+	prop = withSomePrivData [(Password (u++"/"++t)), (Password u)] (Context "aiccu") $+		property "aiccu configured" . writeConfig+	writeConfig :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result+	writeConfig getpassword = getpassword $ ensureProperty . go+	go (Password _, p) = confPath `File.hasContentProtected` config u t p+	go (f, _) = error $ "Unexpected type of privdata: " ++ show f

@@ -80,7 +80,7 @@ -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org. stdSourcesList :: Property NoInfo-stdSourcesList = withOS ("standard sources.list") $ \o ->+stdSourcesList = withOS "standard sources.list" $ \o -> 	case o of 		(Just (System (Debian suite) _)) -> 			ensureProperty $ stdSourcesListFor suite@@ -187,7 +187,7 @@ isInstallable :: [Package] -> IO Bool isInstallable ps = do 	l <- isInstalled' ps-	return $ any (== False) l && not (null l)+	return $ elem False l && not (null l)  isInstalled :: Package -> IO Bool isInstalled p = (== [True]) <$> isInstalled' [p]@@ -197,7 +197,7 @@ -- even vary. If apt does not know about a package at all, it will not -- be included in the result list. isInstalled' :: [Package] -> IO [Bool]-isInstalled' ps = catMaybes . map parse . lines <$> policy+isInstalled' ps = (mapMaybe parse . lines) <$> policy   where 	parse l 		| "Installed: (none)" `isInfixOf` l = Just False@@ -239,18 +239,25 @@ 					("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") 			_ -> noChange +type DebconfTemplate = String+type DebconfTemplateType = String+type DebconfTemplateValue = String+ -- | Preseeds debconf values and reconfigures the package so it takes -- effect.-reConfigure :: Package -> [(String, String, String)] -> Property NoInfo+reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property NoInfo reConfigure package vals = reconfigure `requires` setselections 	`describe` ("reconfigure " ++ package)   where-	setselections = property "preseed" $ makeChange $-		withHandle StdinHandle createProcessSuccess-			(proc "debconf-set-selections" []) $ \h -> do-				forM_ vals $ \(tmpl, tmpltype, value) ->-					hPutStrLn h $ unwords [package, tmpl, tmpltype, value]-				hClose h+	setselections = property "preseed" $ +		if null vals +			then noChange+			else makeChange $+				withHandle StdinHandle createProcessSuccess+					(proc "debconf-set-selections" []) $ \h -> do+						forM_ vals $ \(tmpl, tmpltype, value) ->+							hPutStrLn h $ unwords [package, tmpl, tmpltype, value]+						hClose h 	reconfigure = cmdPropertyEnv "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv  -- | Ensures that a service is installed and running.

@@ -15,6 +15,7 @@ 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 @@ 		(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 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

@@ -38,8 +38,7 @@ 	-> InsertSection 	-> FilePath 	-> Property NoInfo-adjustSection desc start past adjust insert f =-	fileProperty desc go f+adjustSection desc start past adjust insert = fileProperty desc go   where 	go ls = let (pre, wanted, post) = foldl' find ([], [], []) ls 		in if null wanted

@@ -0,0 +1,61 @@+module Propellor.Property.DebianMirror+	( DebianPriority(..)+	, showPriority+	, mirror+	, mirrorCdn+	) where++import Propellor+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Cron as Cron+import qualified Propellor.Property.User as User++import Data.List+++data DebianPriority = Essential | Required | Important | Standard | Optional | Extra+	deriving (Show, Eq)++showPriority :: DebianPriority -> String+showPriority Essential = "essential"+showPriority Required  = "required"+showPriority Important = "important"+showPriority Standard  = "standard"+showPriority Optional  = "optional"+showPriority Extra     = "extra"++mirror :: Apt.Url -> FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo+mirror url dir suites archs sections source priorities crontimes = propertyList+	("Debian mirror " ++ dir)+	[ Apt.installed ["debmirror"]+	, User.accountFor (User "debmirror")+	, File.dirExists dir+	, File.ownerGroup dir (User "debmirror") (Group "debmirror")+	, check (not . and <$> mapM suitemirrored suites) $ cmdProperty "debmirror" args+		`describe` "debmirror setup"+	, Cron.niceJob ("debmirror_" ++ dir) crontimes (User "debmirror") "/" $+		unwords ("/usr/bin/debmirror" : args)+	]+  where+	suitemirrored suite = doesDirectoryExist $ dir </> "dists" </> Apt.showSuite suite+	architecturearg = intercalate ","+	suitearg = intercalate "," $ map Apt.showSuite suites+	priorityRegex pp = "(" ++ intercalate "|" (map showPriority pp) ++ ")"+	args =+		[ "--dist" , suitearg+		, "--arch", architecturearg archs+		, "--section", intercalate "," sections+		, "--limit-priority", "\"" ++ priorityRegex priorities ++ "\""+		]+		+++		(if source then [] else ["--nosource"])+		+++		[ "--host", url+		, "--method", "http"+		, "--keyring", "/usr/share/keyrings/debian-archive-keyring.gpg"+		, dir+		]++mirrorCdn :: FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo+mirrorCdn = mirror "http://httpredir.debian.org/debian"

@@ -158,7 +158,7 @@ 	let indexfile = tmpd </> "index.html" 	unlessM (download baseurl indexfile) $ 		errorMessage $ "Failed to download " ++ baseurl-	urls <- reverse . sort -- highest version first+	urls <- sortBy (flip compare) -- highest version first 		. filter ("debootstrap_" `isInfixOf`) 		. filter (".tar." `isInfixOf`) 		. extractUrls baseurl <$>

@@ -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.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 @@ -- > 		& 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,51 @@ -- | 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 $ 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)+		(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,23 +194,19 @@ 			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+	childsz = mconcat $ mapMaybe (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). toSysDir :: FilePath -> FilePath -> FilePath@@ -191,11 +220,19 @@ 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@@ -235,7 +272,7 @@ extended s = adjustp s $ \p -> p { partType = Extended }  adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec-adjustp (mp, p) f = (mp, \sz -> f (p sz))+adjustp (mp, p) f = (mp, f . p)  -- | The constructor for each Partition is passed the size of the files -- from the chroot that will be put in that partition.@@ -243,7 +280,7 @@ fitChrootSize tt l basesizes = (mounts, parttable)   where 	(mounts, sizers) = unzip l-	parttable = PartTable tt (map (uncurry id) (zip sizers basesizes))+	parttable = PartTable tt (zipWith id sizers basesizes)  -- | A pair of properties. The first property is satisfied within the -- chroot, and is typically used to download the boot loader.@@ -253,6 +290,7 @@ type Finalization = (Property NoInfo, Property NoInfo)  -- | Makes grub be the boot loader of the disk image.+-- TODO not implemented grubBooted :: Grub.BIOS -> Finalization grubBooted bios = (Grub.installed bios, undefined) 

@@ -15,6 +15,7 @@  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@@ -27,8 +28,10 @@ import qualified Data.Set as S import Data.List --- | Primary dns server for a domain.+-- | Primary dns server for a domain, using bind. --+-- Currently, this only configures bind to serve forward DNS, not reverse DNS.+-- -- Most of the content of the zone file is configured by setting properties -- of hosts. For example, --@@ -68,17 +71,17 @@ 	zonefile = "/etc/bind/propellor/db." ++ domain  setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo-setupPrimary zonefile mknamedconffile hosts domain soa rs = +setupPrimary zonefile mknamedconffile hosts domain soa rs = 	withwarnings baseprop 		`requires` servingZones   where 	hostmap = hostMap hosts 	-- Known hosts with hostname located in the domain. 	indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap-	+ 	(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@@ -96,7 +99,7 @@ 		, confFile = mknamedconffile zonefile 		, confMasters = [] 		, confAllowTransfer = nub $-			concatMap (\h -> hostAddresses h hosts) $+			concatMap (`hostAddresses` hosts) $ 				secondaries ++ nssecondaries 		, confLines = [] 		}@@ -152,18 +155,18 @@ signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty signedPrimary recurrance hosts domain soa rs = setup <!> cleanup   where-	setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") +	setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") 		(props 			& setupPrimary zonefile signedZoneFile hosts domain soa rs' 			& zoneSigned domain zonefile 			& forceZoneSigned domain zonefile `period` recurrance 		) 		`onChange` Service.reloaded "bind9"-	+ 	cleanup = cleanupPrimary zonefile domain 		`onChange` toProp (revert (zoneSigned domain zonefile)) 		`onChange` Service.reloaded "bind9"-	+ 	-- Include the public keys into the zone file. 	rs' = include PubKSK : include PubZSK : rs 	include k = (RootDomain, INCLUDE (keyFn domain k))@@ -198,7 +201,7 @@ 		{ confDomain = domain 		, confDnsServerType = Secondary 		, confFile = "db." ++ domain-		, confMasters = concatMap (\m -> hostAddresses m hosts) masters+		, confMasters = concatMap (`hostAddresses` hosts) masters 		, confAllowTransfer = [] 		, confLines = [] 		}@@ -207,7 +210,7 @@ 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@@ -242,7 +245,7 @@ 	]   where 	cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"-	ipblock name l = +	ipblock name l = 		[ "\t" ++ name ++ " {" ] ++ 		(map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++ 		[ "\t};" ]@@ -285,38 +288,40 @@ dValue (AbsDomain d) = d ++ "." dValue (RootDomain) = "@" -rField :: Record -> String-rField (Address (IPv4 _)) = "A"-rField (Address (IPv6 _)) = "AAAA"-rField (CNAME _) = "CNAME"-rField (MX _ _) = "MX"-rField (NS _) = "NS"-rField (TXT _) = "TXT"-rField (SRV _ _ _ _) = "SRV"-rField (SSHFP _ _ _) = "SSHFP"-rField (INCLUDE _) = "$INCLUDE"+rField :: Record -> Maybe String+rField (Address (IPv4 _)) = Just "A"+rField (Address (IPv6 _)) = Just "AAAA"+rField (CNAME _) = Just "CNAME"+rField (MX _ _) = Just "MX"+rField (NS _) = Just "NS"+rField (TXT _) = Just "TXT"+rField (SRV _ _ _ _) = Just "SRV"+rField (SSHFP _ _ _) = Just "SSHFP"+rField (INCLUDE _) = Just "$INCLUDE"+rField (PTR _) = Nothing -rValue :: Record -> String-rValue (Address (IPv4 addr)) = addr-rValue (Address (IPv6 addr)) = addr-rValue (CNAME d) = dValue d-rValue (MX pri d) = show pri ++ " " ++ dValue d-rValue (NS d) = dValue d-rValue (SRV priority weight port target) = unwords+rValue :: Record -> Maybe String+rValue (Address (IPv4 addr)) = Just addr+rValue (Address (IPv6 addr)) = Just addr+rValue (CNAME d) = Just $ dValue d+rValue (MX pri d) = Just $ show pri ++ " " ++ dValue d+rValue (NS d) = Just $ dValue d+rValue (SRV priority weight port target) = Just $ unwords 	[ show priority 	, show weight 	, show port 	, dValue target 	]-rValue (SSHFP x y s) = unwords+rValue (SSHFP x y s) = Just $ unwords 	[ show x 	, show y 	, s 	]-rValue (INCLUDE f) = f-rValue (TXT s) = [q] ++ filter (/= q) s ++ [q]+rValue (INCLUDE f) = Just f+rValue (TXT s) = Just $ [q] ++ filter (/= q) s ++ [q]   where 	q = '"'+rValue (PTR _) = Nothing  -- | Adjusts the serial number of the zone to always be larger -- than the serial number in the Zone record,@@ -374,27 +379,28 @@ -- | Generating a zone file. genZoneFile :: Zone -> String genZoneFile (Zone zdomain soa rs) = unlines $-	header : genSOA soa ++ map (genRecord zdomain) rs+	header : genSOA soa ++ mapMaybe (genRecord zdomain) rs   where 	header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit." -genRecord :: Domain -> (BindDomain, Record) -> String-genRecord _ (_, record@(INCLUDE _)) = intercalate "\t"-		[ rField record-		, rValue record-		]-genRecord zdomain (domain, record) = intercalate "\t"-		[ domainHost zdomain domain-		, "IN"-		, rField record-		, rValue record-		]+genRecord :: Domain -> (BindDomain, Record) -> Maybe String+genRecord zdomain (domain, record) = case (rField record, rValue record) of+	(Nothing, _) -> Nothing+	(_, Nothing) -> Nothing+	(Just rfield, Just rvalue) -> Just $ intercalate "\t" $ case record of+		INCLUDE _ -> [ rfield, rvalue ]+		_ ->+			[ domainHost zdomain domain+			, "IN"+			, rfield+			, rvalue+			]  genSOA :: SOA -> [String]-genSOA soa = +genSOA soa = 	-- "@ IN SOA ns1.example.com. root (" 	[ intercalate "\t"-		[ dValue RootDomain +		[ dValue RootDomain 		, "IN" 		, "SOA" 		, dValue (sDomain soa)@@ -424,7 +430,7 @@ -- Does not include SSHFP records. genZone :: [Host] -> M.Map HostName Host -> Domain -> SOA -> (Zone, [WarningMessage]) genZone inzdomain hostmap zdomain soa =-	let (warnings, zhosts) = partitionEithers $ concat $ map concat+	let (warnings, zhosts) = partitionEithers $ concatMap concat 		[ map hostips inzdomain 		, map hostrecords inzdomain 		, map addcnames (M.elems hostmap)@@ -459,7 +465,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 (_dns info)+		mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info 	  where 		info = hostInfo h 		gen c = case getAddresses info of@@ -467,14 +473,14 @@ 			l -> map (ret . Address) l 		  where 			ret record = Right (c, record)-	+ 	-- Adds any other DNS records for a host located in the zdomain. 	hostrecords :: Host -> [Either WarningMessage (BindDomain, Record)] 	hostrecords h = map Right l 	  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 +509,13 @@   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 +528,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 $ _dns info+	cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info 	hostname = hostName h 	info = hostInfo h 

@@ -49,6 +49,7 @@ 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@@ -74,7 +75,7 @@   where 	prop = withPrivData src anyContext $ \getcfg -> 		property "docker configured" $ getcfg $ \cfg -> ensureProperty $ -			"/root/.dockercfg" `File.hasContent` (lines cfg)+			"/root/.dockercfg" `File.hasContent` privDataLines cfg 	src = PrivDataSourceFileFromCommand DockerAuthentication 		"/root/.dockercfg" "docker login" @@ -186,7 +187,7 @@   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.@@ -212,7 +213,7 @@   where 	gccontainers = property "docker containers garbage collected" $ 		liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)-	gcimages = property "docker images garbage collected" $ do+	gcimages = property "docker images garbage collected" $ 		liftIO $ report <$> (mapM removeImage =<< listImages)  -- | Tweaks a container to work well with docker.@@ -470,8 +471,7 @@  	restartcontainer = do 		oldimage <- liftIO $-			fromMaybe (toImageID image) . fmap toImageID <$>-				commitContainer cid+			maybe (toImageID image) toImageID <$> commitContainer cid 		void $ liftIO $ removeContainer cid 		go oldimage @@ -572,7 +572,7 @@ 	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@@ -630,8 +630,8 @@ -- | Only lists propellor managed containers. listContainers :: ContainerFilter -> IO [ContainerId] listContainers status = -	catMaybes . map toContainerId . concat . map (split ",")-		. catMaybes . map (lastMaybe . words) . lines+	mapMaybe toContainerId . concatMap (split ",")+		. mapMaybe (lastMaybe . words) . lines 		<$> readProcess dockercmd ps   where 	ps@@ -643,17 +643,17 @@ 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

@@ -10,9 +10,17 @@  -- | Replaces all the content of a file. hasContent :: FilePath -> [Line] -> Property NoInfo-f `hasContent` newcontent = fileProperty ("replace " ++ f)+f `hasContent` newcontent = fileProperty+	("replace " ++ f) 	(\_oldcontent -> newcontent) f +-- | Replaces all the content of a file, ensuring that its modes do not+-- allow it to be read or written by anyone other than the current user+hasContentProtected :: FilePath -> [Line] -> Property NoInfo+f `hasContentProtected` newcontent = fileProperty' writeFileProtected +	("replace " ++ f)+	(\_oldcontent -> newcontent) f+ -- | Ensures a file has contents that comes from PrivData. -- -- The file's permissions are preserved if the file already existed.@@ -40,7 +48,7 @@ 	withPrivData source context $ \getcontent ->  		property desc $ getcontent $ \privcontent ->  			ensureProperty $ fileProperty' writer desc-				(\_oldcontent -> lines privcontent) f+				(\_oldcontent -> privDataLines privcontent) f   where 	desc = "privcontent " ++ f @@ -103,5 +111,5 @@ -- | Ensures that a file/dir has the specfied mode. mode :: FilePath -> FileMode -> Property NoInfo mode f v = property (f ++ " mode " ++ show v) $ do-	liftIO $ modifyFileMode f (\_old -> v)+	liftIO $ modifyFileMode f (const v) 	noChange

@@ -33,7 +33,7 @@ 			withHandle StdinHandle createProcessSuccess 				(proc "su" ["-c", "gpg --import", u]) $ \h -> do 					fileEncoding h-					hPutStr h key+					hPutStr h (unlines (privDataLines key)) 					hClose h 	src = PrivDataSource GpgKey "Either a gpg public key, exported with gpg --export -a, or a gpg private key, exported with gpg --export-secret-key -a" 

@@ -8,7 +8,7 @@  -- | 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

@@ -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"]

@@ -39,14 +39,15 @@ 	-- password used to upload the built image. 	rsyncpassword = withPrivData (Password builduser) context $ \getpw -> 		property "rsync password" $ getpw $ \pw -> do-			oldpw <- liftIO $ catchDefaultIO "" $+			have <- liftIO $ catchDefaultIO "" $ 				readFileStrict pwfile-			if pw /= oldpw-				then makeChange $ writeFile pwfile pw+			let want = privDataVal pw+			if want /= have+				then makeChange $ writeFile pwfile want 				else noChange -tree :: Architecture -> Property HasInfo-tree buildarch = combineProperties "gitannexbuilder tree" $ props+tree :: Architecture -> Flavor -> Property HasInfo+tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props 	& Apt.installed ["git"] 	& File.dirExists gitbuilderdir 	& File.ownerGroup gitbuilderdir (User builduser) (Group builduser)@@ -57,7 +58,7 @@ 		userScriptProperty (User builduser) 			[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir 			, "cd " ++ gitbuilderdir-			, "git checkout " ++ buildarch+			, "git checkout " ++ buildarch ++ fromMaybe "" flavor 			] 			`describe` "gitbuilder setup" 	builddircloned = check (not <$> doesDirectoryExist builddir) $ userScriptProperty (User builduser)@@ -96,29 +97,31 @@ 		go = userScriptProperty (User builduser) ["cabal update && cabal install git-annex --only-dependencies || true"] 		cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache" -autoBuilderContainer :: (System -> Property HasInfo) -> System -> Times -> TimeOut -> Systemd.Container-autoBuilderContainer mkprop osver@(System _ arch) crontime timeout =+autoBuilderContainer :: (System -> Flavor -> Property HasInfo) -> System -> Flavor -> Times -> TimeOut -> Systemd.Container+autoBuilderContainer mkprop osver@(System _ arch) flavor crontime timeout = 	Systemd.container name bootstrap-		& mkprop osver+		& mkprop osver flavor 		& buildDepsApt 		& autobuilder arch crontime timeout   where-	name = arch ++ "-git-annex-builder"+	name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder" 	bootstrap = Chroot.debootstrapped osver mempty -standardAutoBuilder :: System -> Property HasInfo-standardAutoBuilder osver@(System _ arch) =+type Flavor = Maybe String++standardAutoBuilder :: System -> Flavor -> Property HasInfo+standardAutoBuilder osver@(System _ arch) flavor = 	propertyList "standard git-annex autobuilder" $ props 		& os osver 		& Apt.stdSourcesList 		& Apt.unattendedUpgrades 		& User.accountFor (User builduser)-		& tree arch+		& tree arch flavor -armAutoBuilder :: System -> Property HasInfo-armAutoBuilder osver = +armAutoBuilder :: System -> Flavor -> Property HasInfo+armAutoBuilder osver flavor =  	propertyList "arm git-annex autobuilder" $ props-		& standardAutoBuilder osver+		& standardAutoBuilder osver flavor 		& buildDepsNoHaskellLibs 		-- Works around ghc crash with parallel builds on arm. 		& (homedir </> ".cabal" </> "config")@@ -129,7 +132,7 @@  androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container androidAutoBuilderContainer crontimes timeout =-	androidContainer "android-git-annex-builder" (tree "android") builddir+	androidContainer "android-git-annex-builder" (tree "android" Nothing) builddir 		& Apt.unattendedUpgrades 		& buildDepsNoHaskellLibs 		& autobuilder "android" crontimes timeout

@@ -103,4 +103,4 @@ 	graphiteCSRF = withPrivData (Password "csrf-token") (Context "iabak.archiveteam.org") $ 		\gettoken -> property "graphite-web CSRF token" $ 			gettoken $ \token -> ensureProperty $ File.containsLine-				"/etc/graphite/local_settings.py" ("SECRET_KEY = '"++ token ++"'")+				"/etc/graphite/local_settings.py" ("SECRET_KEY = '"++ privDataVal token ++"'")

@@ -520,6 +520,9 @@ 		`onChange` Service.restarted "amavisd-milter" 		`describe` "amavisd-milter configured for postfix" 	& Apt.serviceInstalledRunning "clamav-freshclam"+	-- Workaround https://bugs.debian.org/569150+	& Cron.niceJob "amavis-expire" Cron.Daily (User "root") "/"+		"find /var/lib/amavis/virusmails/ -type f -ctime +7 -delete"  	& dkimInstalled 

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveDataTypeable #-}+ module Propellor.Property.Ssh ( 	PubKeyText, 	sshdConfig,@@ -27,6 +29,7 @@ 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@@ -119,7 +122,7 @@ -- -- The corresponding private keys come from the privdata. ----- Any host keysthat are not in the list are removed from the host.+-- Any host keys that are not in the list are removed from the host. hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo hostKeys ctx l = propertyList desc $ catMaybes $ 	map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup]@@ -144,22 +147,29 @@ hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo hostKey context keytype pub = combineProperties desc 	[ pubKey keytype pub-	, toProp $ property desc $ install writeFile True pub+	, toProp $ property desc $ install writeFile True (lines pub) 	, withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->-		property desc $ getkey $ install writeFileProtected False+		property desc $ getkey $+			install writeFileProtected False . privDataLines 	] 	`onChange` restarted   where 	desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")"-	install writer ispub key = do+	install writer ispub keylines = do 		let f = keyFile keytype ispub-		s <- liftIO $ catchDefaultIO "" $ readFileStrict f-		if s == key+		have <- liftIO $ catchDefaultIO "" $ readFileStrict f+		let want = keyFileContent keylines+		if have == want 			then noChange-			else makeChange $ writer f key+			else makeChange $ writer f want 	keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext) 		("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey") +-- Make sure that there is a newline at the end;+-- ssh requires this for some types of private keys.+keyFileContent :: [String] -> String+keyFileContent keylines = unlines (keylines ++ [""])+ keyFile :: SshKeyType -> Bool -> FilePath keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext   where@@ -169,12 +179,25 @@ -- 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 = pureInfoProperty "ssh pubkey known" . SshPubKeyInfo . M.singleton t -getPubKey :: Propellor (M.Map SshKeyType String)-getPubKey = asks (_sshPubKey . hostInfo)+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++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. --@@ -205,7 +228,7 @@ 			, ensureProperties 				[ property desc $ makeChange $ do 					createDirectoryIfMissing True (takeDirectory f)-					writer f key+					writer f (keyFileContent (privDataLines key)) 				, File.ownerGroup f user (userGroup user) 				, File.ownerGroup (takeDirectory f) user (userGroup user) 				]@@ -216,6 +239,8 @@ 			return $ home </> ".ssh" </> "id_" ++ fromKeyType keytype ++ ext 		Just f -> return $ f ++ ext ++ fromKeyType :: SshKeyType -> String fromKeyType SshRsa = "rsa" fromKeyType SshDsa = "dsa"@@ -251,7 +276,7 @@ 		f <- liftIO $ dotFile "authorized_keys" user 		liftIO $ do 			createDirectoryIfMissing True (takeDirectory f)-			writeFileProtected f v+			writeFileProtected f (keyFileContent (privDataLines v)) 		ensureProperties  			[ File.ownerGroup f user (userGroup user) 			, File.ownerGroup (takeDirectory f) user (userGroup user)

@@ -43,6 +43,7 @@ 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 @@   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 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

@@ -134,12 +134,12 @@ 	desc = unwords ["hidden service data available in", varLib </> hn] 	installonion f = withPrivData (PrivFile $ varLib </> hn </> f) context $ \getcontent -> 		property desc $ getcontent $ install $ varLib </> hn </> f-	install f content = ifM (liftIO $ doesFileExist f)+	install f privcontent = ifM (liftIO $ doesFileExist f) 		( noChange 		, ensureProperties 			[ property desc $ makeChange $ do 				createDirectoryIfMissing True (takeDirectory f)-				writeFileProtected f content+				writeFileProtected f (unlines (privDataLines privcontent)) 			, File.mode (takeDirectory f) $ combineModes 				[ownerReadMode, ownerWriteMode, ownerExecuteMode] 			, File.ownerGroup (takeDirectory f) user (userGroup user)

@@ -0,0 +1,132 @@+-- | Properties for the Unbound caching DNS server++module Propellor.Property.Unbound+	( installed+	, restarted+	, reloaded+	, cachingDnsServer+	) where++import Propellor+import Propellor.Property.File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service++import Data.List (find)+++type ConfSection = String++type UnboundSetting = (UnboundKey, UnboundValue)++type UnboundSection = (ConfSection, [UnboundSetting])++type UnboundZone = (BindDomain, ZoneType)++type UnboundHost = (BindDomain, Record)++type UnboundKey = String++type UnboundValue = String++type ZoneType = String++installed :: Property NoInfo+installed = Apt.installed ["unbound"]++restarted :: Property NoInfo+restarted = Service.restarted "unbound"++reloaded :: Property NoInfo+reloaded = Service.reloaded "unbound"++dValue :: BindDomain -> String+dValue (RelDomain d) = d+dValue (AbsDomain d) = d ++ "."+dValue (RootDomain) = "@"++sectionHeader :: ConfSection -> String+sectionHeader header = header ++ ":"++config :: FilePath+config = "/etc/unbound/unbound.conf.d/propellor.conf"++-- | Provided a [UnboundSection], a [UnboundZone] and a [UnboundHost],+-- cachingDnsServer ensure unbound is configured accordingly.+--+-- Example property:+--+-- > cachingDnsServer+-- >      [ ("remote-control", [("control-enable", "no")]+-- >      , ("server",+-- >      	[ ("interface", "0.0.0.0")+-- >      	, ("access-control", "192.168.1.0/24 allow")+-- >      	, ("do-tcp", "no")+-- >      	])+-- >      [ (AbsDomain "example.com", "transparent")+-- >      , (AbsDomain $ reverseIP $ IPv4 "192.168.1", "static")+-- >      ]+-- >      [ (AbsDomain "example.com", Address $ IPv4 "192.168.1.2")+-- >      , (AbsDomain "myhost.example.com", Address $ IPv4 "192.168.1.2")+-- >      , (AbsDomain "myrouter.example.com", Address $ IPv4 "192.168.1.1")+-- >      , (AbsDomain "www.example.com", Address $ IPv4 "192.168.1.2")+-- >      , (AbsDomain "example.com", MX 10 "mail.example.com")+-- >      , (AbsDomain "mylaptop.example.com", Address $ IPv4 "192.168.1.2")+-- >      -- ^ connected via ethernet+-- >      , (AbsDomain "mywifi.example.com", Address $ IPv4 "192.168.2.1")+-- >      , (AbsDomain "mylaptop.example.com", Address $ IPv4 "192.168.2.2")+-- >      -- ^ connected via wifi, use round robin+-- >      , (AbsDomain "myhost.example.com", PTR $ reverseIP $ IPv4 "192.168.1.2")+-- >      , (AbsDomain "myrouter.example.com", PTR $ reverseIP $ IPv4 "192.168.1.1")+-- >      , (AbsDomain "mylaptop.example.com", PTR $ reverseIP $ IPv4 "192.168.1.2")+-- >      ]+cachingDnsServer :: [UnboundSection] -> [UnboundZone] -> [UnboundHost] -> Property NoInfo+cachingDnsServer sections zones hosts =+	config `hasContent` (comment : otherSections ++ serverSection)+	`onChange` restarted+  where+	comment = "# deployed with propellor, do not modify"+	serverSection = genSection (fromMaybe ("server", []) $ find ((== "server") . fst) sections)+		++ map genZone zones+		++ map (uncurry genRecord') hosts+	otherSections = foldr ((++) . genSection) [] $ filter ((/= "server") . fst) sections++genSection :: UnboundSection -> [Line]+genSection (section, settings) = sectionHeader section : map genSetting settings++genSetting :: UnboundSetting -> Line+genSetting (key, value) = "    " ++ key ++ ": " ++ value++genZone :: UnboundZone -> Line+genZone (dom, zt) = "    local-zone: \"" ++ dValue dom ++ "\" " ++ zt++genRecord' :: BindDomain -> Record -> Line+genRecord' dom r = "    local-data: \"" ++ fromMaybe "" (genRecord dom r) ++ "\""++genRecord :: BindDomain -> Record -> Maybe String+genRecord dom (Address addr) = Just $ genAddressNoTtl dom addr+genRecord dom (MX priority dest) = Just $ genMX dom priority dest+genRecord dom (PTR revip) = Just $ genPTR dom revip+genRecord _ (CNAME _) = Nothing+genRecord _ (NS _) = Nothing+genRecord _ (TXT _) = Nothing+genRecord _ (SRV _ _ _ _) = Nothing+genRecord _ (SSHFP _ _ _) = Nothing+genRecord _ (INCLUDE _) = Nothing++genAddressNoTtl :: BindDomain -> IPAddr -> String+genAddressNoTtl dom = genAddress dom Nothing++genAddress :: BindDomain -> Maybe Int -> IPAddr -> String+genAddress dom ttl addr = case addr of+	IPv4 _ -> genAddress' "A" dom ttl addr+	IPv6 _ -> genAddress' "AAAA" dom ttl addr++genAddress' :: String -> BindDomain -> Maybe Int -> IPAddr -> String+genAddress' recordtype dom ttl addr = dValue dom ++ " " ++ maybe "" (\ttl' -> show ttl' ++ " ") ttl ++ "IN " ++ recordtype ++ " " ++ fromIPAddr addr++genMX :: BindDomain -> Int -> BindDomain -> String+genMX dom priority dest = dValue dom ++ " " ++ "MX" ++ " " ++ show priority ++ " " ++ dValue dest++genPTR :: BindDomain -> ReverseIP -> String+genPTR dom revip = revip ++ ". " ++ "PTR" ++ " " ++ dValue dom

@@ -58,8 +58,8 @@ setPassword :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result setPassword getpassword = getpassword $ go   where-	go (Password user, password) = set user password []-	go (CryptPassword user, hash) = set user hash ["--encrypted"]+	go (Password user, password) = set user (privDataVal password) []+	go (CryptPassword user, hash) = set user (privDataVal hash) ["--encrypted"] 	go (f, _) = error $ "Unexpected type of privdata: " ++ show f  	set user v ps = makeChange $ withHandle StdinHandle createProcessSuccess

@@ -77,7 +77,7 @@ installFile top f = do 	createDirectoryIfMissing True destdir 	nukeFile dest-	createLink f dest `catchIO` (const copy)+	createLink f dest `catchIO` const copy   where 	copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest] 	destdir = inTop top $ takeDirectory f

@@ -24,6 +24,7 @@ import Propellor.Gpg import Propellor.Bootstrap import Propellor.Types.CmdLine+import Propellor.Types.Info import qualified Propellor.Shim as Shim import Utility.FileMode import Utility.SafeCommand@@ -58,7 +59,7 @@  	-- And now we can run it. 	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $-		error $ "remote propellor failed"+		error "remote propellor failed"   where 	hn = fromMaybe target relay @@ -126,7 +127,7 @@ 					return ip  	configips = map fromIPAddr $ mapMaybe getIPAddr $-		S.toList $ _dns $ hostInfo hst+		S.toList $ fromDnsInfo $ getInfo $ hostInfo hst  -- Update the privdata, repo url, and git repo over the ssh -- connection, talking to the user's local propellor instance which is@@ -183,7 +184,7 @@ 		let loop = go (toh, fromh) 		let restart = updateServer hn relay hst connect haveprecompiled 		let done = return ()-		v <- (maybe Nothing readish <$> getMarked fromh statusMarker)+		v <- maybe Nothing readish <$> getMarked fromh statusMarker 		case v of 			(Just NeedRepoUrl) -> do 				sendRepoUrl toh@@ -262,7 +263,7 @@ -- This should be reasonably portable, as long as the remote host has the -- same architecture as the build host. sendPrecompiled :: HostName -> IO ()-sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor as a last resort") $ do+sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor as a last resort" $ 	bracket getWorkingDirectory changeWorkingDirectory $ \_ -> 		withTmpDir "propellor" go   where

@@ -6,11 +6,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}  module Propellor.Types 	( Host(..) 	, Desc 	, Property+	, Info 	, HasInfo 	, NoInfo 	, CInfo@@ -27,7 +29,6 @@ 	, CombinedType 	, before 	, combineWith-	, Info(..) 	, Propellor(..) 	, EndAction(..) 	, module Propellor.Types.OS@@ -41,18 +42,12 @@ import Control.Applicative import "mtl" Control.Monad.RWS.Strict import Control.Monad.Catch-import qualified Data.Set as S-import qualified Data.Map as M+import Data.Typeable +import Propellor.Types.Info import Propellor.Types.OS-import Propellor.Types.Chroot import Propellor.Types.Dns-import Propellor.Types.Docker-import Propellor.Types.PrivData-import Propellor.Types.Empty-import Propellor.Types.Val import Propellor.Types.Result-import qualified Propellor.Types.Dns as Dns  -- | Everything Propellor knows about a system: Its hostname, -- properties and their collected info.@@ -61,7 +56,7 @@ 	, hostProperties :: [Property HasInfo] 	, hostInfo :: Info 	}-	deriving (Show)+	deriving (Show, Typeable)  -- | Propellor's monad provides read-only access to info about the host -- it's running on, and a writer to accumulate EndActions.@@ -224,7 +219,7 @@ -- that ensures the first, and if the first succeeds, ensures the second. -- The property uses the description of the first property. before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x-before x y = (y `requires` x) `describe` (getDesc x)+before x y = (y `requires` x) `describe` getDesc x  -- | Combines together two properties, yielding a property that -- has the description and info of the first, and that has the second@@ -269,41 +264,3 @@ 			(x1 `requires` y1) 			-- when reverting, run actions in reverse order 			(y2 `requires` x2)---- | Information about a host.-data Info = Info-	{ _os :: Val System-	, _privData :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext)-	, _sshPubKey :: M.Map SshKeyType String-	, _aliases :: S.Set HostName-	, _dns :: S.Set Dns.Record-	, _namedconf :: Dns.NamedConfMap-	, _dockerinfo :: DockerInfo Host-	, _chrootinfo :: ChrootInfo Host-	}-	deriving (Show)--instance Monoid Info where-	mempty = Info mempty mempty mempty mempty mempty mempty mempty mempty-	mappend old new = Info-		{ _os = _os old <> _os new-		, _privData = _privData old <> _privData new-		, _sshPubKey = _sshPubKey new `M.union` _sshPubKey old-		, _aliases = _aliases old <> _aliases new-		, _dns = _dns old <> _dns new-		, _namedconf = _namedconf old <> _namedconf new-		, _dockerinfo = _dockerinfo old <> _dockerinfo new-		, _chrootinfo = _chrootinfo old <> _chrootinfo new-		}--instance Empty Info where-	isEmpty i = and-		[ isEmpty (_os i)-		, isEmpty (_privData i)-		, isEmpty (_sshPubKey i)-		, isEmpty (_aliases i)-		, isEmpty (_dns i)-		, isEmpty (_namedconf i)-		, isEmpty (_dockerinfo i)-		, isEmpty (_chrootinfo i)-		]

@@ -1,23 +1,31 @@+{-# LANGUAGE DeriveDataTypeable #-}+ module Propellor.Types.Chroot where +import Propellor.Types+import Propellor.Types.Empty+import Propellor.Types.Info+ import Data.Monoid import qualified Data.Map as M-import Propellor.Types.Empty -data ChrootInfo host = ChrootInfo-	{ _chroots :: M.Map FilePath host+data ChrootInfo = ChrootInfo+	{ _chroots :: M.Map FilePath Host 	, _chrootCfg :: ChrootCfg 	}-	deriving (Show)+	deriving (Show, Typeable) -instance Monoid (ChrootInfo host) where+instance IsInfo ChrootInfo where+	propigateInfo _ = False++instance Monoid ChrootInfo where 	mempty = ChrootInfo mempty mempty 	mappend old new = ChrootInfo 		{ _chroots = M.union (_chroots old) (_chroots new) 		, _chrootCfg = _chrootCfg old <> _chrootCfg new 		} -instance Empty (ChrootInfo host) where+instance Empty ChrootInfo where 	isEmpty i = and 		[ isEmpty (_chroots i) 		, isEmpty (_chrootCfg i)

@@ -15,6 +15,7 @@ 	| Edit PrivDataField Context 	| ListFields 	| AddKey String+	| RmKey String 	| Merge 	| Serialized CmdLine 	| Continue CmdLine

@@ -17,12 +17,12 @@ -- For example, @Port 8080 -<- Port 80@ means that port 8080 on the host -- is bound to port 80 from the container. (-<-) :: (hostv ~ v, containerv ~ v) => hostv -> containerv -> Bound v-(-<-) hostv containerv = Bound hostv containerv+(-<-) = Bound  -- | Flipped version of -<- with the container value first and host value -- second. (->-) :: (containerv ~ v, hostv ~ v) => hostv -> containerv -> Bound v-(->-) containerv hostv = Bound hostv containerv+(->-) = flip (-<-)  -- | Create a Bound value, that is the same on both the host and container. same :: v -> Bound v

@@ -1,11 +1,17 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+ module Propellor.Types.Dns where  import Propellor.Types.OS (HostName) import Propellor.Types.Empty+import Propellor.Types.Info  import Data.Word import Data.Monoid import qualified Data.Map as M+import qualified Data.Set as S+import Data.List+import Data.String.Utils (split, replace)  type Domain = String @@ -16,6 +22,29 @@ fromIPAddr (IPv4 addr) = addr fromIPAddr (IPv6 addr) = addr +newtype AliasesInfo = AliasesInfo (S.Set HostName)+	deriving (Show, Eq, Ord, Monoid, Typeable)++instance IsInfo AliasesInfo where+	propigateInfo _ = False++toAliasesInfo :: [HostName] -> AliasesInfo+toAliasesInfo l = AliasesInfo (S.fromList l)++fromAliasesInfo :: AliasesInfo -> [HostName]+fromAliasesInfo (AliasesInfo s) = S.toList s++newtype DnsInfo = DnsInfo { fromDnsInfo :: S.Set Record }+	deriving (Show, Eq, Ord, Monoid, Typeable)++toDnsInfo :: S.Set Record -> DnsInfo+toDnsInfo = DnsInfo++-- | DNS Info is propigated, so that eg, aliases of a container+-- are reflected in the dns for the host where it runs.+instance IsInfo DnsInfo where+	propigateInfo _ = True+ -- | Represents a bind 9 named.conf file. data NamedConf = NamedConf 	{ confDomain :: Domain@@ -64,8 +93,34 @@ 	| SRV Word16 Word16 Word16 BindDomain 	| SSHFP Int Int String 	| INCLUDE FilePath-	deriving (Read, Show, Eq, Ord)+	| PTR ReverseIP+	deriving (Read, Show, Eq, Ord, Typeable) +-- | An in-addr.arpa record corresponding to an IPAddr.+type ReverseIP = String++reverseIP :: IPAddr -> ReverseIP+reverseIP (IPv4 addr) = intercalate "." (reverse $ split "." addr) ++ ".in-addr.arpa"+reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ fromIPAddr $ canonicalIP addr) ++ ".ip6.arpa"++-- | Converts an IP address (particularly IPv6) to canonical, fully+-- expanded form.+canonicalIP :: IPAddr -> IPAddr+canonicalIP (IPv4 addr) = IPv4 addr+canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ":" $ replaceImplicitGroups addr+  where+	canonicalGroup g+		| l <= 4    = replicate (4 - l) '0' ++ g+		| otherwise = error $ "IPv6 group " ++ g ++ "as more than 4 hex digits"+	  where+		l = length g+	emptyGroups n = iterate (++ ":") "" !! n+	numberOfImplicitGroups a = 8 - length (split ":" $ replace "::" "" a)+	replaceImplicitGroups a = concat $ aux $ split "::" a+	  where+		aux [] = []+		aux (x : xs) = x : emptyGroups (numberOfImplicitGroups a) : xs+ getIPAddr :: Record -> Maybe IPAddr getIPAddr (Address addr) = Just addr getIPAddr _ = Nothing@@ -97,7 +152,10 @@ domainHostName RootDomain = Nothing  newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf)-	deriving (Eq, Ord, Show)+	deriving (Eq, Ord, Show, Typeable)++instance IsInfo NamedConfMap where+	propigateInfo _ = False  -- | Adding a Master NamedConf stanza for a particulr domain always -- overrides an existing Secondary stanza for that domain, while a

@@ -1,25 +1,31 @@+{-# LANGUAGE DeriveDataTypeable #-}+ module Propellor.Types.Docker where -import Propellor.Types.OS+import Propellor.Types import Propellor.Types.Empty+import Propellor.Types.Info  import Data.Monoid import qualified Data.Map as M -data DockerInfo h = DockerInfo+data DockerInfo = DockerInfo 	{ _dockerRunParams :: [DockerRunParam]-	, _dockerContainers :: M.Map String h+	, _dockerContainers :: M.Map String Host 	}-	deriving (Show)+	deriving (Show, Typeable) -instance Monoid (DockerInfo h) where+instance IsInfo DockerInfo where+	propigateInfo _ = False++instance Monoid DockerInfo where 	mempty = DockerInfo mempty mempty 	mappend old new = DockerInfo 		{ _dockerRunParams = _dockerRunParams old <> _dockerRunParams new 		, _dockerContainers = M.union (_dockerContainers old) (_dockerContainers new) 		} -instance Empty (DockerInfo h) where+instance Empty DockerInfo where 	isEmpty i = and 		[ isEmpty (_dockerRunParams i) 		, isEmpty (_dockerContainers i)

@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Propellor.Types.Info (+	Info,+	IsInfo(..),+	addInfo,+	getInfo,+	propigatableInfo,+	InfoVal(..),+	fromInfoVal,+	Typeable,+) where++import Data.Dynamic+import Data.Monoid+import Data.Maybe++-- | Information about a Host, which can be provided by its properties.+--+-- Any value in the `IsInfo` type class can be added to an Info.+data Info = Info [(Dynamic, Bool)]++instance Show Info where+	show (Info l) = "Info " ++ show (map (dynTypeRep . fst) l)++instance Monoid Info where+ 	mempty = Info []+	mappend (Info a) (Info b) = Info (a <> b)++-- | Values stored in Info must be members of this class.+--+-- This is used to avoid accidentially using other data types+-- 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) => IsInfo v where+	-- | Should info of this type be propigated out of a+	-- container to its Host?+	propigateInfo :: v -> Bool++addInfo :: IsInfo v => Info -> v -> Info+addInfo (Info l) v = Info ((toDyn v, propigateInfo v):l)++getInfo :: IsInfo v => Info -> v+getInfo (Info l) = mconcat (mapMaybe (fromDynamic . fst) (reverse l))++-- | Filters out parts of the Info that should not propigate out of a+-- container.+propigatableInfo :: Info -> Info+propigatableInfo (Info l) = Info (filter snd l)++-- | Use this to put a value in Info that is not a monoid.+-- The last value set will be used. This info does not propigate+-- out of a container.+data InfoVal v = NoInfoVal | InfoVal v+	deriving (Typeable)++instance Monoid (InfoVal v) where+	mempty = NoInfoVal+	mappend _ v@(InfoVal _) = v+	mappend v NoInfoVal = v++instance Typeable v => IsInfo (InfoVal v) where+	propigateInfo _ = False++fromInfoVal :: InfoVal v -> Maybe v+fromInfoVal NoInfoVal = Nothing+fromInfoVal (InfoVal v) = Just v

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveDataTypeable #-}+ module Propellor.Types.OS ( 	System(..), 	Distribution(..),@@ -14,10 +16,11 @@ ) where  import Network.BSD (HostName)+import Data.Typeable  -- | High level description of a operating system. data System = System Distribution Architecture-	deriving (Show, Eq)+	deriving (Show, Eq, Typeable)  data Distribution 	= Debian DebianSuite

@@ -1,7 +1,12 @@ module Propellor.Types.PrivData where  import Propellor.Types.OS+import Utility.PartialPrelude+import Utility.FileSystemEncoding +import Data.Maybe+import qualified Data.ByteString.Lazy as L+ -- | Note that removing or changing constructors or changing types will -- break the serialized privdata files, so don't do that! -- It's fine to add new constructors.@@ -89,7 +94,27 @@ hostContext :: HostContext hostContext = HostContext Context -type PrivData = String+-- | Contains the actual private data.+--+-- Note that this may contain exta newlines at the end, or they may have+-- been stripped off, depending on how the user entered the privdata,+-- and which version of propellor stored it. Use the accessor functions+-- below to avoid newline problems.+newtype PrivData = PrivData String++-- | When PrivData is the content of a file, this is the lines thereof.+privDataLines :: PrivData -> [String]+privDataLines (PrivData s) = lines s++-- | When the PrivData is a single value, like a password, this extracts+-- it. Note that if multiple lines are present in the PrivData, only+-- the first is returned; there is never a newline in the String.+privDataVal :: PrivData -> String+privDataVal (PrivData s) = fromMaybe "" (headMaybe (lines s))++-- | Use to get ByteString out of PrivData.+privDataByteString :: PrivData -> L.ByteString+privDataByteString (PrivData s) = encodeBS s  data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519 	deriving (Read, Show, Ord, Eq, Enum, Bounded)

@@ -1,22 +0,0 @@-module Propellor.Types.Val where--import Data.Monoid--import Propellor.Types.Empty--data Val a = Val a | NoVal-	deriving (Eq, Show)--instance Monoid (Val a) where-	mempty = NoVal-	mappend old new = case new of-		NoVal -> old-		_ -> new--instance Empty (Val a) where-	isEmpty NoVal = True-	isEmpty _ = False--fromVal :: Val a -> Maybe a-fromVal (Val a) = Just a-fromVal NoVal = Nothing

@@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more)  -- - Copyright 2011-2014 Joey Hess <id@joeyh.name>+ - Copyright 2011-2015 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -20,6 +20,7 @@ 	catchNonAsync, 	tryNonAsync, 	tryWhenExists,+	catchHardwareFault, ) where  import Control.Monad.Catch as X hiding (Handler)@@ -27,7 +28,9 @@ import Control.Exception (IOException, AsyncException) import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO)-import System.IO.Error (isDoesNotExistError)+import System.IO.Error (isDoesNotExistError, ioeGetErrorType)+import GHC.IO.Exception (IOErrorType(..))+ import Utility.Data  {- Catches IO errors and returns a Bool -}@@ -36,10 +39,7 @@  {- Catches IO errors and returns a Maybe -} catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)-catchMaybeIO a = do-	catchDefaultIO Nothing $ do-		v <- a-		return (Just v)+catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just)  {- Catches IO errors and returns a default value. -} catchDefaultIO :: MonadCatch m => a -> m a -> m a@@ -87,3 +87,12 @@ tryWhenExists a = do 	v <- tryJust (guard . isDoesNotExistError) a 	return (eitherToMaybe v)++{- Catches only exceptions caused by hardware faults.+ - Ie, disk IO error. -}+catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a+catchHardwareFault a onhardwareerr = catchIO a onlyhw+  where+	onlyhw e+		| ioeGetErrorType e == HardwareFault = onhardwareerr e+		| otherwise = throwM e

@@ -13,6 +13,7 @@ 	withFilePath, 	md5FilePath, 	decodeBS,+	encodeBS, 	decodeW8, 	encodeW8, 	encodeW8NUL,@@ -34,6 +35,8 @@ import qualified Data.ByteString.Lazy.UTF8 as L8 #endif +import Utility.Exception+ {- Sets a Handle to use the filesystem encoding. This causes data  - written or read from it to be encoded/decoded the same  - as ghc 7.4 does to filenames etc. This special encoding@@ -67,12 +70,16 @@  - only allows doing this conversion with CStrings, and the CString buffer  - is allocated, used, and deallocated within the call, with no side  - effects.+ -+ - If the FilePath contains a value that is not legal in the filesystem+ - encoding, rather than thowing an exception, it will be returned as-is.  -} {-# NOINLINE _encodeFilePath #-} _encodeFilePath :: FilePath -> String _encodeFilePath fp = unsafePerformIO $ do 	enc <- Encoding.getFileSystemEncoding-	GHC.withCString enc fp $ GHC.peekCString Encoding.char8+	GHC.withCString enc fp (GHC.peekCString Encoding.char8)+		`catchNonAsync` (\_ -> return fp)  {- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -} md5FilePath :: FilePath -> MD5.Str@@ -81,11 +88,19 @@ {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBS :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS-decodeBS = encodeW8 . L.unpack+decodeBS = encodeW8NUL . L.unpack #else {- On Windows, we assume that the ByteString is utf-8, since Windows  - only uses unicode for filenames. -} decodeBS = L8.toString+#endif++{- Encodes a FilePath into a ByteString, applying the filesystem encoding. -}+encodeBS :: FilePath -> L.ByteString+#ifndef mingw32_HOST_OS+encodeBS = L.pack . decodeW8NUL+#else+encodeBS = L8.fromString #endif  {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.

@@ -136,7 +136,7 @@  - if this reap gets there first. -} reapZombies :: IO () #ifndef mingw32_HOST_OS-reapZombies = do+reapZombies = 	-- throws an exception when there are no child processes 	catchDefaultIO Nothing (getAnyProcessStatus False True) 		>>= maybe (return ()) (const reapZombies)

@@ -31,6 +31,7 @@ 	withQuietOutput, 	feedWithQuietOutput, 	createProcess,+	waitForProcess, 	startInteractiveProcess, 	stdinHandle, 	stdoutHandle,@@ -42,7 +43,7 @@  import qualified System.Process import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)-import System.Process hiding (createProcess, readProcess)+import System.Process hiding (createProcess, readProcess, waitForProcess) import System.Exit import System.IO import System.Log.Logger@@ -171,7 +172,7 @@ -- returns a transcript combining its stdout and stderr, and -- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)-processTranscript cmd opts input = processTranscript' cmd opts Nothing input+processTranscript cmd opts = processTranscript' cmd opts Nothing  processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool) processTranscript' cmd opts environ input = do@@ -345,22 +346,6 @@ processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid --- | Debugging trace for a CreateProcess.-debugProcess :: CreateProcess -> IO ()-debugProcess p = do-	debugM "Utility.Process" $ unwords-		[ action ++ ":"-		, showCmd p-		]-  where-	action-		| piped (std_in p) && piped (std_out p) = "chat"-		| piped (std_in p)                      = "feed"-		| piped (std_out p)                     = "read"-		| otherwise                             = "call"-	piped Inherit = False-	piped _ = True- -- | Shows the command that a CreateProcess will run. showCmd :: CreateProcess -> String showCmd = go . cmdspec@@ -385,9 +370,30 @@ 	(Just from, Just to, _, pid) <- createProcess p 	return (pid, to, from) --- | Wrapper around 'System.Process.createProcess' from System.Process,--- that does debug logging.+-- | Wrapper around 'System.Process.createProcess' that does debug logging. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do 	debugProcess p 	System.Process.createProcess p++-- | Debugging trace for a CreateProcess.+debugProcess :: CreateProcess -> IO ()+debugProcess p = debugM "Utility.Process" $ unwords+	[ action ++ ":"+	, showCmd p+	]+  where+	action+		| piped (std_in p) && piped (std_out p) = "chat"+		| piped (std_in p)                      = "feed"+		| piped (std_out p)                     = "read"+		| otherwise                             = "call"+	piped Inherit = False+	piped _ = True++-- | Wrapper around 'System.Process.waitForProcess' that does debug logging.+waitForProcess ::  ProcessHandle -> IO ExitCode+waitForProcess h = do+	r <- System.Process.waitForProcess h+	debugM "Utility.Process" ("process done " ++ show r)+	return r

@@ -286,7 +286,7 @@ fromScheduledTime (SpecificTime h m) =  	show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm   where-	pad n s = take (n - length s) (repeat '0') ++ s+	pad n s = replicate (n - length s) '0' ++ s 	(h', ampm) 		| h == 0 = (12, "AM") 		| h < 12 = (h, "AM")

@@ -26,4 +26,4 @@ 		sumcols (map (map length) table) 	sumcols [] = repeat 0 	sumcols [r] = r-	sumcols (r1:r2:rs) = sumcols $ map (uncurry max) (zip r1 r2) : rs+	sumcols (r1:r2:rs) = sumcols $ zipWith max r1 r2 : rs

@@ -74,7 +74,13 @@ 				fetchUpstreamBranch propellordir distrepo 				changeWorkingDirectory propellordir 				void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"]-			, void $ boolSystem "git" [Param "clone", Param netrepo, File propellordir]+			, do+				void $ boolSystem "git" [Param "clone", Param netrepo, File propellordir]+				changeWorkingDirectory propellordir+				-- Rename origin to upstream and avoid+				-- git push to that read-only repo.+				void $ boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"]+				void $ boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"] 			)  	checkRepo = whenM (doesFileExist disthead <&&> doesFileExist (propellordir </> "propellor.cabal")) $ do