summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Docker.hs
diff options
context:
space:
mode:
authorJoey Hess2016-03-26 21:38:39 -0400
committerJoey Hess2016-03-26 21:38:39 -0400
commit46fc5467e633a9c1f149cb0cd7ee03af1e9e0aa1 (patch)
tree85d0136a1bc612a998259ab8690d20916d5ba704 /src/Propellor/Property/Docker.hs
parent530b0dde35e143df1ba8cb8f4828e0a3bc0b4ffb (diff)
ported docker
Also, implemented modifyHostProps to add properties to an existing host. Using it bypasses some type safety. Its use in docker is safe though. But, in Conductor, the use of it was not really safe, because it was used with a DebianLike property. Fixed that by making Ssh.installed target all unix's, although it will fail on non-DebianLike ones.
Diffstat (limited to 'src/Propellor/Property/Docker.hs')
-rw-r--r--src/Propellor/Property/Docker.hs111
1 files changed, 62 insertions, 49 deletions
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index fe1e3b18..041e1987 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
-- | Docker support for propellor
--
@@ -50,6 +50,7 @@ import Propellor.Types.Docker
import Propellor.Types.Container
import Propellor.Types.CmdLine
import Propellor.Types.Info
+import Propellor.Container
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cmd as Cmd
@@ -71,11 +72,12 @@ installed = Apt.installed ["docker.io"]
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io. Optional.
-configured :: Property DebianLike
+configured :: Property (HasInfo + DebianLike)
configured = prop `requires` installed
where
+ prop :: Property (HasInfo + DebianLike)
prop = withPrivData src anyContext $ \getcfg ->
- property "docker configured" $ getcfg $ \cfg -> ensureProperty $
+ property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $
"/root/.dockercfg" `File.hasContent` privDataLines cfg
src = PrivDataSourceFileFromCommand DockerAuthentication
"/root/.dockercfg" "docker login"
@@ -88,6 +90,10 @@ type ContainerName = String
-- | A docker container.
data Container = Container Image Host
+instance IsContainer Container where
+ containerProperties (Container _ h) = containerProperties h
+ containerInfo (Container _ h) = containerInfo h
+
class HasImage a where
getImageName :: a -> Image
@@ -104,7 +110,7 @@ instance HasImage Container where
-- > & publish "80:80"
-- > & Apt.installed {"apache2"]
-- > & ...
-container :: ContainerName -> Image -> Props -> Container
+container :: ContainerName -> Image -> Props metatypes -> Container
container cn image (Props ps) = Container image (Host cn ps info)
where
info = dockerInfo mempty <> mconcat (map getInfoRecursive ps)
@@ -119,7 +125,7 @@ container cn image (Props ps) = Container image (Host cn ps info)
--
-- Reverting this property ensures that the container is stopped and
-- removed.
-docked :: Container -> RevertableProperty HasInfo
+docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
docked ctr@(Container _ h) =
(propagateContainerInfo ctr (go "docked" setup))
<!>
@@ -127,11 +133,12 @@ docked ctr@(Container _ h) =
where
cn = hostName h
- go desc a = property (desc ++ " " ++ cn) $ do
+ go desc a = property' (desc ++ " " ++ cn) $ \w -> do
hn <- asks hostName
let cid = ContainerId hn cn
- ensureChildProperties [a cid (mkContainerInfo cid ctr)]
+ ensureProperty w $ a cid (mkContainerInfo cid ctr)
+ setup :: ContainerId -> ContainerInfo -> Property Linux
setup cid (ContainerInfo image runparams) =
provisionContainer cid
`requires`
@@ -139,8 +146,9 @@ docked ctr@(Container _ h) =
`requires`
installed
+ teardown :: ContainerId -> ContainerInfo -> Property Linux
teardown cid (ContainerInfo image _runparams) =
- combineProperties ("undocked " ++ fromContainerId cid)
+ combineProperties ("undocked " ++ fromContainerId cid) $ toProps
[ stoppedContainer cid
, property ("cleaned up " ++ fromContainerId cid) $
liftIO $ report <$> mapM id
@@ -151,31 +159,31 @@ docked ctr@(Container _ h) =
-- | Build the image from a directory containing a Dockerfile.
imageBuilt :: HasImage c => FilePath -> c -> Property Linux
-imageBuilt directory ctr = describe built msg
+imageBuilt directory ctr = built `describe` msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory
- built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
- `assume` MadeChange
+ built :: Property Linux
+ built = tightenTargets $
+ Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
+ `assume` MadeChange
workDir p = p { cwd = Just directory }
image = getImageName ctr
-- | Pull the image from the standard Docker Hub registry.
imagePulled :: HasImage c => c -> Property Linux
-imagePulled ctr = describe pulled msg
+imagePulled ctr = pulled `describe` msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " pulled"
- pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
- `assume` MadeChange
+ pulled :: Property Linux
+ pulled = tightenTargets $
+ Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
+ `assume` MadeChange
image = getImageName ctr
-propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property (HasInfo + Linux)
-propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
+propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
+propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $
+ p `addInfoProperty'` dockerinfo
where
- p' = infoProperty
- (getDesc p)
- (getSatisfy p)
- (getInfo p <> dockerinfo)
- (propertyChildren p)
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton cn h }
cn = hostName h
@@ -187,7 +195,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
(_dockerRunParams info)
info = fromInfo $ hostInfo h'
- h' = h
+ h' = modifyHostProps h $ hostProps h
-- Restart by default so container comes up on
-- boot or when docker is upgraded.
&^ restartAlways
@@ -209,8 +217,10 @@ garbageCollected = propertyList "docker garbage collected" $ props
& gccontainers
& gcimages
where
+ gccontainers :: Property Linux
gccontainers = property "docker containers garbage collected" $
liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
+ gcimages :: Property Linux
gcimages = property "docker images garbage collected" $
liftIO $ report <$> (mapM removeImage =<< listImages)
@@ -220,7 +230,7 @@ garbageCollected = propertyList "docker garbage collected" $ props
-- the pam config, to work around <https://github.com/docker/docker/issues/5663>
-- which affects docker 1.2.0.
tweaked :: Property Linux
-tweaked = cmdProperty "sh"
+tweaked = tightenTargets $ cmdProperty "sh"
[ "-c"
, "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
]
@@ -234,9 +244,10 @@ tweaked = cmdProperty "sh"
--
-- Only takes effect after reboot. (Not automated.)
memoryLimited :: Property DebianLike
-memoryLimited = "/etc/default/grub" `File.containsLine` cfg
- `describe` "docker memory limited"
- `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
+memoryLimited = tightenTargets $
+ "/etc/default/grub" `File.containsLine` cfg
+ `describe` "docker memory limited"
+ `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
where
cmdline = "cgroup_enable=memory swapaccount=1"
cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
@@ -294,15 +305,15 @@ instance ImageIdentifier ImageUID where
imageIdentifier (ImageUID uid) = uid
-- | Set custom dns server for container.
-dns :: String -> Property HasInfo
+dns :: String -> Property (HasInfo + Linux)
dns = runProp "dns"
-- | Set container host name.
-hostname :: String -> Property HasInfo
+hostname :: String -> Property (HasInfo + Linux)
hostname = runProp "hostname"
-- | Set name of container.
-name :: String -> Property HasInfo
+name :: String -> Property (HasInfo + Linux)
name = runProp "name"
class Publishable p where
@@ -316,15 +327,15 @@ instance Publishable String where
toPublish = id
-- | Publish a container's port to the host
-publish :: Publishable p => p -> Property HasInfo
+publish :: Publishable p => p -> Property (HasInfo + Linux)
publish = runProp "publish" . toPublish
-- | Expose a container's port without publishing it.
-expose :: String -> Property HasInfo
+expose :: String -> Property (HasInfo + Linux)
expose = runProp "expose"
-- | Username or UID for container.
-user :: String -> Property HasInfo
+user :: String -> Property (HasInfo + Linux)
user = runProp "user"
class Mountable p where
@@ -340,17 +351,17 @@ instance Mountable String where
toMount = id
-- | Mount a volume
-volume :: Mountable v => v -> Property HasInfo
+volume :: Mountable v => v -> Property (HasInfo + Linux)
volume = runProp "volume" . toMount
-- | Mount a volume from the specified container into the current
-- container.
-volumes_from :: ContainerName -> Property HasInfo
+volumes_from :: ContainerName -> Property (HasInfo + Linux)
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
-- | Work dir inside the container.
-workdir :: String -> Property HasInfo
+workdir :: String -> Property (HasInfo + Linux)
workdir = runProp "workdir"
-- | Memory limit for container.
@@ -358,18 +369,18 @@ workdir = runProp "workdir"
--
-- Note: Only takes effect when the host has the memoryLimited property
-- enabled.
-memory :: String -> Property HasInfo
+memory :: String -> Property (HasInfo + Linux)
memory = runProp "memory"
-- | CPU shares (relative weight).
--
-- By default, all containers run at the same priority, but you can tell
-- the kernel to give more CPU time to a container using this property.
-cpuShares :: Int -> Property HasInfo
+cpuShares :: Int -> Property (HasInfo + Linux)
cpuShares = runProp "cpu-shares" . show
-- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> Property HasInfo
+link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux)
link linkwith calias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
@@ -381,24 +392,24 @@ type ContainerAlias = String
-- propellor; as well as keeping badly behaved containers running,
-- it ensures that containers get started back up after reboot or
-- after docker is upgraded.
-restartAlways :: Property HasInfo
+restartAlways :: Property (HasInfo + Linux)
restartAlways = runProp "restart" "always"
-- | Docker will restart the container if it exits nonzero.
-- If a number is provided, it will be restarted only up to that many
-- times.
-restartOnFailure :: Maybe Int -> Property HasInfo
+restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
restartOnFailure Nothing = runProp "restart" "on-failure"
restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
-- | Makes docker not restart a container when it exits
-- Note that this includes not restarting it on boot!
-restartNever :: Property HasInfo
+restartNever :: Property (HasInfo + Linux)
restartNever = runProp "restart" "no"
-- | Set environment variable with a tuple composed by the environment
-- variable name and its value.
-environment :: (String, String) -> Property HasInfo
+environment :: (String, String) -> Property (HasInfo + Linux)
environment (k, v) = runProp "env" $ k ++ "=" ++ v
-- | A container is identified by its name, and the host
@@ -501,6 +512,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
retry (n-1) a
_ -> return v
+ go :: ImageIdentifier i => i -> Propellor Result
go img = liftIO $ do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
@@ -592,14 +604,15 @@ startContainer :: ContainerId -> IO Bool
startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
stoppedContainer :: ContainerId -> Property Linux
-stoppedContainer cid = containerDesc cid $ property' desc $ \o ->
+stoppedContainer cid = containerDesc cid $ property' desc $ \w ->
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
- ( liftIO cleanup `after` ensureProperty o
- (property desc $ liftIO $ toResult <$> stopContainer cid)
+ ( liftIO cleanup `after` ensureProperty w stop
, return NoChange
)
where
desc = "stopped"
+ stop :: Property Linux
+ stop = property desc $ liftIO $ toResult <$> stopContainer cid
cleanup = do
nukeFile $ identFile cid
removeDirectoryRecursive $ shimdir cid
@@ -643,14 +656,14 @@ listContainers status =
listImages :: IO [ImageUID]
listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
-runProp :: String -> RunParam -> Property HasInfo
-runProp field val = pureInfoProperty (param) $
+runProp :: String -> RunParam -> Property (HasInfo + Linux)
+runProp field val = tightenTargets $ pureInfoProperty (param) $
mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where
param = field++"="++val
-genProp :: String -> (HostName -> RunParam) -> Property HasInfo
-genProp field mkval = pureInfoProperty field $
+genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
+genProp field mkval = tightenTargets $ pureInfoProperty field $
mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
dockerInfo :: DockerInfo -> Info