better handling of lifting from XMPP -> Assistant
This commit is contained in:
Joey Hess
parent
fdb6a88877
commit
8f08aa3f45
7 changed files with 81 additions and 88 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue