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.

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