From 90f86b8b2bb7f0a3c834387827c9ec2e1876f342 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 1 Apr 2014 01:12:05 -0400 Subject: [PATCH] not quite working docker container interface --- Makefile | 2 +- Propellor/CmdLine.hs | 5 +- Propellor/Property/Cmd.hs | 12 +- Propellor/Property/Docker.hs | 214 ++++++++++++++++++++++++++++++++++- Propellor/Property/File.hs | 5 + Propellor/Types.hs | 2 +- config.hs | 40 ++++--- 7 files changed, 260 insertions(+), 20 deletions(-) diff --git a/Makefile b/Makefile index 14956fd..2ba41b2 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ run: build dev: build tags build: deps dist/setup-config - cabal build || (cabal configure; cabal build) + if ! cabal build; then cabal configure; cabal build; fi ln -sf dist/build/propellor/propellor deps: diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs index 325f8d6..e43cf0a 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 88a8496..3e496b8 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 3f7e470..1f99170 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 02bf27c..f3065d2 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 d864d5d..aef62de 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 diff --git a/config.hs b/config.hs index 75309f6..88703db 100644 --- a/config.hs +++ b/config.hs @@ -1,5 +1,5 @@ -{- This is the main configuration file for Propellor, and is used to build - - the propellor program. -} +-- | This is the main configuration file for Propellor, and is used to build +-- the propellor program. import Propellor import Propellor.CmdLine @@ -18,16 +18,15 @@ import qualified Propellor.Property.GitHome as GitHome import qualified Propellor.Property.JoeySites as JoeySites main :: IO () -main = defaultMain getProperties +main = defaultMain [host, Docker.containerProperties container] -{- | This is where the system's HostName, either as returned by uname - - or one specified on the command line, is converted into a list of - - Properties for that system. - - - - Edit this to configure propellor! - -} -getProperties :: HostName -> Maybe [Property] -getProperties hostname@"clam.kitenet.net" = Just +-- | This is where the system's HostName, either as returned by uname +-- or one specified on the command line, is converted into a list of +-- Properties for that system. +-- +-- Edit this to configure propellor! +host :: HostName -> Maybe [Property] +host hostname@"clam.kitenet.net" = Just [ cleanCloudAtCost hostname , standardSystem Apt.Unstable , Apt.unattendedUpgrades True @@ -37,18 +36,31 @@ getProperties hostname@"clam.kitenet.net" = Just , Tor.isBridge , JoeySites.oldUseNetshellBox , Docker.configured + , File.dirExists "/var/www" + , Docker.hasContainer hostname "webserver" container , Apt.installed ["git-annex", "mtr"] -- Should come last as it reboots. , Apt.installed ["systemd-sysv"] `onChange` Reboot.now ] -getProperties "orca.kitenet.net" = Just +host "orca.kitenet.net" = Just [ standardSystem Apt.Unstable , Apt.unattendedUpgrades True , Docker.configured ] -- add more hosts here... ---getProperties "foo" = -getProperties _ = Nothing +--host "foo.example.com" = +host _ = Nothing + +-- | This is where Docker containers are set up. A container +-- can vary by hostname where it's used, or be the same everywhere. +container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container) +container _ "webserver" = Just $ Docker.containerFromImage "debian" + [ Docker.publish "80:80" + , Docker.volume "/var/www:/var/www" + , Docker.inside $ serviceRunning "apache2" + `requires` Apt.installed ["apache2"] + ] +container _ _ = Nothing -- This is my standard system setup standardSystem :: Apt.Suite -> Property