diff options
| -rw-r--r-- | Assistant/Pairing.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 3 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 3 |
3 files changed, 6 insertions, 2 deletions
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index a157e28f8..f328bf9e0 100644 --- a/Assistant/Pairing.hs +++ b/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) diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 58d8fd969..12f10070c 100644 --- a/Assistant/Threads/PairListener.hs +++ b/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. -} diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index cc7d1cf77..8b56f3392 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/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 $ |