diff options
| -rw-r--r-- | Assistant/Pairing.hs | 9 | ||||
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 55 |
2 files changed, 48 insertions, 16 deletions
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index f328bf9e0..d25d5e56d 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -22,15 +22,24 @@ data PairReq = PairReq (Verifiable PairData) data PairAck = PairAck (Verifiable PairData) deriving (Eq, Read, Show) +{- "I saw your PairAck; you can stop sending them." + - (This is not repeated, it's just sent in response to a valid PairAck) -} +data PairDone = PairDone (Verifiable PairData) + deriving (Eq, Read, Show) + fromPairReq :: PairReq -> Verifiable PairData fromPairReq (PairReq v) = v fromPairAck :: PairAck -> Verifiable PairData fromPairAck (PairAck v) = v +fromPairDone :: PairDone -> Verifiable PairData +fromPairDone (PairDone v) = v + data PairMsg = PairReqM PairReq | PairAckM PairAck + | PairDoneM PairDone deriving (Eq, Read, Show) data PairData = PairData diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 45496ddf2..17826744f 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -27,11 +27,14 @@ thisThread = "PairListener" pairListenerThread :: ThreadState -> DaemonStatusHandle -> UrlRenderer -> NamedThread pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort - forever $ do - msg <- getmsg sock [] - dispatch $ readish msg + go sock where thread = NamedThread thisThread + + go sock = do + msg <- getmsg sock [] + dispatch $ readish msg + go sock getmsg sock c = do (msg, n, _) <- recvFrom sock chunksz @@ -42,22 +45,17 @@ pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do chunksz = 1024 dispatch Nothing = noop - dispatch (Just (PairReqM r@(PairReq v))) = - unlessM (mypair v) $ - pairReqAlert dstatus urlrenderer r - dispatch (Just (PairAckM r@(PairAck v))) = - unlessM (mypair v) $ - pairAckAlert dstatus r - - {- Filter out our own pair requests, by checking if we - - can verify using the secrets of any of them. -} - mypair v = any (verified v . inProgressSecret) . pairingInProgress - <$> getDaemonStatus dstatus + dispatch (Just (PairReqM m@(PairReq v))) = + pairReqAlert dstatus urlrenderer m + dispatch (Just (PairAckM m)) = + pairAckAlert dstatus m + dispatch (Just (PairDoneM m)) = + pairDoneAlert dstatus m {- Pair request alerts from the same host combine, - so repeated requests do not add additional alerts. -} pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairReq -> IO () -pairReqAlert dstatus urlrenderer r@(PairReq v) = do +pairReqAlert dstatus urlrenderer r@(PairReq v) = unlessM myreq $ do let pairdata = verifiableVal v let repo = remoteUserName pairdata ++ "@" ++ fromMaybe (showAddr $ remoteAddress pairdata) @@ -70,6 +68,31 @@ pairReqAlert dstatus urlrenderer r@(PairReq v) = do { buttonUrl = url , buttonLabel = T.pack "Respond" } + where + {- Filter out our own pair requests, by checking if we + - can verify using the secrets of any of them. -} + myreq = any (verified v . inProgressSecret) . pairingInProgress + <$> getDaemonStatus dstatus +{- When a valid PairAck is seen, a host has successfully paired with + - us, and we should finish pairing with them. Then send a PairDone. + - + - A stale PairAck might also be seen, after we've finished pairing. + - Perhaps our PairDone was not received. To handle this, we keep + - a list of recently finished pairings, and re-send PairDone in + - response to stale PairAcks for them. + -} pairAckAlert :: DaemonStatusHandle -> PairAck -> IO () -pairAckAlert dstatus r@(PairAck v) = error "TODO" +pairAckAlert dstatus (PairAck v) = error "TODO" + +{- If we get a valid PairDone, and are sending PairAcks, we can stop + - sending them, as the message has been received. + - + - Also, now is the time to remove the pair request alert, as pairing is + - over. Do that even if the PairDone cannot be validated, as we might + - be a third host that did not participate in the pairing. + - Note: This does allow a bad actor to squelch pairing on a network + - by sending bogus PairDones. + -} +pairDoneAlert :: DaemonStatusHandle -> PairDone -> IO () +pairDoneAlert dstatus (PairDone v) = error "TODO" |