summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2014-06-05 16:52:45 -0400
committerJoey Hess2014-06-05 16:52:45 -0400
commitf8bad2726760268f1daae2a3329be5db310727b8 (patch)
treeab5db4785fee3c7e919213b97975e727e7724907 /src
parent383548956354a00cf24323310e9981ccea6a1ddf (diff)
parentdbffd982bac47cebd3fc67e51b46182f7e43392d (diff)
Merge branch 'joeyconfig'
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Attr.hs16
-rw-r--r--src/Propellor/CmdLine.hs11
-rw-r--r--src/Propellor/PrivData.hs12
-rw-r--r--src/Propellor/Property/Apt.hs6
-rw-r--r--src/Propellor/Property/Dns.hs13
-rw-r--r--src/Propellor/Property/Docker.hs88
-rw-r--r--src/Propellor/Property/Obnam.hs6
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs8
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs8
-rw-r--r--src/Propellor/Types.hs5
-rw-r--r--src/Propellor/Types/Attr.hs77
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))
]