summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Assistant/Pairing.hs9
-rw-r--r--Assistant/Threads/PairListener.hs55
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"