propellor spin

2014-04-10 23:20:12 -04:00 · 2014-04-10 23:20:12 -04:00 · 839e60bbce
parent 50cd59cb3e
commit 839e60bbce
4 changed files with 182 additions and 207 deletions
--- a/Propellor/Property/Docker.hs
+++ b/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))
-	-> HostName
+	:: [Host]
+	-> 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 (ContainerId hn cn) $ Property "" $ do
-		liftIO $ warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
+	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
+	<$> _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.
-- 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
+data Container = Container Image [RunParam]

 -- | 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 cid@(ContainerId hn cn) image containerprops = containerDesc cid $ Property "running" $ do
+runningContainer :: ContainerId -> Image -> [RunParam] -> Property
+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 field val = Containerized
-	[\_ -> "--" ++ param]
-	(Property (param) (return NoChange))
+runProp :: String -> RunParam -> AttrProperty
+runProp field val = AttrProperty prop $ \attr ->
+	attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
  where
 	param = field++"="++val
+	prop = Property (param) (return NoChange)

-genProp :: String -> (HostName -> RunParam) -> Containerized Property
-genProp field mkval = Containerized
-	[\h -> "--" ++ field ++ "=" ++ mkval h]
-	(Property field (return NoChange))
+genProp :: String -> (HostName -> RunParam) -> AttrProperty
+genProp field mkval = AttrProperty prop $ \attr ->
+	attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
+  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
--- a/Propellor/Types/Attr.hs
+++ b/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
--- a/config-joey.hs
+++ b/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
-		& "openid.kitenet.net"
-			`cnameFor` Docker.docked container
+		& JoeySites.oldUseNetShellBox
+
+		& 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 container "i386-git-annex-builder"
-		! Docker.docked container "armel-git-annex-builder-companion"
-		! Docker.docked container "armel-git-annex-builder"
+		& Docker.docked hosts "amd64-git-annex-builder"
+		& Docker.docked hosts "i386-git-annex-builder"
+		! Docker.docked hosts "armel-git-annex-builder-companion"
+		! 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.
-container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)
-container _parenthost name
-{-
+	--------------------------------------------------------------------
+	--  Docker Containers  ----------------------------------- \o/ -----
+	--------------------------------------------------------------------
+
 	-- Simple web server, publishing the outside host's /var/www
-	| name == "webserver" = Just $ standardContainer Stable "amd64"
-		[ Docker.publish "8080:80"
-		, Docker.volume "/var/www:/var/www"
-		, Docker.inside $ props
-			& Apt.serviceInstalledRunning "apache2"
-		]
+	, standardContainer "webserver" Stable "amd64"
+		& Docker.publish "8080:80"
+		& Docker.volume "/var/www:/var/www"
+		& Apt.serviceInstalledRunning "apache2"

 	-- My own openid provider. Uses php, so containerized for security
 	-- and administrative sanity.
-	| name == "openid-provider" = Just $ standardContainer Stable "amd64"
-		[ Docker.publish "8081:80"
-		, Docker.inside $ props
-			& OpenId.providerFor ["joey", "liw"]
-				"openid.kitenet.net:8081"
-		]
+	, standardContainer "openid-provider" Stable "amd64"
+		& Docker.publish "8081:80"
+		& OpenId.providerFor ["joey", "liw"]
+			"openid.kitenet.net:8081"
 	
-	| name == "ancient-kitenet" = Just $ standardContainer Stable "amd64"
-		[ Docker.publish "1994:80"
-		, Docker.inside $ props
-			& Apt.serviceInstalledRunning "apache2"
-			& Apt.installed ["git"]
-			& scriptProperty 
-				[ "cd /var/"
-				, "rm -rf www"
-				, "git clone git://git.kitenet.net/kitewiki www"
-				, "cd www"
-				, "git checkout remotes/origin/old-kitenet.net"
-				] `flagFile` "/var/www/blastfromthepast.html"
-		]
+	, standardContainer "ancient-kitenet" Stable "amd64"
+		& Docker.publish "1994:80"
+		& Apt.serviceInstalledRunning "apache2"
+		& Apt.installed ["git"]
+		& scriptProperty 
+			[ "cd /var/"
+			, "rm -rf www"
+			, "git clone git://git.kitenet.net/kitewiki www"
+			, "cd www"
+			, "git checkout remotes/origin/old-kitenet.net"
+			] `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.inside $ props
-			& Apt.unattendedUpgrades
-		]
-	| name == "armel-git-annex-builder" = Just $ Docker.containerFrom
+		& Docker.volume GitAnnexBuilder.homedir
+		& Apt.unattendedUpgrades
+	, Docker.container "armel-git-annex-builder"
 		(image $ System (Debian Unstable) "armel")
-		[ Docker.link (name ++ "-companion") "companion"
-		, Docker.volumes_from (name ++ "-companion")
-		, Docker.inside $ props
--			& GitAnnexBuilder.builder "armel" "15 * * * *" True
-			& Apt.unattendedUpgrades
-		]
+		& Docker.link "armel-git-annex-builder-companion" "companion"
+		& Docker.volumes_from "armel-git-annex-builder-companion"
+--		& GitAnnexBuilder.builder "armel" "15 * * * *" True
+		& 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.
-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!
+gitAnnexBuilder :: Architecture -> Int -> Host
+gitAnnexBuilder arch buildminute = Docker.container (arch ++ "-git-annex-builder")
+	(image $ System (Debian Unstable) arch)
+	& GitAnnexBuilder.builder arch (show buildminute ++ " * * * *") True
+	& 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 suite arch ps = Docker.containerFrom
-	(image $ System (Debian suite) arch) $
-	[ Docker.inside $ props
-		& Apt.stdSourcesList suite
-		& Apt.unattendedUpgrades
-	] ++ ps
-}
+standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host
+standardContainer name suite arch = Docker.container name (image system)
+	& Apt.stdSourcesList suite
+	& Apt.unattendedUpgrades
+  where
+	system = System (Debian suite) arch
+
+-- | 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
--- a/config-simple.hs
+++ b/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 ()
-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.
--
+-- The hosts propellor knows about.
 -- Edit this to configure propellor!
-host :: HostName -> Maybe [Property]
-host "mybox.example.com" = Just $ props
-	& Apt.stdSourcesList Unstable
-		`onChange` Apt.upgrade
-	& Apt.unattendedUpgrades
-	& Apt.installed ["etckeeper"]
-	& Apt.installed ["ssh"]
-	& User.hasSomePassword "root"
-	& Network.ipv6to4
-	& File.dirExists "/var/www"
-	& Docker.docked container "webserver"
-	& Docker.garbageCollected `period` Daily
-	& Cron.runPropellor "30 * * * *"
-- add more hosts here...
--host "foo.example.com" =
-host _ = Nothing
+hosts :: [Host]
+hosts =
+	[ host "mybox.example.com"
+		& Apt.stdSourcesList Unstable
+			`onChange` Apt.upgrade
+		& Apt.unattendedUpgrades
+		& Apt.installed ["etckeeper"]
+		& Apt.installed ["ssh"]
+		& User.hasSomePassword "root"
+		& Network.ipv6to4
+		& File.dirExists "/var/www"
+		& Docker.docked hosts "webserver"
+		& Docker.garbageCollected `period` Daily
+		& Cron.runPropellor "30 * * * *"

-- | 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.containerFrom "joeyh/debian-unstable"
-	[ Docker.publish "80:80"
-	, Docker.volume "/var/www:/var/www"
-	, Docker.inside $ props
+	-- A generic webserver in a Docker container.
+	, Docker.container "webserver" "joeyh/debian-unstable"
+		& Docker.publish "80:80"
+		& Docker.volume "/var/www:/var/www"
 		& Apt.serviceInstalledRunning "apache2"
+
+	-- add more hosts here...
+	--, host "foo.example.com" = ...
 	]
-container _ _ = Nothing
+
+main :: IO ()
+main = defaultMain hosts