diff options
author | 2012-09-11 01:00:42 -0400 | |
---|---|---|
committer | 2012-09-11 01:00:42 -0400 | |
commit | 9ace0afdfed35ffcd344221e17b6eca8eeb56372 (patch) | |
tree | cac97792afb7cac864dee579f459fda9debd122b /Assistant | |
parent | 675621d903aeb9928955483a58c2e5d463d31a35 (diff) |
handle stale PairAcks
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/Pairing.hs | 3 | ||||
-rw-r--r-- | Assistant/Threads/PairListener.hs | 69 |
2 files changed, 45 insertions, 27 deletions
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index 4aade5465..8031a7213 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -28,6 +28,9 @@ data PairStage newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr)) deriving (Eq, Read, Show) +verifiedPairMsg :: PairMsg -> PairingInProgress -> Bool +verifiedPairMsg (PairMsg m) pip = verify m $ inProgressSecret pip + fromPairMsg :: PairMsg -> (Verifiable (PairStage, PairData, SomeAddr)) fromPairMsg (PairMsg m) = m diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 5cf20fa70..7ba673ec2 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -17,7 +17,6 @@ import Assistant.DaemonStatus import Assistant.WebApp import Assistant.WebApp.Types import Assistant.Alert -import Utility.Verifiable import Utility.Tense import Network.Multicast @@ -30,14 +29,31 @@ thisThread = "PairListener" pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ do sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort - go sock + go sock [] where thread = NamedThread thisThread - go sock = do - msg <- getmsg sock [] - dispatch $ readish msg - go sock + go sock cache = getmsg sock [] >>= \msg -> case readish msg of + Nothing -> go sock cache + Just m -> do + pip <- pairingInProgress <$> getDaemonStatus dstatus + let verified = maybe False (verifiedPairMsg m) pip + case pairMsgStage m of + PairReq -> do + pairReqReceived verified dstatus urlrenderer m + go sock $ invalidateCache m cache + PairAck -> do + pairAckReceived verified pip st dstatus scanremotes m cache + >>= go sock + PairDone -> do + pairDoneReceived verified pip st dstatus scanremotes m + go sock cache + + {- PairReqs invalidate the cache of recently finished pairings. + - This is so that, if a new pairing is started with the + - same secret used before, a bogus PairDone is not sent. -} + invalidateCache msg = + filter (\pip -> not $ verifiedPairMsg msg pip) getmsg sock c = do (msg, n, _) <- recvFrom sock chunksz @@ -47,21 +63,12 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ where chunksz = 1024 - dispatch Nothing = noop - dispatch (Just m@(PairMsg v)) = do - pip <- pairingInProgress <$> getDaemonStatus dstatus - let verified = maybe False (verify v . inProgressSecret) pip - case pairMsgStage m of - PairReq -> pairReqReceived verified dstatus urlrenderer m - PairAck -> pairAckReceived verified pip st dstatus scanremotes m - PairDone -> pairDoneReceived verified pip st dstatus scanremotes m - {- Show an alert when a PairReq is seen. - - Pair request alerts from the same host combine, - so repeated requests do not add additional alerts. -} pairReqReceived :: Bool -> DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO () -pairReqReceived True _ _ _ = noop -- ignore out own PairReq +pairReqReceived True _ _ _ = noop -- ignore our own PairReq pairReqReceived False dstatus urlrenderer msg = do url <- renderUrl urlrenderer (FinishPairR msg) [] void $ addAlert dstatus $ pairRequestReceivedAlert repo @@ -94,29 +101,37 @@ pairReqReceived False dstatus urlrenderer msg = do {- When a verified PairAck is seen, a host is ready to pair with us, and has - already configured our ssh key. Stop sending PairReqs, finish the pairing, - - and send a single PairDone. - - - - TODO: 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. - -} -pairAckReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> IO () -pairAckReceived False _ _ _ _ _ = noop -- not verified -pairAckReceived True Nothing _ _ _ _ = noop -- not in progress -pairAckReceived True (Just pip) st dstatus scanremotes msg = do + - and send a single PairDone. -} +pairAckReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> [PairingInProgress] -> IO [PairingInProgress] +pairAckReceived True (Just pip) st dstatus scanremotes msg cache = do stopSending dstatus pip setupAuthorizedKeys msg finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip) startSending dstatus pip $ multicastPairMsg (Just 1) (inProgressSecret pip) PairDone (inProgressPairData pip) + return $ pip:(take 10 cache) +{- A stale PairAck might also be seen, after we've finished pairing. + - Perhaps our PairDone was not received. To handle this, we keep + - a cache of recently finished pairings, and re-send PairDone in + - response to stale PairAcks for them. -} +pairAckReceived _ _ _ dstatus _ msg cache = do + let pips = filter (verifiedPairMsg msg) cache + unless (null pips) $ + forM_ pips $ \pip -> + startSending dstatus pip $ multicastPairMsg + (Just 1) (inProgressSecret pip) PairDone (inProgressPairData pip) + return cache {- If we get a verified PairDone, the host has accepted our PairAck, and - has paired with us. Stop sending PairAcks, and finish pairing with them. - + - If we get an unverified PairDone that matches the PairReq - TODO: Should third-party hosts remove their pair request alert when they - see a PairDone? How to tell if a PairDone matches with the PairReq - that brought up the alert? Cannot verify it without the secret.. + - Also, the user could have already clicked on the alert and be entering + - the secret. Would be better to start a fresh pair request in this + - situation. -} pairDoneReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> IO () pairDoneReceived False _ _ _ _ _ = noop -- not verified |