From 7c4b1537391d801855e28a61c896efcc70cfaa81 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 31 May 2014 21:18:36 -0400 Subject: simplify monoid instance with some helper types --- src/Propellor/Attr.hs | 11 +++++++---- src/Propellor/Property/Docker.hs | 4 ++-- src/Propellor/Types/Attr.hs | 33 ++++++++++++++++++++------------- 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 -- cgit v1.2.3