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)
2014-11-19 23:11:34 -04:00 · 2014-11-19 23:11:34 -04:00 · d49d251897
parent b7d78e679a
commit d49d251897
7 changed files with 112 additions and 131 deletions
--- a/config-joey.hs
+++ b/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 hosts "simple-debian"
+	! Docker.docked gitAnnexAndroidDev

 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 hosts "i386-git-annex-builder"
-	& Docker.docked hosts "android-git-annex-builder"
-	& Docker.docked hosts "armel-git-annex-builder-companion"
-	& Docker.docked hosts "armel-git-annex-builder"
+	& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h")
+	& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h")
+	& Docker.docked (GitAnnexBuilder.armelCompanionContainer dockerImage)
+	& Docker.docked (GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h")
+	& 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 hosts "openid-provider"
+	& Docker.docked oldusenetShellBox
+	& 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"
-		& Docker.publish "80:80"
-		& Docker.volume "/var/www:/var/www"
-		& Apt.serviceInstalledRunning "apache2"
+-- Simple web server, publishing the outside host's /var/www
+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"
-		& alias "openid.kitenet.net"
-		& Docker.publish "8081:80"
-		& OpenId.providerFor ["joey", "liw"]
-			"openid.kitenet.net:8081"
+-- My own openid provider. Uses php, so containerized for security
+-- and administrative sanity.
+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"
-		& 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"
-		& alias "shell.olduse.net"
-		& Docker.publish "4200:4200"
-		& JoeySites.oldUseNetShellBox
+-- Exhibit: kite's 90's website.
+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")

-	, Docker.container "simple-debian" "debian"
-		& "/hello" `File.containsLine` "hello"
-		& Docker.publish "8081:80"
+oldusenetShellBox :: Docker.Container
+oldusenetShellBox = standardStableContainer "oldusenet-shellbox"
+	& alias "shell.olduse.net"
+	& Docker.publish "4200:4200"
+	& JoeySites.oldUseNetShellBox

-	-- 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)
-	]
+-- for development of git-annex for android, using my git-annex work tree
+gitAnnexAndroidDev :: Docker.Container
+gitAnnexAndroidDev = 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
--- a/config-simple.hs
+++ b/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 * * * *"

-	-- A generic webserver in a Docker container.
-	, 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" = ...
 	]
+
+-- A generic webserver in a Docker container.
+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"
--- a/debian/changelog
+++ b/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
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@ -144,27 +144,28 @@ unrevertable (RevertableProperty p1 _p2) = p1
 host :: HostName -> Host
 host hn = Host hn [] mempty

-- | Adds a property to a Host
--
-- Can add Properties and RevertableProperties
-(&) :: IsProp p => Host -> p -> Host
-(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
+class Hostlike h where
+	-- | Adds a property to a Host
+	--
+	-- Can add Properties and RevertableProperties
+	(&) :: IsProp p => h -> p -> h
+	-- | 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 => h -> p -> h

-infixl 1 &
+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.
-(!) :: Host -> RevertableProperty -> Host
+(!) :: Hostlike h => h -> RevertableProperty -> h
 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
-(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is)
-
 infixl 1 &^
+infixl 1 &
+infixl 1 !

 -- Changes the action that is performed to satisfy a property. 
 adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
--- a/src/Propellor/Property/Docker.hs
+++ b/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 cn image = Host hn [] info
+container :: ContainerName -> Image -> Container
+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
-- its configuration in the passed list of hosts.
+-- | 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.
 --
 -- 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]
-	-> ContainerName
+	:: Container
 	-> RevertableProperty
-docked hosts cn = RevertableProperty
-	((maybe id propigateInfo mhost) (go "docked" setup))
+docked ctr@(Container _ h) = RevertableProperty
+	(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]
-		
-	mhost = findHostNoAlias hosts (cn2hn cn)
+		ensureProperties [a cid (mkContainerInfo cid ctr)]

-	setup cid (Container image runparams) =
+	setup cid (ContainerInfo 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
-	:: Maybe Host
-	-> ContainerId
-	-> 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))
+mkContainerInfo :: ContainerId -> Container -> ContainerInfo
+mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = 
+	ContainerInfo img runparams
  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
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/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")
--- a/src/Propellor/Types/Info.hs
+++ b/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))
 		]