summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2014-05-31 21:18:36 -0400
committerJoey Hess2014-05-31 21:18:36 -0400
commit7c4b1537391d801855e28a61c896efcc70cfaa81 (patch)
tree010b433c4f9eae6f0336ad0735f2893cf0a7498e /src
parentd1eafb12776d6487ecd48d3991838032a81181d6 (diff)
simplify monoid instance with some helper types
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Attr.hs11
-rw-r--r--src/Propellor/Property/Docker.hs4
-rw-r--r--src/Propellor/Types/Attr.hs33
3 files changed, 29 insertions, 19 deletions
diff --git a/src/Propellor/Attr.hs b/src/Propellor/Attr.hs
index 29d7a01e..3ed59437 100644
--- a/src/Propellor/Attr.hs
+++ b/src/Propellor/Attr.hs
@@ -15,12 +15,15 @@ import Control.Applicative
pureAttrProperty :: Desc -> Attr -> Property
pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
+askAttr :: (Attr -> Val a) -> Propellor (Maybe a)
+askAttr f = asks (fromVal . f . hostAttr)
+
os :: System -> Property
os system = pureAttrProperty ("Operating " ++ show system) $
- mempty { _os = Just system }
+ mempty { _os = Val system }
getOS :: Propellor (Maybe System)
-getOS = asks (_os . hostAttr)
+getOS = askAttr _os
-- | Indidate that a host has an A record in the DNS.
--
@@ -55,10 +58,10 @@ addDNS r = pureAttrProperty (rdesc r) $
sshPubKey :: String -> Property
sshPubKey k = pureAttrProperty ("ssh pubkey known") $
- mempty { _sshPubKey = Just k }
+ mempty { _sshPubKey = Val k }
getSshPubKey :: Propellor (Maybe String)
-getSshPubKey = asks (_sshPubKey . hostAttr)
+getSshPubKey = askAttr _sshPubKey
hostMap :: [Host] -> M.Map HostName Host
hostMap l = M.fromList $ zip (map hostName l) l
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 8e081ae4..ce10d318 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -48,7 +48,7 @@ type ContainerName = String
container :: ContainerName -> Image -> Host
container cn image = Host hn [] attr
where
- attr = mempty { _dockerImage = Just image }
+ attr = mempty { _dockerImage = Val image }
hn = cn2hn cn
cn2hn :: ContainerName -> HostName
@@ -116,7 +116,7 @@ findContainer mhost cid cn mk = case mhost of
mkContainer :: ContainerId -> Host -> Maybe Container
mkContainer cid@(ContainerId hn _cn) h = Container
- <$> _dockerImage attr
+ <$> fromVal (_dockerImage attr)
<*> pure (map (\a -> a hn) (_dockerRunParams attr))
where
attr = hostAttr h'
diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs
index 17a02bd2..7455c3c3 100644
--- a/src/Propellor/Types/Attr.hs
+++ b/src/Propellor/Types/Attr.hs
@@ -8,12 +8,12 @@ import Data.Monoid
-- | The attributes of a host.
data Attr = Attr
- { _os :: Maybe System
- , _sshPubKey :: Maybe String
+ { _os :: Val System
+ , _sshPubKey :: Val String
, _dns :: S.Set Dns.Record
, _namedconf :: Dns.NamedConfMap
- , _dockerImage :: Maybe String
+ , _dockerImage :: Val String
, _dockerRunParams :: [HostName -> String]
}
@@ -30,19 +30,13 @@ instance Eq Attr where
]
instance Monoid Attr where
- mempty = Attr Nothing Nothing mempty mempty Nothing mempty
+ mempty = Attr mempty mempty mempty mempty mempty mempty
mappend old new = Attr
- { _os = case _os new of
- Just v -> Just v
- Nothing -> _os old
- , _sshPubKey = case _sshPubKey new of
- Just v -> Just v
- Nothing -> _sshPubKey old
+ { _os = _os old <> _os new
+ , _sshPubKey = _sshPubKey old <> _sshPubKey new
, _dns = _dns new <> _dns old
, _namedconf = _namedconf old <> _namedconf new
- , _dockerImage = case _dockerImage new of
- Just v -> Just v
- Nothing -> _dockerImage old
+ , _dockerImage = _dockerImage old <> _dockerImage new
, _dockerRunParams = _dockerRunParams old <> _dockerRunParams new
}
@@ -55,3 +49,16 @@ instance Show Attr where
, "docker image " ++ show (_dockerImage a)
, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
]
+
+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
+
+fromVal :: Val a -> Maybe a
+fromVal (Val a) = Just a
+fromVal NoVal = Nothing