implement pair request broadcasts

Pair requests are sent on all network interfaces, and contain the best
available hostname to use to contact the host on that interface.

Added a pairing in progress page.

Revert "reduce some boilerplate using ghc extensions", because it caused
overlapping instances for Text.

5 files changed, 162 insertions, 28 deletions

diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index c6942530c..4de160ace 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -9,6 +9,7 @@ module Assistant.DaemonStatus where
 
 import Common.Annex
 import Assistant.Alert
+import Assistant.Pairing
 import Utility.TempFile
 import Utility.NotificationBroadcaster
 import Logs.Transfer
@@ -38,6 +39,8 @@ data DaemonStatus = DaemonStatus
 	, lastAlertId :: AlertId
 	-- Ordered list of remotes to talk to.
 	, knownRemotes :: [Remote]
+	-- Pairing requests that are in progress.
+	, pairingInProgress :: [PairingInProgress]
 	-- Broadcasts notifications about all changes to the DaemonStatus
 	, changeNotifier :: NotificationBroadcaster
 	-- Broadcasts notifications when queued or current transfers change.
@@ -61,6 +64,7 @@ newDaemonStatus = DaemonStatus
 	<*> pure M.empty
 	<*> pure firstAlertId
 	<*> pure []
+	<*> pure []
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index 8a9d897eb..42fc29929 100644
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@@ -7,17 +7,24 @@
 
 module Assistant.Pairing where
 
-import Assistant.Common
+import Common
 import Utility.Verifiable
+import Utility.ThreadScheduler
+import Utility.Network
 
-import Network.Socket (HostName)
+import Network.Multicast
+import Network.Info
+import Network.Socket
+import Control.Concurrent
+import qualified Data.Map as M
 
-{- "I'd like to pair with somebody who knows a secret." -}
+{- "I'll pair with anybody who shares the secret that can be used to verify
+ - this request." -}
 data PairReq = PairReq (Verifiable PairData)
 	deriving (Eq, Read, Show)
 
-{- "I've checked your PairReq, and like it.
- - I set up your ssh key already. Here's mine for you to set up." -}
+{- "I've verified your request, and you can verify mine to see that I know
+ - the secret. I set up your ssh key already. Here's mine for you to set up." -}
 data PairAck = PairAck (Verifiable PairData)
 	deriving (Eq, Read, Show)
 
@@ -35,9 +42,102 @@ data PairMsg
 data PairData = PairData
 	{ remoteHostName :: HostName
 	, remoteUserName :: UserName
-	, sshPubKey :: Maybe SshPubKey
+	, sshPubKey :: SshPubKey
 	}
 	deriving (Eq, Read, Show)
 
 type SshPubKey = String
 type UserName = String
+
+{- A pairing that is in progress has a secret, and a thread that is
+ - broadcasting pairing requests. -}
+data PairingInProgress = PairingInProgress Secret ThreadId
+
+{- This is an arbitrary port in the dynamic port range, that could
+ - conceivably be used for some other broadcast messages.
+ - If so, hope they ignore the garbage from us; we'll certianly
+ - ignore garbage from them. Wild wild west. -}
+pairingPort :: PortNumber
+pairingPort = 55556
+
+{- This is the All Hosts multicast group, which should reach all hosts
+ - on the same network segment. -}
+multicastAddress :: HostName
+multicastAddress = "224.0.0.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.
+ -
+ - 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
+	where
+		go cache = do
+			addrs <- activeNetworkAddresses
+			cache' <- updateMsgCache mkmsg cache addrs
+			mapM_ (sendinterface cache') addrs
+			threadDelaySeconds (Seconds 2)
+			go cache'
+		sendinterface cache i = void $ catchMaybeIO $ withSocketsDo $ do
+			(sock, addr) <- multicastSender multicastAddress pairingPort
+			setInterface sock (show i)
+			maybe noop (\s -> void $ sendTo sock s addr)
+				(M.lookup i cache)
+
+{- 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
+	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
+
+activeNetworkAddresses :: IO [SomeAddr]
+activeNetworkAddresses = filter (not . all (`elem` "0.:") . show)
+	. concat . map (\ni -> [IPv4Addr $ ipv4 ni, IPv6Addr $ ipv6 ni])
+	<$> getNetworkInterfaces
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 82f413a00..350319864 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -3,8 +3,8 @@
  - Pairing works like this:
  -
  - * The user opens StartPairR, which prompts them for a secret.
- - * The user submits it. A PairReq is broadcast out. The secret is
- -   stashed away in a list of known pairing secrets.
+ - * The user submits it. The pairing secret is stored for later.
+ -   A PairReq is broadcast out.
  - * On another device, it's received, and that causes its webapp to 
  -   display an Alert.
  - * The user there clicks the button, which opens FinishPairR,
@@ -15,8 +15,8 @@
  - * The PairAck is received back at the device that started the process.
  -   It's verified using the stored secret. The ssh key from the PairAck
  -   is added. An Alert is displayed noting that the pairing has been set
- -   up. Note that multiple other devices could also send PairAcks, and
- -   as long as they're valid, all those devices are paired with.
+ -   up. The pairing secret is removed to prevent anyone cracking the
+ -   crypto.
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
@@ -29,6 +29,7 @@ module Assistant.WebApp.Configurators.Pairing where
 
 import Assistant.Common
 import Assistant.Pairing
+import Assistant.DaemonStatus
 import Utility.Verifiable
 import Assistant.WebApp
 import Assistant.WebApp.Types
@@ -44,35 +45,48 @@ import Data.Char
 import System.Posix.User
 
 getStartPairR :: Handler RepHtml
-getStartPairR = bootstrap (Just Config) $ do
+getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
+	username <- liftIO $ getUserName
+	let sshkey = "" -- TODO generate/read ssh key
+	let mkmsg hostname = PairReqM $ PairReq $
+		mkVerifiable (PairData hostname username sshkey) secret
+	pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg
+	dstatus <- daemonStatus <$> lift getYesod
+	liftIO $ modifyDaemonStatus_ dstatus $
+		\s -> s { pairingInProgress = pip : pairingInProgress s }
+	lift $ redirect $ InprogressPairR rawsecret
+
+getInprogressPairR :: Text -> Handler RepHtml
+getInprogressPairR secret = bootstrap (Just Config) $ do
 	sideBarDisplay
 	setTitle "Pairing"
-	promptSecret Nothing $ error "TODO"
+	$(widgetFile "configurators/inprogresspairing")
 
 getFinishPairR :: PairReq -> Handler RepHtml
-getFinishPairR req = bootstrap (Just Config) $ do
-	sideBarDisplay
-	setTitle "Pairing"
-	promptSecret (Just req) $ error "TODO"
+getFinishPairR req = promptSecret (Just req) $ \_ secret -> do
+	error "TODO"
 
 data InputSecret = InputSecret { secretText :: Maybe Text }
 
-promptSecret :: Maybe PairReq -> Widget -> Widget
-promptSecret req cont = do
+promptSecret :: Maybe PairReq -> (Text -> Secret -> Widget) -> Handler RepHtml
+promptSecret req cont = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Pairing"
 	((result, form), enctype) <- lift $
 		runFormGet $ renderBootstrap $
 			InputSecret <$> aopt textField "Secret phrase" Nothing
         case result of
                 FormSuccess v -> do
-			let secret = toSecret $ fromMaybe "" $ secretText v
+			let rawsecret = fromMaybe "" $ secretText v
+			let secret = toSecret rawsecret
 			case req of
 				Nothing -> case secretProblem secret of
-					Nothing -> cont
+					Nothing -> cont rawsecret secret
 					Just problem ->
 						showform form enctype $ Just problem
 				Just r ->
 					if verified (fromPairReq r) secret
-						then cont
+						then cont rawsecret secret
 						else showform form enctype $ Just
 							"That's not the right secret phrase."
                 _ -> showform form enctype Nothing
@@ -84,8 +98,7 @@ promptSecret req cont = do
 			let (username, hostname) = maybe ("", "")
 				(\v -> (T.pack $ remoteUserName v, T.pack $ remoteHostName v))
 				(verifiableVal . fromPairReq <$> req)
-			u <- liftIO $ T.pack . userName
-				<$> (getUserEntryForID =<< getEffectiveUserID)
+			u <- T.pack <$> liftIO getUserName
 			let sameusername = username == u
                         let authtoken = webAppFormAuthToken
                         $(widgetFile "configurators/pairing")
@@ -110,3 +123,6 @@ sampleQuote = T.unwords
 	, "it was the age of wisdom,"
 	, "it was the age of foolishness."
 	]
+
+getUserName :: IO String
+getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID)
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index b88e78d67..dd3bd4383 100644
--- a/Assistant/WebApp/Types.hs
+++ b/Assistant/WebApp/Types.hs
@@ -5,9 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Assistant.WebApp.Types where
@@ -79,7 +77,22 @@ data SshData = SshData
 	}
 	deriving (Read, Show, Eq)
 
-{- Allow any serializable data type to be used as a PathPiece -}
-instance (Show a, Read a) => PathPiece a where
+instance PathPiece SshData where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
+instance PathPiece NotificationId where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
+instance PathPiece AlertId where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
+instance PathPiece Transfer where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
+instance PathPiece PairReq where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index 5bab0cc63..181b08f28 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -12,6 +12,7 @@
 /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
 /config/repository/add/rsync.net AddRsyncNetR GET
 /config/repository/pair/start StartPairR GET
+/config/repository/pair/inprogress/#Text InprogressPairR GET
 /config/repository/pair/finish/#PairReq FinishPairR GET
 
 /config/repository/first FirstRepositoryR GET