{-# 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. -- -- Note that propellor provisions a container by running itself, inside the -- container. Currently, to avoid the overhead of building propellor -- inside the container, the binary from outside is reused inside. -- So, the libraries that propellor is linked against need to be available -- in the container with compatable versions. This can cause a problem -- if eg, mixing Debian stable and unstable. 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 -- | 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. docked :: (HostName -> ContainerName -> Maybe (Container)) -> HostName -> ContainerName -> Property docked findcontainer hn cn = case findcontainer hn cn of Nothing -> containerDesc cid $ Property "" $ do warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid return FailedChange Just (Container image containerprops) -> provisionContainer cid `requires` runningContainer cid image containerprops where cid = ContainerId hn cn -- | 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: , 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 = case separate (== '.') s of (cn, hn) | null hn || null cn -> Nothing | otherwise -> Just $ ContainerId hn cn fromContainerId :: ContainerId -> String fromContainerId (ContainerId hn cn) = cn++"."++hn 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 clearProvisionedFlag cid void $ stopContainer cid oldimage <- fromMaybe image <$> commitContainer cid removeContainer cid go oldimage else do whenM (elem cid <$> listContainers AllContainers) $ do clearProvisionedFlag cid 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 ++ -- 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) ] chaincmd = [localdir "propellor", "--docker", fromContainerId cid] go img = do createDirectoryIfMissing True (takeDirectory $ identFile cid) writeFile (identFile cid) (show ident) ifM (runContainer img (runps ++ ["-i", "-d", "-t"]) chaincmd) ( return MadeChange , return FailedChange ) -- | 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 readish 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) $ 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." -- | 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 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 ] removeContainer :: ContainerId -> IO () removeContainer cid = void $ catchMaybeIO $ readProcess dockercmd ["rm", fromContainerId cid ] 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"] 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 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"