propellor 5.3.5 → 5.3.6

raw patch · 36 files changed

+339/−133 lines, 36 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG +16/−0
• README.md +1/−1
• debian/changelog +16/−0
• doc/README.mdwn +1/−1
• joeyconfig.hs +4/−2
• propellor.cabal +5/−6
• src/Propellor/DotDir.hs +2/−5
• src/Propellor/PrivData.hs +2/−1
• src/Propellor/Property/Ccache.hs +5/−1
• src/Propellor/Property/Chroot.hs +1/−4
• src/Propellor/Property/Conductor.hs +4/−3
• src/Propellor/Property/Debootstrap.hs +6/−2
• src/Propellor/Property/DiskImage/PartSpec.hs +6/−2
• src/Propellor/Property/Firewall.hs +5/−1
• src/Propellor/Property/FreeBSD/Pkg.hs +4/−2
• src/Propellor/Property/FreeBSD/Poudriere.hs +4/−3
• src/Propellor/Property/Installer/Target.hs +5/−1
• src/Propellor/Property/List.hs +1/−0
• src/Propellor/Property/Mount.hs +2/−1
• src/Propellor/Property/Parted.hs +13/−7
• src/Propellor/Property/Parted/Types.hs +16/−7
• src/Propellor/Property/Schroot.hs +3/−2
• src/Propellor/Property/SiteSpecific/JoeySites.hs +55/−19
• src/Propellor/Property/Ssh.hs +12/−5
• src/Propellor/Property/Unbound.hs +52/−14
• src/Propellor/Shim.hs +8/−1
• src/Propellor/Types.hs +29/−10
• src/Propellor/Types/Chroot.hs +16/−8
• src/Propellor/Types/Core.hs +7/−3
• src/Propellor/Types/Dns.hs +10/−6
• src/Propellor/Types/Docker.hs +9/−4
• src/Propellor/Types/Info.hs +7/−3
• src/Propellor/Types/MetaTypes.hs +1/−1
• src/Propellor/Types/Result.hs +9/−6
• src/Propellor/Types/ResultCheck.hs +1/−0
• stack.yaml +1/−1

@@ -1,3 +1,19 @@+propellor (5.3.6) unstable; urgency=medium++  * Fix build with ghc 8.4, which broke due to the Semigroup Monoid change.+  * Dropped support for building propellor with ghc 7 (as in debian+    oldstable), to avoid needing to depend on the semigroups transitional+    package, but also because it's just too old to be worth supporting.+  * stack.yaml: Updated to lts-9.21.+  * Make Schroot.overlaysInTmpfs revertable+    Thanks, Sean Whitton+  * Update shim each time propellor is run in a container, to deal with+    library version changes.+  * Unbound: Added support for various DNS record types.+    Thanks, Félix Sipma.++ -- Joey Hess <id@joeyh.name>  Wed, 09 May 2018 16:24:37 -0400+ propellor (5.3.5) unstable; urgency=medium    * Apt.stdSourcesList now adds stable-updates suite

@@ -56,4 +56,4 @@ 7. Write some neat new properties and send patches!  (Want to get your feet wet with propellor before plunging in?-[try this|http://propellor.branchable.com/forum/Simple_quickstart_without_git__44___SSH__44___GPG])+[try this](http://propellor.branchable.com/forum/Simple_quickstart_without_git__44___SSH__44___GPG])

@@ -1,3 +1,19 @@+propellor (5.3.6) unstable; urgency=medium++  * Fix build with ghc 8.4, which broke due to the Semigroup Monoid change.+  * Dropped support for building propellor with ghc 7 (as in debian+    oldstable), to avoid needing to depend on the semigroups transitional+    package, but also because it's just too old to be worth supporting.+  * stack.yaml: Updated to lts-9.21.+  * Make Schroot.overlaysInTmpfs revertable+    Thanks, Sean Whitton+  * Update shim each time propellor is run in a container, to deal with+    library version changes.+  * Unbound: Added support for various DNS record types.+    Thanks, Félix Sipma.++ -- Joey Hess <id@joeyh.name>  Wed, 09 May 2018 16:24:37 -0400+ propellor (5.3.5) unstable; urgency=medium    * Apt.stdSourcesList now adds stable-updates suite

@@ -56,4 +56,4 @@ 7. Write some neat new properties and send patches!  (Want to get your feet wet with propellor before plunging in?-[try this|http://propellor.branchable.com/forum/Simple_quickstart_without_git__44___SSH__44___GPG])+[try this](http://propellor.branchable.com/forum/Simple_quickstart_without_git__44___SSH__44___GPG])

@@ -99,9 +99,10 @@ clam = host "clam.kitenet.net" $ props 	& standardSystem Unstable X86_64 		["Unreliable server. Anything here may be lost at any time!" ]-	& ipv4 "45.62.211.94"+	& ipv4 "64.137.164.186"  	& CloudAtCost.decruft+	& User.hasPassword (User "root") 	& Ssh.hostKeys hostContext 		[ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBAI3WUq0RaigLlcUivgNG4sXpso2ORZkMvfqKz6zkc60L6dpxvWDNmZVEH8hEjxRSYG07NehcuOgQqeyFnS++xw1hdeGjf37JqCUH49i02lra3Zxv8oPpRxyeqe5MmuzUJhlWvBdlc3O/nqZ4bTUfnxMzSYWyy6++s/BpSHttZplNAAAAFQC1DE0vzgVeNAv9smHLObQWZFe2VQAAAIBECtpJry3GC8NVTFsTHDGWksluoFPIbKiZUFFztZGdM0AO2VwAbiJ6Au6M3VddGFANgTlni6d2/9yS919zO90TaFoIjywZeXhxE2CSuRfU7sx2hqDBk73jlycem/ER0sanFhzpHVpwmLfWneTXImWyq37vhAxatJANOtbj81vQ3AAAAIBV3lcyTT9xWg1Q4vERJbvyF8mCliwZmnIPa7ohveKkxlcgUk5d6dnaqFfjVaiXBPN3Qd08WXoQ/a9k3chBPT9nW2vWgzzM8l36j2MbHLmaxGwevAc9+vx4MXqvnGHzd2ex950mC33ct3j0fzMZlO6vqEsgD4CYmiASxhfefj+JCQ==") 		, (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDJybAjUPUWIhvVMmer8K5ZgdfI54DM6vc8Mzw+5KmVKL0TwkvzbR1HAB4heyMGtN1F8YzkWhsI3/Txh+MQUJ+i4u8SvSYc6D1q3j3ZyCi06wZ3DJS25tZrOM/thOOA1DFA4Hhb0uI/1Kg8PguNNNSMXn8F7q3F6cFQizYgszs6z6ktiST/BTC+IXWovhcnn2vQXXU8FTcTsqBFqA5dEjZbp1WDzqp3km84ZyXGmoVlpqzXeMvlkWTIshYiQjXIwPOkALzlGYjp1lw1OaxPVI1IGFcgCbIWQQWoCReb+genX2VaR+odAYXjaOdRx0lQj7UCPTBCpqMyzBMLtT5Yiaqh")@@ -175,6 +176,7 @@ honeybee = host "honeybee.kitenet.net" $ props 	& standardSystem Testing ARMHF 		[ "Home router and arm git-annex build box." ]+	& Apt.removed ["rsyslog"] 	 	& cubietech_Cubietruck 	& hasPartition@@ -195,7 +197,7 @@ 		[ (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIIS/hDYq1MAxfOBf49htym3BOYlx4Gk9SDpiHjv7u6IC") 		] -	& JoeySites.homePowerMonitor+	& JoeySites.homePower 		(User "joey") 		hosts 		(Context "homepower.joeyh.name")

@@ -1,6 +1,6 @@ Name: propellor-Version: 5.3.5-Cabal-Version: >= 1.20+Version: 5.3.6+Cabal-Version: 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess@@ -45,7 +45,7 @@   Build-Depends:     -- propellor needs to support the ghc shipped in Debian stable,     -- and also only depends on packages in Debian stable.-    base >= 4.5, base < 5,+    base >= 4.9, base < 5,     directory, filepath, IfElse, process, bytestring, hslogger, split,     unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,     time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable@@ -232,9 +232,7 @@   Default-Language: Haskell98   Hs-Source-Dirs: executables   Main-Is: propellor-config.hs-  GHC-Options: -threaded -Wall -fno-warn-tabs -O0-  if impl(ghc >= 8.0)-    GHC-Options: -fno-warn-redundant-constraints+  GHC-Options: -threaded -Wall -fno-warn-tabs   Default-Extensions: TypeOperators   Build-Depends: propellor, base @@ -242,6 +240,7 @@   Default-Language: Haskell98   Hs-Source-Dirs: executables   Main-Is: wrapper.hs+  GHC-Options: -threaded -Wall -fno-warn-tabs   Build-Depends: propellor, base  source-repository head

@@ -271,7 +271,7 @@ 		, "  Main-Is: config.hs" 		, "  GHC-Options: -threaded -Wall -fno-warn-tabs -O0" 		, "  Extensions: TypeOperators"-		, "  Build-Depends: propellor >= 3.0, base >= 3"+		, "  Build-Depends: propellor >= 3.0, base >= 4.9" 		] 	configcontent = 		[ "-- This is the main configuration file for Propellor, and is used to build"@@ -316,7 +316,7 @@ 		]  stackResolver :: String-stackResolver = "lts-8.22"+stackResolver = "lts-9.21"  fullClone :: IO Result fullClone = do@@ -446,9 +446,6 @@ 					) 			Nothing -> return mref --- And, if there's a remote named "upstream"--- that does not point at the distrepo, the user must have set that up--- and is not using the distrepo, so do nothing. warnoutofdate :: Bool -> IO () warnoutofdate havebranch = warningMessage $ unlines 	[ "** Your ~/.propellor/ is out of date.."

@@ -37,6 +37,7 @@ import qualified Data.ByteString.Lazy as L import Control.Applicative import Data.Monoid+import Data.Semigroup as Sem import Prelude  import Propellor.Types@@ -279,7 +280,7 @@  newtype PrivInfo = PrivInfo 	{ fromPrivInfo :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext) }-	deriving (Eq, Ord, Show, Typeable, Monoid)+	deriving (Eq, Ord, Show, Typeable, Sem.Semigroup, Monoid)  -- PrivInfo always propagates out of containers, so that propellor -- can see which hosts need it.

@@ -14,6 +14,7 @@ import Utility.FileMode import Utility.DataUnits import System.Posix.Files+import qualified Data.Semigroup as Sem  -- | Limits on the size of a ccache data Limit@@ -25,9 +26,12 @@ 	| NoLimit 	| Limit :+ Limit +instance Sem.Semigroup Limit where+	(<>) = (:+)+ instance Monoid Limit where 	mempty  = NoLimit-	mappend = (:+)+	mappend = (Sem.<>)  -- | A string that will be parsed to get a data size. --

@@ -169,10 +169,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do 	let d = localdir </> shimdir c 	let me = localdir </> "propellor"-	shim <- liftIO $ ifM (doesDirectoryExist d)-		( pure (Shim.file me d)-		, Shim.setup me Nothing d-		)+	shim <- liftIO $ Shim.setup me Nothing d 	ifM (liftIO $ bindmount shim) 		( chainprovision shim 		, return FailedChange

@@ -81,6 +81,7 @@ import qualified Propellor.Property.Ssh as Ssh  import qualified Data.Set as S+import qualified Data.Semigroup as Sem  -- | Class of things that can be conducted. --@@ -313,9 +314,9 @@ -- A Host's Info indicates when it's a conductor for hosts, and when it's -- stopped being a conductor. newtype ConductorFor = ConductorFor [Host]-	deriving (Typeable, Monoid)+	deriving (Typeable, Sem.Semigroup, Monoid) newtype NotConductorFor = NotConductorFor [Host]-	deriving (Typeable, Monoid)+	deriving (Typeable, Sem.Semigroup, Monoid)  instance Show ConductorFor where 	show (ConductorFor l) = "ConductorFor " ++ show (map hostName l)@@ -329,7 +330,7 @@  -- Added to Info when a host has been orchestrated. newtype Orchestrated = Orchestrated Any-	deriving (Typeable, Monoid, Show)+	deriving (Typeable, Sem.Semigroup, Monoid, Show) instance IsInfo Orchestrated where 	propagateInfo _ = PropagateInfo False 

@@ -19,12 +19,13 @@  import Data.List import Data.Char+import qualified Data.Semigroup as Sem import System.Posix.Directory import System.Posix.Files  type Url = String --- | A monoid for debootstrap configuration.+-- | A data type for debootstrap configuration. -- mempty is a default debootstrapped system. data DebootstrapConfig 	= DefaultConfig@@ -35,9 +36,12 @@ 	| DebootstrapConfig :+ DebootstrapConfig 	deriving (Show) +instance Sem.Semigroup DebootstrapConfig where+	(<>) = (:+)+ instance Monoid DebootstrapConfig where 	mempty  = DefaultConfig-	mappend = (:+)+	mappend = (Sem.<>)  toParams :: DebootstrapConfig -> [CommandParam] toParams DefaultConfig = []

@@ -43,6 +43,7 @@  import Data.List (sortBy) import Data.Ord+import qualified Data.Semigroup as Sem  -- | Specifies a partition with a given filesystem. --@@ -110,7 +111,7 @@ 	| AdjustPartSpecInfo MountPoint (PartSpec PartLocation -> PartSpec PartLocation)  newtype PartInfo = PartInfo [PartInfoVal]-	deriving (Monoid, Typeable)+	deriving (Monoid, Sem.Semigroup, Typeable)  instance IsInfo PartInfo where 	propagateInfo _ = PropagateInfo False@@ -183,9 +184,12 @@ data PartLocation = Beginning | Middle | End 	deriving (Eq, Ord) +instance Sem.Semigroup PartLocation where+	_ <> b = b+ instance Monoid PartLocation where 	mempty = Middle-	mappend _ b = b+	mappend = (Sem.<>)  partLocation :: PartSpec PartLocation -> PartLocation -> PartSpec PartLocation partLocation (mp, o, p, _) l = (mp, o, p, l)

@@ -18,6 +18,7 @@ ) where  import Data.Monoid+import qualified Data.Semigroup as Sem import Data.Char import Data.List @@ -199,6 +200,9 @@  infixl 0 :- +instance Sem.Semigroup Rules where+	(<>) = (:-)+ instance Monoid Rules where 	mempty  = Everything-	mappend = (:-)+	mappend = (Sem.<>)

@@ -9,6 +9,8 @@ import Propellor.Base import Propellor.Types.Info +import qualified Data.Semigroup as Sem+ noninteractiveEnv :: [([Char], [Char])] noninteractiveEnv = [("ASSUME_ALWAYS_YES", "yes")] @@ -37,7 +39,7 @@ 		lines <$> readProcessEnv p a (Just noninteractiveEnv)  newtype PkgUpdate = PkgUpdate String-	deriving (Typeable, Monoid, Show)+	deriving (Typeable, Sem.Semigroup, Monoid, Show) instance IsInfo PkgUpdate where 	propagateInfo _ = PropagateInfo False @@ -54,7 +56,7 @@ 			`setInfoProperty` (toInfo (PkgUpdate ""))  newtype PkgUpgrade = PkgUpgrade String-	deriving (Typeable, Monoid, Show)+	deriving (Typeable, Sem.Semigroup, Monoid, Show)  instance IsInfo PkgUpgrade where 	propagateInfo _ = PropagateInfo False

@@ -8,17 +8,18 @@  import Propellor.Base import Propellor.Types.Info-import Data.List- import qualified Propellor.Property.FreeBSD.Pkg as Pkg import qualified Propellor.Property.ZFS as ZFS import qualified Propellor.Property.File as File +import Data.List+import qualified Data.Semigroup as Sem+ poudriereConfigPath :: FilePath poudriereConfigPath = "/usr/local/etc/poudriere.conf"  newtype PoudriereConfigured = PoudriereConfigured String-	deriving (Typeable, Monoid, Show)+	deriving (Typeable, Sem.Semigroup, Monoid, Show)  instance IsInfo PoudriereConfigured where 	propagateInfo _ = PropagateInfo False

@@ -112,6 +112,7 @@ import Data.Char import Data.Ord import Data.Ratio+import qualified Data.Semigroup as Sem import System.Process (readProcess)  -- | Partition table for the target disk.@@ -438,9 +439,12 @@ data TargetFilled = TargetFilled (Ratio Integer) 	deriving (Show, Eq) +instance Sem.Semigroup TargetFilled where+	TargetFilled n <> TargetFilled m = TargetFilled (n+m) + instance Monoid TargetFilled where 	mempty = TargetFilled (0 % 1)-	mappend (TargetFilled n) (TargetFilled m) = TargetFilled (n+m)+	mappend = (Sem.<>)  newtype TargetFilledHandle = TargetFilledHandle Integer 

@@ -20,6 +20,7 @@ import Propellor.Exception  import Data.Monoid+import Prelude  toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes) toProps ps = Props (map toChildProperty ps)

@@ -10,6 +10,7 @@ import Utility.Path  import Data.List+import qualified Data.Semigroup as Sem  -- | type of filesystem to mount ("auto" to autodetect) type FsType = String@@ -24,7 +25,7 @@ -- -- For default mount options, use `mempty`. newtype MountOpts = MountOpts [String]-	deriving Monoid+	deriving (Sem.Semigroup, Monoid)  class ToMountOpts a where 	toMountOpts :: a -> MountOpts

@@ -42,6 +42,7 @@ import Utility.DataUnits  import System.Posix.Files+import qualified Data.Semigroup as Sem import Data.List (genericLength)  data Eep = YesReallyDeleteDiskContents@@ -178,16 +179,21 @@  data DiskSpaceUse = Percent Int | RemainingSpace +instance Sem.Semigroup DiskPart where+	FixedDiskPart <> FixedDiskPart = FixedDiskPart+	DynamicDiskPart (Percent a) <> DynamicDiskPart (Percent b) =+		DynamicDiskPart (Percent (a + b))+	DynamicDiskPart RemainingSpace <> DynamicDiskPart RemainingSpace = +		DynamicDiskPart RemainingSpace+	DynamicDiskPart (Percent a) <> _ = DynamicDiskPart (Percent a)+	_ <> DynamicDiskPart (Percent b) = DynamicDiskPart (Percent b)+	DynamicDiskPart RemainingSpace <> _ = DynamicDiskPart RemainingSpace+	_ <> DynamicDiskPart RemainingSpace = DynamicDiskPart RemainingSpace+ instance Monoid DiskPart   where 	mempty = FixedDiskPart-	mappend FixedDiskPart FixedDiskPart = FixedDiskPart-	mappend (DynamicDiskPart (Percent a)) (DynamicDiskPart (Percent b)) = DynamicDiskPart (Percent (a + b))-	mappend (DynamicDiskPart RemainingSpace) (DynamicDiskPart RemainingSpace) = DynamicDiskPart RemainingSpace-	mappend (DynamicDiskPart (Percent a)) _ = DynamicDiskPart (Percent a)-	mappend _ (DynamicDiskPart (Percent b)) = DynamicDiskPart (Percent b)-	mappend (DynamicDiskPart RemainingSpace) _ = DynamicDiskPart RemainingSpace-	mappend _ (DynamicDiskPart RemainingSpace) = DynamicDiskPart RemainingSpace+	mappend = (Sem.<>)  -- | Make a partition use some percentage of the size of the disk -- (less all fixed size partitions), or the remaining space in the disk.

@@ -4,6 +4,9 @@ import Utility.DataUnits  import Data.Char+import qualified Data.Semigroup as Sem+import Data.Monoid+import Prelude  class PartedVal a where 	pval :: a -> String@@ -19,14 +22,17 @@ data PartTable = PartTable TableType Alignment [Partition] 	deriving (Show) -instance Monoid PartTable where-	-- | default TableType is MSDOS, with a `safeAlignment`.-	mempty = PartTable MSDOS safeAlignment []+instance Sem.Semigroup PartTable where 	-- | uses the TableType of the second parameter 	-- and the larger alignment,-	mappend (PartTable _l1 a1 ps1) (PartTable l2 a2 ps2) =+	PartTable _l1 a1 ps1 <> PartTable l2 a2 ps2 = 		PartTable l2 (max a1 a2) (ps1 ++ ps2) +instance Monoid PartTable where+	-- | default TableType is MSDOS, with a `safeAlignment`.+	mempty = PartTable MSDOS safeAlignment []+	mappend = (Sem.<>)+ -- | A partition on the disk. data Partition = Partition 	{ partType :: PartType@@ -80,11 +86,14 @@ fromPartSize (MegaBytes b) = b * 1000000 fromPartSize (Bytes n) = n +instance Sem.Semigroup PartSize where+	MegaBytes a <> MegaBytes b = MegaBytes (a + b)+	Bytes a <> b = Bytes (a + fromPartSize b)+	a <> Bytes b = Bytes (b + fromPartSize a)+ instance Monoid PartSize where 	mempty = MegaBytes 0-	mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b)-	mappend (Bytes a) b = Bytes (a + fromPartSize b)-	mappend a (Bytes b) = Bytes (b + fromPartSize a)+	mappend = (Sem.<>)  reducePartSize :: PartSize -> PartSize -> PartSize reducePartSize (MegaBytes a) (MegaBytes b) = MegaBytes (a - b)

@@ -32,8 +32,8 @@ -- Implicitly sets 'useOverlays' info property. -- -- Shell script from <https://wiki.debian.org/sbuild>.-overlaysInTmpfs :: Property (HasInfo + DebianLike)-overlaysInTmpfs = go `requires` installed+overlaysInTmpfs :: RevertableProperty (HasInfo + DebianLike) UnixLike+overlaysInTmpfs = (go `requires` installed) <!> undo   where 	f = "/etc/schroot/setup.d/04tmpfs" 	go :: Property (HasInfo + UnixLike)@@ -58,6 +58,7 @@ 			, "fi" 			] 		`onChange` (f `File.mode` combineModes (readModes ++ executeModes))+	undo = File.notPresent f  installed :: Property DebianLike installed = Apt.installed ["schroot"]

@@ -909,20 +909,23 @@ 	& "/etc/systemd/logind.conf" `ConfFile.containsIniSetting` 		("Login", "LidSwitchIgnoreInhibited", "no") --- My home power monitor.-homePowerMonitor :: IsContext c => User -> [Host] -> c -> (SshKeyType, Ssh.PubKeyText) -> Property (HasInfo + DebianLike)-homePowerMonitor user hosts ctx sshkey = propertyList "home power monitor" $ props+homePower :: IsContext c => User -> [Host] -> c -> (SshKeyType, Ssh.PubKeyText) -> Property (HasInfo + DebianLike)+homePower user hosts ctx sshkey = propertyList "home power" $ props 	& Apache.installed 	& Apt.installed ["python", "python-pymodbus", "rrdtool", "rsync"] 	& File.ownerGroup "/var/www/html" user (userGroup user)-	& Git.cloned user "git://git.kitenet.net/joey/homepower" d Nothing-	& buildpoller+	& Git.cloned user "https://git.joeyh.name/git/joey/homepower.git" d Nothing+	& Git.cloned user "https://git.joeyh.name/git/reactive-banana-automation.git" (d </> "reactive-banana-automation") Nothing+	& build 	& Systemd.enabled setupservicename 		`requires` setupserviceinstalled 		`onChange` Systemd.started setupservicename-	& Systemd.enabled servicename-		`requires` serviceinstalled-		`onChange` Systemd.started servicename+	& Systemd.enabled pollerservicename+		`requires` pollerserviceinstalled+		`onChange` Systemd.started pollerservicename+	& Systemd.enabled controllerservicename+		`requires` controllerserviceinstalled+		`onChange` Systemd.started controllerservicename 	& User.hasGroup user (Group "dialout") 	& Group.exists (Group "gpio") Nothing 	& User.hasGroup user (Group "gpio")@@ -936,27 +939,57 @@   where 	d = "/var/www/html/homepower" 	sshkeyfile = d </> ".ssh/key"-	buildpoller = userScriptProperty (User "joey")-		[ "cd " ++ d+	build = userScriptProperty (User "joey")+		[ "cd " ++ d </> "reactive-banana-automation"+		, "cabal install"+		, "cd " ++ d 		, "make" 		] 		`assume` MadeChange-		`requires` Apt.installed ["ghc", "make"]-	servicename = "homepower"-	servicefile = "/etc/systemd/system/" ++ servicename ++ ".service"-	serviceinstalled = servicefile `File.hasContent`+		`requires` Apt.installed+			[ "ghc", "cabal-install", "make"+			, "libghc-http-types-dev"+			, "libghc-stm-dev"+			, "libghc-aeson-dev"+			, "libghc-wai-dev"+			, "libghc-warp-dev"+			, "libghc-http-client-dev"+			, "libghc-reactive-banana-dev"+			, "libghc-hinotify-dev"+			]+	pollerservicename = "homepower"+	pollerservicefile = "/etc/systemd/system/" ++ pollerservicename ++ ".service"+	pollerserviceinstalled = pollerservicefile `File.hasContent` 		[ "[Unit]"-		, "Description=home power monitor"+		, "Description=home power poller" 		, "" 		, "[Service]" 		, "ExecStart=" ++ d ++ "/poller" 		, "WorkingDirectory=" ++ d 		, "User=joey" 		, "Group=joey"+		, "Restart=always" 		, "" 		, "[Install]" 		, "WantedBy=multi-user.target"+		, "WantedBy=homepower-controller.target" 		]+	controllerservicename = "homepower-controller"+	controllerservicefile = "/etc/systemd/system/" ++ controllerservicename ++ ".service"+	controllerserviceinstalled = controllerservicefile `File.hasContent`+		[ "[Unit]"+		, "Description=home power controller"+		, ""+		, "[Service]"+		, "ExecStart=" ++ d ++ "/controller"+		, "WorkingDirectory=" ++ d+		, "User=joey"+		, "Group=joey"+		, "Restart=always"+		, ""+		, "[Install]"+		, "WantedBy=multi-user.target"+		] 	setupservicename = "homepower-setup" 	setupservicefile = "/etc/systemd/system/" ++ setupservicename ++ ".service" 	setupserviceinstalled = setupservicefile `File.hasContent`@@ -976,7 +1009,7 @@ 		] 	-- Any changes to the rsync command will need my .authorized_keys 	-- rsync server command to be updated too.-	rsynccommand = "rsync -e 'ssh -i" ++ sshkeyfile ++ "' -avz rrds/recent/ joey@kitenet.net:/srv/web/homepower.joeyh.name/rrds/recent/"+	rsynccommand = "rsync -e 'ssh -i" ++ sshkeyfile ++ "' -avz rrds/ joey@kitenet.net:/srv/web/homepower.joeyh.name/rrds/"  -- My home router, running hostapd and dnsmasq for wlan0, -- with eth0 connected to a satellite modem, and a fallback ppp connection.@@ -1007,7 +1040,9 @@ 		, "bogus-priv" 		, "interface=wlan0" 		, "domain=kitenet.net"-		, "dhcp-range=10.1.1.100,10.1.1.150,24h"+		-- lease time is short because the homepower+		-- controller wants to know when clients disconnect+		, "dhcp-range=10.1.1.100,10.1.1.150,10m" 		, "no-hosts" 		, "address=/honeybee.kitenet.net/10.1.1.1" 		, "address=/house.kitenet.net/10.1.1.1"@@ -1074,7 +1109,7 @@ 	, "bsdgames", "nethack-console" 	, "xmonad", "libghc-xmonad-dev", "libghc-xmonad-contrib-dev" 	, "ttf-bitstream-vera"-	, "mairix", "offlineimap", "mutt"+	, "mairix", "offlineimap", "mutt", "slrn" 	, "mtr", "nmap", "whois", "wireshark", "tcpdump", "iftop" 	, "pmount", "tree", "pv" 	, "arbtt", "hledger", "bc"@@ -1105,7 +1140,8 @@ 	[ "build-essential", "debhelper", "devscripts" 	, "ghc", "cabal-install", "haskell-stack" 	, "hothasktags", "hdevtools", "hlint"-	, "gdb", "dpkg-repack", "lintian"+	, "gdb", "time"+	, "dpkg-repack", "lintian" 	, "pristine-tar", "github-backup" 	] 

@@ -45,6 +45,7 @@ import System.PosixCompat import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.Semigroup as Sem import Data.List  installed :: Property UnixLike@@ -229,13 +230,16 @@ instance IsInfo HostKeyInfo where 	propagateInfo _ = PropagateInfo False -instance Monoid HostKeyInfo where-	mempty = HostKeyInfo M.empty-	mappend (HostKeyInfo old) (HostKeyInfo new) =+instance Sem.Semigroup HostKeyInfo where+	HostKeyInfo old <> HostKeyInfo new = 		-- new first because union prefers values from the first 		-- parameter when there is a duplicate key 		HostKeyInfo (new `M.union` old) +instance Monoid HostKeyInfo where+	mempty = HostKeyInfo M.empty+	mappend = (Sem.<>)+ userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike) userPubKeys u@(User n) l = pureInfoProperty ("ssh pubkey for " ++ n) $ 	UserKeyInfo (M.singleton u (S.fromList l))@@ -250,10 +254,13 @@ instance IsInfo UserKeyInfo where 	propagateInfo _ = PropagateInfo False +instance Sem.Semigroup UserKeyInfo where+	UserKeyInfo old <> UserKeyInfo new =+		UserKeyInfo (M.unionWith S.union old new)+ instance Monoid UserKeyInfo where 	mempty = UserKeyInfo M.empty-	mappend (UserKeyInfo old) (UserKeyInfo new) =-		UserKeyInfo (M.unionWith S.union old new)+	mappend = (Sem.<>)  -- | Sets up a user with the specified public keys, and the corresponding -- private keys from the privdata.

@@ -64,6 +64,10 @@ -- | Provided a [UnboundSection], a [UnboundZone] and a [UnboundHost], -- cachingDnsServer ensure unbound is configured accordingly. --+-- Be carefull with CNAMEs, unbound is not a primary DNS server, so it will+-- resolve these by itself. For a locally served zone, you probably want A/AAAA+-- records instead.+-- -- Example property: -- -- > cachingDnsServer@@ -115,13 +119,47 @@  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 dom (MX priority dest) = Just $ unwords+	[ dValue dom+	, "MX"+	, val priority+	, dValue dest+	]+genRecord dom (PTR revip) = Just $ unwords+	[ revip ++ "."+	, "PTR"+	, dValue dom+	]+genRecord dom (CNAME dest) = Just $ unwords+	[ dValue dom+	, "CNAME"+	, dValue dest+	]+genRecord dom (NS serv) = Just $ unwords+	[ dValue dom+	, "NS"+	, dValue serv+	]+genRecord dom (TXT txt) = Just $ unwords+	[ dValue dom+	, "TXT"+	, txt+	]+genRecord dom (SRV priority weight port target) = Just $ unwords+	[ dValue dom+	, "SRV"+	, val priority+	, val weight+	, val port+	, dValue target+	]+genRecord dom (SSHFP algo hash fingerprint) = Just $ unwords+	[ dValue dom+	, "SSHFP"+	, val algo+	, val hash+	, fingerprint+	] genRecord _ (INCLUDE _) = Nothing  genAddressNoTtl :: BindDomain -> IPAddr -> String@@ -133,10 +171,10 @@ 	IPv6 _ -> genAddress' "AAAA" dom ttl addr  genAddress' :: String -> BindDomain -> Maybe Int -> IPAddr -> String-genAddress' recordtype dom ttl addr = dValue dom ++ " " ++ maybe "" (\ttl' -> val ttl' ++ " ") ttl ++ "IN " ++ recordtype ++ " " ++ val addr--genMX :: BindDomain -> Int -> BindDomain -> String-genMX dom priority dest = dValue dom ++ " " ++ "MX" ++ " " ++ val priority ++ " " ++ dValue dest--genPTR :: BindDomain -> ReverseIP -> String-genPTR dom revip = revip ++ ". " ++ "PTR" ++ " " ++ dValue dom+genAddress' recordtype dom ttl addr = unwords $+	[ dValue dom ]+	++ maybe [] (\ttl' -> [val ttl']) ttl +++	[ "IN"+	, recordtype+	, val addr+	]

@@ -16,11 +16,18 @@ -- | Sets up a shimmed version of the program, in a directory, and -- returns its path. --+-- If the shim was already set up, it's refreshed, in case newer+-- versions of libraries are needed.+-- -- Propellor may be running from an existing shim, in which case it's -- simply reused. setup :: FilePath -> Maybe FilePath -> FilePath -> IO FilePath-setup propellorbin propellorbinpath dest = checkAlreadyShimmed shim $ do+setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do 	createDirectoryIfMissing True dest++	-- Remove all old libraries inside dest, but do not delete the+	-- directory itself, since it may be bind-mounted inside a chroot.+	mapM_ nukeFile =<< dirContentsRecursive dest  	libs <- parseLdd <$> readProcess "ldd" [propellorbin] 	glibclibs <- glibcLibs

@@ -43,6 +43,7 @@ 	, module Propellor.Types.ZFS 	) where +import qualified Data.Semigroup as Sem import Data.Monoid import Control.Applicative import Prelude@@ -212,14 +213,13 @@ instance TightenTargets Property where 	tightenTargets (Property _ d a i c) = Property sing d a i c --- | Any type of Property is a monoid. When properties x and y are+-- | Any type of Property is a Semigroup. When properties x and y are -- appended together, the resulting property has a description like -- "x and y". Note that when x fails to be ensured, it will not -- try to ensure y.-instance SingI metatypes => Monoid (Property (MetaTypes metatypes))+instance SingI metatypes => Sem.Semigroup (Property (MetaTypes metatypes))   where-	mempty = Property sing "noop property" Nothing mempty mempty-	mappend (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) =+	Property _ d1 a1 i1 c1 <> Property _ d2 a2 i2 c2 = 	  	Property sing d (a1 <> a2) (i1 <> i2) (c1 <> c2) 	  where 		-- Avoid including "noop property" in description@@ -230,16 +230,35 @@ 			(Nothing, Just _) -> d2 			(Nothing, Nothing) -> d1 --- | Any type of RevertableProperty is a monoid. When revertable +-- | Any type of Property is a Monoid.+instance SingI metatypes => Monoid (Property (MetaTypes metatypes))+  where+	-- | A property that does nothing.+	mempty = Property sing "noop property" Nothing mempty mempty+	mappend = (Sem.<>)++-- | Any type of RevertableProperty is a Semigroup. When revertable  -- properties x and y are appended together, the resulting revertable -- property has a description like "x and y". -- Note that when x fails to be ensured, it will not try to ensure y. instance-	( Monoid (Property setupmetatypes)-	, Monoid (Property undometatypes)+	( Sem.Semigroup (Property (MetaTypes setupmetatypes))+	, Sem.Semigroup (Property (MetaTypes undometatypes))+	, SingI setupmetatypes+	, SingI undometatypes 	)-	=> Monoid (RevertableProperty setupmetatypes undometatypes)+	=> Sem.Semigroup (RevertableProperty (MetaTypes setupmetatypes) (MetaTypes undometatypes))   where-	mempty = RevertableProperty mempty mempty-	mappend (RevertableProperty s1 u1) (RevertableProperty s2 u2) =+	RevertableProperty s1 u1 <> RevertableProperty s2 u2 = 		RevertableProperty (s1 <> s2) (u2 <> u1)++instance+	( Monoid (Property (MetaTypes setupmetatypes))+	, Monoid (Property (MetaTypes undometatypes))+	, SingI setupmetatypes+	, SingI undometatypes+	)+	=> Monoid (RevertableProperty (MetaTypes setupmetatypes) (MetaTypes undometatypes))+  where+	mempty = RevertableProperty mempty mempty+	mappend = (Sem.<>)

@@ -6,8 +6,10 @@ import Propellor.Types.Empty import Propellor.Types.Info -import Data.Monoid+import qualified Data.Semigroup as Sem import qualified Data.Map as M+import Data.Monoid+import Prelude  data ChrootInfo = ChrootInfo 	{ _chroots :: M.Map FilePath Host@@ -18,13 +20,16 @@ instance IsInfo ChrootInfo where 	propagateInfo _ = PropagateInfo False -instance Monoid ChrootInfo where-	mempty = ChrootInfo mempty mempty-	mappend old new = ChrootInfo+instance Sem.Semigroup ChrootInfo where+	old <> new = ChrootInfo 		{ _chroots = M.union (_chroots old) (_chroots new) 		, _chrootCfg = _chrootCfg old <> _chrootCfg new 		} +instance Monoid ChrootInfo where+	mempty = ChrootInfo mempty mempty+	mappend = (Sem.<>)+ instance Empty ChrootInfo where 	isEmpty i = and 		[ isEmpty (_chroots i)@@ -36,12 +41,15 @@ 	| SystemdNspawnCfg [(String, Bool)] 	deriving (Show, Eq) +instance Sem.Semigroup ChrootCfg where+	v <> NoChrootCfg = v+	NoChrootCfg <> v = v+	SystemdNspawnCfg l1 <> SystemdNspawnCfg l2 =+		SystemdNspawnCfg (l1 <> l2)+ instance Monoid ChrootCfg where 	mempty = NoChrootCfg-	mappend v NoChrootCfg = v-	mappend NoChrootCfg v = v-	mappend (SystemdNspawnCfg l1) (SystemdNspawnCfg l2) =-		SystemdNspawnCfg (l1 <> l2)+	mappend = (Sem.<>)  instance Empty ChrootCfg where 	isEmpty c= c == NoChrootCfg

@@ -10,6 +10,7 @@ import Propellor.Types.Result  import Data.Monoid+import qualified Data.Semigroup as Sem import "mtl" Control.Monad.RWS.Strict import Control.Monad.Catch import Control.Applicative@@ -50,15 +51,18 @@  -- | When two actions are appended together, the second action -- is only run if the first action does not fail.-instance Monoid (Propellor Result) where-	mempty = return NoChange-	mappend x y = do+instance Sem.Semigroup (Propellor Result) where+	x <> y = do 		rx <- x 		case rx of 			FailedChange -> return FailedChange 			_ -> do 				ry <- y 				return (rx <> ry)+	+instance Monoid (Propellor Result) where+	mempty = return NoChange+	mappend = (Sem.<>)  -- | An action that Propellor runs at the end, after trying to satisfy all -- properties. It's passed the combined Result of the entire Propellor run.

@@ -12,6 +12,7 @@ import Data.Word import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.Semigroup as Sem import Data.List import Data.Monoid import Prelude@@ -26,7 +27,7 @@ 	val (IPv6 addr) = addr  newtype AliasesInfo = AliasesInfo (S.Set HostName)-	deriving (Show, Eq, Ord, Monoid, Typeable)+	deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable)  instance IsInfo AliasesInfo where 	propagateInfo _ = PropagateInfo False@@ -42,7 +43,7 @@ -- of the containers in the host be reflected in the DNS. newtype DnsInfoPropagated = DnsInfoPropagated 	{ fromDnsInfoPropagated :: S.Set Record }-	deriving (Show, Eq, Ord, Monoid, Typeable)+	deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable)  toDnsInfoPropagated :: S.Set Record -> DnsInfoPropagated toDnsInfoPropagated = DnsInfoPropagated@@ -55,7 +56,7 @@ -- the host. newtype DnsInfoUnpropagated = DnsInfoUnpropagated 	{ fromDnsInfoUnpropagated :: S.Set Record }-	deriving (Show, Eq, Ord, Monoid, Typeable)+	deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable)  toDnsInfoUnpropagated :: S.Set Record -> DnsInfoUnpropagated toDnsInfoUnpropagated = DnsInfoUnpropagated@@ -183,14 +184,17 @@ -- | Adding a Master NamedConf stanza for a particulr domain always -- overrides an existing Secondary stanza for that domain, while a -- Secondary stanza is only added when there is no existing Master stanza.-instance Monoid NamedConfMap where-	mempty = NamedConfMap M.empty-	mappend (NamedConfMap old) (NamedConfMap new) = NamedConfMap $+instance Sem.Semigroup NamedConfMap where+	NamedConfMap old <> NamedConfMap new = NamedConfMap $ 		M.unionWith combiner new old 	  where 		combiner n o = case (confDnsServerType n, confDnsServerType o) of 			(Secondary, Master) -> o 			_  -> n++instance Monoid NamedConfMap where+	mempty = NamedConfMap M.empty+	mappend = (Sem.<>)  instance Empty NamedConfMap where 	isEmpty (NamedConfMap m) = isEmpty m

@@ -6,8 +6,10 @@ import Propellor.Types.Empty import Propellor.Types.Info -import Data.Monoid+import qualified Data.Semigroup as Sem import qualified Data.Map as M+import Data.Monoid+import Prelude  data DockerInfo = DockerInfo 	{ _dockerRunParams :: [DockerRunParam]@@ -18,12 +20,15 @@ instance IsInfo DockerInfo where 	propagateInfo _ = PropagateInfo False -instance Monoid DockerInfo where-	mempty = DockerInfo mempty mempty-	mappend old new = DockerInfo+instance Sem.Semigroup DockerInfo where+	old <> new = DockerInfo 		{ _dockerRunParams = _dockerRunParams old <> _dockerRunParams new 		, _dockerContainers = M.union (_dockerContainers old) (_dockerContainers new) 		}++instance Monoid DockerInfo where+	mempty = DockerInfo mempty mempty+	mappend = (Sem.<>)  instance Empty DockerInfo where 	isEmpty i = and

@@ -17,6 +17,7 @@ import Data.Dynamic import Data.Maybe import Data.Monoid+import qualified Data.Semigroup as Sem import qualified Data.Typeable as T import Prelude @@ -25,7 +26,7 @@ -- Many different types of data can be contained in the same Info value -- at the same time. See `toInfo` and `fromInfo`. newtype Info = Info [InfoEntry]-	deriving (Monoid, Show)+	deriving (Sem.Semigroup, Monoid, Show)  data InfoEntry where 	InfoEntry :: (IsInfo v, Typeable v) => v -> InfoEntry@@ -80,10 +81,13 @@ data InfoVal v = NoInfoVal | InfoVal v 	deriving (Typeable, Show) +instance Sem.Semigroup (InfoVal v) where+	_ <> v@(InfoVal _) = v+	v <> NoInfoVal = v+ instance Monoid (InfoVal v) where 	mempty = NoInfoVal-	mappend _ v@(InfoVal _) = v-	mappend v NoInfoVal = v+	mappend = (Sem.<>)  instance (Typeable v, Show v) => IsInfo (InfoVal v) where 	propagateInfo _ = PropagateInfo False

@@ -66,7 +66,7 @@ type MetaTypes = Sing  -- This boilerplate would not be needed if the singletons library were--- used. However, we're targeting too old a version of ghc to use it yet.+-- used. data instance Sing (x :: MetaType) where 	OSDebianS :: Sing ('Targeting 'OSDebian) 	OSBuntishS :: Sing ('Targeting 'OSBuntish)

@@ -1,6 +1,7 @@ module Propellor.Types.Result where  import System.Console.ANSI+import qualified Data.Semigroup as Sem import Data.Monoid import Prelude @@ -8,14 +9,16 @@ data Result = NoChange | MadeChange | FailedChange 	deriving (Read, Show, Eq) +instance Sem.Semigroup Result where+	FailedChange <> _ = FailedChange+	_ <> FailedChange = FailedChange+	MadeChange <> _ = MadeChange+	_ <> MadeChange = MadeChange+	NoChange <> NoChange = NoChange+ instance Monoid Result where 	mempty = NoChange--	mappend FailedChange _ = FailedChange-	mappend _ FailedChange = FailedChange-	mappend MadeChange _ = MadeChange-	mappend _ MadeChange = MadeChange-	mappend NoChange NoChange = NoChange+	mappend = (Sem.<>)  class ToResult t where 	toResult :: t -> Result

@@ -14,6 +14,7 @@ import Utility.Monad  import Data.Monoid+import Prelude  -- | This is a `Property` but its `Result` is not accurate; in particular -- it may return `NoChange` despite having made a change. 

@@ -1,4 +1,4 @@ # When updating the resolver here, also update stackResolver in Propellor.DotDir-resolver: lts-8.22+resolver: lts-9.21 packages: - '.'