summaryrefslogtreecommitdiff
path: root/Assistant/Threads/XMPPClient.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant/Threads/XMPPClient.hs')
-rw-r--r--Assistant/Threads/XMPPClient.hs150
1 files changed, 72 insertions, 78 deletions
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 3d454d9c8..7da2bccc6 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -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
-
- {- 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
-
- 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
-
- receivenotifications selfjid = forever $ do
- l <- decodeStanza selfjid <$> getStanza
- debug' ["received:", show l]
- mapM_ (handle selfjid) l
-
- 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
+ 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 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 = liftIO $ connectXMPP c $ \jid -> do
+ selfjid <- bindJID jid
+ putStanza gitAnnexSignature
+
+ 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
+
+ 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-06 09:09:10 +0000