diff options
author | 2012-10-29 14:07:12 -0400 | |
---|---|---|
committer | 2012-10-29 14:07:12 -0400 | |
commit | 0b808465e21d667c0826f454bbe88abff79389b7 (patch) | |
tree | 4e44a4ad43cee59eca51d90721fc93cbf3d68596 /Assistant/Threads/PairListener.hs | |
parent | 5be6ce672226df37900ddb32f29b24e6b96277a9 (diff) |
Assistant monad, stage 3
All toplevel named threads are converted to the Assistant monad.
Some utility functions still need to be converted.
Diffstat (limited to 'Assistant/Threads/PairListener.hs')
-rw-r--r-- | Assistant/Threads/PairListener.hs | 189 |
1 files changed, 93 insertions, 96 deletions
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 116cc0fa1..77f84a4f6 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -11,8 +11,6 @@ import Assistant.Common import Assistant.Pairing import Assistant.Pairing.Network import Assistant.Pairing.MakeRemote -import Assistant.ThreadedMonad -import Assistant.ScanRemotes import Assistant.DaemonStatus import Assistant.WebApp import Assistant.WebApp.Types @@ -27,117 +25,116 @@ import Data.Char thisThread :: ThreadName thisThread = "PairListener" -pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread -pairListenerThread st dstatus scanremotes urlrenderer = thread $ liftIO $ withSocketsDo $ - runEvery (Seconds 1) $ void $ tryIO $ do - sock <- getsock - go sock [] [] - where - thread = NamedThread thisThread +pairListenerThread :: UrlRenderer -> NamedThread +pairListenerThread urlrenderer = NamedThread "PairListener" $ do + listener <- asIO $ go [] [] + liftIO $ withSocketsDo $ + runEvery (Seconds 1) $ void $ tryIO $ + listener =<< getsock + where + {- Note this can crash if there's no network interface, + - or only one like lo that doesn't support multicast. -} + getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort - {- Note this can crash if there's no network interface, - - or only one like lo that doesn't support multicast. -} - getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort - - go sock reqs cache = getmsg sock [] >>= \msg -> case readish msg of - Nothing -> go sock reqs cache - Just m -> do - sane <- checkSane msg - (pip, verified) <- verificationCheck m - =<< (pairingInProgress <$> getDaemonStatus dstatus) - let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip - case (wrongstage, sane, pairMsgStage m) of - -- ignore our own messages, and - -- out of order messages - (True, _, _) -> go sock reqs cache - (_, False, _) -> go sock reqs cache - (_, _, PairReq) -> if m `elem` reqs - then go sock reqs (invalidateCache m cache) - else do - pairReqReceived verified dstatus urlrenderer m - go sock (m:take 10 reqs) (invalidateCache m cache) - (_, _, PairAck) -> - pairAckReceived verified pip st dstatus scanremotes m cache - >>= go sock reqs - (_, _, PairDone) -> do - pairDoneReceived verified pip st dstatus scanremotes m - go sock reqs cache + go reqs cache sock = liftIO (getmsg sock []) >>= \msg -> case readish msg of + Nothing -> go reqs cache sock + Just m -> do + sane <- checkSane msg + (pip, verified) <- verificationCheck m + =<< (pairingInProgress <$> daemonStatus) + let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip + case (wrongstage, sane, pairMsgStage m) of + -- ignore our own messages, and + -- out of order messages + (True, _, _) -> go reqs cache sock + (_, False, _) -> go reqs cache sock + (_, _, PairReq) -> if m `elem` reqs + then go reqs (invalidateCache m cache) sock + else do + pairReqReceived verified urlrenderer m + go (m:take 10 reqs) (invalidateCache m cache) sock + (_, _, PairAck) -> do + cache' <- pairAckReceived verified pip m cache + go reqs cache' sock + (_, _, PairDone) -> do + pairDoneReceived verified pip m + go reqs cache sock - {- As well as verifying the message using the shared secret, - - check its UUID against the UUID we have stored. If - - they're the same, someone is sending bogus messages, - - which could be an attempt to brute force the shared - - secret. - -} - verificationCheck m (Just pip) = do - let verified = verifiedPairMsg m pip - let sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m) - if not verified && sameuuid - then do - runThreadState st $ - warning "detected possible pairing brute force attempt; disabled pairing" - stopSending dstatus pip - return (Nothing, False) - else return (Just pip, verified && sameuuid) - verificationCheck _ Nothing = return (Nothing, False) + {- As well as verifying the message using the shared secret, + - check its UUID against the UUID we have stored. If + - they're the same, someone is sending bogus messages, + - which could be an attempt to brute force the shared secret. -} + verificationCheck _ Nothing = return (Nothing, False) + verificationCheck m (Just pip) + | not verified && sameuuid = do + liftAnnex $ warning + "detected possible pairing brute force attempt; disabled pairing" + stopSending pip <<~ daemonStatusHandle + return (Nothing, False) + |otherwise = return (Just pip, verified && sameuuid) + where + verified = verifiedPairMsg m pip + sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m) - {- Various sanity checks on the content of the message. -} - checkSane msg - {- Control characters could be used in a - - console poisoning attack. -} - | any isControl msg || any (`elem` "\r\n") msg = do - runThreadState st $ - warning "illegal control characters in pairing message; ignoring" - return False - | otherwise = return True + {- Various sanity checks on the content of the message. -} + checkSane msg + {- Control characters could be used in a + - console poisoning attack. -} + | any isControl msg || any (`elem` "\r\n") msg = do + liftAnnex $ warning + "illegal control characters in pairing message; ignoring" + return False + | otherwise = return True - {- 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 (not . verifiedPairMsg msg) + {- 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 (not . verifiedPairMsg msg) - getmsg sock c = do - (msg, n, _) <- recvFrom sock chunksz - if n < chunksz - then return $ c ++ msg - else getmsg sock $ c ++ msg - where - chunksz = 1024 + getmsg sock c = do + (msg, n, _) <- recvFrom sock chunksz + if n < chunksz + then return $ c ++ msg + else getmsg sock $ c ++ msg + where + chunksz = 1024 {- Show an alert when a PairReq is seen. -} -pairReqReceived :: Bool -> DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO () -pairReqReceived True _ _ _ = noop -- ignore our own PairReq -pairReqReceived False dstatus urlrenderer msg = do - url <- renderUrl urlrenderer (FinishPairR msg) [] - void $ addAlert dstatus $ pairRequestReceivedAlert repo +pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant () +pairReqReceived True _ _ = noop -- ignore our own PairReq +pairReqReceived False urlrenderer msg = do + url <- liftIO $ renderUrl urlrenderer (FinishPairR msg) [] + dstatus <- getAssistant daemonStatusHandle + liftIO $ void $ addAlert dstatus $ pairRequestReceivedAlert repo AlertButton { buttonUrl = url , buttonLabel = T.pack "Respond" , buttonAction = Just $ removeAlert dstatus } - where - repo = pairRepo msg + where + repo = pairRepo msg {- 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. - -} -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 PairDone $ multicastPairMsg + - and send a single PairDone. -} +pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress] +pairAckReceived True (Just pip) msg cache = do + stopSending pip <<~ daemonStatusHandle + liftIO $ setupAuthorizedKeys msg + finishedPairing msg (inProgressSshKeyPair pip) + dstatus <- getAssistant daemonStatusHandle + liftIO $ startSending dstatus pip PairDone $ multicastPairMsg (Just 1) (inProgressSecret pip) (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 +pairAckReceived _ _ msg cache = do let pips = filter (verifiedPairMsg msg) cache + dstatus <- getAssistant daemonStatusHandle unless (null pips) $ - forM_ pips $ \pip -> + liftIO $ forM_ pips $ \pip -> startSending dstatus pip PairDone $ multicastPairMsg (Just 1) (inProgressSecret pip) (inProgressPairData pip) return cache @@ -151,9 +148,9 @@ pairAckReceived _ _ _ dstatus _ msg cache = do - 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 -pairDoneReceived True Nothing _ _ _ _ = noop -- not in progress -pairDoneReceived True (Just pip) st dstatus scanremotes msg = do - stopSending dstatus pip - finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip) +pairDoneReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> Assistant () +pairDoneReceived False _ _ = noop -- not verified +pairDoneReceived True Nothing _ = noop -- not in progress +pairDoneReceived True (Just pip) msg = do + stopSending pip <<~ daemonStatusHandle + finishedPairing msg (inProgressSshKeyPair pip) |