propellor/Propellor/Property/Docker.hs

460 lines
15 KiB
Haskell
Raw Normal View History

2014-04-11 03:20:12 +00:00
{-# LANGUAGE BangPatterns #-}
2014-04-01 19:26:34 +00:00
-- | Docker support for propellor
--
-- The existance of a docker container is just another Property of a system,
-- which propellor can set up. See config.hs for an example.
2014-03-31 03:37:54 +00:00
module Propellor.Property.Docker where
2014-03-31 01:01:18 +00:00
2014-03-31 03:55:59 +00:00
import Propellor
import Propellor.SimpleSh
2014-04-11 03:20:12 +00:00
import Propellor.Types.Attr
2014-03-31 03:37:54 +00:00
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
2014-04-04 01:22:37 +00:00
import qualified Propellor.Property.Docker.Shim as Shim
import Utility.SafeCommand
import Utility.Path
import Control.Concurrent.Async
2014-04-02 00:23:11 +00:00
import System.Posix.Directory
import System.Posix.Process
import Data.List
import Data.List.Utils
2014-03-31 03:59:07 +00:00
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io.
2014-03-31 01:01:18 +00:00
configured :: Property
configured = property "docker configured" go `requires` installed
2014-03-31 01:03:42 +00:00
where
go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $
"/root/.dockercfg" `File.hasContent` (lines cfg)
2014-03-31 01:03:42 +00:00
installed :: Property
installed = Apt.installed ["docker.io"]
2014-04-11 03:20:12 +00:00
-- | A short descriptive name for a container.
-- Should not contain whitespace or other unusual characters,
-- only [a-zA-Z0-9_-] are allowed
type ContainerName = String
-- | Starts accumulating the properties of a Docker container.
--
-- > container "web-server" "debian"
-- > & publish "80:80"
-- > & Apt.installed {"apache2"]
-- > & ...
container :: ContainerName -> Image -> Host
container cn image = Host [] (\_ -> attr)
where
attr = (newAttr (cn2hn cn)) { _dockerImage = Just image }
cn2hn :: ContainerName -> HostName
cn2hn cn = cn ++ ".docker"
2014-04-02 01:53:11 +00:00
-- | Ensures that a docker container is set up and running. The container
-- has its own Properties which are handled by running propellor
-- inside the container.
2014-04-02 16:13:39 +00:00
--
-- Reverting this property ensures that the container is stopped and
-- removed.
2014-04-02 01:53:11 +00:00
docked
2014-04-11 03:20:12 +00:00
:: [Host]
2014-04-02 01:53:11 +00:00
-> ContainerName
2014-04-02 16:13:39 +00:00
-> RevertableProperty
2014-04-11 03:20:12 +00:00
docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
2014-04-10 21:46:03 +00:00
where
go desc a = property (desc ++ " " ++ cn) $ do
2014-04-10 21:46:03 +00:00
hn <- getHostName
let cid = ContainerId hn cn
2014-04-11 03:20:12 +00:00
ensureProperties [findContainer hosts cid cn $ a cid]
2014-04-10 21:46:03 +00:00
2014-04-11 03:20:12 +00:00
setup cid (Container image runparams) =
2014-04-10 21:46:03 +00:00
provisionContainer cid
`requires`
2014-04-11 03:20:12 +00:00
runningContainer cid image runparams
2014-04-10 21:46:03 +00:00
`requires`
installed
2014-04-11 03:20:12 +00:00
teardown cid (Container image _runparams) =
2014-04-10 21:46:03 +00:00
combineProperties ("undocked " ++ fromContainerId cid)
[ stoppedContainer cid
, property ("cleaned up " ++ fromContainerId cid) $
liftIO $ report <$> mapM id
2014-04-03 00:56:02 +00:00
[ removeContainer cid
, removeImage image
]
]
2014-04-02 04:52:39 +00:00
findContainer
2014-04-11 03:20:12 +00:00
:: [Host]
-> ContainerId
2014-04-02 04:52:39 +00:00
-> ContainerName
2014-04-10 21:46:03 +00:00
-> (Container -> Property)
-> Property
2014-04-11 03:20:12 +00:00
findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of
2014-04-10 21:46:03 +00:00
Nothing -> cantfind
2014-04-11 03:20:12 +00:00
Just h -> maybe cantfind mk (mkContainer cid h)
2014-04-02 01:53:11 +00:00
where
cantfind = containerDesc cid $ property "" $ do
2014-04-11 03:20:12 +00:00
liftIO $ warningMessage $
"missing definition for docker container \"" ++ cn2hn cn
2014-04-02 16:13:39 +00:00
return FailedChange
2014-04-11 03:20:12 +00:00
mkContainer :: ContainerId -> Host -> Maybe Container
mkContainer cid@(ContainerId hn _cn) h = Container
<$> _dockerImage attr
<*> pure (map (\a -> a hn) (_dockerRunParams attr))
where
attr = hostAttr h'
h' = h
-- expose propellor directory inside the container
& volume (localdir++":"++localdir)
-- name the container in a predictable way so we
-- and the user can easily find it later
& name (fromContainerId cid)
2014-04-02 03:24:31 +00:00
-- | Causes *any* docker images that are not in use by running containers to
-- be deleted. And deletes any containers that propellor has set up
-- before that are not currently running. Does not delete any containers
-- that were not set up using propellor.
--
-- Generally, should come after the properties for the desired containers.
garbageCollected :: Property
garbageCollected = propertyList "docker garbage collected"
[ gccontainers
, gcimages
]
where
gccontainers = property "docker containers garbage collected" $
liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
gcimages = property "docker images garbage collected" $ do
liftIO $ report <$> (mapM removeImage =<< listImages)
2014-04-02 03:24:31 +00:00
2014-04-11 03:20:12 +00:00
data Container = Container Image [RunParam]
2014-04-02 01:53:11 +00:00
-- | Parameters to pass to `docker run` when creating a container.
type RunParam = String
-- | A docker image, that can be used to run a container.
type Image = String
2014-04-02 01:53:11 +00:00
-- | Set custom dns server for container.
dns :: String -> Property
2014-04-02 01:53:11 +00:00
dns = runProp "dns"
-- | Set container host name.
hostname :: String -> Property
2014-04-02 01:53:11 +00:00
hostname = runProp "hostname"
-- | Set name for container. (Normally done automatically.)
name :: String -> Property
2014-04-02 01:53:11 +00:00
name = runProp "name"
-- | Publish a container's port to the host
-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
publish :: String -> Property
2014-04-02 01:53:11 +00:00
publish = runProp "publish"
-- | Username or UID for container.
user :: String -> Property
2014-04-02 01:53:11 +00:00
user = runProp "user"
2014-04-08 05:21:23 +00:00
-- | Mount a volume
-- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]
-- With just a directory, creates a volume in the container.
volume :: String -> Property
2014-04-02 01:53:11 +00:00
volume = runProp "volume"
2014-04-08 05:21:23 +00:00
-- | Mount a volume from the specified container into the current
-- container.
volumes_from :: ContainerName -> Property
2014-04-08 05:45:19 +00:00
volumes_from cn = genProp "volumes-from" $ \hn ->
2014-04-08 05:21:23 +00:00
fromContainerId (ContainerId hn cn)
2014-04-02 01:53:11 +00:00
-- | Work dir inside the container.
workdir :: String -> Property
2014-04-02 01:53:11 +00:00
workdir = runProp "workdir"
-- | Memory limit for container.
--Format: <number><optional unit>, where unit = b, k, m or g
memory :: String -> Property
2014-04-02 01:53:11 +00:00
memory = runProp "memory"
2014-04-08 05:10:54 +00:00
-- | Link with another container on the same host.
link :: ContainerName -> ContainerAlias -> Property
2014-04-19 05:28:46 +00:00
link linkwith calias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
2014-04-08 05:10:54 +00:00
-- | A short alias for a linked container.
-- Each container has its own alias namespace.
type ContainerAlias = String
-- | A container is identified by its name, and the host
-- on which it's deployed.
data ContainerId = ContainerId HostName ContainerName
deriving (Eq, Read, Show)
2014-04-02 01:53:11 +00:00
-- | Two containers with the same ContainerIdent were started from
-- the same base image (possibly a different version though), and
-- with the same RunParams.
data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
deriving (Read, Show, Eq)
ident2id :: ContainerIdent -> ContainerId
ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn
toContainerId :: String -> Maybe ContainerId
toContainerId s
| myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of
(cn, hn)
| null hn || null cn -> Nothing
| otherwise -> Just $ ContainerId hn cn
| otherwise = Nothing
where
desuffix = reverse . drop len . reverse
len = length myContainerSuffix
fromContainerId :: ContainerId -> String
fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
2014-04-11 04:48:37 +00:00
containerHostName :: ContainerId -> HostName
2014-04-11 04:51:21 +00:00
containerHostName (ContainerId _ cn) = cn2hn cn
2014-04-11 04:48:37 +00:00
myContainerSuffix :: String
myContainerSuffix = ".propellor"
containerDesc :: ContainerId -> Property -> Property
containerDesc cid p = p `describe` desc
where
2014-04-01 21:14:56 +00:00
desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
2014-04-11 03:20:12 +00:00
runningContainer :: ContainerId -> Image -> [RunParam] -> Property
runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
l <- liftIO $ listContainers RunningContainers
if cid `elem` l
then do
2014-04-04 18:55:34 +00:00
-- Check if the ident has changed; if so the
-- parameters of the container differ and it must
-- be restarted.
runningident <- liftIO $ getrunningident
2014-04-04 18:55:34 +00:00
if runningident == Just ident
then noChange
else do
void $ liftIO $ stopContainer cid
2014-04-04 19:47:06 +00:00
restartcontainer
else ifM (liftIO $ elem cid <$> listContainers AllContainers)
2014-04-04 19:47:06 +00:00
( restartcontainer
, go image
)
where
2014-04-01 17:04:24 +00:00
ident = ContainerIdent image hn cn runps
2014-04-04 19:47:06 +00:00
restartcontainer = do
oldimage <- liftIO $ fromMaybe image <$> commitContainer cid
void $ liftIO $ removeContainer cid
2014-04-04 19:47:06 +00:00
go oldimage
2014-04-04 18:55:34 +00:00
getrunningident :: IO (Maybe ContainerIdent)
2014-04-04 19:54:42 +00:00
getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do
2014-04-04 19:58:48 +00:00
let !v = extractident rs
return v
2014-04-04 19:03:03 +00:00
extractident :: [Resp] -> Maybe ContainerIdent
2014-04-04 19:58:48 +00:00
extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
go img = do
liftIO $ do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
shim <- liftIO $ Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
liftIO $ writeFile (identFile cid) (show ident)
2014-04-03 00:56:02 +00:00
ensureProperty $ boolProperty "run" $ runContainer img
(runps ++ ["-i", "-d", "-t"])
2014-04-04 01:22:37 +00:00
[shim, "--docker", fromContainerId cid]
-- | Called when propellor is running inside a docker container.
-- The string should be the container's ContainerId.
--
-- This process is effectively init inside the container.
-- It even needs to wait on zombie processes!
--
-- Fork a thread to run the SimpleSh server in the background.
-- In the foreground, run an interactive bash (or sh) shell,
-- so that the user can interact with it when attached to the container.
2014-04-02 01:53:11 +00:00
--
-- When the system reboots, docker restarts the container, and this is run
-- again. So, to make the necessary services get started on boot, this needs
-- to provision the container then. However, if the container is already
-- being provisioned by the calling propellor, it would be redundant and
-- problimatic to also provisoon it here.
--
-- The solution is a flag file. If the flag file exists, then the container
-- was already provisioned. So, it must be a reboot, and time to provision
-- again. If the flag file doesn't exist, don't provision here.
chain :: String -> IO ()
2014-04-02 02:55:32 +00:00
chain s = case toContainerId s of
Nothing -> error $ "Invalid ContainerId: " ++ s
Just cid -> do
2014-04-02 00:23:11 +00:00
changeWorkingDirectory localdir
writeFile propellorIdent . show =<< readIdentFile cid
2014-04-02 01:53:11 +00:00
-- Run boot provisioning before starting simpleSh,
-- to avoid ever provisioning twice at the same time.
2014-04-04 01:22:37 +00:00
whenM (checkProvisionedFlag cid) $ do
2014-04-04 03:30:23 +00:00
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
2014-04-11 04:48:37 +00:00
unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $
2014-04-02 01:53:11 +00:00
warningMessage "Boot provision failed!"
2014-04-04 22:46:54 +00:00
void $ async $ job reapzombies
void $ async $ job $ simpleSh $ namedPipe cid
job $ do
2014-04-04 22:50:54 +00:00
void $ tryIO $ ifM (inPath "bash")
( boolSystem "bash" [Param "-l"]
, boolSystem "/bin/sh" []
)
putStrLn "Container is still running. Press ^P^Q to detach."
where
2014-04-04 22:46:54 +00:00
job = forever . void . tryIO
reapzombies = void $ getAnyProcessStatus True False
-- | Once a container is running, propellor can be run inside
-- it to provision it.
--
-- Note that there is a race here, between the simplesh
-- server starting up in the container, and this property
-- being run. So, retry connections to the client for up to
-- 1 minute.
provisionContainer :: ContainerId -> Property
provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do
2014-04-04 03:30:23 +00:00
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
2014-04-04 01:22:37 +00:00
r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
2014-04-02 01:53:11 +00:00
when (r /= FailedChange) $
setProvisionedFlag cid
return r
where
2014-04-11 04:48:37 +00:00
params = ["--continue", show $ Chain $ containerHostName cid]
go lastline (v:rest) = case v of
StdoutLine s -> do
2014-04-01 18:33:03 +00:00
debug ["stdout: ", show s]
maybe noop putStrLn lastline
hFlush stdout
go (Just s) rest
StderrLine s -> do
2014-04-01 18:33:03 +00:00
debug ["stderr: ", show s]
maybe noop putStrLn lastline
hFlush stdout
hPutStrLn stderr s
hFlush stderr
go Nothing rest
Done -> ret lastline
go lastline [] = ret lastline
ret lastline = return $ fromMaybe FailedChange $
readish =<< lastline
stopContainer :: ContainerId -> IO Bool
stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
2014-04-03 00:56:02 +00:00
stoppedContainer :: ContainerId -> Property
stoppedContainer cid = containerDesc cid $ property desc $
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
( liftIO cleanup `after` ensureProperty
2014-04-04 01:22:37 +00:00
(boolProperty desc $ stopContainer cid)
2014-04-03 00:56:02 +00:00
, return NoChange
)
where
desc = "stopped"
2014-04-04 01:22:37 +00:00
cleanup = do
nukeFile $ namedPipe cid
nukeFile $ identFile cid
removeDirectoryRecursive $ shimdir cid
clearProvisionedFlag cid
2014-04-02 17:56:16 +00:00
2014-04-02 03:24:31 +00:00
removeContainer :: ContainerId -> IO Bool
removeContainer cid = catchBoolIO $
snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing
removeImage :: Image -> IO Bool
removeImage image = catchBoolIO $
snd <$> processTranscript dockercmd ["rmi", image ] Nothing
2014-04-01 16:54:51 +00:00
runContainer :: Image -> [RunParam] -> [String] -> IO Bool
runContainer image ps cmd = boolSystem dockercmd $ map Param $
2014-04-01 16:54:51 +00:00
"run" : (ps ++ image : cmd)
commitContainer :: ContainerId -> IO (Maybe Image)
commitContainer cid = catchMaybeIO $
takeWhile (/= '\n')
<$> readProcess dockercmd ["commit", fromContainerId cid]
2014-04-01 17:04:24 +00:00
data ContainerFilter = RunningContainers | AllContainers
2014-04-01 16:37:57 +00:00
deriving (Eq)
-- | Only lists propellor managed containers.
2014-04-01 17:04:24 +00:00
listContainers :: ContainerFilter -> IO [ContainerId]
2014-04-01 16:37:57 +00:00
listContainers status =
catMaybes . map toContainerId . concat . map (split ",")
. catMaybes . map (lastMaybe . words) . lines
2014-04-01 16:37:57 +00:00
<$> readProcess dockercmd ps
where
ps
2014-04-01 17:04:24 +00:00
| status == AllContainers = baseps ++ ["--all"]
2014-04-01 16:37:57 +00:00
| otherwise = baseps
baseps = ["ps", "--no-trunc"]
2014-04-02 03:24:31 +00:00
listImages :: IO [Image]
2014-04-02 03:27:52 +00:00
listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
2014-04-02 03:24:31 +00:00
runProp :: String -> RunParam -> Property
runProp field val = pureAttrProperty (param) $ \attr ->
2014-04-11 03:20:12 +00:00
attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
where
param = field++"="++val
genProp :: String -> (HostName -> RunParam) -> Property
genProp field mkval = pureAttrProperty field $ \attr ->
2014-04-11 03:20:12 +00:00
attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
2014-04-08 05:10:54 +00:00
2014-04-02 01:53:11 +00:00
-- | 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.
propellorIdent :: FilePath
propellorIdent = "/.propellor-ident"
2014-04-02 01:53:11 +00:00
-- | Named pipe used for communication with the container.
namedPipe :: ContainerId -> FilePath
2014-04-04 01:22:37 +00:00
namedPipe cid = "docker" </> fromContainerId cid
2014-04-02 01:53:11 +00:00
provisionedFlag :: ContainerId -> FilePath
2014-04-04 01:22:37 +00:00
provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"
2014-04-02 01:53:11 +00:00
clearProvisionedFlag :: ContainerId -> IO ()
clearProvisionedFlag = nukeFile . provisionedFlag
2014-04-02 01:53:11 +00:00
setProvisionedFlag :: ContainerId -> IO ()
setProvisionedFlag cid = do
createDirectoryIfMissing True (takeDirectory (provisionedFlag cid))
writeFile (provisionedFlag cid) "1"
2014-04-02 01:53:11 +00:00
checkProvisionedFlag :: ContainerId -> IO Bool
checkProvisionedFlag = doesFileExist . provisionedFlag
2014-04-04 01:22:37 +00:00
shimdir :: ContainerId -> FilePath
shimdir cid = "docker" </> fromContainerId cid ++ ".shim"
2014-04-02 01:53:11 +00:00
identFile :: ContainerId -> FilePath
2014-04-04 01:22:37 +00:00
identFile cid = "docker" </> fromContainerId cid ++ ".ident"
2014-04-02 01:53:11 +00:00
readIdentFile :: ContainerId -> IO ContainerIdent
readIdentFile cid = fromMaybe (error "bad ident in identFile")
. readish <$> readFile (identFile cid)
2014-04-02 01:53:11 +00:00
dockercmd :: String
dockercmd = "docker.io"
2014-04-02 04:52:39 +00:00
report :: [Bool] -> Result
report rmed
| or rmed = MadeChange
| otherwise = NoChange