propellor spin

Propellor/Property/Docker.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
 
 -- | Docker support for propellor
 --
@@ -9,6 +9,7 @@ module Propellor.Property.Docker where
 
 import Propellor
 import Propellor.SimpleSh
+import Propellor.Types.Attr
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Docker.Shim as Shim
@@ -32,6 +33,25 @@ configured = Property "docker configured" go `requires` installed
 installed :: Property
 installed = Apt.installed ["docker.io"]
 
+-- | A short descriptive name for a container.
+-- Should not contain whitespace or other unusual characters,
+-- only [a-zA-Z0-9_-] are allowed
+type ContainerName = String
+
+-- | Starts accumulating the properties of a Docker container.
+--
+-- > container "web-server" "debian"
+-- >    & publish "80:80"
+-- >    & Apt.installed {"apache2"]
+-- >    & ...
+container :: ContainerName -> Image -> Host
+container cn image = Host [] (\_ -> attr)
+  where
+	attr = (newAttr (cn2hn cn)) { _dockerImage = Just image }
+
+cn2hn :: ContainerName -> HostName
+cn2hn cn = cn ++ ".docker"
+
 -- | 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.
@@ -39,24 +59,24 @@ installed = Apt.installed ["docker.io"]
 -- Reverting this property ensures that the container is stopped and
 -- removed.
 docked
-	:: (HostName -> ContainerName -> Maybe (Container))
+	:: [Host]
 	-> ContainerName
 	-> RevertableProperty
-docked findc cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
+docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
   where
 	go desc a = Property (desc ++ " " ++ cn) $ do
 		hn <- getHostName
   		let cid = ContainerId hn cn
-		ensureProperties [findContainer findc hn cn $ a cid]
+		ensureProperties [findContainer hosts cid cn $ a cid]
 
-	setup cid (Container image containerprops) =
+	setup cid (Container image runparams) =
 		provisionContainer cid
 			`requires`
-		runningContainer cid image containerprops
+		runningContainer cid image runparams
 			`requires`
 		installed
 
-	teardown cid (Container image _) =
+	teardown cid (Container image _runparams) =
 		combineProperties ("undocked " ++ fromContainerId cid)
 			[ stoppedContainer cid
 			, Property ("cleaned up " ++ fromContainerId cid) $
@@ -67,20 +87,33 @@ docked findc cn = RevertableProperty (go "docked" setup) (go "undocked" teardown
 			]
 
 findContainer
-	:: (HostName -> ContainerName -> Maybe (Container))
+	:: [Host]
-	-> HostName
+	-> ContainerId
 	-> ContainerName
 	-> (Container -> Property)
 	-> Property
-findContainer findc hn cn mk = case findc hn cn of
+findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of
 	Nothing -> cantfind
-	Just container -> mk container
+	Just h -> maybe cantfind mk (mkContainer cid h)
   where
-  	cid = ContainerId hn cn
+	cantfind = containerDesc cid $ Property "" $ do
-	cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do
+		liftIO $ warningMessage $
-		liftIO $ warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
+			"missing definition for docker container \"" ++ cn2hn cn
 		return FailedChange
 
+mkContainer :: ContainerId -> Host -> Maybe Container
+mkContainer cid@(ContainerId hn _cn) h = Container
+	<$> _dockerImage attr
+	<*> pure (map (\a -> a hn) (_dockerRunParams attr))
+  where
+	attr = hostAttr h'
+  	h' = h
+		-- 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)
+
 -- | Causes *any* docker images that are not in use by running containers to
 -- be deleted. And deletes any containers that propellor has set up
 -- before that are not currently running. Does not delete any containers
@@ -98,30 +131,7 @@ garbageCollected = propertyList "docker garbage collected"
 	gcimages = Property "docker images garbage collected" $ do
 		liftIO $ report <$> (mapM removeImage =<< listImages)
 
--- | Pass to defaultMain to add docker containers.
+data Container = Container Image [RunParam]
--- You need to provide the function mapping from
--- HostName and ContainerName to the Container to use.
-containerProperties
-	:: (HostName -> ContainerName -> Maybe (Container))
-	-> (HostName -> Maybe [Property])
-containerProperties findcontainer = \h -> case toContainerId h of
-	Nothing -> Nothing
-	Just cid@(ContainerId hn cn) ->
-		case findcontainer hn cn of
-			Nothing -> Nothing
-			Just (Container _ cprops) -> 
-				Just $ map (containerDesc cid) $
-					fromContainerized cprops
-
--- | This type is used to configure a docker container.
--- It has an image, and a list of Properties, but these
--- properties are Containerized; they can specify
--- things about the container's configuration, in
--- addition to properties of the system inside the
--- container.
-data Container = Container Image [Containerized Property]
-
-data Containerized a = Containerized [HostName -> RunParam] a
 
 -- | Parameters to pass to `docker run` when creating a container.
 type RunParam = String
@@ -129,62 +139,50 @@ type RunParam = String
 -- | A docker image, that can be used to run a container.
 type Image = String
 
--- | A short descriptive name for a container.
--- Should not contain whitespace or other unusual characters,
--- only [a-zA-Z0-9_.-] are allowed
-type ContainerName = String
-
--- | Lift a Property to apply inside a container.
-inside1 :: Property -> Containerized Property
-inside1 = Containerized []
-
-inside :: [Property] -> Containerized Property
-inside = Containerized [] . combineProperties "provision"
-
 -- | Set custom dns server for container.
-dns :: String -> Containerized Property
+dns :: String -> AttrProperty
 dns = runProp "dns"
 
 -- | Set container host name.
-hostname :: String -> Containerized Property
+hostname :: String -> AttrProperty
 hostname = runProp "hostname"
 
 -- | Set name for container. (Normally done automatically.)
-name :: String -> Containerized Property
+name :: String -> AttrProperty
 name = runProp "name"
 
 -- | Publish a container's port to the host
 -- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
-publish :: String -> Containerized Property
+publish :: String -> AttrProperty
 publish = runProp "publish"
 
 -- | Username or UID for container.
-user :: String -> Containerized Property
+user :: String -> AttrProperty
 user = runProp "user"
 
 -- | Mount a volume
 -- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]
 -- With just a directory, creates a volume in the container.
-volume :: String -> Containerized Property
+volume :: String -> AttrProperty
 volume = runProp "volume"
 
 -- | Mount a volume from the specified container into the current
 -- container.
-volumes_from :: ContainerName -> Containerized Property
+volumes_from :: ContainerName -> AttrProperty
 volumes_from cn = genProp "volumes-from" $ \hn ->
 	fromContainerId (ContainerId hn cn)
 
 -- | Work dir inside the container. 
-workdir :: String -> Containerized Property
+workdir :: String -> AttrProperty
 workdir = runProp "workdir"
 
 -- | Memory limit for container.
 --Format: <number><optional unit>, where unit = b, k, m or g
-memory :: String -> Containerized Property
+memory :: String -> AttrProperty
 memory = runProp "memory"
 
 -- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> Containerized Property
+link :: ContainerName -> ContainerAlias -> AttrProperty
 link linkwith alias = genProp "link" $ \hn ->
 	fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias
 
@@ -203,16 +201,6 @@ data ContainerId = ContainerId HostName ContainerName
 data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
 	deriving (Read, Show, Eq)
 
-getRunParams :: HostName -> [Containerized a] -> [RunParam]
-getRunParams hn l = concatMap get l
-  where
-	get (Containerized ps _) = map (\a -> a hn ) ps
-
-fromContainerized :: forall a. [Containerized a] -> [a]
-fromContainerized l = map get l
-  where
-	get (Containerized _ a) = a
-
 ident2id :: ContainerIdent -> ContainerId
 ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn
 
@@ -233,16 +221,13 @@ fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
 myContainerSuffix :: String
 myContainerSuffix = ".propellor"
 
-containerFrom :: Image -> [Containerized Property] -> Container
-containerFrom = Container
-
 containerDesc :: ContainerId -> Property -> Property
 containerDesc cid p = p `describe` desc
   where
 	desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
 
-runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property
+runningContainer :: ContainerId -> Image -> [RunParam] -> Property
-runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc cid $ Property "running" $ do
+runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ Property "running" $ do
 	l <- liftIO $ listContainers RunningContainers
 	if cid `elem` l
 		then do
@@ -275,14 +260,6 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
 	extractident :: [Resp] -> Maybe ContainerIdent
 	extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
 
-	runps = getRunParams hn $ 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)
-		]
-	
 	go img = do
 		liftIO $ do
 			clearProvisionedFlag cid
@@ -425,17 +402,18 @@ listContainers status =
 listImages :: IO [Image]
 listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
 
-runProp :: String -> RunParam -> Containerized Property
+runProp :: String -> RunParam -> AttrProperty
-runProp field val = Containerized
+runProp field val = AttrProperty prop $ \attr ->
-	[\_ -> "--" ++ param]
+	attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
-	(Property (param) (return NoChange))
   where
 	param = field++"="++val
+	prop = Property (param) (return NoChange)
 
-genProp :: String -> (HostName -> RunParam) -> Containerized Property
+genProp :: String -> (HostName -> RunParam) -> AttrProperty
-genProp field mkval = Containerized
+genProp field mkval = AttrProperty prop $ \attr ->
-	[\h -> "--" ++ field ++ "=" ++ mkval h]
+	attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
-	(Property field (return NoChange))
+  where
+	prop = Property field (return NoChange)
 
 -- | The ContainerIdent of a container is written to
 -- /.propellor-ident inside it. This can be checked to see if

Propellor/Types/Attr.hs

@@ -6,11 +6,23 @@ import qualified Data.Set as S
 data Attr = Attr
 	{ _hostname :: HostName
 	, _cnames :: S.Set Domain
+
+	, _dockerImage :: Maybe String
+	, _dockerRunParams :: [HostName -> String]
 	}
-	deriving (Eq, Show)
+
+instance Eq Attr where
+	x == y = and
+		[ _hostname x == _hostname y
+		, _cnames x == _cnames y
+
+		, _dockerImage x == _dockerImage y
+		, let simpl v = map (\a -> a "") (_dockerRunParams v)
+		  in simpl x == simpl y
+		]
 
 newAttr :: HostName -> Attr
-newAttr hn = Attr hn S.empty
+newAttr hn = Attr hn S.empty Nothing []
 
 type HostName = String
 type Domain = String

config-joey.hs

@@ -11,7 +11,7 @@ import qualified Propellor.Property.Cron as Cron
 import qualified Propellor.Property.Sudo as Sudo
 import qualified Propellor.Property.User as User
 import qualified Propellor.Property.Hostname as Hostname
-import qualified Propellor.Property.Reboot as Reboot
+--import qualified Propellor.Property.Reboot as Reboot
 import qualified Propellor.Property.Tor as Tor
 import qualified Propellor.Property.Dns as Dns
 import qualified Propellor.Property.OpenId as OpenId
@@ -23,7 +23,13 @@ import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
 
 hosts :: [Host]
 hosts =
-	[ host "clam.kitenet.net"
+	-- My laptop
+	[ host "darkstar.kitenet.net"
+		& Docker.configured
+		& Apt.buildDep ["git-annex"] `period` Daily
+
+	-- Nothing super-important lives here.
+	, host "clam.kitenet.net"
 		& cleanCloudAtCost
 		& standardSystem Unstable
 		& Apt.unattendedUpgrades
@@ -31,26 +37,31 @@ hosts =
 		& Tor.isBridge
 		& Docker.configured
 		& cname "shell.olduse.net"
-			`requires` JoeySites.oldUseNetShellBox
+		& JoeySites.oldUseNetShellBox
-		& "openid.kitenet.net"
+
-			`cnameFor` Docker.docked container
+		& cname "openid.kitenet.net"
+		& Docker.docked hosts "openid-provider"
 			`requires` Apt.installed ["ntp"]
-		& "ancient.kitenet.net"
+
-			`cnameFor` Docker.docked container
+		& cname "ancient.kitenet.net"
+		& Docker.docked hosts "ancient-kitenet"
+
 		& Docker.garbageCollected `period` Daily
 		& Apt.installed ["git-annex", "mtr", "screen"]
+	
 	-- Orca is the main git-annex build box.
 	, host "orca.kitenet.net"
 		& standardSystem Unstable
 		& Hostname.sane
 		& Apt.unattendedUpgrades
 		& Docker.configured
-		& Docker.docked container "amd64-git-annex-builder"
+		& Docker.docked hosts "amd64-git-annex-builder"
-		& Docker.docked container "i386-git-annex-builder"
+		& Docker.docked hosts "i386-git-annex-builder"
-		! Docker.docked container "armel-git-annex-builder-companion"
+		! Docker.docked hosts "armel-git-annex-builder-companion"
-		! Docker.docked container "armel-git-annex-builder"
+		! Docker.docked hosts "armel-git-annex-builder"
 		& Docker.garbageCollected `period` Daily
 		& Apt.buildDep ["git-annex"] `period` Daily
+	
 	-- Important stuff that needs not too much memory or CPU.
   	, host "diatom.kitenet.net"
 		& standardSystem Stable
@@ -71,83 +82,60 @@ hosts =
 		-- ssh keys for branchable and github repo hooks
 		-- gitweb
 		-- downloads.kitenet.net setup (including ssh key to turtle)
-	-- My laptop
-	, host "darkstar.kitenet.net"
-		& Docker.configured
-		& Apt.buildDep ["git-annex"] `period` Daily
-	]
 
--- | This is where Docker containers are set up. A container
+	--------------------------------------------------------------------
--- can vary by hostname where it's used, or be the same everywhere.
+	--  Docker Containers  ----------------------------------- \o/ -----
-container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)
+	--------------------------------------------------------------------
-container _parenthost name
+
-{-
 	-- Simple web server, publishing the outside host's /var/www
-	| name == "webserver" = Just $ standardContainer Stable "amd64"
+	, standardContainer "webserver" Stable "amd64"
-		[ Docker.publish "8080:80"
+		& Docker.publish "8080:80"
-		, Docker.volume "/var/www:/var/www"
+		& Docker.volume "/var/www:/var/www"
-		, Docker.inside $ props
+		& Apt.serviceInstalledRunning "apache2"
-			& Apt.serviceInstalledRunning "apache2"
-		]
 
 	-- My own openid provider. Uses php, so containerized for security
 	-- and administrative sanity.
-	| name == "openid-provider" = Just $ standardContainer Stable "amd64"
+	, standardContainer "openid-provider" Stable "amd64"
-		[ Docker.publish "8081:80"
+		& Docker.publish "8081:80"
-		, Docker.inside $ props
+		& OpenId.providerFor ["joey", "liw"]
-			& OpenId.providerFor ["joey", "liw"]
+			"openid.kitenet.net:8081"
-				"openid.kitenet.net:8081"
-		]
 	
-	| name == "ancient-kitenet" = Just $ standardContainer Stable "amd64"
+	, standardContainer "ancient-kitenet" Stable "amd64"
-		[ Docker.publish "1994:80"
+		& Docker.publish "1994:80"
-		, Docker.inside $ props
+		& Apt.serviceInstalledRunning "apache2"
-			& Apt.serviceInstalledRunning "apache2"
+		& Apt.installed ["git"]
-			& Apt.installed ["git"]
+		& scriptProperty 
-			& scriptProperty 
+			[ "cd /var/"
-				[ "cd /var/"
+			, "rm -rf www"
-				, "rm -rf www"
+			, "git clone git://git.kitenet.net/kitewiki www"
-				, "git clone git://git.kitenet.net/kitewiki www"
+			, "cd www"
-				, "cd www"
+			, "git checkout remotes/origin/old-kitenet.net"
-				, "git checkout remotes/origin/old-kitenet.net"
+			] `flagFile` "/var/www/blastfromthepast.html"
-				] `flagFile` "/var/www/blastfromthepast.html"
-		]
 	
+	-- git-annex autobuilder containers
+	, gitAnnexBuilder "amd64" 15
+	, gitAnnexBuilder "i386" 45
 	-- armel builder has a companion container that run amd64 and
 	-- runs the build first to get TH splices. They share a home
 	-- directory, and need to have the same versions of all haskell
 	-- libraries installed.
-	| name == "armel-git-annex-builder-companion" = Just $ Docker.containerFrom
+	, Docker.container "armel-git-annex-builder-companion"
 		(image $ System (Debian Unstable) "amd64")
-		[ Docker.volume GitAnnexBuilder.homedir
+		& Docker.volume GitAnnexBuilder.homedir
-		, Docker.inside $ props
+		& Apt.unattendedUpgrades
-			& Apt.unattendedUpgrades
+	, Docker.container "armel-git-annex-builder"
-		]
-	| name == "armel-git-annex-builder" = Just $ Docker.containerFrom
 		(image $ System (Debian Unstable) "armel")
-		[ Docker.link (name ++ "-companion") "companion"
+		& Docker.link "armel-git-annex-builder-companion" "companion"
-		, Docker.volumes_from (name ++ "-companion")
+		& Docker.volumes_from "armel-git-annex-builder-companion"
-		, Docker.inside $ props
+--		& GitAnnexBuilder.builder "armel" "15 * * * *" True
---			& GitAnnexBuilder.builder "armel" "15 * * * *" True
+		& Apt.unattendedUpgrades
-			& Apt.unattendedUpgrades
+	]
-		]
-	
-	| "-git-annex-builder" `isSuffixOf` name =
-		let arch = takeWhile (/= '-') name
-		in Just $ Docker.containerFrom
-			(image $ System (Debian Unstable) arch)
-			[ Docker.inside $ props
-				& GitAnnexBuilder.builder arch "15 * * * *" True
-				& Apt.unattendedUpgrades
-			]
--}
-	| otherwise = Nothing
 
--- | Docker images I prefer to use.
+gitAnnexBuilder :: Architecture -> Int -> Host
-image :: System -> Docker.Image
+gitAnnexBuilder arch buildminute = Docker.container (arch ++ "-git-annex-builder")
-image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch
+	(image $ System (Debian Unstable) arch)
-image (System (Debian Stable) arch) = "joeyh/debian-stable-" ++ arch
+	& GitAnnexBuilder.builder arch (show buildminute ++ " * * * *") True
-image _ = "debian-stable-official" -- does not currently exist!
+	& Apt.unattendedUpgrades
 
 -- This is my standard system setup
 standardSystem :: DebianSuite -> Property
@@ -171,16 +159,19 @@ standardSystem suite = template "standard system" $ props
 	& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
 		`onChange` Apt.autoRemove
 
-{-
 -- This is my standard container setup, featuring automatic upgrades.
-standardContainer :: DebianSuite -> Architecture -> [Docker.Containerized Property] -> Docker.Container
+standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host
-standardContainer suite arch ps = Docker.containerFrom
+standardContainer name suite arch = Docker.container name (image system)
-	(image $ System (Debian suite) arch) $
+	& Apt.stdSourcesList suite
-	[ Docker.inside $ props
+	& Apt.unattendedUpgrades
-		& Apt.stdSourcesList suite
+  where
-		& Apt.unattendedUpgrades
+	system = System (Debian suite) arch
-	] ++ ps
+
--}
+-- | Docker images I prefer to use.
+image :: System -> Docker.Image
+image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch
+image (System (Debian Stable) arch) = "joeyh/debian-stable-" ++ arch
+image _ = "debian-stable-official" -- does not currently exist!
 
 -- Clean up a system as installed by cloudatcost.com
 cleanCloudAtCost :: Property

config-simple.hs

@@ -16,38 +16,32 @@ import qualified Propellor.Property.User as User
 --import qualified Propellor.Property.Tor as Tor
 import qualified Propellor.Property.Docker as Docker
 
-main :: IO ()
+-- The hosts propellor knows about.
-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!
-host :: HostName -> Maybe [Property]
+hosts :: [Host]
-host "mybox.example.com" = Just $ props
+hosts =
-	& Apt.stdSourcesList Unstable
+	[ host "mybox.example.com"
-		`onChange` Apt.upgrade
+		& Apt.stdSourcesList Unstable
-	& Apt.unattendedUpgrades
+			`onChange` Apt.upgrade
-	& Apt.installed ["etckeeper"]
+		& Apt.unattendedUpgrades
-	& Apt.installed ["ssh"]
+		& Apt.installed ["etckeeper"]
-	& User.hasSomePassword "root"
+		& Apt.installed ["ssh"]
-	& Network.ipv6to4
+		& User.hasSomePassword "root"
-	& File.dirExists "/var/www"
+		& Network.ipv6to4
-	& Docker.docked container "webserver"
+		& File.dirExists "/var/www"
-	& Docker.garbageCollected `period` Daily
+		& Docker.docked hosts "webserver"
-	& Cron.runPropellor "30 * * * *"
+		& Docker.garbageCollected `period` Daily
--- add more hosts here...
+		& Cron.runPropellor "30 * * * *"
---host "foo.example.com" =
-host _ = Nothing
 
--- | This is where Docker containers are set up. A container
+	-- A generic webserver in a Docker container.
--- can vary by hostname where it's used, or be the same everywhere.
+	, Docker.container "webserver" "joeyh/debian-unstable"
-container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)
+		& Docker.publish "80:80"
-container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"
+		& Docker.volume "/var/www:/var/www"
-	[ Docker.publish "80:80"
-	, Docker.volume "/var/www:/var/www"
-	, Docker.inside $ props
 		& Apt.serviceInstalledRunning "apache2"
+
+	-- add more hosts here...
+	--, host "foo.example.com" = ...
 	]
-container _ _ = Nothing
+
+main :: IO ()
+main = defaultMain hosts