add remote directory to pair request

Assistant/Pairing.hs

@@ -36,8 +36,10 @@ data PairMsg
 data PairData = PairData
 	-- uname -n output, not a full domain name
 	{ remoteHostName :: Maybe HostName
+	-- the address is included so that it can be verified, avoiding spoofing
 	, remoteAddress :: SomeAddr
 	, remoteUserName :: UserName
+	, remoteDirectory :: FilePath
 	, sshPubKey :: SshPubKey
 	}
 	deriving (Eq, Read, Show)

Assistant/Threads/PairListener.hs

@@ -43,7 +43,8 @@ pairListenerThread st dstatus = thread $ withSocketsDo $ do
 			let pairdata = verifiableVal v
 			let repo = remoteUserName pairdata ++ "@" ++
 				fromMaybe (showAddr $ remoteAddress pairdata)
-					(remoteHostName pairdata)
+					(remoteHostName pairdata) ++
+					(remoteDirectory pairdata)
 			let msg = repo ++ " is sending a pair request."
 			{- Pair request alerts from the same host combine,
 			 - so repeated requests do not add additional alerts. -}

Assistant/WebApp/Configurators/Pairing.hs

@@ -56,9 +56,10 @@ getStartPairR :: Handler RepHtml
 getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
 	hostname <- liftIO $ getHostname
 	username <- liftIO $ getUserName
+	reldir <- fromJust . relDir <$> lift getYesod
 	let sshkey = "" -- TODO generate/read ssh key
 	let mkmsg addr = PairReqM $ PairReq $
-		mkVerifiable (PairData hostname addr username sshkey) secret
+		mkVerifiable (PairData hostname addr username reldir sshkey) secret
 	pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg
 	dstatus <- daemonStatus <$> lift getYesod
 	liftIO $ modifyDaemonStatus_ dstatus $