From 9228bda32f0a3f6d52e7cc5eb444376e7b024d8c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 23 Apr 2018 13:20:13 -0400 Subject: semigroup monoid change fallout; drop ghc 7 support Fix build with ghc 8.4, which broke due to the Semigroup Monoid change. See https://prime.haskell.org/wiki/Libraries/Proposals/SemigroupMonoid 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. If we indeed drop ghc 7 support entirely, some code to support "jessie" can be removed; concurrent-output can be de-embedded, and the Singletons code can be simplified. This commit was sponsored by Jack Hill on Patreon. --- src/Propellor/Property/Ccache.hs | 6 +++++- src/Propellor/Property/Conductor.hs | 7 ++++--- src/Propellor/Property/Debootstrap.hs | 8 ++++++-- src/Propellor/Property/DiskImage/PartSpec.hs | 8 ++++++-- src/Propellor/Property/Firewall.hs | 6 +++++- src/Propellor/Property/FreeBSD/Pkg.hs | 6 ++++-- src/Propellor/Property/FreeBSD/Poudriere.hs | 7 ++++--- src/Propellor/Property/Installer/Target.hs | 6 +++++- src/Propellor/Property/Mount.hs | 3 ++- src/Propellor/Property/Parted.hs | 20 +++++++++++++------- src/Propellor/Property/Parted/Types.hs | 23 ++++++++++++++++------- src/Propellor/Property/Ssh.hs | 17 ++++++++++++----- 12 files changed, 82 insertions(+), 35 deletions(-) (limited to 'src/Propellor/Property') 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. -- cgit v1.2.3