module Propellor.Property.Docker (
installed,
configured,
container,
docked,
memoryLimited,
garbageCollected,
tweaked,
Image,
ContainerName,
dns,
hostname,
publish,
expose,
user,
volume,
volumes_from,
workdir,
memory,
cpuShares,
link,
ContainerAlias,
restartAlways,
restartOnFailure,
restartNever,
chain,
) where
import Propellor
import Propellor.SimpleSh
import Propellor.Types.Info
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 hiding (link)
import System.Posix.Directory
import System.Posix.Process
import Data.List
import Data.List.Utils
import qualified Data.Set as S
installed :: Property
installed = Apt.installed ["docker.io"]
configured :: Property
configured = prop `requires` installed
where
prop = withPrivData DockerAuthentication anyContext $ \getcfg ->
property "docker configured" $ getcfg $ \cfg -> ensureProperty $
"/root/.dockercfg" `File.hasContent` (lines cfg)
type ContainerName = String
container :: ContainerName -> Image -> Host
container cn image = Host hn [] info
where
info = dockerInfo $ mempty { _dockerImage = Val image }
hn = cn2hn cn
cn2hn :: ContainerName -> HostName
cn2hn cn = cn ++ ".docker"
docked
:: [Host]
-> ContainerName
-> RevertableProperty
docked hosts cn = RevertableProperty
((maybe id propigateInfo mhost) (go "docked" setup))
(go "undocked" teardown)
where
go desc a = property (desc ++ " " ++ cn) $ do
hn <- asks hostName
let cid = ContainerId hn cn
ensureProperties [findContainer mhost cid cn $ a cid]
mhost = findHostNoAlias hosts (cn2hn cn)
setup cid (Container image runparams) =
provisionContainer cid
`requires`
runningContainer cid image runparams
`requires`
installed
teardown cid (Container image _runparams) =
combineProperties ("undocked " ++ fromContainerId cid)
[ stoppedContainer cid
, property ("cleaned up " ++ fromContainerId cid) $
liftIO $ report <$> mapM id
[ removeContainer cid
, removeImage image
]
]
propigateInfo :: Host -> Property -> Property
propigateInfo (Host _ _ containerinfo) p =
combineProperties (propertyDesc p) $ p : dnsprops ++ privprops
where
dnsprops = map addDNS (S.toList $ _dns containerinfo)
privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo)
findContainer
:: Maybe Host
-> ContainerId
-> ContainerName
-> (Container -> Property)
-> Property
findContainer mhost cid cn mk = case mhost of
Nothing -> cantfind
Just h -> maybe cantfind mk (mkContainer cid h)
where
cantfind = containerDesc cid $ property "" $ do
liftIO $ warningMessage $
"missing definition for docker container \"" ++ cn2hn cn
return FailedChange
mkContainer :: ContainerId -> Host -> Maybe Container
mkContainer cid@(ContainerId hn _cn) h = Container
<$> fromVal (_dockerImage info)
<*> pure (map (\mkparam -> mkparam hn) (_dockerRunParams info))
where
info = _dockerinfo $ hostInfo h'
h' = h
&^ restartAlways
& volume (localdir++":"++localdir)
& name (fromContainerId cid)
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)
tweaked :: Property
tweaked = trivial $
cmdProperty "sh" ["-c", "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"]
`describe` "tweaked for docker"
memoryLimited :: Property
memoryLimited = "/etc/default/grub" `File.containsLine` cfg
`describe` "docker memory limited"
`onChange` cmdProperty "update-grub" []
where
cmdline = "cgroup_enable=memory swapaccount=1"
cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
data Container = Container Image [RunParam]
type RunParam = String
type Image = String
dns :: String -> Property
dns = runProp "dns"
hostname :: String -> Property
hostname = runProp "hostname"
name :: String -> Property
name = runProp "name"
publish :: String -> Property
publish = runProp "publish"
expose :: String -> Property
expose = runProp "expose"
user :: String -> Property
user = runProp "user"
volume :: String -> Property
volume = runProp "volume"
volumes_from :: ContainerName -> Property
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
workdir :: String -> Property
workdir = runProp "workdir"
memory :: String -> Property
memory = runProp "memory"
cpuShares :: Int -> Property
cpuShares = runProp "cpu-shares" . show
link :: ContainerName -> ContainerAlias -> Property
link linkwith calias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
type ContainerAlias = String
restartAlways :: Property
restartAlways = runProp "restart" "always"
restartOnFailure :: Maybe Int -> Property
restartOnFailure Nothing = runProp "restart" "on-failure"
restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
restartNever :: Property
restartNever = runProp "restart" "no"
data ContainerId = ContainerId HostName ContainerName
deriving (Eq, Read, Show)
data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
deriving (Read, Show, Eq)
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
containerHostName :: ContainerId -> HostName
containerHostName (ContainerId _ cn) = cn2hn cn
myContainerSuffix :: String
myContainerSuffix = ".propellor"
containerDesc :: ContainerId -> Property -> Property
containerDesc cid p = p `describe` desc
where
desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
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 checkident =<< liftIO (getrunningident simpleShClient)
else ifM (liftIO $ elem cid <$> listContainers AllContainers)
( do
void $ liftIO $ startContainer cid
checkident =<< liftIO (getrunningident (simpleShClientRetry 60))
, go image
)
where
ident = ContainerIdent image hn cn runps
checkident runningident
| runningident == Just ident = noChange
| otherwise = do
void $ liftIO $ stopContainer cid
restartcontainer
restartcontainer = do
oldimage <- liftIO $ fromMaybe image <$> commitContainer cid
void $ liftIO $ removeContainer cid
go oldimage
getrunningident shclient = shclient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do
let !v = extractident rs
return v
extractident :: [Resp] -> Maybe ContainerIdent
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)
ensureProperty $ boolProperty "run" $ runContainer img
(runps ++ ["-i", "-d", "-t"])
[shim, "--docker", fromContainerId cid]
chain :: String -> IO ()
chain s = case toContainerId s of
Nothing -> error $ "Invalid ContainerId: " ++ s
Just cid -> do
changeWorkingDirectory localdir
writeFile propellorIdent . show =<< readIdentFile cid
whenM (checkProvisionedFlag cid) $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName 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
provisionContainer :: ContainerId -> Property
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ 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 $ containerHostName cid]
go lastline (v:rest) = case v of
StdoutLine s -> do
maybe noop putStrLn lastline
hFlush stdout
go (Just s) rest
StderrLine s -> do
maybe noop putStrLn lastline
hFlush stdout
hPutStrLn stderr s
hFlush stderr
go Nothing rest
Done -> ret lastline
go lastline [] = ret lastline
ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline
stopContainer :: ContainerId -> IO Bool
stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
startContainer :: ContainerId -> IO Bool
startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
stoppedContainer :: ContainerId -> Property
stoppedContainer cid = containerDesc cid $ property desc $
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
( liftIO 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)
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 -> Property
runProp field val = pureInfoProperty (param) $ dockerInfo $
mempty { _dockerRunParams = [\_ -> "--"++param] }
where
param = field++"="++val
genProp :: String -> (HostName -> RunParam) -> Property
genProp field mkval = pureInfoProperty field $ dockerInfo $
mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] }
dockerInfo :: DockerInfo -> Info
dockerInfo i = mempty { _dockerinfo = i }
propellorIdent :: FilePath
propellorIdent = "/.propellor-ident"
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"
report :: [Bool] -> Result
report rmed
| or rmed = MadeChange
| otherwise = NoChange