propellor/Propellor/Property/Docker.hs

477 lines
16 KiB
Haskell

{-# LANGUAGE RankNTypes, BangPatterns #-}
-- | 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.
module Propellor.Property.Docker where
import Propellor
import Propellor.SimpleSh
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Docker.Shim as Shim
import Utility.SafeCommand
import Utility.Path
import Control.Concurrent.Async
import System.Posix.Directory
import System.Posix.Process
import Data.List
import Data.List.Utils
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io.
configured :: Property
configured = Property "docker configured" go `requires` installed
where
go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $
"/root/.dockercfg" `File.hasContent` (lines cfg)
installed :: Property
installed = Apt.installed ["docker.io"]
-- | 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.
--
-- Reverting this property ensures that the container is stopped and
-- removed.
docked
:: (HostName -> ContainerName -> Maybe (Container))
-> HostName
-> ContainerName
-> RevertableProperty
docked findc hn cn = findContainer findc hn cn $
\(Container image containerprops) ->
let setup = provisionContainer cid
`requires`
runningContainer cid image containerprops
`requires`
installed
teardown = combineProperties ("undocked " ++ fromContainerId cid)
[ stoppedContainer cid
, Property ("cleaned up " ++ fromContainerId cid) $
report <$> mapM id
[ removeContainer cid
, removeImage image
]
]
in RevertableProperty setup teardown
where
cid = ContainerId hn cn
findContainer
:: (HostName -> ContainerName -> Maybe (Container))
-> HostName
-> ContainerName
-> (Container -> RevertableProperty)
-> RevertableProperty
findContainer findc hn cn mk = case findc hn cn of
Nothing -> RevertableProperty cantfind cantfind
Just container -> mk container
where
cid = ContainerId hn cn
cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do
warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
return FailedChange
-- | 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" $
report <$> (mapM removeContainer =<< listContainers AllContainers)
gcimages = Property "docker images garbage collected" $ do
report <$> (mapM removeImage =<< listImages)
-- | Pass to defaultMain to add docker containers.
-- You need to provide the function mapping from
-- HostName and ContainerName to the Container to use.
containerProperties
:: (HostName -> ContainerName -> Maybe (Container))
-> (HostName -> Maybe [Property])
containerProperties findcontainer = \h -> case toContainerId h of
Nothing -> Nothing
Just cid@(ContainerId hn cn) ->
case findcontainer hn cn of
Nothing -> Nothing
Just (Container _ cprops) ->
Just $ map (containerDesc cid) $
fromContainerized cprops
-- | This type is used to configure a docker container.
-- It has an image, and a list of Properties, but these
-- properties are Containerized; they can specify
-- things about the container's configuration, in
-- addition to properties of the system inside the
-- container.
data Container = Container Image [Containerized Property]
data Containerized a = Containerized [HostName -> RunParam] a
-- | 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
-- | 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
-- | Lift a Property to apply inside a container.
inside1 :: Property -> Containerized Property
inside1 = Containerized []
inside :: [Property] -> Containerized Property
inside = Containerized [] . combineProperties "provision"
-- | Set custom dns server for container.
dns :: String -> Containerized Property
dns = runProp "dns"
-- | Set container host name.
hostname :: String -> Containerized Property
hostname = runProp "hostname"
-- | Set name for container. (Normally done automatically.)
name :: String -> Containerized Property
name = runProp "name"
-- | Publish a container's port to the host
-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
publish :: String -> Containerized Property
publish = runProp "publish"
-- | Username or UID for container.
user :: String -> Containerized Property
user = runProp "user"
-- | 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 -> Containerized Property
volume = runProp "volume"
-- | Mount a volume from the specified container into the current
-- container.
volumes_from :: ContainerName -> Containerized Property
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
-- | Work dir inside the container.
workdir :: String -> Containerized Property
workdir = runProp "workdir"
-- | Memory limit for container.
--Format: <number><optional unit>, where unit = b, k, m or g
memory :: String -> Containerized Property
memory = runProp "memory"
-- | Link with another container on the same host.
link :: ContainerName -> ContainerAlias -> Containerized Property
link linkwith alias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias
-- | 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)
-- | 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)
getRunParams :: HostName -> [Containerized a] -> [RunParam]
getRunParams hn l = concatMap get l
where
get (Containerized ps _) = map (\a -> a hn ) ps
fromContainerized :: forall a. [Containerized a] -> [a]
fromContainerized l = map get l
where
get (Containerized _ a) = a
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
myContainerSuffix :: String
myContainerSuffix = ".propellor"
containerFrom :: Image -> [Containerized Property] -> Container
containerFrom = Container
containerDesc :: ContainerId -> Property -> Property
containerDesc cid p = p `describe` desc
where
desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property
runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc cid $ Property "running" $ do
l <- listContainers RunningContainers
if cid `elem` l
then do
-- Check if the ident has changed; if so the
-- parameters of the container differ and it must
-- be restarted.
runningident <- getrunningident
if runningident == Just ident
then return NoChange
else do
void $ stopContainer cid
restartcontainer
else ifM (elem cid <$> listContainers AllContainers)
( restartcontainer
, go image
)
where
ident = ContainerIdent image hn cn runps
restartcontainer = do
oldimage <- fromMaybe image <$> commitContainer cid
void $ removeContainer cid
go oldimage
getrunningident :: IO (Maybe ContainerIdent)
getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do
let !v = extractident rs
return v
extractident :: [Resp] -> Maybe ContainerIdent
extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
runps = getRunParams hn $ containerprops ++
-- 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)
]
go img = do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
shim <- Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
writeFile (identFile cid) (show ident)
ensureProperty $ boolProperty "run" $ runContainer img
(runps ++ ["-i", "-d", "-t"])
[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.
--
-- 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 ()
chain s = case toContainerId s of
Nothing -> error $ "Invalid ContainerId: " ++ s
Just cid -> do
changeWorkingDirectory localdir
writeFile propellorIdent . show =<< readIdentFile cid
-- Run boot provisioning before starting simpleSh,
-- to avoid ever provisioning twice at the same time.
whenM (checkProvisionedFlag cid) $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ fromContainerId cid]) $
warningMessage "Boot provision failed!"
void $ async $ job reapzombies
void $ async $ job $ simpleSh $ namedPipe cid
job $ do
void $ tryIO $ ifM (inPath "bash")
( boolSystem "bash" [Param "-l"]
, boolSystem "/bin/sh" []
)
putStrLn "Container is still running. Press ^P^Q to detach."
where
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" $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
when (r /= FailedChange) $
setProvisionedFlag cid
return r
where
params = ["--continue", show $ Chain $ fromContainerId cid]
go lastline (v:rest) = case v of
StdoutLine s -> do
debug ["stdout: ", show s]
maybe noop putStrLn lastline
hFlush stdout
go (Just s) rest
StderrLine s -> do
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 ]
stoppedContainer :: ContainerId -> Property
stoppedContainer cid = containerDesc cid $ Property desc $
ifM (elem cid <$> listContainers RunningContainers)
( cleanup `after` ensureProperty
(boolProperty desc $ stopContainer cid)
, return NoChange
)
where
desc = "stopped"
cleanup = do
nukeFile $ namedPipe cid
nukeFile $ identFile cid
removeDirectoryRecursive $ shimdir cid
clearProvisionedFlag cid
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
runContainer :: Image -> [RunParam] -> [String] -> IO Bool
runContainer image ps cmd = boolSystem dockercmd $ map Param $
"run" : (ps ++ image : cmd)
commitContainer :: ContainerId -> IO (Maybe Image)
commitContainer cid = catchMaybeIO $
takeWhile (/= '\n')
<$> readProcess dockercmd ["commit", fromContainerId cid]
data ContainerFilter = RunningContainers | AllContainers
deriving (Eq)
-- | Only lists propellor managed containers.
listContainers :: ContainerFilter -> IO [ContainerId]
listContainers status =
catMaybes . map toContainerId . concat . map (split ",")
. catMaybes . map (lastMaybe . words) . lines
<$> readProcess dockercmd ps
where
ps
| status == AllContainers = baseps ++ ["--all"]
| otherwise = baseps
baseps = ["ps", "--no-trunc"]
listImages :: IO [Image]
listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
runProp :: String -> RunParam -> Containerized Property
runProp field val = Containerized
[\_ -> "--" ++ param]
(Property (param) (return NoChange))
where
param = field++"="++val
genProp :: String -> (HostName -> RunParam) -> Containerized Property
genProp field mkval = Containerized
[\h -> "--" ++ field ++ "=" ++ mkval h]
(Property field (return NoChange))
-- | 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"
-- | Named pipe used for communication with the container.
namedPipe :: ContainerId -> FilePath
namedPipe cid = "docker" </> fromContainerId cid
provisionedFlag :: ContainerId -> FilePath
provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"
clearProvisionedFlag :: ContainerId -> IO ()
clearProvisionedFlag = nukeFile . provisionedFlag
setProvisionedFlag :: ContainerId -> IO ()
setProvisionedFlag cid = do
createDirectoryIfMissing True (takeDirectory (provisionedFlag cid))
writeFile (provisionedFlag cid) "1"
checkProvisionedFlag :: ContainerId -> IO Bool
checkProvisionedFlag = doesFileExist . provisionedFlag
shimdir :: ContainerId -> FilePath
shimdir cid = "docker" </> fromContainerId cid ++ ".shim"
identFile :: ContainerId -> FilePath
identFile cid = "docker" </> fromContainerId cid ++ ".ident"
readIdentFile :: ContainerId -> IO ContainerIdent
readIdentFile cid = fromMaybe (error "bad ident in identFile")
. readish <$> readFile (identFile cid)
dockercmd :: String
dockercmd = "docker.io"
report :: [Bool] -> Result
report rmed
| or rmed = MadeChange
| otherwise = NoChange