summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-04-01 01:12:05 -0400
committerJoey Hess2014-04-01 01:12:05 -0400
commit90f86b8b2bb7f0a3c834387827c9ec2e1876f342 (patch)
tree10e74b0a52f4987c6f7e9cf2abf756275e0cefae
parentd53729495efe7174239deab3b5dd71204543b0d0 (diff)
not quite working docker container interface
-rw-r--r--Makefile2
-rw-r--r--Propellor/CmdLine.hs5
-rw-r--r--Propellor/Property/Cmd.hs12
-rw-r--r--Propellor/Property/Docker.hs214
-rw-r--r--Propellor/Property/File.hs5
-rw-r--r--Propellor/Types.hs2
-rw-r--r--config.hs40
7 files changed, 260 insertions, 20 deletions
diff --git a/Makefile b/Makefile
index 14956fde..2ba41b2b 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 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: <number><optional unit>, 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
diff --git a/config.hs b/config.hs
index 75309f6c..88703db7 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