not quite working docker container interface

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:

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

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"]

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"

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

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

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