module Propellor.Property.Docker (
installed,
configured,
container,
docked,
imageBuilt,
imagePulled,
memoryLimited,
garbageCollected,
tweaked,
Image(..),
latestImage,
ContainerName,
Container(..),
HasImage(..),
dns,
hostname,
Publishable,
publish,
expose,
user,
Mountable,
volume,
volumes_from,
workdir,
memory,
cpuShares,
link,
environment,
ContainerAlias,
restartAlways,
restartOnFailure,
restartNever,
init,
chain,
) where
import Propellor.Base hiding (init)
import Propellor.Types.Docker
import Propellor.Types.Container
import Propellor.Types.Core
import Propellor.Types.CmdLine
import Propellor.Types.Info
import Propellor.Container
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cmd as Cmd
import qualified Propellor.Property.Pacman as Pacman
import qualified Propellor.Shim as Shim
import Utility.Path
import Utility.ThreadScheduler
import Utility.Split
import Control.Concurrent.Async hiding (link)
import System.Posix.Directory
import System.Posix.Process
import Prelude hiding (init)
import Data.List hiding (init)
import qualified Data.Map as M
import System.Console.Concurrent
installed :: Property (DebianLike + ArchLinux)
installed = Apt.installed ["docker.io"] `pickOS` Pacman.installed ["docker"]
configured :: Property (HasInfo + DebianLike)
configured = prop `requires` installed
where
prop :: Property (HasInfo + DebianLike)
prop = withPrivData src anyContext $ \getcfg ->
property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $
"/root/.dockercfg" `File.hasContent` privDataLines cfg
src = PrivDataSourceFileFromCommand DockerAuthentication
"/root/.dockercfg" "docker login"
type ContainerName = String
data Container = Container Image Host
instance IsContainer Container where
containerProperties (Container _ h) = containerProperties h
containerInfo (Container _ h) = containerInfo h
setContainerProperties (Container i h) ps = Container i (setContainerProperties h ps)
class HasImage a where
getImageName :: a -> Image
instance HasImage Image where
getImageName = id
instance HasImage Container where
getImageName (Container i _) = i
container :: ContainerName -> Image -> Props metatypes -> Container
container cn image (Props ps) = Container image (Host cn ps info)
where
info = dockerInfo mempty <> mconcat (map getInfoRecursive ps)
docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
docked ctr@(Container _ h) =
(propagateContainerInfo ctr (go "docked" setup))
<!>
(go "undocked" teardown)
where
cn = hostName h
go desc a = property' (desc ++ " " ++ cn) $ \w -> do
hn <- asks hostName
let cid = ContainerId hn cn
ensureProperty w $ a cid (mkContainerInfo cid ctr)
setup :: ContainerId -> ContainerInfo -> Property Linux
setup cid (ContainerInfo image runparams) =
provisionContainer cid
`requires`
runningContainer cid image runparams
`requires`
installed
teardown :: ContainerId -> ContainerInfo -> Property Linux
teardown cid (ContainerInfo image _runparams) =
combineProperties ("undocked " ++ fromContainerId cid) $ toProps
[ stoppedContainer cid
, property ("cleaned up " ++ fromContainerId cid) $
liftIO $ report <$> mapM id
[ removeContainer cid
, removeImage image
]
]
imageBuilt :: HasImage c => FilePath -> c -> Property Linux
imageBuilt directory ctr = built `describe` msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory
built :: Property Linux
built = tightenTargets $
Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
`assume` MadeChange
workDir p = p { cwd = Just directory }
image = getImageName ctr
imagePulled :: HasImage c => c -> Property Linux
imagePulled ctr = pulled `describe` msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " pulled"
pulled :: Property Linux
pulled = tightenTargets $
Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
`assume` MadeChange
image = getImageName ctr
propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
propagateContainerInfo ctr@(Container _ h) p =
propagateContainer cn ctr normalContainerInfo $
p `addInfoProperty` dockerinfo
where
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton cn h }
cn = hostName h
mkContainerInfo :: ContainerId -> Container -> ContainerInfo
mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
ContainerInfo img runparams
where
runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
(_dockerRunParams info)
info = fromInfo $ hostInfo h'
h' = setContainerProps h $ containerProps h
&^ restartAlways
& volume (localdir++":"++localdir)
& name (fromContainerId cid)
garbageCollected :: Property Linux
garbageCollected = propertyList "docker garbage collected" $ props
& gccontainers
& gcimages
where
gccontainers :: Property Linux
gccontainers = property "docker containers garbage collected" $
liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
gcimages :: Property Linux
gcimages = property "docker images garbage collected" $
liftIO $ report <$> (mapM removeImage =<< listImages)
tweaked :: Property Linux
tweaked = tightenTargets $ cmdProperty "sh"
[ "-c"
, "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
]
`assume` NoChange
`describe` "tweaked for docker"
memoryLimited :: Property DebianLike
memoryLimited = tightenTargets $
"/etc/default/grub" `File.containsLine` cfg
`describe` "docker memory limited"
`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
where
cmdline = "cgroup_enable=memory swapaccount=1"
cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
data ContainerInfo = ContainerInfo Image [RunParam]
type RunParam = String
newtype ImageID = ImageID String
class ImageIdentifier i where
toImageID :: i -> ImageID
toImageID = ImageID . imageIdentifier
imageIdentifier :: i -> String
instance ImageIdentifier ImageID where
imageIdentifier (ImageID i) = i
toImageID = id
data Image = Image
{ repository :: String
, tag :: Maybe String
}
deriving (Eq, Read, Show)
latestImage :: String -> Image
latestImage repo = Image repo Nothing
instance ImageIdentifier Image where
imageIdentifier i = repository i ++ (maybe "" ((++) ":") $ tag i)
newtype ImageUID = ImageUID String
instance ImageIdentifier ImageUID where
imageIdentifier (ImageUID uid) = uid
dns :: String -> Property (HasInfo + Linux)
dns = runProp "dns"
hostname :: String -> Property (HasInfo + Linux)
hostname = runProp "hostname"
name :: String -> Property (HasInfo + Linux)
name = runProp "name"
class Publishable p where
toPublish :: p -> String
instance Publishable (Bound Port) where
toPublish p = val (hostSide p) ++ ":" ++ val (containerSide p)
instance Publishable String where
toPublish = id
publish :: Publishable p => p -> Property (HasInfo + Linux)
publish = runProp "publish" . toPublish
expose :: String -> Property (HasInfo + Linux)
expose = runProp "expose"
user :: String -> Property (HasInfo + Linux)
user = runProp "user"
class Mountable p where
toMount :: p -> String
instance Mountable (Bound FilePath) where
toMount p = hostSide p ++ ":" ++ containerSide p
instance Mountable String where
toMount = id
volume :: Mountable v => v -> Property (HasInfo + Linux)
volume = runProp "volume" . toMount
volumes_from :: ContainerName -> Property (HasInfo + Linux)
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
workdir :: String -> Property (HasInfo + Linux)
workdir = runProp "workdir"
memory :: String -> Property (HasInfo + Linux)
memory = runProp "memory"
cpuShares :: Int -> Property (HasInfo + Linux)
cpuShares = runProp "cpu-shares" . show
link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux)
link linkwith calias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
type ContainerAlias = String
restartAlways :: Property (HasInfo + Linux)
restartAlways = runProp "restart" "always"
restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
restartOnFailure Nothing = runProp "restart" "on-failure"
restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
restartNever :: Property (HasInfo + Linux)
restartNever = runProp "restart" "no"
environment :: (String, String) -> Property (HasInfo + Linux)
environment (k, v) = runProp "env" $ k ++ "=" ++ v
data ContainerId = ContainerId
{ containerHostName :: HostName
, containerName :: 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
myContainerSuffix :: String
myContainerSuffix = ".propellor"
containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i
containerDesc cid p = p `describe` desc
where
desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p
runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux
runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
l <- liftIO $ listContainers RunningContainers
if cid `elem` l
then checkident =<< liftIO getrunningident
else ifM (liftIO $ elem cid <$> listContainers AllContainers)
( do
void $ liftIO $ startContainer cid
checkident =<< liftIO (retry 60 $ getrunningident)
, go image
)
where
ident = ContainerIdent image hn cn runps
checkident (Right runningident)
| runningident == Just ident = noChange
| otherwise = do
void $ liftIO $ stopContainer cid
restartcontainer
checkident (Left errmsg) = do
warningMessage errmsg
return FailedChange
restartcontainer = do
oldimage <- liftIO $
maybe (toImageID image) toImageID <$> commitContainer cid
void $ liftIO $ removeContainer cid
go oldimage
getrunningident = withTmpFile "dockerrunsane" $ \t h -> do
hClose h
void . checkSuccessProcess . processHandle =<<
createProcess (inContainerProcess cid []
["rm", "-f", t])
ifM (doesFileExist t)
( Right . readish <$>
readProcess' (inContainerProcess cid []
["cat", propellorIdent])
, return $ Left "docker exec failed to enter chroot properly (maybe an old kernel version?)"
)
retry :: Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
retry 0 _ = return (Right Nothing)
retry n a = do
v <- a
case v of
Right Nothing -> do
threadDelaySeconds (Seconds 1)
retry (n1) a
_ -> return v
go :: ImageIdentifier i => i -> Propellor Result
go img = liftIO $ do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
shim <- Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid)
writeFile (identFile cid) (show ident)
toResult <$> runContainer img
(runps ++ ["-i", "-d", "-t"])
[shim, "--continue", show (DockerInit (fromContainerId cid))]
init :: String -> IO ()
init 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 $ toChain cid]) $
warningMessage "Boot provision failed!"
void $ async $ job reapzombies
job $ do
flushConcurrentOutput
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 Linux
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
let params = ["--continue", show $ toChain cid]
msgh <- getMessageHandle
let p = inContainerProcess cid
(if isConsole msgh then ["-it"] else [])
(shim : params)
r <- chainPropellor p
when (r /= FailedChange) $
setProvisionedFlag cid
return r
toChain :: ContainerId -> CmdLine
toChain cid = DockerChain (containerHostName cid) (fromContainerId cid)
chain :: [Host] -> HostName -> String -> IO ()
chain hostlist hn s = case toContainerId s of
Nothing -> errorMessage "bad container id"
Just cid -> case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn)
Just h -> go cid h
where
go cid h = do
changeWorkingDirectory localdir
onlyProcess (provisioningLock cid) $
runChainPropellor h $
ensureChildProperties $ hostProperties h
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 Linux
stoppedContainer cid = containerDesc cid $ property' desc $ \w ->
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
( liftIO cleanup `after` ensureProperty w stop
, return NoChange
)
where
desc = "stopped"
stop :: Property Linux
stop = property desc $ liftIO $ toResult <$> stopContainer cid
cleanup = do
nukeFile $ identFile cid
removeDirectoryRecursive $ shimdir cid
clearProvisionedFlag cid
removeContainer :: ContainerId -> IO Bool
removeContainer cid = catchBoolIO $
snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing
removeImage :: ImageIdentifier i => i -> IO Bool
removeImage image = catchBoolIO $
snd <$> processTranscript dockercmd ["rmi", imageIdentifier image] Nothing
runContainer :: ImageIdentifier i => i -> [RunParam] -> [String] -> IO Bool
runContainer image ps cmd = boolSystem dockercmd $ map Param $
"run" : (ps ++ (imageIdentifier image) : cmd)
inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess
inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd)
commitContainer :: ContainerId -> IO (Maybe ImageUID)
commitContainer cid = catchMaybeIO $
ImageUID . takeWhile (/= '\n')
<$> readProcess dockercmd ["commit", fromContainerId cid]
data ContainerFilter = RunningContainers | AllContainers
deriving (Eq)
listContainers :: ContainerFilter -> IO [ContainerId]
listContainers status =
mapMaybe toContainerId . concatMap (split ",")
. mapMaybe (lastMaybe . words) . lines
<$> readProcess dockercmd ps
where
ps
| status == AllContainers = baseps ++ ["--all"]
| otherwise = baseps
baseps = ["ps", "--no-trunc"]
listImages :: IO [ImageUID]
listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
runProp :: String -> RunParam -> Property (HasInfo + Linux)
runProp field v = tightenTargets $ pureInfoProperty (param) $
mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where
param = field++"="++v
genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
genProp field mkval = tightenTargets $ pureInfoProperty field $
mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
dockerInfo :: DockerInfo -> Info
dockerInfo i = mempty `addInfo` i
propellorIdent :: FilePath
propellorIdent = "/.propellor-ident"
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
provisioningLock :: ContainerId -> FilePath
provisioningLock cid = "docker" </> fromContainerId cid ++ ".lock"
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