Merge branch 'joeyconfig'

11 files changed, 192 insertions, 58 deletions

diff --git a/src/Propellor/Attr.hs b/src/Propellor/Attr.hs
index 29d7a01e..7d371d40 100644
--- a/src/Propellor/Attr.hs
+++ b/src/Propellor/Attr.hs
@@ -15,12 +15,15 @@ import Control.Applicative
 pureAttrProperty :: Desc -> Attr -> Property 
 pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
 
+askAttr :: (Attr -> Val a) -> Propellor (Maybe a)
+askAttr f = asks (fromVal . f . hostAttr)
+
 os :: System -> Property
 os system = pureAttrProperty ("Operating " ++ show system) $
-	mempty { _os = Just system }
+	mempty { _os = Val system }
 
 getOS :: Propellor (Maybe System)
-getOS = asks (_os . hostAttr)
+getOS = askAttr _os
 
 -- | Indidate that a host has an A record in the DNS.
 --
@@ -34,6 +37,11 @@ ipv6 :: String -> Property
 ipv6 = addDNS . Address . IPv6
 
 -- | Indicates another name for the host in the DNS.
+--
+-- When the host's ipv4/ipv6 addresses are known, the alias is set up
+-- to use their address, rather than using a CNAME. This avoids various
+-- problems with CNAMEs, and also means that when multiple hosts have the
+-- same alias, a DNS round-robin is automatically set up.
 alias :: Domain -> Property
 alias = addDNS . CNAME . AbsDomain
 
@@ -55,10 +63,10 @@ addDNS r = pureAttrProperty (rdesc r) $
 
 sshPubKey :: String -> Property
 sshPubKey k = pureAttrProperty ("ssh pubkey known") $
-	mempty { _sshPubKey = Just k }
+	mempty { _sshPubKey = Val k }
 
 getSshPubKey :: Propellor (Maybe String)
-getSshPubKey = asks (_sshPubKey . hostAttr)
+getSshPubKey = askAttr _sshPubKey
 
 hostMap :: [Host] -> M.Map HostName Host
 hostMap l = M.fromList $ zip (map hostName l) l 
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index a7b7ef96..06a5921d 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -27,6 +27,7 @@ usage = do
 		, "  propellor hostname"
 		, "  propellor --spin hostname"
 		, "  propellor --set hostname field"
+		, "  propellor --dump hostname field"
 		, "  propellor --add-key keyid"
 		]
 	exitFailure
@@ -38,9 +39,8 @@ processCmdLine = go =<< getArgs
   	go ("--spin":h:[]) = return $ Spin h
   	go ("--boot":h:[]) = return $ Boot h
 	go ("--add-key":k:[]) = return $ AddKey k
-	go ("--set":h:f:[]) = case readish f of
-		Just pf -> return $ Set h pf
-		Nothing -> errorMessage $ "Unknown privdata field " ++ f
+	go ("--set":h:f:[]) = withprivfield f (return . Set h)
+	go ("--dump":h:f:[]) = withprivfield f (return . Dump h)
 	go ("--continue":s:[]) = case readish s of
 		Just cmdline -> return $ Continue cmdline
 		Nothing -> errorMessage "--continue serialization failure"
@@ -56,6 +56,10 @@ processCmdLine = go =<< getArgs
 			else return $ Run s
 	go _ = usage
 
+	withprivfield s f = case readish s of
+		Just pf -> f pf
+		Nothing -> errorMessage $ "Unknown privdata field " ++ s
+
 defaultMain :: [Host] -> IO ()
 defaultMain hostlist = do
 	DockerShim.cleanEnv
@@ -66,6 +70,7 @@ defaultMain hostlist = do
   where
 	go _ (Continue cmdline) = go False cmdline
 	go _ (Set hn field) = setPrivData hn field
+	go _ (Dump hn field) = dumpPrivData hn field
 	go _ (AddKey keyid) = addKey keyid
 	go _ (Chain hn) = withhost hn $ \h -> do
 		r <- runPropellor h $ ensureProperties $ hostProperties h
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 54f67d73..5ddbdcff 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -49,7 +49,7 @@ setPrivData host field = do
 	value <- chomp <$> hGetContentsStrict stdin
 	makePrivDataDir
 	let f = privDataFile host
-	m <- fromMaybe M.empty . readish <$> gpgDecrypt f
+	m <- decryptPrivData host
 	let m' = M.insert field value m
 	gpgEncrypt f (show m')
 	putStrLn "Private data set."
@@ -59,6 +59,16 @@ setPrivData host field = do
 		| end s == "\n" = chomp (beginning s)
 		| otherwise = s
 
+dumpPrivData :: HostName -> PrivDataField -> IO ()
+dumpPrivData host field = go . M.lookup field =<< decryptPrivData host
+  where
+	go Nothing = error "Requested privdata is not set."
+	go (Just s) = putStrLn s
+
+decryptPrivData :: HostName -> IO (M.Map PrivDataField String)
+decryptPrivData host = fromMaybe M.empty . readish
+	<$> gpgDecrypt (privDataFile host)
+
 makePrivDataDir :: IO ()
 makePrivDataDir = createDirectoryIfMissing False privDataDir
 
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index d3f47a80..69144d72 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -254,3 +254,9 @@ trustsKey k = RevertableProperty trust untrust
 				hPutStr h (pubkey k)
 				hClose h
 		nukeFile $ f ++ "~" -- gpg dropping
+
+-- | Cleans apt's cache of downloaded packages to avoid using up disk
+-- space.
+cacheCleaned :: Property
+cacheCleaned = cmdProperty "apt-get" ["clean"]
+	`describe` "apt cache cleaned" 
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 3e5c7828..50ce649e 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -339,7 +339,7 @@ genZone hosts zdomain soa =
 		, map hostrecords inzdomain
 		, map addcnames (M.elems m)
 		]
-	in (Zone zdomain soa (nub zhosts), warnings)
+	in (Zone zdomain soa (simplify zhosts), warnings)
   where
 	m = hostMap hosts
 	-- Known hosts with hostname located in the zone's domain.
@@ -390,6 +390,17 @@ genZone hosts zdomain soa =
 		l = zip (repeat $ AbsDomain $ hostName h)
 			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr))
 
+	-- Simplifies the list of hosts. Remove duplicate entries.
+	-- Also, filter out any CHAMES where the same domain has an
+	-- IP address, since that's not legal.
+	simplify :: [(BindDomain, Record)] -> [(BindDomain, Record)]
+	simplify l = nub $ filter (not . dupcname ) l
+	  where
+		dupcname (d, CNAME _) | any (matchingaddr d) l = True
+		dupcname _ = False
+		matchingaddr d (d', (Address _)) | d == d' = True
+		matchingaddr _ _ = False
+
 inDomain :: Domain -> BindDomain -> Bool
 inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d
 inDomain _ _ = False -- can't tell, so assume not
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 8e081ae4..fa3e2344 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -5,7 +5,33 @@
 -- The existance of a docker container is just another Property of a system,
 -- which propellor can set up. See config.hs for an example.
 
-module Propellor.Property.Docker where
+module Propellor.Property.Docker (
+	-- * Host properties
+	installed,
+	configured,
+	container,
+	docked,
+	memoryLimited,
+	garbageCollected,
+	Image,
+	ContainerName,
+	-- * Container configuration
+	dns,
+	hostname,
+	name,
+	publish,
+	expose,
+	user,
+	volume,
+	volumes_from,
+	workdir,
+	memory,
+	cpuShares,
+	link,
+	ContainerAlias,
+	-- * Internal use
+	chain,
+) where
 
 import Propellor
 import Propellor.SimpleSh
@@ -16,24 +42,24 @@ import qualified Propellor.Property.Docker.Shim as Shim
 import Utility.SafeCommand
 import Utility.Path
 
-import Control.Concurrent.Async
+import Control.Concurrent.Async hiding (link)
 import System.Posix.Directory
 import System.Posix.Process
 import Data.List
 import Data.List.Utils
 import qualified Data.Set as S
 
+installed :: Property
+installed = Apt.installed ["docker.io"]
+
 -- | Configures docker with an authentication file, so that images can be
--- pushed to index.docker.io.
+-- pushed to index.docker.io. Optional.
 configured :: Property
 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"]
-
 -- | A short descriptive name for a container.
 -- Should not contain whitespace or other unusual characters,
 -- only [a-zA-Z0-9_-] are allowed
@@ -48,15 +74,17 @@ type ContainerName = String
 container :: ContainerName -> Image -> Host
 container cn image = Host hn [] attr
   where
-	attr = mempty { _dockerImage = Just image }
+	attr = dockerAttr $ mempty { _dockerImage = Val image }
 	hn = cn2hn cn
 
 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. 
+-- | Ensures that a docker container is set up and running, finding
+-- its configuration in the passed list of hosts.
+-- 
+-- The container has its own Properties which are handled by running
+-- propellor inside the container.
 --
 -- Additionally, the container can have DNS attributes, such as a CNAME.
 -- These become attributes of the host(s) it's docked in.
@@ -116,10 +144,10 @@ findContainer mhost cid cn mk = case mhost of
 
 mkContainer :: ContainerId -> Host -> Maybe Container
 mkContainer cid@(ContainerId hn _cn) h = Container
-	<$> _dockerImage attr
+	<$> fromVal (_dockerImage attr)
 	<*> pure (map (\a -> a hn) (_dockerRunParams attr))
   where
-	attr = hostAttr h'
+	attr = _dockerattr $ hostAttr h'
   	h' = h
 		-- expose propellor directory inside the container
 		& volume (localdir++":"++localdir)
@@ -144,6 +172,20 @@ garbageCollected = propertyList "docker garbage collected"
 	gcimages = property "docker images garbage collected" $ do
 		liftIO $ report <$> (mapM removeImage =<< listImages)
 
+-- | Configures the kernel to respect docker memory limits. 
+--
+-- This assumes the system boots using grub 2. And that you don't need any
+-- other GRUB_CMDLINE_LINUX_DEFAULT settings.
+--
+-- Only takes effect after reboot. (Not automated.)
+memoryLimited :: Property
+memoryLimited = "/etc/default/grub" `File.containsLine` cfg
+	`describe` "docker memory limited" 
+	`onChange` cmdProperty "update-grub" []
+  where
+	cmdline = "cgroup_enable=memory swapaccount=1"
+	cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
+
 data Container = Container Image [RunParam]
 
 -- | Parameters to pass to `docker run` when creating a container.
@@ -194,10 +236,20 @@ workdir :: String -> Property
 workdir = runProp "workdir"
 
 -- | Memory limit for container.
---Format: <number><optional unit>, where unit = b, k, m or g
+-- Format: <number><optional unit>, where unit = b, k, m or g
+--
+-- Note: Only takes effect when the host has the memoryLimited property
+-- enabled.
 memory :: String -> Property
 memory = runProp "memory"
 
+-- | CPU shares (relative weight).
+--
+-- By default, all containers run at the same priority, but you can tell
+-- the kernel to give more CPU time to a container using this property.
+cpuShares :: Int -> Property
+cpuShares = runProp "cpu-shares" . show
+
 -- | Link with another container on the same host.
 link :: ContainerName -> ContainerAlias -> Property
 link linkwith calias = genProp "link" $ \hn ->
@@ -218,9 +270,6 @@ data ContainerId = ContainerId HostName ContainerName
 data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
 	deriving (Read, Show, Eq)
 
-ident2id :: ContainerIdent -> ContainerId
-ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn
-
 toContainerId :: String -> Maybe ContainerId
 toContainerId s
 	| myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of
@@ -420,15 +469,18 @@ listImages :: IO [Image]
 listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
 
 runProp :: String -> RunParam -> Property
-runProp field val = pureAttrProperty (param) $
+runProp field val = pureAttrProperty (param) $ dockerAttr $
 	mempty { _dockerRunParams = [\_ -> "--"++param] }
   where
 	param = field++"="++val
 
 genProp :: String -> (HostName -> RunParam) -> Property
-genProp field mkval = pureAttrProperty field $
+genProp field mkval = pureAttrProperty field $ dockerAttr $
 	mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] }
 
+dockerAttr :: DockerAttr -> Attr
+dockerAttr a = mempty { _dockerattr = a }
+
 -- | The ContainerIdent of a container is written to
 -- /.propellor-ident inside it. This can be checked to see if
 -- the container has the same ident later.
diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs
index 32374b57..e5ef7365 100644
--- a/src/Propellor/Property/Obnam.hs
+++ b/src/Propellor/Property/Obnam.hs
@@ -38,8 +38,12 @@ data NumClients = OnlyClient | MultipleClients
 --
 -- How awesome is that?
 backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property
-backup dir crontimes params numclients = cronjob `describe` desc
+backup dir crontimes params numclients = backup' dir crontimes params numclients
 	`requires` restored dir params
+
+-- | Does a backup, but does not automatically restore.
+backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property
+backup' dir crontimes params numclients = cronjob `describe` desc
   where
 	desc = dir ++ " backed up by obnam"
 	cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes "root" "/" $
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 3dcafa35..6e4ca81a 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -99,7 +99,9 @@ cabalDeps = flagFile go cabalupdated
 standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host
 standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder")
 	(dockerImage $ System (Debian Unstable) arch)
+	& os (System (Debian Unstable) arch)
 	& Apt.stdSourcesList Unstable
+	& Apt.installed ["systemd"]
 	& Apt.unattendedUpgrades
 	& buildDepsApt
 	& autobuilder (show buildminute ++ " * * * *") timeout True
@@ -115,7 +117,9 @@ androidAutoBuilderContainer dockerImage crontimes timeout =
 androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host
 androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name
 	(dockerImage $ System (Debian Stable) "i386")
+	& os (System (Debian Stable) "i386")
 	& Apt.stdSourcesList Stable
+	& Apt.installed ["systemd"]
 	& User.accountFor builduser
 	& File.dirExists gitbuilderdir
 	& File.ownerGroup homedir builduser builduser
@@ -140,7 +144,9 @@ androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.containe
 armelCompanionContainer :: (System -> Docker.Image) -> Host
 armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion"
 	(dockerImage $ System (Debian Unstable) "amd64")
+	& os (System (Debian Unstable) "amd64")
 	& Apt.stdSourcesList Unstable
+	& Apt.installed ["systemd"]
 	& Apt.unattendedUpgrades
 	-- This volume is shared with the armel builder.
 	& Docker.volume gitbuilderdir
@@ -156,8 +162,10 @@ armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-
 armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host
 armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder"
 	(dockerImage $ System (Debian Unstable) "armel")
+	& os (System (Debian Unstable) "armel")
 	& Apt.stdSourcesList Unstable
 	& Apt.unattendedUpgrades
+	& Apt.installed ["systemd"]
 	& Apt.installed ["openssh-client"]
 	& Docker.link "armel-git-annex-builder-companion" "companion"
 	& Docker.volumes_from "armel-git-annex-builder-companion"
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index f6e1e37f..b44401ea 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -330,3 +330,11 @@ kiteShellBox = propertyList "kitenet.net shellinabox"
 		`onChange` Service.restarted "shellinabox"
 	, Service.running "shellinabox"
 	]
+
+githubBackup :: Property
+githubBackup = propertyList "github-backup box"
+	[ Apt.installed ["github-backup", "moreutils"]
+	, let f = "/home/joey/.github-keys"
+	  in File.hasPrivContent f
+		`onChange` File.ownerGroup f "joey" "joey"
+	]
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 4ea97bce..d0481b69 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -40,6 +40,7 @@ data Host = Host
 	, hostProperties :: [Property]
 	, hostAttr :: Attr
 	}
+	deriving (Show)
 
 -- | Propellor's monad provides read-only access to the host it's running
 -- on, including its attributes.
@@ -64,6 +65,9 @@ data Property = Property
 	-- ^ a property can set an attribute of the host that has the property.
 	}
 
+instance Show Property where
+	show = propertyDesc
+
 -- | A property that can be reverted.
 data RevertableProperty = RevertableProperty Property Property
 
@@ -132,6 +136,7 @@ data CmdLine
 	| Spin HostName
 	| Boot HostName
 	| Set HostName PrivDataField
+	| Dump HostName PrivDataField
 	| AddKey String
 	| Continue CmdLine
 	| Chain HostName
diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs
index 4c891a46..e8c22a94 100644
--- a/src/Propellor/Types/Attr.hs
+++ b/src/Propellor/Types/Attr.hs
@@ -8,50 +8,67 @@ import Data.Monoid
 
 -- | The attributes of a host.
 data Attr = Attr
-	{ _os :: Maybe System
-	, _sshPubKey :: Maybe String
+	{ _os :: Val System
+	, _sshPubKey :: Val String
 	, _dns :: S.Set Dns.Record
 	, _namedconf :: Dns.NamedConfMap
+	, _dockerattr :: DockerAttr
+	}
+	deriving (Eq)
+
+instance Monoid Attr where
+	mempty = Attr mempty mempty mempty mempty mempty
+	mappend old new = Attr
+		{ _os = _os old <> _os new
+		, _sshPubKey = _sshPubKey old <> _sshPubKey new
+		, _dns = _dns old <> _dns new
+		, _namedconf = _namedconf old <> _namedconf new
+		, _dockerattr = _dockerattr old <> _dockerattr new
+		}
+
+instance Show Attr where
+	show a = unlines
+		[ "OS " ++ show (_os a)
+		, "sshPubKey " ++ show (_sshPubKey a)
+		, "dns " ++ show (_dns a)
+		, "namedconf " ++ show (_namedconf a)
+		, show (_dockerattr a)
+		]
+
+data Val a = Val a | NoVal
+	deriving (Eq, Show)
+
+instance Monoid (Val a) where
+	mempty = NoVal
+	mappend old new = case new of
+		NoVal -> old
+		_ -> new
 
-	, _dockerImage :: Maybe String
+fromVal :: Val a -> Maybe a
+fromVal (Val a) = Just a
+fromVal NoVal = Nothing
+
+data DockerAttr = DockerAttr
+	{ _dockerImage :: Val String
 	, _dockerRunParams :: [HostName -> String]
 	}
 
-instance Eq Attr where
+instance Eq DockerAttr where
 	x == y = and
-		[ _os x == _os y
-		, _dns x == _dns y
-		, _namedconf x == _namedconf y
-		, _sshPubKey x == _sshPubKey y
-
-		, _dockerImage x == _dockerImage y
+		[ _dockerImage x == _dockerImage y
 		, let simpl v = map (\a -> a "") (_dockerRunParams v)
 		  in simpl x == simpl y
 		]
 
-instance Monoid Attr where
-	mempty = Attr Nothing Nothing mempty mempty Nothing mempty
-	mappend old new = Attr
-		{ _os = case _os new of
-			Just v -> Just v
-			Nothing -> _os old
-		, _sshPubKey = case _sshPubKey new of
-			Just v -> Just v
-			Nothing -> _sshPubKey old
-		, _dns = _dns new <> _dns old
-		, _namedconf = _namedconf new <> _namedconf old
-		, _dockerImage = case _dockerImage new of
-			Just v -> Just v
-			Nothing -> _dockerImage old
+instance Monoid DockerAttr where
+	mempty = DockerAttr mempty mempty
+	mappend old new = DockerAttr
+		{ _dockerImage = _dockerImage old <> _dockerImage new
 		, _dockerRunParams = _dockerRunParams old <> _dockerRunParams new
 		}
 
-instance Show Attr where
+instance Show DockerAttr where
 	show a = unlines
-		[ "OS " ++ show (_os a)
-		, "sshPubKey " ++ show (_sshPubKey a)
-		, "dns " ++ show (_dns a)
-		, "namedconf " ++ show (_namedconf a)
-		, "docker image " ++ show (_dockerImage a)
+		[ "docker image " ++ show (_dockerImage a)
 		, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
 		]