summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2014-05-31 22:00:11 -0400
committerJoey Hess2014-05-31 22:00:11 -0400
commitcae7e15f569dfe672b1a667e468447f6153ea5f0 (patch)
tree88e6281704df3a85e8e46456f2c06e1173b38a6a /src
parentb0f2478bcbfcf5adc2d6f1692d667d42b108ca04 (diff)
split out DockerAttr
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property/Docker.hs11
-rw-r--r--src/Propellor/Types/Attr.hs50
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))
+ ]