From d1eafb12776d6487ecd48d3991838032a81181d6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 31 May 2014 21:08:50 -0400 Subject: correct order (didn't really cause any breakage) --- src/Propellor/Types/Attr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor/Types/Attr.hs') diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs index 4c891a46..17a02bd2 100644 --- a/src/Propellor/Types/Attr.hs +++ b/src/Propellor/Types/Attr.hs @@ -39,7 +39,7 @@ instance Monoid Attr where Just v -> Just v Nothing -> _sshPubKey old , _dns = _dns new <> _dns old - , _namedconf = _namedconf new <> _namedconf old + , _namedconf = _namedconf old <> _namedconf new , _dockerImage = case _dockerImage new of Just v -> Just v Nothing -> _dockerImage old -- cgit v1.2.3 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(-) (limited to 'src/Propellor/Types/Attr.hs') 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 From d1aaf06f1c30764f26428223840a7d66f255ab47 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 31 May 2014 21:19:07 -0400 Subject: reorder for consistency Onrder does not matter for mappend on set --- src/Propellor/Types/Attr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor/Types/Attr.hs') diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs index 7455c3c3..b41a813b 100644 --- a/src/Propellor/Types/Attr.hs +++ b/src/Propellor/Types/Attr.hs @@ -34,7 +34,7 @@ instance Monoid Attr where mappend old new = Attr { _os = _os old <> _os new , _sshPubKey = _sshPubKey old <> _sshPubKey new - , _dns = _dns new <> _dns old + , _dns = _dns old <> _dns new , _namedconf = _namedconf old <> _namedconf new , _dockerImage = _dockerImage old <> _dockerImage new , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new -- cgit v1.2.3 From cae7e15f569dfe672b1a667e468447f6153ea5f0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 31 May 2014 22:00:11 -0400 Subject: split out DockerAttr --- src/Propellor/Property/Docker.hs | 11 +++++---- src/Propellor/Types/Attr.hs | 50 ++++++++++++++++++++++++---------------- 2 files changed, 37 insertions(+), 24 deletions(-) (limited to 'src/Propellor/Types/Attr.hs') diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index f23738b3..fbf34965 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -72,7 +72,7 @@ type ContainerName = String container :: ContainerName -> Image -> Host container cn image = Host hn [] attr where - attr = mempty { _dockerImage = Val image } + attr = dockerAttr $ mempty { _dockerImage = Val image } hn = cn2hn cn cn2hn :: ContainerName -> HostName @@ -145,7 +145,7 @@ mkContainer cid@(ContainerId hn _cn) h = Container <$> fromVal (_dockerImage attr) <*> pure (map (\a -> a hn) (_dockerRunParams attr)) where - attr = hostAttr h' + attr = _dockerattr $ hostAttr h' h' = h -- expose propellor directory inside the container & volume (localdir++":"++localdir) @@ -443,15 +443,18 @@ listImages :: IO [Image] listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] runProp :: String -> RunParam -> Property -runProp field val = pureAttrProperty (param) $ +runProp field val = pureAttrProperty (param) $ dockerAttr $ mempty { _dockerRunParams = [\_ -> "--"++param] } where param = field++"="++val genProp :: String -> (HostName -> RunParam) -> Property -genProp field mkval = pureAttrProperty field $ +genProp field mkval = pureAttrProperty field $ dockerAttr $ mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] } +dockerAttr :: DockerAttr -> Attr +dockerAttr a = mempty { _dockerattr = a } + -- | The ContainerIdent of a container is written to -- /.propellor-ident inside it. This can be checked to see if -- the container has the same ident later. diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs index b41a813b..e8c22a94 100644 --- a/src/Propellor/Types/Attr.hs +++ b/src/Propellor/Types/Attr.hs @@ -12,32 +12,18 @@ data Attr = Attr , _sshPubKey :: Val String , _dns :: S.Set Dns.Record , _namedconf :: Dns.NamedConfMap - - , _dockerImage :: Val String - , _dockerRunParams :: [HostName -> String] + , _dockerattr :: DockerAttr } - -instance Eq Attr where - x == y = and - [ _os x == _os y - , _dns x == _dns y - , _namedconf x == _namedconf y - , _sshPubKey x == _sshPubKey y - - , _dockerImage x == _dockerImage y - , let simpl v = map (\a -> a "") (_dockerRunParams v) - in simpl x == simpl y - ] + deriving (Eq) instance Monoid Attr where - mempty = Attr mempty mempty mempty mempty mempty mempty + mempty = Attr mempty mempty mempty mempty mempty mappend old new = Attr { _os = _os old <> _os new , _sshPubKey = _sshPubKey old <> _sshPubKey new , _dns = _dns old <> _dns new , _namedconf = _namedconf old <> _namedconf new - , _dockerImage = _dockerImage old <> _dockerImage new - , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new + , _dockerattr = _dockerattr old <> _dockerattr new } instance Show Attr where @@ -46,8 +32,7 @@ instance Show Attr where , "sshPubKey " ++ show (_sshPubKey a) , "dns " ++ show (_dns a) , "namedconf " ++ show (_namedconf a) - , "docker image " ++ show (_dockerImage a) - , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) + , show (_dockerattr a) ] data Val a = Val a | NoVal @@ -62,3 +47,28 @@ instance Monoid (Val a) where fromVal :: Val a -> Maybe a fromVal (Val a) = Just a fromVal NoVal = Nothing + +data DockerAttr = DockerAttr + { _dockerImage :: Val String + , _dockerRunParams :: [HostName -> String] + } + +instance Eq DockerAttr where + x == y = and + [ _dockerImage x == _dockerImage y + , let simpl v = map (\a -> a "") (_dockerRunParams v) + in simpl x == simpl y + ] + +instance Monoid DockerAttr where + mempty = DockerAttr mempty mempty + mappend old new = DockerAttr + { _dockerImage = _dockerImage old <> _dockerImage new + , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new + } + +instance Show DockerAttr where + show a = unlines + [ "docker image " ++ show (_dockerImage a) + , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) + ] -- cgit v1.2.3