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(-) 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