summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/DotDir.hs2
-rw-r--r--src/Propellor/PrivData.hs3
-rw-r--r--src/Propellor/Property/Ccache.hs6
-rw-r--r--src/Propellor/Property/Conductor.hs7
-rw-r--r--src/Propellor/Property/Debootstrap.hs8
-rw-r--r--src/Propellor/Property/DiskImage/PartSpec.hs8
-rw-r--r--src/Propellor/Property/Firewall.hs6
-rw-r--r--src/Propellor/Property/FreeBSD/Pkg.hs6
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs7
-rw-r--r--src/Propellor/Property/Installer/Target.hs6
-rw-r--r--src/Propellor/Property/Mount.hs3
-rw-r--r--src/Propellor/Property/Parted.hs20
-rw-r--r--src/Propellor/Property/Parted/Types.hs23
-rw-r--r--src/Propellor/Property/Ssh.hs17
-rw-r--r--src/Propellor/Types/Chroot.hs21
-rw-r--r--src/Propellor/Types/Core.hs10
-rw-r--r--src/Propellor/Types/Dns.hs16
-rw-r--r--src/Propellor/Types/Docker.hs10
-rw-r--r--src/Propellor/Types/Info.hs10
-rw-r--r--src/Propellor/Types/Result.hs15
20 files changed, 139 insertions, 65 deletions
diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs
index 125cec3f..dc881eeb 100644
--- a/src/Propellor/DotDir.hs
+++ b/src/Propellor/DotDir.hs
@@ -271,7 +271,7 @@ minimalConfig = do
, " 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"
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 516eda03..9b62720f 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -37,6 +37,7 @@ import qualified Data.Set as S
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 @@ makePrivDataDir = createDirectoryIfMissing False privDataDir
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.
diff --git a/src/Propellor/Property/Ccache.hs b/src/Propellor/Property/Ccache.hs
index a2bef117..ebc21b88 100644
--- a/src/Propellor/Property/Ccache.hs
+++ b/src/Propellor/Property/Ccache.hs
@@ -14,6 +14,7 @@ import qualified Propellor.Property.Apt as Apt
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 @@ data Limit
| NoLimit
| Limit :+ Limit
+instance Sem.Semigroup Limit where
+ (<>) = (:+)
+
instance Monoid Limit where
mempty = NoLimit
- mappend = (:+)
+ mappend = (<>)
-- | A string that will be parsed to get a data size.
--
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index cfeb5aa7..1a67402a 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -81,6 +81,7 @@ import Propellor.Types.Info
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 @@ cdesc n = "conducting " ++ n
-- 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 @@ instance IsInfo NotConductorFor where
-- 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
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 7c8e9618..c6e5c373 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -19,12 +19,13 @@ import Utility.FileMode
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 @@ data DebootstrapConfig
| DebootstrapConfig :+ DebootstrapConfig
deriving (Show)
+instance Sem.Semigroup DebootstrapConfig where
+ (<>) = (:+)
+
instance Monoid DebootstrapConfig where
mempty = DefaultConfig
- mappend = (:+)
+ mappend = (<>)
toParams :: DebootstrapConfig -> [CommandParam]
toParams DefaultConfig = []
diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs
index b78e4280..0698d806 100644
--- a/src/Propellor/Property/DiskImage/PartSpec.hs
+++ b/src/Propellor/Property/DiskImage/PartSpec.hs
@@ -43,6 +43,7 @@ import Propellor.Property.Mount
import Data.List (sortBy)
import Data.Ord
+import qualified Data.Semigroup as Sem
-- | Specifies a partition with a given filesystem.
--
@@ -110,7 +111,7 @@ data PartInfoVal
| 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 @@ adjustPartition mp f = pureInfoProperty
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 = (<>)
partLocation :: PartSpec PartLocation -> PartLocation -> PartSpec PartLocation
partLocation (mp, o, p, _) l = (mp, o, p, l)
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index bbc14473..ff7ffebf 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -18,6 +18,7 @@ module Propellor.Property.Firewall (
) where
import Data.Monoid
+import qualified Data.Semigroup as Sem
import Data.Char
import Data.List
@@ -199,6 +200,9 @@ data Rules
infixl 0 :-
+instance Sem.Semigroup Rules where
+ (<>) = (:-)
+
instance Monoid Rules where
mempty = Everything
- mappend = (:-)
+ mappend = (<>)
diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs
index 77bf5768..56ac55fb 100644
--- a/src/Propellor/Property/FreeBSD/Pkg.hs
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -9,6 +9,8 @@ module Propellor.Property.FreeBSD.Pkg where
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 @@ pkgCmd cmd args =
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 @@ update =
`setInfoProperty` (toInfo (PkgUpdate ""))
newtype PkgUpgrade = PkgUpgrade String
- deriving (Typeable, Monoid, Show)
+ deriving (Typeable, Sem.Semigroup, Monoid, Show)
instance IsInfo PkgUpgrade where
propagateInfo _ = PropagateInfo False
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
index 378c5530..cde2a6d3 100644
--- a/src/Propellor/Property/FreeBSD/Poudriere.hs
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -8,17 +8,18 @@ module Propellor.Property.FreeBSD.Poudriere where
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
diff --git a/src/Propellor/Property/Installer/Target.hs b/src/Propellor/Property/Installer/Target.hs
index 80e660ad..54e9075e 100644
--- a/src/Propellor/Property/Installer/Target.hs
+++ b/src/Propellor/Property/Installer/Target.hs
@@ -112,6 +112,7 @@ import Data.List
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 @@ getMountsSizes = mapMaybe (parse . words) . lines <$> readProcess "findmnt" ps "
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 = (<>)
newtype TargetFilledHandle = TargetFilledHandle Integer
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 71f1733e..53129f50 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -10,6 +10,7 @@ import Propellor.Base
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 @@ type MountPoint = FilePath
--
-- For default mount options, use `mempty`.
newtype MountOpts = MountOpts [String]
- deriving Monoid
+ deriving (Sem.Semigroup, Monoid)
class ToMountOpts a where
toMountOpts :: a -> MountOpts
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 81b84972..39ee1723 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -42,6 +42,7 @@ import Propellor.Types.PartSpec (PartSpec)
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 DiskPart = FixedDiskPart | DynamicDiskPart DiskSpaceUse
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 = (<>)
-- | Make a partition use some percentage of the size of the disk
-- (less all fixed size partitions), or the remaining space in the disk.
diff --git a/src/Propellor/Property/Parted/Types.hs b/src/Propellor/Property/Parted/Types.hs
index cfd8760d..5891cc16 100644
--- a/src/Propellor/Property/Parted/Types.hs
+++ b/src/Propellor/Property/Parted/Types.hs
@@ -4,6 +4,9 @@ import qualified Propellor.Property.Partition as Partition
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 @@ instance PartedVal TableType where
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 = (<>)
+
-- | A partition on the disk.
data Partition = Partition
{ partType :: PartType
@@ -80,11 +86,14 @@ fromPartSize :: PartSize -> ByteSize
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 = (<>)
reducePartSize :: PartSize -> PartSize -> PartSize
reducePartSize (MegaBytes a) (MegaBytes b) = MegaBytes (a - b)
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index fd89f97a..05098983 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -45,6 +45,7 @@ import Utility.FileMode
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 @@ newtype HostKeyInfo = HostKeyInfo
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 = (<>)
+
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 @@ newtype UserKeyInfo = UserKeyInfo
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 = (<>)
-- | Sets up a user with the specified public keys, and the corresponding
-- private keys from the privdata.
diff --git a/src/Propellor/Types/Chroot.hs b/src/Propellor/Types/Chroot.hs
index da912120..b27203e5 100644
--- a/src/Propellor/Types/Chroot.hs
+++ b/src/Propellor/Types/Chroot.hs
@@ -7,6 +7,7 @@ import Propellor.Types.Empty
import Propellor.Types.Info
import Data.Monoid
+import qualified Data.Semigroup as Sem
import qualified Data.Map as M
data ChrootInfo = ChrootInfo
@@ -18,13 +19,16 @@ data ChrootInfo = ChrootInfo
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 = (<>)
+
instance Empty ChrootInfo where
isEmpty i = and
[ isEmpty (_chroots i)
@@ -36,12 +40,15 @@ data ChrootCfg
| 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 = (<>)
instance Empty ChrootCfg where
isEmpty c= c == NoChrootCfg
diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs
index a805f561..cd3e09c5 100644
--- a/src/Propellor/Types/Core.hs
+++ b/src/Propellor/Types/Core.hs
@@ -10,6 +10,7 @@ import Propellor.Types.OS
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 @@ instance LiftPropellor IO where
-- | 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 = (<>)
-- | 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.
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index 513f162a..21a4860c 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/src/Propellor/Types/Dns.hs
@@ -12,6 +12,7 @@ import Utility.Split
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 @@ instance ConfigurableValue IPAddr where
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 @@ fromAliasesInfo (AliasesInfo s) = S.toList s
-- 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 @@ instance IsInfo DnsInfoPropagated where
-- 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,15 +184,18 @@ instance IsInfo NamedConfMap where
-- | 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 = (<>)
+
instance Empty NamedConfMap where
isEmpty (NamedConfMap m) = isEmpty m
diff --git a/src/Propellor/Types/Docker.hs b/src/Propellor/Types/Docker.hs
index 6ff340e5..79577591 100644
--- a/src/Propellor/Types/Docker.hs
+++ b/src/Propellor/Types/Docker.hs
@@ -7,6 +7,7 @@ import Propellor.Types.Empty
import Propellor.Types.Info
import Data.Monoid
+import qualified Data.Semigroup as Sem
import qualified Data.Map as M
data DockerInfo = DockerInfo
@@ -18,13 +19,16 @@ data DockerInfo = DockerInfo
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 = (<>)
+
instance Empty DockerInfo where
isEmpty i = and
[ isEmpty (_dockerRunParams i)
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index 06c45ed2..2ab6da7b 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -17,6 +17,7 @@ module Propellor.Types.Info (
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 @@ import Prelude
-- 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 @@ mapInfo f (Info l) = Info (map go l)
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 = (<>)
instance (Typeable v, Show v) => IsInfo (InfoVal v) where
propagateInfo _ = PropagateInfo False
diff --git a/src/Propellor/Types/Result.hs b/src/Propellor/Types/Result.hs
index 5209094b..f552b29b 100644
--- a/src/Propellor/Types/Result.hs
+++ b/src/Propellor/Types/Result.hs
@@ -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 @@ import Prelude
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 = (<>)
class ToResult t where
toResult :: t -> Result