summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-10-19 12:33:18 -0400
committerJoey Hess2015-10-19 12:33:18 -0400
commitace352cc0aa732d00900122e0ab8552c870f3901 (patch)
tree53e8a1019203a94131592f18e280859108129183 /src
parent10286791b63b198de7d0dc3742f8e1d58113d3f1 (diff)
improve Info type using GADT, at nomeata's suggestion
This makes Show Info work, and simplifies the implementation.
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/PropAccum.hs2
-rw-r--r--src/Propellor/Property/Spin.hs2
-rw-r--r--src/Propellor/Property/Ssh.hs4
-rw-r--r--src/Propellor/Types/Info.hs40
-rw-r--r--src/Propellor/Types/OS.hs4
5 files changed, 30 insertions, 22 deletions
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 1f9459d0..3c50cf32 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -83,6 +83,6 @@ propagateContainer containername c prop = infoProperty
hostprops = map go $ getProperties c
go p =
let i = mapInfo (forceHostContext containername)
- (propigatableInfo (propertyInfo p))
+ (propagatableInfo (propertyInfo p))
cs = map go (propertyChildren p)
in infoProperty (propertyDesc p) (propertySatisfy p) i cs
diff --git a/src/Propellor/Property/Spin.hs b/src/Propellor/Property/Spin.hs
index ead85f59..5f857ef4 100644
--- a/src/Propellor/Property/Spin.hs
+++ b/src/Propellor/Property/Spin.hs
@@ -125,7 +125,7 @@ cdesc n = "controller for " ++ n
-- To detect loops of controlled hosts, each Host's info contains a list
-- of the hosts it's controlling.
newtype Controlling = Controlled [Host]
- deriving (Typeable, Monoid)
+ deriving (Typeable, Monoid, Show)
isControlledBy :: Host -> Controlling -> Bool
h `isControlledBy` (Controlled hs) = any (== hostName h) (map hostName hs)
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index ea38980b..fa07c6f8 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -209,7 +209,7 @@ getHostPubKey = fromHostKeyInfo <$> askInfo
newtype HostKeyInfo = HostKeyInfo
{ fromHostKeyInfo :: M.Map SshKeyType PubKeyText }
- deriving (Eq, Ord, Typeable)
+ deriving (Eq, Ord, Typeable, Show)
instance IsInfo HostKeyInfo where
propagateInfo _ = False
@@ -230,7 +230,7 @@ getUserPubKeys u = maybe [] S.toList . M.lookup u . fromUserKeyInfo <$> askInfo
newtype UserKeyInfo = UserKeyInfo
{ fromUserKeyInfo :: M.Map User (S.Set (SshKeyType, PubKeyText)) }
- deriving (Eq, Ord, Typeable)
+ deriving (Eq, Ord, Typeable, Show)
instance IsInfo UserKeyInfo where
propagateInfo _ = False
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index e94c370e..59cc13e0 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GADTs, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Propellor.Types.Info (
Info,
@@ -6,7 +6,7 @@ module Propellor.Types.Info (
addInfo,
getInfo,
mapInfo,
- propigatableInfo,
+ propagatableInfo,
InfoVal(..),
fromInfoVal,
Typeable,
@@ -17,56 +17,64 @@ import Data.Monoid
import Data.Maybe
-- | Information about a Host, which can be provided by its properties.
-newtype Info = Info [(Dynamic, Bool)]
- deriving (Monoid)
+newtype Info = Info [InfoEntry]
+ deriving (Monoid, Show)
-instance Show Info where
- show (Info l) = "Info " ++ show (map (dynTypeRep . fst) l)
+data InfoEntry where
+ InfoEntry :: (IsInfo v, Typeable v) => v -> InfoEntry
+
+instance Show InfoEntry where
+ show (InfoEntry v) = show v
+
+-- Extracts the value from an InfoEntry but only when
+-- it's of the requested type.
+extractInfoEntry :: Typeable v => InfoEntry -> Maybe v
+extractInfoEntry (InfoEntry v) = fromDynamic (toDyn v)
-- | 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
+class (Typeable v, Monoid v, Show v) => IsInfo v where
-- | Should info of this type be propagated out of a
-- container to its Host?
propagateInfo :: v -> Bool
-- | Any value in the `IsInfo` type class can be added to an Info.
addInfo :: IsInfo v => Info -> v -> Info
-addInfo (Info l) v = Info ((toDyn v, propagateInfo v):l)
+addInfo (Info l) v = Info (InfoEntry v:l)
-- The list is reversed here because addInfo builds it up in reverse order.
getInfo :: IsInfo v => Info -> v
-getInfo (Info l) = mconcat (mapMaybe (fromDynamic . fst) (reverse l))
+getInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l))
-- | Maps a function over all values stored in the Info that are of the
-- appropriate type.
mapInfo :: IsInfo v => (v -> v) -> Info -> Info
mapInfo f (Info l) = Info (map go l)
where
- go (i, p) = case fromDynamic i of
- Nothing -> (i, p)
- Just v -> (toDyn (f v), p)
+ go i = case extractInfoEntry i of
+ Nothing -> i
+ Just v -> InfoEntry (f v)
-- | Filters out parts of the Info that should not propagate out of a
-- container.
-propigatableInfo :: Info -> Info
-propigatableInfo (Info l) = Info (filter snd l)
+propagatableInfo :: Info -> Info
+propagatableInfo (Info l) = Info (filter (\(InfoEntry a) -> propagateInfo a) 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 propagate
-- out of a container.
data InfoVal v = NoInfoVal | InfoVal v
- deriving (Typeable)
+ deriving (Typeable, Show)
instance Monoid (InfoVal v) where
mempty = NoInfoVal
mappend _ v@(InfoVal _) = v
mappend v NoInfoVal = v
-instance Typeable v => IsInfo (InfoVal v) where
+instance (Typeable v, Show v) => IsInfo (InfoVal v) where
propagateInfo _ = False
fromInfoVal :: InfoVal v -> Maybe v
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index b16939c7..447d4396 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -42,10 +42,10 @@ type Architecture = String
type UserName = String
newtype User = User UserName
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Show)
newtype Group = Group String
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Show)
-- | Makes a Group with the same name as the User.
userGroup :: User -> Group