From 90f86b8b2bb7f0a3c834387827c9ec2e1876f342 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 1 Apr 2014 01:12:05 -0400 Subject: not quite working docker container interface --- Propellor/CmdLine.hs | 5 +- Propellor/Property/Cmd.hs | 12 ++- Propellor/Property/Docker.hs | 214 ++++++++++++++++++++++++++++++++++++++++++- Propellor/Property/File.hs | 5 + Propellor/Types.hs | 2 +- 5 files changed, 233 insertions(+), 5 deletions(-) (limited to 'Propellor') diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs index 325f8d68..e43cf0aa 100644 --- a/Propellor/CmdLine.hs +++ b/Propellor/CmdLine.hs @@ -50,7 +50,7 @@ processCmdLine = go =<< getArgs else return $ Run s go _ = usage -defaultMain :: (HostName -> Maybe [Property]) -> IO () +defaultMain :: [HostName -> Maybe [Property]] -> IO () defaultMain getprops = go True =<< processCmdLine where go _ (Continue cmdline) = go False cmdline @@ -62,7 +62,8 @@ defaultMain getprops = go True =<< processCmdLine go False (Run host) = withprops host $ ensureProperties go False (Boot host) = withprops host $ boot - withprops host a = maybe (unknownhost host) a (getprops host) + withprops host a = maybe (unknownhost host) a $ + headMaybe $ catMaybes $ map (\get -> get host) getprops unknownhost :: HostName -> IO a unknownhost h = errorMessage $ unwords diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs index 88a84968..3e496b82 100644 --- a/Propellor/Property/Cmd.hs +++ b/Propellor/Property/Cmd.hs @@ -1,7 +1,8 @@ module Propellor.Property.Cmd ( cmdProperty, cmdProperty', - scriptProperty + scriptProperty, + serviceRunning, ) where import Control.Applicative @@ -35,3 +36,12 @@ scriptProperty :: [String] -> Property scriptProperty script = cmdProperty "sh" ["-c", shellcmd] where shellcmd = intercalate " ; " ("set -e" : script) + +-- | Ensures that a service is running. +-- +-- Note that due to the general poor state of init scripts, the best +-- we can do is try to start the service, and if it fails, assume +-- this means it's already running. +serviceRunning :: String -> Property +serviceRunning svc = scriptProperty + ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"] diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs index 3f7e470e..1f991709 100644 --- a/Propellor/Property/Docker.hs +++ b/Propellor/Property/Docker.hs @@ -1,8 +1,15 @@ +{-# LANGUAGE RankNTypes #-} + module Propellor.Property.Docker where import Propellor +import Propellor.CmdLine import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt +import Utility.SafeCommand + +dockercmd :: String +dockercmd = "docker.io" -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. @@ -11,6 +18,211 @@ 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"] + +-- | Parameters to pass to `docker run` when creating a container. +type RunParam = String + +data Containerized a = Containerized [RunParam] a + +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 + +-- | A docker image, that can be used to run a container. +type Image = String + +type ContainerName = String + +-- | A container is identified by its name, and the host +-- on which it's deployed. +data ContainerId = ContainerId HostName ContainerName + deriving (Read, Show, Eq) + +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 + +data Container = Container Image [Containerized Property] + +containerFromImage :: Image -> [Containerized Property] -> Container +containerFromImage = Container + +containerProperties + :: (HostName -> ContainerName -> Maybe (Container)) + -> (HostName -> Maybe [Property]) +containerProperties findcontainer = \h -> case toContainerId h of + Nothing -> Nothing + Just (ContainerId hn cn) -> + case findcontainer hn cn of + Nothing -> Nothing + Just (Container _ cprops) -> + Just $ fromContainerized cprops + +-- | 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. +hasContainer + :: HostName + -> ContainerName + -> (HostName -> ContainerName -> Maybe (Container)) + -> Property +hasContainer hn cn findcontainer = + case findcontainer hn cn of + Nothing -> Property desc $ do + warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid + return FailedChange + Just (Container image containerprops) -> + running image containerprops + where + cid = ContainerId hn cn + + desc = "docker container " ++ fromContainerId cid + + -- Start the container, if it's not already running. + running image containerprops = Property desc $ do + let 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) + -- cd to propellor directory + , workdir localdir + ] + let ident = ContainerIdent image cid runps + let runit img = ifM (runContainer cid img runps ident) + ( do + r <- runinside + return $ MadeChange <> r + , return FailedChange + ) + l <- listRunningContainers + if cid `elem` l + then do + runningident <- readish <$> readContainerCommand cid "cat" ["/.propeller-ident"] + if runningident == Just ident + then runinside + else do + void $ stopContainer cid + oldimage <- fromMaybe image <$> commitContainer cid + removeContainer cid + runit oldimage + else do + removeContainer cid + runit image + + -- Use propellor binary exposed inside the container + -- (assumes libc compatablity), and run it, passing it the + -- container@hostname so it knows what to do. + -- Read its Result code and propigate + runinside :: IO Result + runinside = fromMaybe FailedChange . readish + <$> readContainerCommand cid "./propellor" [show params] + where + -- Using Continue avoids auto-update of the binary inside + -- the container. + params = Continue $ Run $ fromContainerId cid + +-- | 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 ContainerId [RunParam] + deriving (Read, Show, Eq) + +-- | The ContainerIdent of a container is written to +-- /.propeller-ident inside it. This can be checked to see if +-- the container has the same ident later. +propellerIdent :: FilePath +propellerIdent = "/.propeller-ident" + +stopContainer :: ContainerId -> IO Bool +stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] + +removeContainer :: ContainerId -> IO () +removeContainer cid = void $ boolSystem "sh" + [Param "-c", Param $ dockercmd ++ " rm " ++ fromContainerId cid ] + +runContainer :: ContainerId -> Image -> [RunParam] -> ContainerIdent -> IO Bool +runContainer cid image ps ident = do + ok <- boolSystem dockercmd undefined + when ok $ + void $ readContainerCommand cid "sh" + ["-c", "echo '" ++ show ident ++ "' > " ++ propellerIdent] + return ok + +-- | Runs a command inside the container. +readContainerCommand :: ContainerId -> String -> [String] -> IO String +readContainerCommand cid command params = undefined + +commitContainer :: ContainerId -> IO (Maybe Image) +commitContainer cid = catchMaybeIO $ + readProcess dockercmd ["commit", fromContainerId cid] + +-- | Only lists propellor managed containers. +listRunningContainers :: IO [ContainerId] +listRunningContainers = undefined -- docker.io ps + +-- | Only lists propellor managed containers. +listContainers :: IO [ContainerId] +listContainers = undefined + +listImages :: IO [ContainerId] +listImages = undefined -- docker.io images --no-trunc + +runProp :: String -> RunParam -> Containerized Property +runProp field val = Containerized [param] (Property param (return NoChange)) + where + param = field++"="++val + +-- | Lift a Property to run inside the container. +inside :: Property -> Containerized Property +inside p = Containerized [] p + +-- | 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. +-- Must contain ./propellor! (Normally set automatically.) +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" diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs index 02bf27c0..f3065d21 100644 --- a/Propellor/Property/File.hs +++ b/Propellor/Property/File.hs @@ -38,3 +38,8 @@ fileProperty desc a f = Property desc $ go =<< doesFileExist f then noChange else makeChange $ viaTmp writeFile f (unlines ls') go False = makeChange $ writeFile f (unlines $ a []) + +-- | Ensures a directory exists. +dirExists :: FilePath -> Property +dirExists d = check (doesDirectoryExist d) $ Property (d ++ " exists") $ + makeChange $ createDirectoryIfMissing True d diff --git a/Propellor/Types.hs b/Propellor/Types.hs index d864d5d0..aef62de4 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -15,7 +15,7 @@ data Property = Property type Desc = String data Result = NoChange | MadeChange | FailedChange - deriving (Show, Eq) + deriving (Read, Show, Eq) instance Monoid Result where mempty = NoChange -- cgit v1.2.3