separate docker container type

Docker containers are now a separate data type, cannot be included in the
main host list, and are instead passed to Docker.docked. (API change)

config-joey.hs

@@ -45,7 +45,7 @@ hosts =                --                  (o)  `
 	, kite
 	, diatom
 	, elephant
-	] ++ containers ++ monsters
+	] ++ monsters
 
 darkstar :: Host
 darkstar = host "darkstar.kitenet.net"
@@ -53,8 +53,7 @@ darkstar = host "darkstar.kitenet.net"
 
 	& Apt.buildDep ["git-annex"] `period` Daily
 	& Docker.configured
-	! Docker.docked hosts "android-git-annex"
+	! Docker.docked gitAnnexAndroidDev
-	! Docker.docked hosts "simple-debian"
 
 clam :: Host
 clam = standardSystem "clam.kitenet.net" Unstable "amd64"
@@ -69,7 +68,7 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"
 
 	& Docker.configured
 	& Docker.garbageCollected `period` Daily
-	& Docker.docked hosts "webserver"
+	& Docker.docked webserver
 	& File.dirExists "/var/www/html"
 	& File.notPresent "/var/www/html/index.html"
 	& "/var/www/index.html" `File.hasContent` ["hello, world"]
@@ -91,11 +90,11 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64"
 	& Apt.unattendedUpgrades
 	& Postfix.satellite
 	& Docker.configured
-	& Docker.docked hosts "amd64-git-annex-builder"
+	& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h")
-	& Docker.docked hosts "i386-git-annex-builder"
+	& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h")
-	& Docker.docked hosts "android-git-annex-builder"
+	& Docker.docked (GitAnnexBuilder.armelCompanionContainer dockerImage)
-	& Docker.docked hosts "armel-git-annex-builder-companion"
+	& Docker.docked (GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h")
-	& Docker.docked hosts "armel-git-annex-builder"
+	& Docker.docked (GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h")
 	& Docker.garbageCollected `period` Daily
 	& Apt.buildDep ["git-annex"] `period` Daily
 	
@@ -258,11 +257,10 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
 	& myDnsSecondary
 	
 	& Docker.configured
-		& Docker.docked hosts "oldusenet-shellbox"
+	& Docker.docked oldusenetShellBox
-	& Docker.docked hosts "openid-provider"
+	& Docker.docked openidProvider
 		`requires` Apt.serviceInstalledRunning "ntp"
-	& Docker.docked hosts "ancient-kitenet"
+	& Docker.docked ancientKitenet
-
 	& Docker.garbageCollected `period` (Weekly (Just 1))
 	
 	-- For https port 443, shellinabox with ssh login to
@@ -284,52 +282,43 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
 	----------------------- :                    / -----------------------
 	------------------------ \____, o          ,' ------------------------
 	------------------------- '--,___________,'  -------------------------
-containers :: [Host]
-containers =
 -- Simple web server, publishing the outside host's /var/www
-	[ standardStableContainer "webserver"
+webserver :: Docker.Container
+webserver = standardStableContainer "webserver"
 	& Docker.publish "80:80"
 	& Docker.volume "/var/www:/var/www"
 	& Apt.serviceInstalledRunning "apache2"
 
 -- My own openid provider. Uses php, so containerized for security
 -- and administrative sanity.
-	, standardStableContainer "openid-provider"
+openidProvider :: Docker.Container
+openidProvider = standardStableContainer "openid-provider"
 	& alias "openid.kitenet.net"
 	& Docker.publish "8081:80"
 	& OpenId.providerFor ["joey", "liw"]
 		"openid.kitenet.net:8081"
 
 -- Exhibit: kite's 90's website.
-	, standardStableContainer "ancient-kitenet"
+ancientKitenet :: Docker.Container
+ancientKitenet = standardStableContainer "ancient-kitenet"
 	& alias "ancient.kitenet.net"
 	& Docker.publish "1994:80"
 	& Apt.serviceInstalledRunning "apache2"
 	& Git.cloned "root" "git://kitenet-net.branchable.com/" "/var/www"
 		(Just "remotes/origin/old-kitenet.net")
 
-	, standardStableContainer "oldusenet-shellbox"
+oldusenetShellBox :: Docker.Container
+oldusenetShellBox = standardStableContainer "oldusenet-shellbox"
 	& alias "shell.olduse.net"
 	& Docker.publish "4200:4200"
 	& JoeySites.oldUseNetShellBox
 
-	, Docker.container "simple-debian" "debian"
+-- for development of git-annex for android, using my git-annex work tree
-		& "/hello" `File.containsLine` "hello"
+gitAnnexAndroidDev :: Docker.Container
-		& Docker.publish "8081:80"
+gitAnnexAndroidDev = GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir
-
-	-- git-annex autobuilder containers
-	, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h"
-	, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h"
-	, GitAnnexBuilder.armelCompanionContainer dockerImage
-	, GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h"
-	, GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h"
-
-	-- for development of git-annex for android, using my git-annex
-	-- work tree
-	, let gitannexdir = GitAnnexBuilder.homedir </> "git-annex"
-	  in GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir
 	& Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir)
-	]
+  where
+	gitannexdir = GitAnnexBuilder.homedir </> "git-annex"
 
 type Motd = [String]
 
@@ -363,11 +352,11 @@ standardSystemUnhardened hn suite arch motd = host hn
 	& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
 		`onChange` Apt.autoRemove
 
-standardStableContainer :: Docker.ContainerName -> Host
+standardStableContainer :: Docker.ContainerName -> Docker.Container
 standardStableContainer name = standardContainer name (Stable "wheezy") "amd64"
 
 -- This is my standard container setup, featuring automatic upgrades.
-standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host
+standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Docker.Container
 standardContainer name suite arch = Docker.container name (dockerImage system)
 	& os system
 	& Apt.stdSourcesList `onChange` Apt.upgrade

config-simple.hs

@@ -32,18 +32,19 @@ hosts =
 		& User.hasSomePassword "root" (Context "mybox.example.com")
 		& Network.ipv6to4
 		& File.dirExists "/var/www"
-		& Docker.docked hosts "webserver"
+		& Docker.docked webserverContainer
 		& Docker.garbageCollected `period` Daily
 		& Cron.runPropellor "30 * * * *"
 
+	-- add more hosts here...
+	--, host "foo.example.com" = ...
+	]
+
 -- A generic webserver in a Docker container.
-	, Docker.container "webserver" "joeyh/debian-stable"
+webserverContainer :: Docker.Container
+webserverContainer = Docker.container "webserver" "joeyh/debian-stable"
 	& os (System (Debian (Stable "wheezy")) "amd64")
 	& Apt.stdSourcesList
 	& Docker.publish "80:80"
 	& Docker.volume "/var/www:/var/www"
 	& Apt.serviceInstalledRunning "apache2"
-
-	-- add more hosts here...
-	--, host "foo.example.com" = ...
-	]

debian/changelog

@@ -15,6 +15,9 @@ propellor (1.0.0) UNRELEASED; urgency=medium
   * Avoid outputting color setting sequences when not run on a terminal.
   * Run remote propellor --spin with a controlling terminal.
   * Docker code simplified by using `docker exec`; needs docker 1.3.1.
+  * Docker containers are now a separate data type, cannot be included
+    in the main host list, and are instead passed to
+    Docker.docked. (API change)
   * Added support for using debootstrap from propellor.
 
  -- Joey Hess <id@joeyh.name>  Mon, 10 Nov 2014 11:15:27 -0400

src/Propellor/Property.hs

@@ -144,27 +144,28 @@ unrevertable (RevertableProperty p1 _p2) = p1
 host :: HostName -> Host
 host hn = Host hn [] mempty
 
+class Hostlike h where
 	-- | Adds a property to a Host
 	--
 	-- Can add Properties and RevertableProperties
-(&) :: IsProp p => Host -> p -> Host
+	(&) :: IsProp p => h -> p -> h
-(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
+	-- | Like (&), but adds the property as the
-
+	-- first property of the host. Normally, property
-infixl 1 &
+	-- order should not matter, but this is useful
-
--- | Adds a property to the Host in reverted form.
-(!) :: Host -> RevertableProperty -> Host
-h ! p = h & revert p
-
-infixl 1 !
-
--- | Like (&), but adds the property as the first property of the host.
--- Normally, property order should not matter, but this is useful
 	-- when it does.
-(&^) :: IsProp p => Host -> p -> Host
+	(&^) :: IsProp p => h -> p -> h
+
+instance Hostlike Host where
+	(Host hn ps is) &  p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
 	(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is)
 
+-- | Adds a property to the Host in reverted form.
+(!) :: Hostlike h => h -> RevertableProperty -> h
+h ! p = h & revert p
+
 infixl 1 &^
+infixl 1 &
+infixl 1 !
 
 -- Changes the action that is performed to satisfy a property. 
 adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property

src/Propellor/Property/Docker.hs

@@ -16,6 +16,7 @@ module Propellor.Property.Docker (
 	tweaked,
 	Image,
 	ContainerName,
+	Container,
 	-- * Container configuration
 	dns,
 	hostname,
@@ -71,55 +72,60 @@ configured = prop `requires` installed
 -- only [a-zA-Z0-9_-] are allowed
 type ContainerName = String
 
--- | Starts accumulating the properties of a Docker container.
+-- | A docker container.
+data Container = Container Image Host
+
+instance Hostlike Container where
+	(Container i h) & p = Container i (h & p)
+	(Container i h) &^ p = Container i (h &^ p)
+
+-- | Builds a Container with a given name, image, and properties.
 --
 -- > container "web-server" "debian"
 -- >    & publish "80:80"
 -- >    & Apt.installed {"apache2"]
 -- >    & ...
-container :: ContainerName -> Image -> Host
+container :: ContainerName -> Image -> Container
-container cn image = Host hn [] info
+container cn image = Container image (Host hn [] info)
   where
-	info = dockerInfo $ mempty { _dockerImage = Val image }
+	info = dockerInfo mempty
 	hn = cn2hn cn
 
 cn2hn :: ContainerName -> HostName
 cn2hn cn = cn ++ ".docker"
 
--- | Ensures that a docker container is set up and running, finding
+-- | Ensures that a docker container is set up and running.
--- its configuration in the passed list of hosts.
 -- 
 -- The container has its own Properties which are handled by running
 -- propellor inside the container.
 --
 -- When the container's Properties include DNS info, such as a CNAME,
--- that is propigated to the Info of the host(s) it's docked in.
+-- that is propigated to the Info of the Host it's docked in.
 --
 -- Reverting this property ensures that the container is stopped and
 -- removed.
 docked
-	:: [Host]
+	:: Container
-	-> ContainerName
 	-> RevertableProperty
-docked hosts cn = RevertableProperty
+docked ctr@(Container _ h) = RevertableProperty
-	((maybe id propigateInfo mhost) (go "docked" setup))
+	(propigateInfo h (go "docked" setup))
 	(go "undocked" teardown)
   where
+	cn = hostName h
+
 	go desc a = property (desc ++ " " ++ cn) $ do
 		hn <- asks hostName
 		let cid = ContainerId hn cn
-		ensureProperties [findContainer mhost cid cn $ a cid]
+		ensureProperties [a cid (mkContainerInfo cid ctr)]
 
-	mhost = findHostNoAlias hosts (cn2hn cn)
+	setup cid (ContainerInfo image runparams) =
-
-	setup cid (Container image runparams) =
 		provisionContainer cid
 			`requires`
 		runningContainer cid image runparams
 			`requires`
 		installed
 
-	teardown cid (Container image _runparams) =
+	teardown cid (ContainerInfo image _runparams) =
 		combineProperties ("undocked " ++ fromContainerId cid)
 			[ stoppedContainer cid
 			, property ("cleaned up " ++ fromContainerId cid) $
@@ -136,26 +142,11 @@ propigateInfo (Host _ _ containerinfo) p =
 	dnsprops = map addDNS (S.toList $ _dns containerinfo)
 	privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo)
 
-findContainer
+mkContainerInfo :: ContainerId -> Container -> ContainerInfo
-	:: Maybe Host
+mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = 
-	-> ContainerId
+	ContainerInfo img runparams
-	-> ContainerName
-	-> (Container -> Property)
-	-> Property
-findContainer mhost cid cn mk = case mhost of
-	Nothing -> cantfind
-	Just h -> maybe cantfind mk (mkContainer cid h)
-  where
-	cantfind = containerDesc cid $ property "" $ do
-		liftIO $ warningMessage $
-			"missing definition for docker container \"" ++ cn2hn cn
-		return FailedChange
-
-mkContainer :: ContainerId -> Host -> Maybe Container
-mkContainer cid@(ContainerId hn _cn) h = Container
-	<$> fromVal (_dockerImage info)
-	<*> pure (map (\mkparam -> mkparam hn) (_dockerRunParams info))
   where
+	runparams = map (\mkparam -> mkparam hn) (_dockerRunParams info)
 	info = _dockerinfo $ hostInfo h'
 	h' = h
 		-- Restart by default so container comes up on
@@ -209,7 +200,7 @@ memoryLimited = "/etc/default/grub" `File.containsLine` cfg
 	cmdline = "cgroup_enable=memory swapaccount=1"
 	cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
 
-data Container = Container Image [RunParam]
+data ContainerInfo = ContainerInfo Image [RunParam]
 
 -- | Parameters to pass to `docker run` when creating a container.
 type RunParam = String

src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs

@@ -88,7 +88,7 @@ cabalDeps = flagFile go cabalupdated
 		go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"]
 		cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"
 
-standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host
+standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Docker.Container
 standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder")
 	(dockerImage $ System (Debian Testing) arch)
 	& os (System (Debian Testing) arch)
@@ -101,14 +101,14 @@ standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.conta
 	& autobuilder arch (show buildminute ++ " * * * *") timeout
 	& Docker.tweaked
 
-androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host
+androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container
 androidAutoBuilderContainer dockerImage crontimes timeout =
 	androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir
 		& Apt.unattendedUpgrades
 		& autobuilder "android" crontimes timeout
 
 -- Android is cross-built in a Debian i386 container, using the Android NDK.
-androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host
+androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container
 androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name
 	(dockerImage osver)
 	& os osver
@@ -137,7 +137,7 @@ androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.containe
 -- armel builder has a companion container using amd64 that
 -- runs the build first to get TH splices. They need
 -- to have the same versions of all haskell libraries installed.
-armelCompanionContainer :: (System -> Docker.Image) -> Host
+armelCompanionContainer :: (System -> Docker.Image) -> Docker.Container
 armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion"
 	(dockerImage $ System (Debian Unstable) "amd64")
 	& os (System (Debian Testing) "amd64")
@@ -156,7 +156,7 @@ armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-
 	& Ssh.authorizedKeys builduser (Context "armel-git-annex-builder")
 	& Docker.tweaked
 
-armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host
+armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container
 armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder"
 	(dockerImage $ System (Debian Unstable) "armel")
 	& os (System (Debian Testing) "armel")

src/Propellor/Types/Info.hs

@@ -45,26 +45,22 @@ fromVal (Val a) = Just a
 fromVal NoVal = Nothing
 
 data DockerInfo = DockerInfo
-	{ _dockerImage :: Val String
+	{ _dockerRunParams :: [HostName -> String]
-	, _dockerRunParams :: [HostName -> String]
 	}
 
 instance Eq DockerInfo where
 	x == y = and
-		[ _dockerImage x == _dockerImage y
+		[ let simpl v = map (\a -> a "") (_dockerRunParams v)
-		, let simpl v = map (\a -> a "") (_dockerRunParams v)
 		  in simpl x == simpl y
 		]
 
 instance Monoid DockerInfo where
-	mempty = DockerInfo mempty mempty
+	mempty = DockerInfo mempty
 	mappend old new = DockerInfo
-		{ _dockerImage = _dockerImage old <> _dockerImage new
+		{ _dockerRunParams = _dockerRunParams old <> _dockerRunParams new
-		, _dockerRunParams = _dockerRunParams old <> _dockerRunParams new
 		}
 
 instance Show DockerInfo where
 	show a = unlines
-		[ "docker image " ++ show (_dockerImage a)
+		[ "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
-		, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
 		]