summaryrefslogtreecommitdiff
path: root/src/Propellor/Spin.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Spin.hs')
-rw-r--r--src/Propellor/Spin.hs44
1 files changed, 39 insertions, 5 deletions
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