summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-01-04 17:16:55 -0400
committerJoey Hess2015-01-04 17:16:55 -0400
commitacdcff5ca48aeb08cb0b06621cf9889e1c628a86 (patch)
treec57102d12541ec2be0c25bbaddeb8644a0cdeaf8 /src
parenta9163ba3ab5e59b93dc901959b43c05e3fe6498a (diff)
parentdf8d8eb5328b19dcde123d46d6cd9db0e2df88e9 (diff)
Merge branch 'joeyconfig'
Conflicts: privdata.joey/privdata.gpg
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/CmdLine.hs4
-rw-r--r--src/Propellor/Engine.hs2
-rw-r--r--src/Propellor/Info.hs17
-rw-r--r--src/Propellor/PrivData.hs2
-rw-r--r--src/Propellor/Property.hs3
-rw-r--r--src/Propellor/Property/Dns.hs96
-rw-r--r--src/Propellor/Property/DnsSec.hs122
-rw-r--r--src/Propellor/Property/Docker.hs31
-rw-r--r--src/Propellor/Property/File.hs18
-rw-r--r--src/Propellor/Property/HostingProvider/CloudAtCost.hs2
-rw-r--r--src/Propellor/Property/Ssh.hs83
-rw-r--r--src/Propellor/Spin.hs44
-rw-r--r--src/Propellor/Types.hs6
-rw-r--r--src/Propellor/Types/Dns.hs1
-rw-r--r--src/Propellor/Types/PrivData.hs17
-rw-r--r--src/Utility/Process.hs10
16 files changed, 375 insertions, 83 deletions
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index 3e375c7e..378367e8 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -54,7 +54,6 @@ processCmdLine = go =<< getArgs
go ("--help":_) = do
usage stdout
exitFailure
- go ("--update":_:[]) = return $ Update Nothing
go ("--boot":_:[]) = return $ Update Nothing -- for back-compat
go ("--serialized":s:[]) = serialized Serialized s
go ("--continue":s:[]) = serialized Continue s
@@ -98,8 +97,9 @@ defaultMain hostlist = do
go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
go _ (DockerInit hn) = Docker.init hn
go _ (GitPush fin fout) = gitPushHelper fin fout
+ go _ (Relay h) = forceConsole >> updateFirst (Update (Just h)) (update (Just h))
go _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing))
- go _ (Update (Just h)) = forceConsole >> fetchFirst (update (Just h))
+ go _ (Update (Just h)) = update (Just h)
go _ Merge = mergeSpin
go True cmdline@(Spin _ _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index f29ce1a9..667f6bfb 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -77,7 +77,7 @@ ensureProperties ps = ensure ps NoChange
-- | Lifts an action into a different host.
--
--- For example, `fromHost hosts "otherhost" getSshPubKey`
+-- For example, `fromHost hosts "otherhost" getPubKey`
fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
fromHost l hn getter = case findHost l hn of
Nothing -> return Nothing
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index a91f69c8..b7ca81b5 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -26,8 +26,13 @@ getOS = askInfo _os
-- | Indidate that a host has an A record in the DNS.
--
--- TODO check at run time if the host really has this address.
--- (Can't change the host's address, but as a sanity check.)
+-- When propellor is used to deploy a DNS server for a domain,
+-- the hosts in the domain are found by looking for these
+-- and similar properites.
+--
+-- When propellor --spin is used to deploy a host, it checks
+-- if the host's IP Property matches the DNS. If the DNS is missing or
+-- out of date, the host will instead be contacted directly by IP address.
ipv4 :: String -> Property
ipv4 = addDNS . Address . IPv4
@@ -59,18 +64,12 @@ addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r }
rdesc (NS d) = unwords ["NS", ddesc d]
rdesc (TXT s) = unwords ["TXT", s]
rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d]
+ rdesc (INCLUDE f) = unwords ["$INCLUDE", f]
ddesc (AbsDomain domain) = domain
ddesc (RelDomain domain) = domain
ddesc RootDomain = "@"
-sshPubKey :: String -> Property
-sshPubKey k = pureInfoProperty ("ssh pubkey known") $
- mempty { _sshPubKey = Val k }
-
-getSshPubKey :: Propellor (Maybe String)
-getSshPubKey = askInfo _sshPubKey
-
hostMap :: [Host] -> M.Map HostName Host
hostMap l = M.fromList $ zip (map hostName l) l
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 6253e924..2b27f221 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -55,7 +55,7 @@ withPrivData
-> Property
withPrivData s = withPrivData' snd [s]
--- Like withPrivData, but here any of a list of PrivDataFields can be used.
+-- Like withPrivData, but here any one of a list of PrivDataFields can be used.
withSomePrivData
:: (IsContext c, IsPrivDataSource s)
=> [s]
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 37fd90d6..c0878fb6 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -26,8 +26,7 @@ propertyList :: Desc -> [Property] -> Property
propertyList desc ps = Property desc (ensureProperties ps) (combineInfos ps)
-- | Combines a list of properties, resulting in one property that
--- ensures each in turn. Does not stop on failure; does propigate
--- overall success/failure.
+-- ensures each in turn. Stops if a property fails.
combineProperties :: Desc -> [Property] -> Property
combineProperties desc ps = Property desc (go ps NoChange) (combineInfos ps)
where
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index f351804c..581a9bfe 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -1,6 +1,7 @@
module Propellor.Property.Dns (
module Propellor.Types.Dns,
primary,
+ signedPrimary,
secondary,
secondaryFor,
mkSOA,
@@ -17,6 +18,8 @@ import Propellor.Types.Dns
import Propellor.Property.File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
+import Propellor.Property.Scheduled
+import Propellor.Property.DnsSec
import Utility.Applicative
import qualified Data.Map as M
@@ -53,18 +56,20 @@ import Data.List
primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
primary hosts domain soa rs = RevertableProperty setup cleanup
where
- setup = withwarnings (check needupdate baseprop)
- `requires` servingZones
+ setup = setupPrimary zonefile id hosts domain soa rs
+ `onChange` Service.reloaded "bind9"
+ cleanup = cleanupPrimary zonefile domain
`onChange` Service.reloaded "bind9"
- cleanup = check (doesFileExist zonefile) $
- property ("removed dns primary for " ++ domain)
- (makeChange $ removeZoneFile zonefile)
- `requires` namedConfWritten
- `onChange` Service.reloaded "bind9"
+ zonefile = "/etc/bind/propellor/db." ++ domain
+
+setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property
+setupPrimary zonefile mknamedconffile hosts domain soa rs =
+ withwarnings (check needupdate baseprop)
+ `requires` servingZones
+ where
(partialzone, zonewarnings) = genZone hosts domain soa
zone = partialzone { zHosts = zHosts partialzone ++ rs }
- zonefile = "/etc/bind/propellor/db." ++ domain
baseprop = Property ("dns primary for " ++ domain)
(makeChange $ writeZoneFile zone zonefile)
(addNamedConf conf)
@@ -74,7 +79,7 @@ primary hosts domain soa rs = RevertableProperty setup cleanup
conf = NamedConf
{ confDomain = domain
, confDnsServerType = Master
- , confFile = zonefile
+ , confFile = mknamedconffile zonefile
, confMasters = []
, confAllowTransfer = nub $
concatMap (\h -> hostAddresses h hosts) $
@@ -97,6 +102,63 @@ primary hosts domain soa rs = RevertableProperty setup cleanup
z = zone { zSOA = (zSOA zone) { sSerial = oldserial } }
in z /= oldzone || oldserial < sSerial (zSOA zone)
+
+cleanupPrimary :: FilePath -> Domain -> Property
+cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
+ property ("removed dns primary for " ++ domain)
+ (makeChange $ removeZoneFile zonefile)
+ `requires` namedConfWritten
+
+-- | Primary dns server for a domain, secured with DNSSEC.
+--
+-- This is like `primary`, except the resulting zone
+-- file is signed.
+-- The Zone Signing Key (ZSK) and Key Signing Key (KSK)
+-- used in signing it are taken from the PrivData.
+--
+-- As a side effect of signing the zone, a
+-- </var/cache/bind/dsset-domain.>
+-- file will be created. This file contains the DS records
+-- which need to be communicated to your domain registrar
+-- to make DNSSEC be used for your domain. Doing so is outside
+-- the scope of propellor (currently). See for example the tutorial
+-- <https://www.digitalocean.com/community/tutorials/how-to-setup-dnssec-on-an-authoritative-bind-dns-server--2>
+--
+-- The 'Recurrance' controls how frequently the signature
+-- should be regenerated, using a new random salt, to prevent
+-- zone walking attacks. `Weekly Nothing` is a reasonable choice.
+--
+-- To transition from 'primary' to 'signedPrimary', you can revert
+-- the 'primary' property, and add this property.
+--
+-- Note that DNSSEC zone files use a serial number based on the unix epoch.
+-- This is different from the serial number used by 'primary', so if you
+-- want to later disable DNSSEC you will need to adjust the serial number
+-- passed to mkSOA to ensure it is larger.
+signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
+signedPrimary recurrance hosts domain soa rs = RevertableProperty setup cleanup
+ where
+ setup = combineProperties ("dns primary for " ++ domain ++ " (signed)")
+ [ setupPrimary zonefile signedZoneFile hosts domain soa rs'
+ , toProp (zoneSigned domain zonefile)
+ , forceZoneSigned domain zonefile `period` recurrance
+ ]
+ `onChange` Service.reloaded "bind9"
+
+ cleanup = cleanupPrimary zonefile domain
+ `onChange` toProp (revert (zoneSigned domain zonefile))
+ `onChange` Service.reloaded "bind9"
+
+ -- Include the public keys into the zone file.
+ rs' = include PubKSK : include PubZSK : rs
+ include k = (RootDomain, INCLUDE (keyFn domain k))
+
+ -- Put DNSSEC zone files in a different directory than is used for
+ -- the regular ones. This allows 'primary' to be reverted and
+ -- 'signedPrimary' enabled, without the reverted property stomping
+ -- on the new one's settings.
+ zonefile = "/etc/bind/propellor/dnssec/db." ++ domain
+
-- | Secondary dns server for a domain.
--
-- The primary server is determined by looking at the properties of other
@@ -216,6 +278,7 @@ rField (MX _ _) = "MX"
rField (NS _) = "NS"
rField (TXT _) = "TXT"
rField (SRV _ _ _ _) = "SRV"
+rField (INCLUDE _) = "$INCLUDE"
rValue :: Record -> String
rValue (Address (IPv4 addr)) = addr
@@ -229,6 +292,7 @@ rValue (SRV priority weight port target) = unwords
, show port
, dValue target
]
+rValue (INCLUDE f) = f
rValue (TXT s) = [q] ++ filter (/= q) s ++ [q]
where
q = '"'
@@ -294,12 +358,16 @@ genZoneFile (Zone zdomain soa rs) = unlines $
header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit."
genRecord :: Domain -> (BindDomain, Record) -> String
+genRecord _ (_, record@(INCLUDE _)) = intercalate "\t"
+ [ rField record
+ , rValue record
+ ]
genRecord zdomain (domain, record) = intercalate "\t"
- [ domainHost zdomain domain
- , "IN"
- , rField record
- , rValue record
- ]
+ [ domainHost zdomain domain
+ , "IN"
+ , rField record
+ , rValue record
+ ]
genSOA :: SOA -> [String]
genSOA soa =
diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs
new file mode 100644
index 00000000..b7557006
--- /dev/null
+++ b/src/Propellor/Property/DnsSec.hs
@@ -0,0 +1,122 @@
+module Propellor.Property.DnsSec where
+
+import Propellor
+import qualified Propellor.Property.File as File
+
+-- | Puts the DNSSEC key files in place from PrivData.
+--
+-- signedPrimary uses this, so this property does not normally need to be
+-- used directly.
+keysInstalled :: Domain -> RevertableProperty
+keysInstalled domain = RevertableProperty setup cleanup
+ where
+ setup = propertyList "DNSSEC keys installed" $
+ map installkey keys
+
+ cleanup = propertyList "DNSSEC keys removed" $
+ map (File.notPresent . keyFn domain) keys
+
+ installkey k = writer (keysrc k) (keyFn domain k) (Context domain)
+ where
+ writer
+ | isPublic k = File.hasPrivContentExposedFrom
+ | otherwise = File.hasPrivContentFrom
+
+ keys = [ PubZSK, PrivZSK, PubKSK, PrivKSK ]
+
+ keysrc k = PrivDataSource (DnsSec k) $ unwords
+ [ "The file with extension"
+ , keyExt k
+ , "created by running:"
+ , if isZoneSigningKey k
+ then "dnssec-keygen -a RSASHA256 -b 2048 -n ZONE " ++ domain
+ else "dnssec-keygen -f KSK -a RSASHA256 -b 4096 -n ZONE " ++ domain
+ ]
+
+-- | Uses dnssec-signzone to sign a domain's zone file.
+--
+-- signedPrimary uses this, so this property does not normally need to be
+-- used directly.
+zoneSigned :: Domain -> FilePath -> RevertableProperty
+zoneSigned domain zonefile = RevertableProperty setup cleanup
+ where
+ setup = check needupdate (forceZoneSigned domain zonefile)
+ `requires` toProp (keysInstalled domain)
+
+ cleanup = combineProperties ("removed signed zone for " ++ domain)
+ [ File.notPresent (signedZoneFile zonefile)
+ , File.notPresent dssetfile
+ , toProp (revert (keysInstalled domain))
+ ]
+
+ dssetfile = dir </> "-" ++ domain ++ "."
+ dir = takeDirectory zonefile
+
+ -- Need to update the signed zone file if the zone file or
+ -- any of the keys have a newer timestamp.
+ needupdate = do
+ v <- catchMaybeIO $ getModificationTime (signedZoneFile zonefile)
+ case v of
+ Nothing -> return True
+ Just t1 -> anyM (newerthan t1) $
+ zonefile : map (keyFn domain) [minBound..maxBound]
+
+ newerthan t1 f = do
+ t2 <- getModificationTime f
+ return (t2 >= t1)
+
+forceZoneSigned :: Domain -> FilePath -> Property
+forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do
+ salt <- take 16 <$> saltSha1
+ let p = proc "dnssec-signzone"
+ [ "-A"
+ , "-3", salt
+ -- The serial number needs to be increased each time the
+ -- zone is resigned, even if there are no other changes,
+ -- so that it will propigate to secondaries. So, use the
+ -- unixtime serial format.
+ , "-N", "unixtime"
+ , "-o", domain
+ , zonefile
+ -- the ordering of these key files does not matter
+ , keyFn domain PubZSK
+ , keyFn domain PubKSK
+ ]
+ -- Run in the same directory as the zonefile, so it will
+ -- write the dsset file there.
+ (_, _, _, h) <- createProcess $
+ p { cwd = Just (takeDirectory zonefile) }
+ ifM (checkSuccessProcess h)
+ ( return MadeChange
+ , return FailedChange
+ )
+
+saltSha1 :: IO String
+saltSha1 = readProcess "sh"
+ [ "-c"
+ , "head -c 1024 /dev/urandom | sha1sum | cut -d ' ' -f 1"
+ ]
+
+-- | The file used for a given key.
+keyFn :: Domain -> DnsSecKey -> FilePath
+keyFn domain k = "/etc/bind/propellor/dnssec" </> concat
+ [ "K" ++ domain ++ "."
+ , if isZoneSigningKey k then "ZSK" else "KSK"
+ , keyExt k
+ ]
+
+-- | These are the extensions that dnssec-keygen looks for.
+keyExt :: DnsSecKey -> String
+keyExt k
+ | isPublic k = ".key"
+ | otherwise = ".private"
+
+isPublic :: DnsSecKey -> Bool
+isPublic k = k `elem` [PubZSK, PubKSK]
+
+isZoneSigningKey :: DnsSecKey -> Bool
+isZoneSigningKey k = k `elem` [PubZSK, PrivZSK]
+
+-- | dnssec-signzone makes a .signed file
+signedZoneFile :: FilePath -> FilePath
+signedZoneFile zonefile = zonefile ++ ".signed"
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 02bda2e9..eb0d8ec5 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -351,29 +351,44 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
-- Check if the ident has changed; if so the
-- parameters of the container differ and it must
-- be restarted.
- checkident runningident
+ checkident (Right runningident)
| runningident == Just ident = noChange
| otherwise = do
void $ liftIO $ stopContainer cid
restartcontainer
+ checkident (Left errmsg) = do
+ warningMessage errmsg
+ return FailedChange
restartcontainer = do
oldimage <- liftIO $ fromMaybe image <$> commitContainer cid
void $ liftIO $ removeContainer cid
go oldimage
- getrunningident = readish
- <$> readProcess' (inContainerProcess cid [] ["cat", propellorIdent])
+ getrunningident = withTmpFile "dockerrunsane" $ \t h -> do
+ -- detect #774376 which caused docker exec to not enter
+ -- the container namespace, and be able to access files
+ -- outside
+ hClose h
+ void . checkSuccessProcess . processHandle =<<
+ createProcess (inContainerProcess cid []
+ ["rm", "-f", t])
+ ifM (doesFileExist t)
+ ( Right . readish <$>
+ readProcess' (inContainerProcess cid []
+ ["cat", propellorIdent])
+ , return $ Left "docker exec failed to enter chroot properly (maybe an old kernel version?)"
+ )
- retry :: Int -> IO (Maybe a) -> IO (Maybe a)
- retry 0 _ = return Nothing
+ retry :: Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
+ retry 0 _ = return (Right Nothing)
retry n a = do
v <- a
case v of
- Just _ -> return v
- Nothing -> do
- threadDelaySeconds (Seconds 1)
+ Right Nothing -> do
+ threadDelaySeconds (Seconds 1)
retry (n-1) a
+ _ -> return v
go img = do
liftIO $ do
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 76de68c0..032268c4 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -18,18 +18,26 @@ f `hasContent` newcontent = fileProperty ("replace " ++ f)
-- The file's permissions are preserved if the file already existed.
-- Otherwise, they're set to 600.
hasPrivContent :: IsContext c => FilePath -> c -> Property
-hasPrivContent = hasPrivContent' writeFileProtected
+hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f
+
+-- | Like hasPrivContent, but allows specifying a source
+-- for PrivData, rather than using PrivDataSourceFile.
+hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property
+hasPrivContentFrom = hasPrivContent' writeFileProtected
-- | Leaves the file at its default or current mode,
-- allowing "private" data to be read.
--
-- Use with caution!
hasPrivContentExposed :: IsContext c => FilePath -> c -> Property
-hasPrivContentExposed = hasPrivContent' writeFile
+hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f
+
+hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property
+hasPrivContentExposedFrom = hasPrivContent' writeFile
-hasPrivContent' :: IsContext c => (String -> FilePath -> IO ()) -> FilePath -> c -> Property
-hasPrivContent' writer f context =
- withPrivData (PrivDataSourceFile (PrivFile f) f) context $ \getcontent ->
+hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property
+hasPrivContent' writer source f context =
+ withPrivData source context $ \getcontent ->
property desc $ getcontent $ \privcontent ->
ensureProperty $ fileProperty' writer desc
(\_oldcontent -> lines privcontent) f
diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
index 003bd3c5..f45a4aa8 100644
--- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs
+++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
@@ -10,7 +10,6 @@ import qualified Propellor.Property.User as User
decruft :: Property
decruft = propertyList "cloudatcost cleanup"
[ Hostname.sane
- , Ssh.randomHostKeys
, "worked around grub/lvm boot bug #743126" ==>
"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"
`onChange` cmdProperty "update-grub" []
@@ -18,6 +17,7 @@ decruft = propertyList "cloudatcost cleanup"
, combineProperties "nuked cloudatcost cruft"
[ File.notPresent "/etc/rc.local"
, File.notPresent "/etc/init.d/S97-setup.sh"
+ , File.notPresent "/zang-debian.sh"
, User.nuked "user" User.YesReallyDeleteHome
]
]
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 695b67cb..b6ed476e 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -8,6 +8,7 @@ module Propellor.Property.Ssh (
randomHostKeys,
hostKeys,
hostKey,
+ pubKey,
keyImported,
knownHost,
authorizedKeys,
@@ -22,6 +23,9 @@ import Utility.SafeCommand
import Utility.FileMode
import System.PosixCompat
+import qualified Data.Map as M
+
+type PubKeyText = String
sshBool :: Bool -> String
sshBool True = "yes"
@@ -79,27 +83,43 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
ensureProperty $ scriptProperty
[ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ]
--- | Sets all types of ssh host keys from the privdata.
-hostKeys :: IsContext c => c -> Property
-hostKeys ctx = propertyList "known ssh host keys"
- [ hostKey SshDsa ctx
- , hostKey SshRsa ctx
- , hostKey SshEcdsa ctx
- ]
-
--- | Sets a single ssh host key from the privdata.
-hostKey :: IsContext c => SshKeyType -> c -> Property
-hostKey keytype context = combineProperties desc
- [ installkey (keysrc ".pub" (SshPubKey keytype "")) (install writeFile ".pub")
- , installkey (keysrc "" (SshPrivKey keytype "")) (install writeFileProtected "")
+-- | Installs the specified list of ssh host keys.
+--
+-- The corresponding private keys come from the privdata.
+--
+-- Any host keysthat are not in the list are removed from the host.
+hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property
+hostKeys ctx l = propertyList desc $ catMaybes $
+ map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup]
+ where
+ desc = "ssh host keys configured " ++ typelist (map fst l)
+ typelist tl = "(" ++ unwords (map fromKeyType tl) ++ ")"
+ alltypes = [minBound..maxBound]
+ staletypes = let have = map fst l in filter (`notElem` have) alltypes
+ removestale b = map (File.notPresent . flip keyFile b) staletypes
+ cleanup
+ | null staletypes || null l = Nothing
+ | otherwise = Just $ property ("any other ssh host keys removed " ++ typelist staletypes) $
+ ensureProperty $
+ combineProperties desc (removestale True ++ removestale False)
+ `onChange` restarted
+
+-- | Installs a single ssh host key of a particular type.
+--
+-- The public key is provided to this function;
+-- the private key comes from the privdata;
+hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property
+hostKey context keytype pub = combineProperties desc
+ [ pubKey keytype pub
+ , property desc $ install writeFile True pub
+ , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
+ property desc $ getkey $ install writeFileProtected False
]
`onChange` restarted
where
- desc = "known ssh host key (" ++ fromKeyType keytype ++ ")"
- installkey p a = withPrivData p context $ \getkey ->
- property desc $ getkey a
- install writer ext key = do
- let f = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext
+ desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")"
+ install writer ispub key = do
+ let f = keyFile keytype ispub
s <- liftIO $ readFileStrict f
if s == key
then noChange
@@ -107,6 +127,21 @@ hostKey keytype context = combineProperties desc
keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext)
("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey")
+keyFile :: SshKeyType -> Bool -> FilePath
+keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext
+ where
+ ext = if ispub then ".pub" else ""
+
+-- | Indicates the host key that is used by a Host, but does not actually
+-- configure the host to use it. Normally this does not need to be used;
+-- use 'hostKey' instead.
+pubKey :: SshKeyType -> PubKeyText -> Property
+pubKey t k = pureInfoProperty ("ssh pubkey known") $
+ mempty { _sshPubKey = M.singleton t k }
+
+getPubKey :: Propellor (M.Map SshKeyType String)
+getPubKey = asks (_sshPubKey . hostInfo)
+
-- | Sets up a user with a ssh private key and public key pair from the
-- PrivData.
keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property
@@ -140,21 +175,23 @@ fromKeyType SshDsa = "dsa"
fromKeyType SshEcdsa = "ecdsa"
fromKeyType SshEd25519 = "ed25519"
--- | Puts some host's ssh public key into the known_hosts file for a user.
+-- | Puts some host's ssh public key(s), as set using 'pubKey',
+-- into the known_hosts file for a user.
knownHost :: [Host] -> HostName -> UserName -> Property
knownHost hosts hn user = property desc $
- go =<< fromHost hosts hn getSshPubKey
+ go =<< fromHost hosts hn getPubKey
where
desc = user ++ " knows ssh key for " ++ hn
- go (Just (Just k)) = do
+ go (Just m) | not (M.null m) = do
f <- liftIO $ dotFile "known_hosts" user
ensureProperty $ combineProperties desc
[ File.dirExists (takeDirectory f)
- , f `File.containsLine` (hn ++ " " ++ k)
+ , f `File.containsLines`
+ (map (\k -> hn ++ " " ++ k) (M.elems m))
, File.ownerGroup f user user
]
go _ = do
- warningMessage $ "no configred sshPubKey for " ++ hn
+ warningMessage $ "no configred pubKey for " ++ hn
return FailedChange
-- | Makes a user have authorized_keys from the PrivData
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 3bafd165..a1035387 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -14,6 +14,9 @@ import System.Posix.Directory
import Control.Concurrent.Async
import Control.Exception (bracket)
import qualified Data.ByteString as B
+import qualified Data.Set as S
+import qualified Network.BSD as BSD
+import Network.Socket (inet_ntoa)
import Propellor
import Propellor.Protocol
@@ -44,17 +47,20 @@ spin target relay hst = do
when viarelay $
void $ boolSystem "ssh-add" []
+ sshtarget <- ("root@" ++) <$> case relay of
+ Just r -> pure r
+ Nothing -> getSshTarget target hst
+
-- Install, or update the remote propellor.
updateServer target relay hst
- (proc "ssh" $ cacheparams ++ [user, shellWrap probecmd])
- (proc "ssh" $ cacheparams ++ [user, shellWrap updatecmd])
+ (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd])
+ (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd])
-- And now we can run it.
- unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, shellWrap runcmd])) $
+ unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
error $ "remote propellor failed"
where
hn = fromMaybe target relay
- user = "root@"++hn
relaying = relay == Just target
viarelay = isJust relay && not relaying
@@ -74,7 +80,7 @@ spin target relay hst = do
, "if ! test -x ./propellor; then make deps build; fi"
, if viarelay
then "./propellor --continue " ++
- shellEscape (show (Update (Just target)))
+ shellEscape (show (Relay target))
-- Still using --boot for back-compat...
else "./propellor --boot " ++ target
]
@@ -84,6 +90,34 @@ spin target relay hst = do
then "--serialized " ++ shellEscape (show (Spin [target] (Just target)))
else "--continue " ++ shellEscape (show (SimpleRun target))
+-- Check if the Host contains an IP address that matches one of the IPs
+-- in the DNS for the HostName. If so, the HostName is used as-is,
+-- but if the DNS is out of sync with the Host config, or doesn't have
+-- the host in it at all, use one of the Host's IPs instead.
+getSshTarget :: HostName -> Host -> IO String
+getSshTarget target hst
+ | null configips = return target
+ | otherwise = go =<< tryIO (BSD.getHostByName target)
+ where
+ go (Left e) = useip (show e)
+ go (Right hostentry) = ifM (anyM matchingconfig (BSD.hostAddresses hostentry))
+ ( return target
+ , do
+ ips <- mapM inet_ntoa (BSD.hostAddresses hostentry)
+ useip ("DNS " ++ show ips ++ " vs configured " ++ show configips)
+ )
+
+ matchingconfig a = flip elem configips <$> inet_ntoa a
+
+ useip why = case headMaybe configips of
+ Nothing -> return target
+ Just ip -> do
+ warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead."
+ return ip
+
+ configips = map fromIPAddr $ mapMaybe getIPAddr $
+ S.toList $ _dns $ hostInfo hst
+
-- Update the privdata, repo url, and git repo over the ssh
-- connection, talking to the user's local propellor instance which is
-- running the updateServer
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 63abd226..ca3a9582 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -37,6 +37,7 @@ import System.Posix.Types
import "mtl" Control.Monad.RWS.Strict
import "MonadCatchIO-transformers" Control.Monad.CatchIO
import qualified Data.Set as S
+import qualified Data.Map as M
import qualified Propellor.Types.Dns as Dns
import Propellor.Types.OS
@@ -165,6 +166,7 @@ data CmdLine
| Serialized CmdLine
| Continue CmdLine
| Update (Maybe HostName)
+ | Relay HostName
| DockerInit HostName
| DockerChain HostName String
| ChrootChain HostName FilePath Bool Bool
@@ -175,7 +177,7 @@ data CmdLine
data Info = Info
{ _os :: Val System
, _privDataFields :: S.Set (PrivDataField, HostContext)
- , _sshPubKey :: Val String
+ , _sshPubKey :: M.Map SshKeyType String
, _aliases :: S.Set HostName
, _dns :: S.Set Dns.Record
, _namedconf :: Dns.NamedConfMap
@@ -189,7 +191,7 @@ instance Monoid Info where
mappend old new = Info
{ _os = _os old <> _os new
, _privDataFields = _privDataFields old <> _privDataFields new
- , _sshPubKey = _sshPubKey old <> _sshPubKey new
+ , _sshPubKey = _sshPubKey new `M.union` _sshPubKey old
, _aliases = _aliases old <> _aliases new
, _dns = _dns old <> _dns new
, _namedconf = _namedconf old <> _namedconf new
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index 5e9666d8..2fbf51e5 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/src/Propellor/Types/Dns.hs
@@ -62,6 +62,7 @@ data Record
| NS BindDomain
| TXT String
| SRV Word16 Word16 Word16 BindDomain
+ | INCLUDE FilePath
deriving (Read, Show, Eq, Ord)
getIPAddr :: Record -> Maybe IPAddr
diff --git a/src/Propellor/Types/PrivData.hs b/src/Propellor/Types/PrivData.hs
index f746a74c..c760ae55 100644
--- a/src/Propellor/Types/PrivData.hs
+++ b/src/Propellor/Types/PrivData.hs
@@ -2,18 +2,19 @@ module Propellor.Types.PrivData where
import Propellor.Types.OS
--- | Note that removing or changing field names will break the
+-- | Note that removing or changing constructors will break the
-- serialized privdata files, so don't do that!
--- It's fine to add new fields.
+-- It's fine to add new constructors.
data PrivDataField
= DockerAuthentication
- | SshPubKey SshKeyType UserName
+ | SshPubKey SshKeyType UserName -- ^ For host key, use empty UserName
| SshPrivKey SshKeyType UserName
| SshAuthorizedKeys UserName
| Password UserName
| CryptPassword UserName
| PrivFile FilePath
| GpgKey
+ | DnsSec DnsSecKey
deriving (Read, Show, Ord, Eq)
-- | Combines a PrivDataField with a description of how to generate
@@ -49,7 +50,7 @@ instance IsPrivDataSource PrivDataSource where
-- for the web server serving that domain. Multiple hosts might
-- use that privdata.
--
--- This appears in serlialized privdata files.
+-- This appears in serialized privdata files.
newtype Context = Context String
deriving (Read, Show, Ord, Eq)
@@ -89,7 +90,7 @@ hostContext = HostContext Context
type PrivData = String
data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519
- deriving (Read, Show, Ord, Eq)
+ deriving (Read, Show, Ord, Eq, Enum, Bounded)
-- | Parameter that would be passed to ssh-keygen to generate key of this type
sshKeyTypeParam :: SshKeyType -> String
@@ -98,3 +99,9 @@ sshKeyTypeParam SshDsa = "DSA"
sshKeyTypeParam SshEcdsa = "ECDSA"
sshKeyTypeParam SshEd25519 = "ED25519"
+data DnsSecKey
+ = PubZSK -- ^ DNSSEC Zone Signing Key (public)
+ | PrivZSK -- ^ DNSSEC Zone Signing Key (private)
+ | PubKSK -- ^ DNSSEC Key Signing Key (public)
+ | PrivKSK -- ^ DNSSEC Key Signing Key (private)
+ deriving (Read, Show, Ord, Eq, Bounded, Enum)
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index 3e010541..8fefaa54 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -38,7 +38,7 @@ module Utility.Process (
) where
import qualified System.Process
-import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
+import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
import System.Process hiding (createProcess, readProcess)
import System.Exit
import System.IO
@@ -47,7 +47,7 @@ import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
#ifndef mingw32_HOST_OS
-import System.Posix.IO
+import qualified System.Posix.IO
#else
import Control.Applicative
#endif
@@ -175,9 +175,9 @@ processTranscript' cmd opts environ input = do
#ifndef mingw32_HOST_OS
{- This implementation interleves stdout and stderr in exactly the order
- the process writes them. -}
- (readf, writef) <- createPipe
- readh <- fdToHandle readf
- writeh <- fdToHandle writef
+ (readf, writef) <- System.Posix.IO.createPipe
+ readh <- System.Posix.IO.fdToHandle readf
+ writeh <- System.Posix.IO.fdToHandle writef
p@(_, _, _, pid) <- createProcess $
(proc cmd opts)
{ std_in = if isJust input then CreatePipe else Inherit