From def53b64cc17b95eb5729dd97a800dfe1257b352 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Sep 2015 08:19:02 -0700 Subject: Added Propellor.Property.Rsync. WIP; untested 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. --- src/Propellor/Types/Chroot.hs | 20 +++++++++---- src/Propellor/Types/Dns.hs | 34 ++++++++++++++++++++-- src/Propellor/Types/Docker.hs | 18 ++++++++---- src/Propellor/Types/Info.hs | 67 +++++++++++++++++++++++++++++++++++++++++++ src/Propellor/Types/OS.hs | 5 +++- src/Propellor/Types/Val.hs | 22 -------------- 6 files changed, 129 insertions(+), 37 deletions(-) create mode 100644 src/Propellor/Types/Info.hs delete mode 100644 src/Propellor/Types/Val.hs (limited to 'src/Propellor/Types') diff --git a/src/Propellor/Types/Chroot.hs b/src/Propellor/Types/Chroot.hs index d37d34c7..d92c7070 100644 --- a/src/Propellor/Types/Chroot.hs +++ b/src/Propellor/Types/Chroot.hs @@ -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 IsInfo ChrootInfo where + propigateInfo _ = False -instance Monoid (ChrootInfo host) where +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) diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs index 50297f57..d78c78fd 100644 --- a/src/Propellor/Types/Dns.hs +++ b/src/Propellor/Types/Dns.hs @@ -1,11 +1,15 @@ +{-# 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 type Domain = String @@ -16,6 +20,29 @@ fromIPAddr :: IPAddr -> String 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,7 +91,7 @@ data Record | SRV Word16 Word16 Word16 BindDomain | SSHFP Int Int String | INCLUDE FilePath - deriving (Read, Show, Eq, Ord) + deriving (Read, Show, Eq, Ord, Typeable) getIPAddr :: Record -> Maybe IPAddr getIPAddr (Address addr) = Just addr @@ -97,7 +124,10 @@ domainHostName (AbsDomain d) = Just d 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 diff --git a/src/Propellor/Types/Docker.hs b/src/Propellor/Types/Docker.hs index 3eafa59d..a1ed4cd9 100644 --- a/src/Propellor/Types/Docker.hs +++ b/src/Propellor/Types/Docker.hs @@ -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 IsInfo DockerInfo where + propigateInfo _ = False -instance Monoid (DockerInfo h) where +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) diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs new file mode 100644 index 00000000..d5c463c3 --- /dev/null +++ b/src/Propellor/Types/Info.hs @@ -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 (length 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 diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs index c46d9a28..eb6b5171 100644 --- a/src/Propellor/Types/OS.hs +++ b/src/Propellor/Types/OS.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable #-} + module Propellor.Types.OS ( System(..), Distribution(..), @@ -14,10 +16,11 @@ module Propellor.Types.OS ( ) 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 diff --git a/src/Propellor/Types/Val.hs b/src/Propellor/Types/Val.hs deleted file mode 100644 index 8890bee8..00000000 --- a/src/Propellor/Types/Val.hs +++ /dev/null @@ -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 -- cgit v1.2.3 From 581a87cad226c1e1c3fbe6a8cbd52c65bd3baef5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Sep 2015 22:36:38 -0400 Subject: better Show for Info --- src/Propellor/Types/Info.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor/Types') diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index d5c463c3..a80bb681 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -21,7 +21,7 @@ import Data.Maybe data Info = Info [(Dynamic, Bool)] instance Show Info where - show (Info l) = "Info " ++ show (length l) + show (Info l) = "Info " ++ show (map (dynTypeRep . fst) l) instance Monoid Info where mempty = Info [] -- cgit v1.2.3