445 lines
14 KiB
Haskell
445 lines
14 KiB
Haskell
{-# LANGUAGE RankNTypes #-}
|
|
|
|
-- | 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 Data.List
|
|
|
|
-- | 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 [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"
|
|
|
|
-- | Bind mount a volume
|
|
volume :: String -> Containerized Property
|
|
volume = runProp "volume"
|
|
|
|
-- | 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"
|
|
|
|
-- | 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 :: [Containerized a] -> [RunParam]
|
|
getRunParams l = concatMap get l
|
|
where
|
|
get (Containerized ps _) = 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
|
|
print runningident
|
|
if runningident == Just ident
|
|
then return NoChange
|
|
else do
|
|
print "container parameters changed"
|
|
void $ stopContainer cid
|
|
oldimage <- fromMaybe image <$> commitContainer cid
|
|
void $ removeContainer cid
|
|
go oldimage
|
|
else do
|
|
whenM (elem cid <$> listContainers AllContainers) $ do
|
|
void $ removeContainer cid
|
|
go image
|
|
where
|
|
ident = ContainerIdent image hn cn runps
|
|
|
|
getrunningident :: IO (Maybe ContainerIdent)
|
|
getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \vs -> do
|
|
let l = (extractident) vs
|
|
print l
|
|
print vs
|
|
return l
|
|
|
|
extractident :: [Resp] -> Maybe ContainerIdent
|
|
extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
|
|
|
|
runps = getRunParams $ 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.
|
|
--
|
|
-- 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 $ simpleSh $ namedPipe cid
|
|
forever $ do
|
|
void $ ifM (inPath "bash")
|
|
( boolSystem "bash" [Param "-l"]
|
|
, boolSystem "/bin/sh" []
|
|
)
|
|
putStrLn "Container is still running. Press ^P^Q to detach."
|
|
|
|
-- | 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 . 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
|
|
|
|
-- | 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
|
|
|