summaryrefslogtreecommitdiff
path: root/src/Propellor/Types
diff options
context:
space:
mode:
authorJoey Hess2015-09-06 08:19:02 -0700
committerJoey Hess2015-09-06 16:13:54 -0400
commitdef53b64cc17b95eb5729dd97a800dfe1257b352 (patch)
tree03f63e5bcb6486b00639e1ea78c21d8928c3b8ca /src/Propellor/Types
parent6f4024f5307a81f26f5e6bf86b84c7363219cb3d (diff)
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.
Diffstat (limited to 'src/Propellor/Types')
-rw-r--r--src/Propellor/Types/Chroot.hs20
-rw-r--r--src/Propellor/Types/Dns.hs34
-rw-r--r--src/Propellor/Types/Docker.hs18
-rw-r--r--src/Propellor/Types/Info.hs67
-rw-r--r--src/Propellor/Types/OS.hs5
-rw-r--r--src/Propellor/Types/Val.hs22
6 files changed, 129 insertions, 37 deletions
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