summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-09-08 14:23:35 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-09-08 14:23:35 -0400
commit3e070b947ab77dea1b5bb0e4d547f5cd74463a7f (patch)
treef392494f1b17a1c558027aeff2b33286f5a5d9db /Assistant
parent92b1f427306b92706a4d785fe819c8b0cbedca63 (diff)
don't pass .local hostname over the wire
The remote computer may not support mDNS. Instead, pass over the uname -a hostname, and the IP address, and leave best hostname calculation to the remote side.
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Pairing.hs105
-rw-r--r--Assistant/WebApp/Configurators/Pairing.hs8
2 files changed, 54 insertions, 59 deletions
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index 4f8a8bb11..2ad339969 100644
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@@ -10,7 +10,6 @@ module Assistant.Pairing where
import Common
import Utility.Verifiable
import Utility.ThreadScheduler
-import Utility.Network
import Network.Multicast
import Network.Info
@@ -41,7 +40,9 @@ data PairMsg
deriving (Eq, Read, Show)
data PairData = PairData
- { remoteHostName :: HostName
+ -- uname -n output, not a full domain name
+ { remoteHostName :: Maybe HostName
+ , remoteAddress :: SomeAddr
, remoteUserName :: UserName
, sshPubKey :: SshPubKey
}
@@ -67,26 +68,21 @@ multicastAddress :: SomeAddr -> HostName
multicastAddress (IPv4Addr _) = "224.0.0.1"
multicastAddress (IPv6Addr _) = "ff02::1"
-type MkPairMsg = HostName -> PairMsg
-
{- Multicasts a message repeatedly on all interfaces until its thread
- is killed, with a 2 second delay between each transmission.
-
- - The remoteHostName is set to the best host name that can be found for
- - each interface's IP address. When possible, that's a .local name.
- - If not, it's whatever is found in the DNS for the address, or failing
- - that, the IP address.
+ - The remoteHostAddress is set to the interface's IP address.
-
- Note that new sockets are opened each time. This is hardly efficient,
- but it allows new network interfaces to be used as they come up.
- On the other hand, the expensive DNS lookups are cached.
-}
-multicastPairMsg :: MkPairMsg -> IO ThreadId
-multicastPairMsg mkmsg = forkIO $ go =<< initMsgCache mkmsg
+multicastPairMsg :: (SomeAddr -> PairMsg) -> IO ThreadId
+multicastPairMsg mkmsg = forkIO $ go M.empty
where
go cache = do
addrs <- activeNetworkAddresses
- cache' <- updateMsgCache mkmsg cache addrs
+ let cache' = updatecache cache addrs
mapM_ (sendinterface cache') addrs
threadDelaySeconds (Seconds 2)
go cache'
@@ -95,56 +91,53 @@ multicastPairMsg mkmsg = forkIO $ go =<< initMsgCache mkmsg
(multicastSender (multicastAddress i) pairingPort)
(sClose . fst)
(\(sock, addr) -> do
- setInterface sock (show i)
+ setInterface sock (showAddr i)
maybe noop (\s -> void $ sendTo sock s addr)
(M.lookup i cache)
)
+ updatecache cache [] = cache
+ updatecache cache (i:is)
+ | M.member i cache = updatecache cache is
+ | otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is
-{- A cache of serialized messages. -}
-type MsgCache = M.Map SomeAddr String
-
-{- Ensures that the cache has messages for each address. -}
-updateMsgCache :: MkPairMsg -> MsgCache -> [SomeAddr] -> IO MsgCache
-updateMsgCache _ m [] = return m
-updateMsgCache mkmsg m (v:vs)
- | M.member v m = updateMsgCache mkmsg m vs
- | otherwise = do
- let sockaddr = case v of
- IPv4Addr (IPv4 a) -> SockAddrInet (PortNum 0) a
- IPv6Addr (IPv6 o1 o2 o3 o4) -> SockAddrInet6 (PortNum 0) 0 (o1, o2, o3, o4) 0
- mhostname <- catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing
- let cache' = M.insert v (show $ mkmsg $ fromMaybe (show v) mhostname) m
- updateMsgCache mkmsg cache' vs
-
-{- An initial message cache. Look up hostname.local, and if found,
- - put it in the cache. -}
-initMsgCache :: MkPairMsg -> IO MsgCache
-initMsgCache mkmsg = go =<< getHostname
+{- Finds the best hostname to use for the host that sent the PairData.
+ -
+ - If remoteHostName is set, tries to use a .local address based on it.
+ - That's the most robust, if this system supports .local.
+ - Otherwise, looks up the hostname in the DNS for the remoteAddress,
+ - if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
+bestHostName :: PairData -> IO HostName
+bestHostName d = case remoteHostName d of
+ Just h -> do
+ let localname = h ++ ".local"
+ addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) []
+ maybe fallback (const $ return localname) (headMaybe addrs)
+ Nothing -> fallback
where
- go Nothing = return M.empty
- go (Just n) = do
- let localname = n ++ ".local"
- addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) []
- case headMaybe addrs of
- Nothing -> return M.empty
- Just addr -> case addrAddress addr of
- SockAddrInet _ a ->
- use localname $
- IPv4Addr $ IPv4 a
- SockAddrInet6 _ _ (o1, o2, o3, o4) _ ->
- use localname $
- IPv6Addr $ IPv6 o1 o2 o3 o4
- _ -> return M.empty
- use hostname addr = return $ M.fromList [(addr, show $ mkmsg hostname)]
-
-data SomeAddr = IPv4Addr IPv4 | IPv6Addr IPv6
- deriving (Ord, Eq)
-
-instance Show SomeAddr where
- show (IPv4Addr x) = show x
- show (IPv6Addr x) = show x
+ fallback = do
+ let sockaddr = case remoteAddress d of
+ IPv4Addr a -> SockAddrInet (PortNum 0) a
+ IPv6Addr a -> SockAddrInet6 (PortNum 0) 0 a 0
+ fromMaybe (show $ remoteAddress d)
+ <$> catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing
+
+data SomeAddr = IPv4Addr HostAddress | IPv6Addr HostAddress6
+ deriving (Ord, Eq, Read, Show)
+
+class ToSomeAddr a where
+ toSomeAddr :: a -> SomeAddr
+
+instance ToSomeAddr IPv4 where
+ toSomeAddr (IPv4 a) = IPv4Addr a
+
+instance ToSomeAddr IPv6 where
+ toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4)
+
+showAddr :: SomeAddr -> HostName
+showAddr (IPv4Addr a) = show $ IPv4 a
+showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4
activeNetworkAddresses :: IO [SomeAddr]
-activeNetworkAddresses = filter (not . all (`elem` "0.:") . show)
- . concat . map (\ni -> [IPv4Addr $ ipv4 ni, IPv6Addr $ ipv6 ni])
+activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr)
+ . concat . map (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
<$> getNetworkInterfaces
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 350319864..e314b9526 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -35,6 +35,7 @@ import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
+import Utility.Network
import Yesod
import Data.Text (Text)
@@ -46,10 +47,11 @@ import System.Posix.User
getStartPairR :: Handler RepHtml
getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
+ hostname <- liftIO $ getHostname
username <- liftIO $ getUserName
let sshkey = "" -- TODO generate/read ssh key
- let mkmsg hostname = PairReqM $ PairReq $
- mkVerifiable (PairData hostname username sshkey) secret
+ let mkmsg addr = PairReqM $ PairReq $
+ mkVerifiable (PairData hostname addr username sshkey) secret
pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg
dstatus <- daemonStatus <$> lift getYesod
liftIO $ modifyDaemonStatus_ dstatus $
@@ -96,7 +98,7 @@ promptSecret req cont = bootstrap (Just Config) $ do
let badphrase = isJust mproblem
let msg = fromMaybe "" mproblem
let (username, hostname) = maybe ("", "")
- (\v -> (T.pack $ remoteUserName v, T.pack $ remoteHostName v))
+ (\v -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v)))
(verifiableVal . fromPairReq <$> req)
u <- T.pack <$> liftIO getUserName
let sameusername = username == u