fixed all pairing alert issues

This commit is contained in:
Joey Hess 2012-09-11 16:11:28 -04:00
parent ade511f6e3
commit 4d592aaec2
2 changed files with 20 additions and 20 deletions

View file

@ -294,8 +294,12 @@ pairingAlert button = baseActivityAlert
} }
pairRequestReceivedAlert :: String -> AlertButton -> Alert pairRequestReceivedAlert :: String -> AlertButton -> Alert
pairRequestReceivedAlert repo button = baseActivityAlert pairRequestReceivedAlert repo button = Alert
{ alertData = [UnTensed $ T.pack $ repo ++ " is sending a pair request."] { alertClass = Message
, alertHeader = Nothing
, alertMessageRender = tenseWords
, alertData = [UnTensed $ T.pack $ repo ++ " is sending a pair request."]
, alertBlockDisplay = False
, alertPriority = High , alertPriority = High
, alertClosable = True , alertClosable = True
, alertIcon = Just InfoIcon , alertIcon = Just InfoIcon
@ -308,7 +312,6 @@ pairRequestAcknowledgedAlert :: String -> (Maybe AlertButton) -> Alert
pairRequestAcknowledgedAlert repo button = baseActivityAlert pairRequestAcknowledgedAlert repo button = baseActivityAlert
{ alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"] { alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"]
, alertPriority = High , alertPriority = High
, alertName = Just $ PairAlert repo
, alertCombiner = Just $ dataCombiner $ \_old new -> new , alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertButton = button , alertButton = button
} }

View file

@ -29,12 +29,12 @@ thisThread = "PairListener"
pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread
pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ do pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ do
sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
go sock [] go sock [] []
where where
thread = NamedThread thisThread thread = NamedThread thisThread
go sock cache = getmsg sock [] >>= \msg -> case readish msg of go sock reqs cache = getmsg sock [] >>= \msg -> case readish msg of
Nothing -> go sock cache Nothing -> go sock reqs cache
Just m -> do Just m -> do
sane <- checkSane msg sane <- checkSane msg
(pip, verified) <- verificationCheck m (pip, verified) <- verificationCheck m
@ -43,17 +43,19 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
case (wrongstage, sane, pairMsgStage m) of case (wrongstage, sane, pairMsgStage m) of
-- ignore our own messages, and -- ignore our own messages, and
-- out of order messages -- out of order messages
(True, _, _) -> go sock cache (True, _, _) -> go sock reqs cache
(_, False, _) -> go sock cache (_, False, _) -> go sock reqs cache
(_, _, PairReq) -> do (_, _, PairReq) -> if m `elem` reqs
pairReqReceived verified dstatus urlrenderer m then go sock reqs (invalidateCache m cache)
go sock $ invalidateCache m cache else do
pairReqReceived verified dstatus urlrenderer m
go sock (m:take 10 reqs) (invalidateCache m cache)
(_, _, PairAck) -> do (_, _, PairAck) -> do
pairAckReceived verified pip st dstatus scanremotes m cache pairAckReceived verified pip st dstatus scanremotes m cache
>>= go sock >>= go sock reqs
(_, _, PairDone) -> do (_, _, PairDone) -> do
pairDoneReceived verified pip st dstatus scanremotes m pairDoneReceived verified pip st dstatus scanremotes m
go sock cache go sock reqs cache
{- As well as verifying the message using the shared secret, {- As well as verifying the message using the shared secret,
- check its UUID against the UUID we have stored. If - check its UUID against the UUID we have stored. If
@ -97,10 +99,7 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
where where
chunksz = 1024 chunksz = 1024
{- Show an alert when a PairReq is seen. {- 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 :: Bool -> DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO ()
pairReqReceived True _ _ _ = noop -- ignore our own PairReq pairReqReceived True _ _ _ = noop -- ignore our own PairReq
pairReqReceived False dstatus urlrenderer msg = do pairReqReceived False dstatus urlrenderer msg = do
@ -109,12 +108,10 @@ pairReqReceived False dstatus urlrenderer msg = do
AlertButton AlertButton
{ buttonUrl = url { buttonUrl = url
, buttonLabel = T.pack "Respond" , buttonLabel = T.pack "Respond"
, buttonAction = Just onclick , buttonAction = Just $ removeAlert dstatus
} }
where where
repo = pairRepo msg repo = pairRepo msg
onclick = \i -> updateAlert dstatus i $ const $ Just $
pairRequestAcknowledgedAlert repo Nothing
{- When a verified PairAck is seen, a host is ready to pair with us, and has {- 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, - already configured our ssh key. Stop sending PairReqs, finish the pairing,