2012-11-03 18:16:17 +00:00
|
|
|
|
{- git-annex XMPP client
|
|
|
|
|
-
|
|
|
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
|
|
|
-
|
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
|
-}
|
|
|
|
|
|
|
|
|
|
module Assistant.Threads.XMPPClient where
|
|
|
|
|
|
|
|
|
|
import Assistant.Common
|
|
|
|
|
import Assistant.XMPP
|
|
|
|
|
import Assistant.XMPP.Client
|
|
|
|
|
import Assistant.NetMessager
|
|
|
|
|
import Assistant.Types.NetMessager
|
|
|
|
|
import Assistant.Types.Buddies
|
|
|
|
|
import Assistant.XMPP.Buddies
|
|
|
|
|
import Assistant.Sync
|
|
|
|
|
import Assistant.DaemonStatus
|
|
|
|
|
import qualified Remote
|
|
|
|
|
import Utility.ThreadScheduler
|
2012-11-05 23:39:08 +00:00
|
|
|
|
import Assistant.WebApp (UrlRenderer, renderUrl)
|
2012-11-03 21:34:19 +00:00
|
|
|
|
import Assistant.WebApp.Types
|
|
|
|
|
import Assistant.Alert
|
|
|
|
|
import Assistant.Pairing
|
2012-11-05 21:43:17 +00:00
|
|
|
|
import Assistant.XMPP.Git
|
|
|
|
|
import Annex.UUID
|
2012-11-03 18:16:17 +00:00
|
|
|
|
|
|
|
|
|
import Network.Protocol.XMPP
|
|
|
|
|
import Control.Concurrent
|
2012-11-03 21:34:19 +00:00
|
|
|
|
import qualified Data.Text as T
|
2012-11-03 18:16:17 +00:00
|
|
|
|
import qualified Data.Set as S
|
2012-11-05 21:43:17 +00:00
|
|
|
|
import qualified Data.Map as M
|
2012-11-03 18:16:17 +00:00
|
|
|
|
import qualified Git.Branch
|
|
|
|
|
import Data.Time.Clock
|
|
|
|
|
|
2013-03-06 22:28:34 +00:00
|
|
|
|
{- Whether to include verbose protocol dump in debug output. -}
|
|
|
|
|
protocolDebug :: Bool
|
2013-03-07 01:33:08 +00:00
|
|
|
|
protocolDebug = False
|
2013-03-06 22:28:34 +00:00
|
|
|
|
|
2012-11-03 21:34:19 +00:00
|
|
|
|
xmppClientThread :: UrlRenderer -> NamedThread
|
2013-01-26 06:09:33 +00:00
|
|
|
|
xmppClientThread urlrenderer = namedThread "XMPPClient" $
|
2012-11-05 23:39:08 +00:00
|
|
|
|
restartableClient . xmppClient urlrenderer =<< getAssistant id
|
|
|
|
|
|
|
|
|
|
{- Runs the client, handing restart events. -}
|
2013-03-06 20:29:19 +00:00
|
|
|
|
restartableClient :: (XMPPCreds -> IO ()) -> Assistant ()
|
|
|
|
|
restartableClient a = forever $ go =<< liftAnnex getXMPPCreds
|
|
|
|
|
where
|
|
|
|
|
go Nothing = waitNetMessagerRestart
|
|
|
|
|
go (Just creds) = do
|
|
|
|
|
tid <- liftIO $ forkIO $ a creds
|
|
|
|
|
waitNetMessagerRestart
|
|
|
|
|
liftIO $ killThread tid
|
2012-11-05 23:39:08 +00:00
|
|
|
|
|
2013-03-06 20:29:19 +00:00
|
|
|
|
xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> IO ()
|
|
|
|
|
xmppClient urlrenderer d creds =
|
|
|
|
|
retry (runclient creds) =<< getCurrentTime
|
2012-11-03 18:16:17 +00:00
|
|
|
|
where
|
2012-11-05 23:39:08 +00:00
|
|
|
|
liftAssistant = runAssistant d
|
2012-11-08 18:02:37 +00:00
|
|
|
|
inAssistant = liftIO . liftAssistant
|
2012-11-05 23:39:08 +00:00
|
|
|
|
|
|
|
|
|
{- When the client exits, it's restarted;
|
2012-12-13 04:45:27 +00:00
|
|
|
|
- if it keeps failing, back off to wait 5 minutes before
|
2012-11-05 23:39:08 +00:00
|
|
|
|
- trying it again. -}
|
|
|
|
|
retry client starttime = do
|
2013-03-07 07:50:21 +00:00
|
|
|
|
{- The buddy list starts empty each time
|
|
|
|
|
- the client connects, so that stale info
|
|
|
|
|
- is not retained. -}
|
|
|
|
|
liftAssistant $
|
|
|
|
|
updateBuddyList (const noBuddies) <<~ buddyList
|
2012-11-05 23:39:08 +00:00
|
|
|
|
e <- client
|
2013-03-07 02:02:47 +00:00
|
|
|
|
liftAssistant $ modifyDaemonStatus_ $ \s -> s
|
|
|
|
|
{ xmppClientID = Nothing }
|
2012-11-05 23:39:08 +00:00
|
|
|
|
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
|
|
|
|
|
|
2013-03-07 02:02:47 +00:00
|
|
|
|
inAssistant $ do
|
|
|
|
|
modifyDaemonStatus_ $ \s -> s
|
|
|
|
|
{ xmppClientID = Just $ xmppJID creds }
|
|
|
|
|
debug ["connected", show selfjid]
|
2012-11-05 23:39:08 +00:00
|
|
|
|
|
|
|
|
|
xmppThread $ receivenotifications selfjid
|
|
|
|
|
forever $ do
|
2012-11-08 18:02:37 +00:00
|
|
|
|
a <- inAssistant $ relayNetMessage selfjid
|
2012-11-05 23:39:08 +00:00
|
|
|
|
a
|
|
|
|
|
|
|
|
|
|
receivenotifications selfjid = forever $ do
|
|
|
|
|
l <- decodeStanza selfjid <$> getStanza
|
2013-03-06 22:28:34 +00:00
|
|
|
|
when protocolDebug $
|
|
|
|
|
inAssistant $ debug ["received:", show l]
|
2012-11-05 23:39:08 +00:00
|
|
|
|
mapM_ (handle selfjid) l
|
|
|
|
|
|
2013-03-07 01:33:08 +00:00
|
|
|
|
handle selfjid (PresenceMessage p) = do
|
2013-03-06 22:28:34 +00:00
|
|
|
|
void $ inAssistant $
|
|
|
|
|
updateBuddyList (updateBuddies p) <<~ buddyList
|
2013-03-07 01:33:08 +00:00
|
|
|
|
resendImportantMessages selfjid p
|
2012-11-05 23:39:08 +00:00
|
|
|
|
handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature
|
2012-11-08 20:44:23 +00:00
|
|
|
|
handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us
|
2012-11-08 18:02:37 +00:00
|
|
|
|
handle selfjid (GotNetMessage (PairingNotification stage c u)) =
|
|
|
|
|
maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c)
|
2012-11-10 16:18:00 +00:00
|
|
|
|
handle _ (GotNetMessage m@(Pushing _ pushstage))
|
|
|
|
|
| isPushInitiation pushstage = inAssistant $
|
|
|
|
|
unlessM (queueNetPushMessage m) $
|
2012-11-11 19:42:03 +00:00
|
|
|
|
void $ forkIO <~> handlePushInitiation m
|
2012-11-10 16:18:00 +00:00
|
|
|
|
| otherwise = void $ inAssistant $ queueNetPushMessage m
|
2012-11-05 23:39:08 +00:00
|
|
|
|
handle _ (Ignorable _) = noop
|
|
|
|
|
handle _ (Unknown _) = noop
|
|
|
|
|
handle _ (ProtocolError _) = noop
|
2012-11-03 18:16:17 +00:00
|
|
|
|
|
2013-03-07 01:33:08 +00:00
|
|
|
|
resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do
|
|
|
|
|
let c = formatJID jid
|
|
|
|
|
(stored, sent) <- inAssistant $
|
|
|
|
|
checkImportantNetMessages (formatJID (baseJID jid), c)
|
|
|
|
|
forM_ (S.toList $ S.difference stored sent) $ \msg -> do
|
|
|
|
|
inAssistant $ debug ["sending to new client:", show c, show msg]
|
|
|
|
|
a <- inAssistant $ convertNetMsg (readdressNetMessage msg c) selfjid
|
|
|
|
|
a
|
|
|
|
|
inAssistant $ sentImportantNetMessage msg c
|
|
|
|
|
resendImportantMessages _ _ = noop
|
2012-11-09 20:04:55 +00:00
|
|
|
|
|
2012-11-03 20:00:38 +00:00
|
|
|
|
data XMPPEvent
|
|
|
|
|
= GotNetMessage NetMessage
|
|
|
|
|
| PresenceMessage Presence
|
2012-11-05 21:54:21 +00:00
|
|
|
|
| Ignorable ReceivedStanza
|
2012-11-03 18:16:17 +00:00
|
|
|
|
| Unknown ReceivedStanza
|
2012-11-03 21:34:19 +00:00
|
|
|
|
| ProtocolError ReceivedStanza
|
2012-11-03 18:16:17 +00:00
|
|
|
|
deriving Show
|
|
|
|
|
|
2012-11-03 20:00:38 +00:00
|
|
|
|
{- Decodes an XMPP stanza into one or more events. -}
|
|
|
|
|
decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
|
2012-11-04 02:52:41 +00:00
|
|
|
|
decodeStanza selfjid s@(ReceivedPresence p)
|
2012-11-03 21:34:19 +00:00
|
|
|
|
| presenceType p == PresenceError = [ProtocolError s]
|
2012-11-05 21:54:21 +00:00
|
|
|
|
| presenceFrom p == Nothing = [Ignorable s]
|
|
|
|
|
| presenceFrom p == Just selfjid = [Ignorable s]
|
2012-11-10 06:35:54 +00:00
|
|
|
|
| otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p)
|
2012-11-03 18:16:17 +00:00
|
|
|
|
where
|
2012-11-10 06:35:54 +00:00
|
|
|
|
decode i
|
|
|
|
|
| tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
|
|
|
|
|
decodePushNotification (tagValue i)
|
|
|
|
|
| tagAttr i == queryAttr = impliedp $ GotNetMessage QueryPresence
|
2012-11-05 19:40:56 +00:00
|
|
|
|
| otherwise = [Unknown s]
|
|
|
|
|
{- Things sent via presence imply a presence message,
|
|
|
|
|
- along with their real meaning. -}
|
2012-11-03 20:00:38 +00:00
|
|
|
|
impliedp v = [PresenceMessage p, v]
|
2012-11-05 21:54:21 +00:00
|
|
|
|
decodeStanza selfjid s@(ReceivedMessage m)
|
|
|
|
|
| messageFrom m == Nothing = [Ignorable s]
|
|
|
|
|
| messageFrom m == Just selfjid = [Ignorable s]
|
2012-11-05 19:40:56 +00:00
|
|
|
|
| messageType m == MessageError = [ProtocolError s]
|
2012-11-10 17:00:13 +00:00
|
|
|
|
| otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)]
|
2012-11-03 20:00:38 +00:00
|
|
|
|
decodeStanza _ s = [Unknown s]
|
|
|
|
|
|
2012-11-10 19:33:12 +00:00
|
|
|
|
{- Waits for a NetMessager message to be sent, and relays it to XMPP.
|
|
|
|
|
-
|
|
|
|
|
- Chat messages must be directed to specific clients, not a base
|
|
|
|
|
- account JID, due to git-annex clients using a negative presence priority.
|
|
|
|
|
- PairingNotification messages are always directed at specific
|
2013-03-07 01:33:08 +00:00
|
|
|
|
- clients, but Pushing messages are sometimes not, and need to be exploded
|
|
|
|
|
- out to specific clients.
|
|
|
|
|
-
|
|
|
|
|
- Important messages, not directed at any specific client,
|
|
|
|
|
- are cached to be sent later when additional clients connect.
|
2012-11-10 19:33:12 +00:00
|
|
|
|
-}
|
2012-11-03 20:00:38 +00:00
|
|
|
|
relayNetMessage :: JID -> Assistant (XMPP ())
|
2013-03-06 22:28:34 +00:00
|
|
|
|
relayNetMessage selfjid = do
|
|
|
|
|
msg <- waitNetMessage
|
|
|
|
|
when protocolDebug $
|
|
|
|
|
debug ["sending:", show msg]
|
2013-03-07 01:33:08 +00:00
|
|
|
|
handleImportant msg
|
2013-03-06 22:28:34 +00:00
|
|
|
|
convert msg
|
2012-11-03 20:00:38 +00:00
|
|
|
|
where
|
2013-03-07 01:33:08 +00:00
|
|
|
|
handleImportant msg = case parseJID =<< isImportantNetMessage msg of
|
|
|
|
|
Just tojid
|
|
|
|
|
| tojid == baseJID tojid ->
|
|
|
|
|
storeImportantNetMessage msg (formatJID tojid) $
|
|
|
|
|
\c -> (baseJID <$> parseJID c) == Just tojid
|
|
|
|
|
_ -> noop
|
|
|
|
|
convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> do
|
2012-11-10 19:33:12 +00:00
|
|
|
|
if tojid == baseJID tojid
|
|
|
|
|
then do
|
2013-03-06 22:28:34 +00:00
|
|
|
|
clients <- maybe [] (S.toList . buddyAssistants)
|
|
|
|
|
<$> getBuddy (genBuddyKey tojid) <<~ buddyList
|
|
|
|
|
when protocolDebug $
|
|
|
|
|
debug ["exploded undirected message to clients", show clients]
|
|
|
|
|
return $ forM_ (clients) $ \(Client jid) ->
|
2012-11-10 19:33:12 +00:00
|
|
|
|
putStanza $ pushMessage pushstage jid selfjid
|
|
|
|
|
else return $ putStanza $ pushMessage pushstage tojid selfjid
|
2013-03-07 01:33:08 +00:00
|
|
|
|
convert msg = convertNetMsg msg selfjid
|
2012-11-08 18:02:37 +00:00
|
|
|
|
|
2013-03-07 01:33:08 +00:00
|
|
|
|
{- Converts a NetMessage to an XMPP action. -}
|
|
|
|
|
convertNetMsg :: NetMessage -> JID -> Assistant (XMPP ())
|
|
|
|
|
convertNetMsg msg selfjid = convert msg
|
|
|
|
|
where
|
|
|
|
|
convert (NotifyPush us) = return $ putStanza $ pushNotification us
|
|
|
|
|
convert QueryPresence = return $ putStanza presenceQuery
|
|
|
|
|
convert (PairingNotification stage c u) = withOtherClient selfjid c $ \tojid -> do
|
|
|
|
|
changeBuddyPairing tojid True
|
|
|
|
|
return $ putStanza $ pairingNotification stage u tojid selfjid
|
|
|
|
|
convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid ->
|
|
|
|
|
return $ putStanza $ pushMessage pushstage tojid selfjid
|
|
|
|
|
|
|
|
|
|
withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> (Assistant (XMPP ()))
|
|
|
|
|
withOtherClient selfjid c a = case parseJID c of
|
|
|
|
|
Nothing -> return noop
|
|
|
|
|
Just tojid
|
|
|
|
|
| tojid == selfjid -> return noop
|
|
|
|
|
| otherwise -> a tojid
|
|
|
|
|
|
|
|
|
|
withClient :: ClientID -> (JID -> XMPP ()) -> XMPP ()
|
|
|
|
|
withClient c a = maybe noop a $ parseJID c
|
2012-11-03 18:16:17 +00:00
|
|
|
|
|
|
|
|
|
{- Runs a XMPP action in a separate thread, using a session to allow it
|
|
|
|
|
- to access the same XMPP client. -}
|
|
|
|
|
xmppThread :: XMPP () -> XMPP ()
|
|
|
|
|
xmppThread a = do
|
|
|
|
|
s <- getSession
|
|
|
|
|
void $ liftIO $ forkIO $
|
|
|
|
|
void $ runXMPP s a
|
|
|
|
|
|
|
|
|
|
{- We only pull from one remote out of the set listed in the push
|
|
|
|
|
- notification, as an optimisation.
|
|
|
|
|
-
|
|
|
|
|
- Note that it might be possible (though very unlikely) for the push
|
|
|
|
|
- notification to take a while to be sent, and multiple pushes happen
|
|
|
|
|
- before it is sent, so it includes multiple remotes that were pushed
|
|
|
|
|
- to at different times.
|
|
|
|
|
-
|
|
|
|
|
- It could then be the case that the remote we choose had the earlier
|
|
|
|
|
- push sent to it, but then failed to get the later push, and so is not
|
|
|
|
|
- fully up-to-date. If that happens, the pushRetryThread will come along
|
|
|
|
|
- and retry the push, and we'll get another notification once it succeeds,
|
|
|
|
|
- and pull again. -}
|
|
|
|
|
pull :: [UUID] -> Assistant ()
|
|
|
|
|
pull [] = noop
|
|
|
|
|
pull us = do
|
2012-11-11 20:23:16 +00:00
|
|
|
|
rs <- filter matching . syncGitRemotes <$> getDaemonStatus
|
2012-11-03 18:16:17 +00:00
|
|
|
|
debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs
|
|
|
|
|
pullone rs =<< liftAnnex (inRepo Git.Branch.current)
|
|
|
|
|
where
|
|
|
|
|
matching r = Remote.uuid r `S.member` s
|
|
|
|
|
s = S.fromList us
|
|
|
|
|
|
|
|
|
|
pullone [] _ = noop
|
|
|
|
|
pullone (r:rs) branch =
|
|
|
|
|
unlessM (all id . fst <$> manualPull branch [r]) $
|
|
|
|
|
pullone rs branch
|
2012-11-03 21:34:19 +00:00
|
|
|
|
|
2012-11-05 23:39:08 +00:00
|
|
|
|
pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant ()
|
|
|
|
|
pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
|
2012-11-11 22:16:11 +00:00
|
|
|
|
| baseJID selfjid == baseJID theirjid = autoaccept
|
|
|
|
|
| otherwise = do
|
|
|
|
|
knownjids <- catMaybes . map (parseJID . getXMPPClientID)
|
|
|
|
|
. filter isXMPPRemote . syncRemotes <$> getDaemonStatus
|
|
|
|
|
if any (== baseJID theirjid) knownjids
|
|
|
|
|
then autoaccept
|
|
|
|
|
else showalert
|
|
|
|
|
|
|
|
|
|
where
|
|
|
|
|
-- PairReq from another client using our JID, or the JID of
|
|
|
|
|
-- any repo we're already paired with is automatically accepted.
|
|
|
|
|
autoaccept = do
|
2012-11-05 21:43:17 +00:00
|
|
|
|
selfuuid <- liftAnnex getUUID
|
|
|
|
|
sendNetMessage $
|
|
|
|
|
PairingNotification PairAck (formatJID theirjid) selfuuid
|
|
|
|
|
finishXMPPPairing theirjid theiruuid
|
|
|
|
|
-- Show an alert to let the user decide if they want to pair.
|
2012-11-11 22:16:11 +00:00
|
|
|
|
showalert = do
|
2013-03-15 19:05:02 +00:00
|
|
|
|
let route = ConfirmXMPPPairFriendR $
|
|
|
|
|
PairKey theiruuid $ formatJID theirjid
|
2012-11-05 21:43:17 +00:00
|
|
|
|
url <- liftIO $ renderUrl urlrenderer route []
|
|
|
|
|
close <- asIO1 removeAlert
|
|
|
|
|
void $ addAlert $ pairRequestReceivedAlert (T.unpack $ buddyName theirjid)
|
|
|
|
|
AlertButton
|
|
|
|
|
{ buttonUrl = url
|
|
|
|
|
, buttonLabel = T.pack "Respond"
|
|
|
|
|
, buttonAction = Just close
|
|
|
|
|
}
|
2012-11-05 23:39:08 +00:00
|
|
|
|
|
|
|
|
|
pairMsgReceived _ PairAck theiruuid _selfjid theirjid =
|
2012-11-05 21:43:17 +00:00
|
|
|
|
{- PairAck must come from one of the buddies we are pairing with;
|
|
|
|
|
- don't pair with just anyone. -}
|
|
|
|
|
whenM (isBuddyPairing theirjid) $ do
|
|
|
|
|
changeBuddyPairing theirjid False
|
|
|
|
|
selfuuid <- liftAnnex getUUID
|
|
|
|
|
sendNetMessage $
|
|
|
|
|
PairingNotification PairDone (formatJID theirjid) selfuuid
|
|
|
|
|
finishXMPPPairing theirjid theiruuid
|
2012-11-05 23:39:08 +00:00
|
|
|
|
|
|
|
|
|
pairMsgReceived _ PairDone _theiruuid _selfjid theirjid =
|
2012-11-05 21:43:17 +00:00
|
|
|
|
changeBuddyPairing theirjid False
|
|
|
|
|
|
|
|
|
|
isBuddyPairing :: JID -> Assistant Bool
|
|
|
|
|
isBuddyPairing jid = maybe False buddyPairing <$>
|
|
|
|
|
getBuddy (genBuddyKey jid) <<~ buddyList
|
|
|
|
|
|
|
|
|
|
changeBuddyPairing :: JID -> Bool -> Assistant ()
|
|
|
|
|
changeBuddyPairing jid ispairing =
|
|
|
|
|
updateBuddyList (M.adjust set key) <<~ buddyList
|
|
|
|
|
where
|
|
|
|
|
key = genBuddyKey jid
|
|
|
|
|
set b = b { buddyPairing = ispairing }
|