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 Utility.SafeCommand
import Utility.Path
import Control.Concurrent.Async
import System.Posix.Directory
import Data.List
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"]
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
teardown =
Property ("undocked " ++ fromContainerId cid) $
report <$> mapM id
[ stopContainerIfRunning cid
, 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
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)
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
data Container = Container Image [Containerized Property]
data Containerized a = Containerized [RunParam] a
type RunParam = String
type Image = String
type ContainerName = String
inside1 :: Property -> Containerized Property
inside1 = Containerized []
inside :: [Property] -> Containerized Property
inside = Containerized [] . combineProperties "provision"
dns :: String -> Containerized Property
dns = runProp "dns"
hostname :: String -> Containerized Property
hostname = runProp "hostname"
name :: String -> Containerized Property
name = runProp "name"
publish :: String -> Containerized Property
publish = runProp "publish"
user :: String -> Containerized Property
user = runProp "user"
volume :: String -> Containerized Property
volume = runProp "volume"
workdir :: String -> Containerized Property
workdir = runProp "workdir"
memory :: String -> Containerized Property
memory = runProp "memory"
data ContainerId = ContainerId HostName ContainerName
deriving (Eq, Read, Show)
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
runningident <- getrunningident
if (ident2id <$> runningident) == Just (ident2id ident)
then return NoChange
else do
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 = catchDefaultIO Nothing $
simpleShClient (namedPipe cid) "cat" [propellorIdent] $
pure . headMaybe . catMaybes . map readish . catMaybes . map getStdout
runps = getRunParams $ containerprops ++
[ volume (localdir++":"++localdir)
, name (fromContainerId cid)
]
chaincmd = [localdir </> "propellor", "--docker", fromContainerId cid]
go img = do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
writeFile (identFile cid) (show ident)
ifM (runContainer img (runps ++ ["-i", "-d", "-t"]) chaincmd)
( return MadeChange
, return FailedChange
)
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) $
unlessM (boolSystem "./propellor" [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."
provisionContainer :: ContainerId -> Property
provisionContainer cid = containerDesc cid $ Property "provision" $ do
r <- simpleShClientRetry 60 (namedPipe cid) "./propellor" 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 ]
stopContainerIfRunning :: ContainerId -> IO Bool
stopContainerIfRunning cid = ifM (elem cid <$> listContainers RunningContainers)
( stopContainer cid
, return True
)
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 . 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
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
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