add remote directory to pair request

This commit is contained in:
Joey Hess 2012-09-08 15:40:47 -04:00
parent 5401b9f249
commit 317ab14da2
3 changed files with 6 additions and 2 deletions

View file

@ -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 $