better handling of lifting from XMPP -> Assistant

This commit is contained in:
Joey Hess 2012-11-05 19:39:08 -04:00
parent fdb6a88877
commit 8f08aa3f45
7 changed files with 81 additions and 88 deletions

View file

@ -18,7 +18,7 @@ import Assistant.Sync
import Assistant.DaemonStatus
import qualified Remote
import Utility.ThreadScheduler
import Assistant.WebApp
import Assistant.WebApp (UrlRenderer, renderUrl)
import Assistant.WebApp.Types
import Assistant.Alert
import Assistant.Pairing
@ -34,73 +34,72 @@ import qualified Git.Branch
import Data.Time.Clock
xmppClientThread :: UrlRenderer -> NamedThread
xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
{- All Assistant actions have to be converted into IO actions that
- can be run from within the XMPP monad using liftIO. Ugly. -}
iodebug <- asIO1 debug
iopull <- asIO1 pull
iopairMsgReceived <- asIO2 $ pairMsgReceived urlrenderer
ioupdatebuddies <- asIO1 $ \p ->
updateBuddyList (updateBuddies p) <<~ buddyList
ioemptybuddies <- asIO $
updateBuddyList (const noBuddies) <<~ buddyList
iorelay <- asIO1 relayNetMessage
ioclientthread <- asIO $
go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived
restartableClient ioclientthread
xmppClientThread urlrenderer = NamedThread "XMPPClient" $
restartableClient . xmppClient urlrenderer =<< getAssistant id
{- Runs the client, handing restart events. -}
restartableClient :: IO () -> Assistant ()
restartableClient a = forever $ do
tid <- liftIO $ forkIO a
waitNetMessagerRestart
liftIO $ killThread tid
xmppClient :: UrlRenderer -> AssistantData -> IO ()
xmppClient urlrenderer d = do
v <- liftAssistant $ liftAnnex getXMPPCreds
case v of
Nothing -> noop -- will be restarted once creds get configured
Just c -> retry (runclient c) =<< getCurrentTime
where
go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived = do
v <- liftAnnex getXMPPCreds
case v of
Nothing -> noop
Just c -> liftIO $ retry (runclient c) =<< getCurrentTime
where
debug' = void . liftIO . iodebug
liftAssistant = runAssistant d
xAssistant = liftIO . liftAssistant
{- When the client exits, it's restarted;
- if it keeps failing, back off to wait 5 minutes before
- trying it again. -}
retry a starttime = do
e <- a
now <- getCurrentTime
if diffUTCTime now starttime > 300
then do
void $ iodebug ["connection lost; reconnecting", show e]
retry a now
else do
void $ iodebug ["connection failed; will retry", show e]
threadDelaySeconds (Seconds 300)
retry a =<< getCurrentTime
{- When the client exits, it's restarted;
- if it keeps failing, back off to wait 5 minutes before
- trying it again. -}
retry client starttime = do
e <- client
now <- getCurrentTime
if diffUTCTime now starttime > 300
then do
liftAssistant $ debug ["connection lost; reconnecting", show e]
retry client now
else do
liftAssistant $ debug ["connection failed; will retry", show e]
threadDelaySeconds (Seconds 300)
retry client =<< getCurrentTime
runclient c = void $ connectXMPP c $ \jid -> do
selfjid <- bindJID jid
debug' ["connected", show selfjid]
{- The buddy list starts empty each time
- the client connects, so that stale info
- is not retained. -}
void $ liftIO ioemptybuddies
putStanza gitAnnexSignature
xmppThread $ receivenotifications selfjid
forever $ do
a <- liftIO $ iorelay selfjid
a
runclient c = liftIO $ connectXMPP c $ \jid -> do
selfjid <- bindJID jid
putStanza gitAnnexSignature
receivenotifications selfjid = forever $ do
l <- decodeStanza selfjid <$> getStanza
debug' ["received:", show l]
mapM_ (handle selfjid) l
xAssistant $ debug ["connected", show selfjid]
{- The buddy list starts empty each time
- the client connects, so that stale info
- is not retained. -}
void $ xAssistant $
updateBuddyList (const noBuddies) <<~ buddyList
handle _ (PresenceMessage p) =
void $ liftIO $ ioupdatebuddies p
handle _ (GotNetMessage QueryPresence) =
putStanza gitAnnexSignature
handle _ (GotNetMessage (NotifyPush us)) =
void $ liftIO $ iopull us
handle selfjid (GotNetMessage (PairingNotification stage t u)) =
maybe noop (\jid -> liftIO $ iopairMsgReceived (stage, u) (selfjid, jid)) (parseJID t)
handle _ (Ignorable _) = noop
handle _ (Unknown _) = noop
handle _ (ProtocolError _) = noop
xmppThread $ receivenotifications selfjid
forever $ do
a <- xAssistant $ relayNetMessage selfjid
a
receivenotifications selfjid = forever $ do
l <- decodeStanza selfjid <$> getStanza
xAssistant $ debug ["received:", show l]
mapM_ (handle selfjid) l
handle _ (PresenceMessage p) = void $ xAssistant $
updateBuddyList (updateBuddies p) <<~ buddyList
handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature
handle _ (GotNetMessage (NotifyPush us)) = void $ xAssistant $
pull us
handle selfjid (GotNetMessage (PairingNotification stage t u)) =
maybe noop (xAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID t)
handle _ (Ignorable _) = noop
handle _ (Unknown _) = noop
handle _ (ProtocolError _) = noop
data XMPPEvent
= GotNetMessage NetMessage
@ -153,13 +152,6 @@ relayNetMessage selfjid = convert =<< waitNetMessage
return $ putStanza $
pairingNotification stage u tojid selfjid
{- Runs the client, handing restart events. -}
restartableClient :: IO () -> Assistant ()
restartableClient a = forever $ do
tid <- liftIO $ forkIO a
waitNetMessagerRestart
liftIO $ killThread tid
{- Runs a XMPP action in a separate thread, using a session to allow it
- to access the same XMPP client. -}
xmppThread :: XMPP () -> XMPP ()
@ -196,8 +188,8 @@ pull us = do
unlessM (all id . fst <$> manualPull branch [r]) $
pullone rs branch
pairMsgReceived :: UrlRenderer -> (PairStage, UUID) -> (JID, JID) -> Assistant ()
pairMsgReceived urlrenderer (PairReq, theiruuid) (selfjid, theirjid)
pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant ()
pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
-- PairReq from another client using our JID is automatically accepted.
| baseJID selfjid == baseJID theirjid = do
selfuuid <- liftAnnex getUUID
@ -215,7 +207,8 @@ pairMsgReceived urlrenderer (PairReq, theiruuid) (selfjid, theirjid)
, buttonLabel = T.pack "Respond"
, buttonAction = Just close
}
pairMsgReceived _ (PairAck, theiruuid) (_selfjid, theirjid) =
pairMsgReceived _ PairAck theiruuid _selfjid theirjid =
{- PairAck must come from one of the buddies we are pairing with;
- don't pair with just anyone. -}
whenM (isBuddyPairing theirjid) $ do
@ -224,7 +217,8 @@ pairMsgReceived _ (PairAck, theiruuid) (_selfjid, theirjid) =
sendNetMessage $
PairingNotification PairDone (formatJID theirjid) selfuuid
finishXMPPPairing theirjid theiruuid
pairMsgReceived _ (PairDone, _theiruuid) (_selfjid, theirjid) =
pairMsgReceived _ PairDone _theiruuid _selfjid theirjid =
changeBuddyPairing theirjid False
isBuddyPairing :: JID -> Assistant Bool