aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Assistant.hs12
-rw-r--r--Assistant/Alert.hs10
-rw-r--r--Assistant/Threads/XMPPClient.hs64
-rw-r--r--Assistant/Types/Buddies.hs9
-rw-r--r--Assistant/XMPP.hs14
-rw-r--r--Assistant/XMPP/Buddies.hs7
6 files changed, 76 insertions, 40 deletions
diff --git a/Assistant.hs b/Assistant.hs
index a58015c37..5cc9f303f 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -136,15 +136,15 @@ import Assistant.Threads.NetWatcher
import Assistant.Threads.TransferScanner
import Assistant.Threads.TransferPoller
import Assistant.Threads.ConfigMonitor
-#ifdef WITH_XMPP
-import Assistant.Threads.XMPPClient
-#endif
#ifdef WITH_WEBAPP
import Assistant.WebApp
import Assistant.Threads.WebApp
#ifdef WITH_PAIRING
import Assistant.Threads.PairListener
#endif
+#ifdef WITH_XMPP
+import Assistant.Threads.XMPPClient
+#endif
#else
#warning Building without the webapp. You probably need to install Yesod..
#endif
@@ -191,6 +191,9 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
#ifdef WITH_PAIRING
, assist $ pairListenerThread urlrenderer
#endif
+#ifdef WITH_XMPP
+ , assist $ xmppClientThread urlrenderer
+#endif
#endif
, assist $ pushThread
, assist $ pushRetryThread
@@ -205,9 +208,6 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
, assist $ netWatcherFallbackThread
, assist $ transferScannerThread
, assist $ configMonitorThread
-#ifdef WITH_XMPP
- , assist $ xmppClientThread
-#endif
, watch $ watchThread
]
liftIO waitForTermination
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index c729e4de4..8d9455e66 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -301,23 +301,23 @@ pairingAlert button = baseActivityAlert
}
pairRequestReceivedAlert :: String -> AlertButton -> Alert
-pairRequestReceivedAlert repo button = Alert
+pairRequestReceivedAlert who button = Alert
{ alertClass = Message
, alertHeader = Nothing
, alertMessageRender = tenseWords
- , alertData = [UnTensed $ T.pack $ repo ++ " is sending a pair request."]
+ , alertData = [UnTensed $ T.pack $ who ++ " is sending a pair request."]
, alertBlockDisplay = False
, alertPriority = High
, alertClosable = True
, alertIcon = Just InfoIcon
- , alertName = Just $ PairAlert repo
+ , alertName = Just $ PairAlert who
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertButton = Just button
}
pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
-pairRequestAcknowledgedAlert repo button = baseActivityAlert
- { alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"]
+pairRequestAcknowledgedAlert who button = baseActivityAlert
+ { alertData = ["Pair request with", UnTensed (T.pack who), Tensed "in progress" "complete"]
, alertPriority = High
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertButton = button
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 6aeabb24b..974cc83a0 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -18,27 +18,35 @@ import Assistant.Sync
import Assistant.DaemonStatus
import qualified Remote
import Utility.ThreadScheduler
+import Assistant.WebApp
+import Assistant.WebApp.Types
+import Assistant.Alert
+import Assistant.Pairing
import Network.Protocol.XMPP
import Control.Concurrent
+import qualified Data.Text as T
import qualified Data.Set as S
import qualified Git.Branch
import Data.Time.Clock
-xmppClientThread :: NamedThread
-xmppClientThread = NamedThread "XMPPClient" $ do
+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
+ iopairReqReceived <- asIO2 $ pairReqReceived 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
+ go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairReqReceived
restartableClient ioclientthread
where
- go iorelay iodebug iopull ioupdatebuddies ioemptybuddies = do
+ go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairReqReceived = do
v <- liftAnnex getXMPPCreds
case v of
Nothing -> noop
@@ -75,10 +83,9 @@ xmppClientThread = NamedThread "XMPPClient" $ do
a
receivenotifications fulljid = forever $ do
- s <- getStanza
- let vs = decodeStanza fulljid s
- debug' ["received:", show vs]
- mapM_ handle vs
+ l <- decodeStanza fulljid <$> getStanza
+ debug' ["received:", show l]
+ mapM_ handle l
handle (PresenceMessage p) =
void $ liftIO $ ioupdatebuddies p
@@ -86,22 +93,28 @@ xmppClientThread = NamedThread "XMPPClient" $ do
putStanza $ gitAnnexPresence gitAnnexSignature
handle (GotNetMessage (NotifyPush us)) =
void $ liftIO $ iopull us
- handle (GotNetMessage (PairingNotification stage t u)) = case parseJID t of
- Nothing -> noop
- Just jid -> error "TODO"
+ handle (GotNetMessage (PairingNotification stage t u)) =
+ maybe noop (handlePairing stage u) (parseJID t)
handle (Ignorable _) = noop
handle (Unknown _) = noop
+ handle (ProtocolError _) = noop
+
+ handlePairing PairReq u jid = liftIO $ iopairReqReceived u jid
+ handlePairing PairAck _ _ = error "TODO"
+ handlePairing PairDone _ _ = error "TODO"
data XMPPEvent
= GotNetMessage NetMessage
| PresenceMessage Presence
| Ignorable Presence
| Unknown ReceivedStanza
+ | ProtocolError ReceivedStanza
deriving Show
{- Decodes an XMPP stanza into one or more events. -}
decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
-decodeStanza fulljid (ReceivedPresence p)
+decodeStanza fulljid s@(ReceivedPresence p)
+ | presenceType p == PresenceError = [ProtocolError s]
| presenceFrom p == Nothing = [Ignorable p]
| presenceFrom p == Just fulljid = [Ignorable p]
| not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed
@@ -113,9 +126,11 @@ decodeStanza fulljid (ReceivedPresence p)
impliedp v = [PresenceMessage p, v]
pushed = concat $ catMaybes $ map decodePushNotification $
presencePayloads p
-decodeStanza _ s@(ReceivedIQ iq) = case decodePairingNotification iq of
- Nothing -> [Unknown s]
- Just pn -> [GotNetMessage pn]
+decodeStanza _ s@(ReceivedIQ iq)
+ | iqType iq == IQError = [ProtocolError s]
+ | otherwise = case decodePairingNotification iq of
+ Nothing -> [Unknown s]
+ Just pn -> [GotNetMessage pn]
decodeStanza _ s = [Unknown s]
{- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
@@ -126,7 +141,9 @@ relayNetMessage fulljid = convert <$> waitNetMessage
convert QueryPresence = putStanza $ presenceQuery
convert (PairingNotification stage t u) = case parseJID t of
Nothing -> noop
- Just tojid -> putStanza $ pairingNotification stage u tojid fulljid
+ Just tojid -> do
+ liftIO $ print $ pairingNotification stage u tojid fulljid
+ putStanza $ pairingNotification stage u tojid fulljid
{- Runs the client, handing restart events. -}
restartableClient :: IO () -> Assistant ()
@@ -170,3 +187,18 @@ pull us = do
pullone (r:rs) branch =
unlessM (all id . fst <$> manualPull branch [r]) $
pullone rs branch
+
+{- Show an alert when a PairReq is seen, unless the PairReq came from
+ - another client using our JID. In that case, just start pairing. -}
+pairReqReceived :: UrlRenderer -> UUID -> JID -> Assistant ()
+pairReqReceived urlrenderer u jid = do
+ -- TODO: check same JID
+ let route = FinishXMPPPairR (PairKey u $ formatJID jid)
+ url <- liftIO $ renderUrl urlrenderer route []
+ close <- asIO1 removeAlert
+ void $ addAlert $ pairRequestReceivedAlert (T.unpack $ buddyName jid)
+ AlertButton
+ { buttonUrl = url
+ , buttonLabel = T.pack "Respond"
+ , buttonAction = Just close
+ }
diff --git a/Assistant/Types/Buddies.hs b/Assistant/Types/Buddies.hs
index 9c070aa6a..3e7ecec62 100644
--- a/Assistant/Types/Buddies.hs
+++ b/Assistant/Types/Buddies.hs
@@ -38,11 +38,11 @@ data Buddy
#endif
deriving (Eq, Show)
-data BuddyID = BuddyID T.Text
+data BuddyKey = BuddyKey T.Text
deriving (Eq, Ord, Show, Read)
-data BuddyKey = BuddyKey T.Text
- deriving (Eq, Ord, Show)
+data PairKey = PairKey UUID T.Text
+ deriving (Eq, Ord, Show, Read)
type Buddies = M.Map BuddyKey Buddy
@@ -60,6 +60,9 @@ newBuddyList = (,)
getBuddyList :: BuddyList -> IO [Buddy]
getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)
+getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy)
+getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v)
+
getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster
getBuddyBroadcaster (_, h) = h
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 04eea50f6..3aef76b1a 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -86,24 +86,28 @@ isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of
((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs
{- A notification about a stage of pairing. Sent as an XMPP ping.
- - The pairing info is sent using its id attribute. -}
+ - The pairing info is sent using its id attribute; it also has a git-annex
+ - tag to identify it as from us. -}
pairingNotification :: PairStage -> UUID -> JID -> JID -> IQ
pairingNotification pairstage u tojid fromjid = (emptyIQ IQGet)
{ iqTo = Just tojid
, iqFrom = Just fromjid
, iqID = Just $ T.unwords $ map T.pack
- [ "git-annex"
- , show pairstage
+ [ show pairstage
, fromUUID u
]
+ , iqPayload = Just gitAnnexSignature
}
decodePairingNotification :: IQ -> Maybe NetMessage
-decodePairingNotification iq = parseid =<< words . T.unpack <$> iqID iq
+decodePairingNotification iq@(IQ { iqPayload = Just elt })
+ | isGitAnnexTag elt = parseid =<< words . T.unpack <$> iqID iq
+ | otherwise = Nothing
where
- parseid ["git-annex", stage, u] =
+ parseid [stage, u] =
PairingNotification
<$> readish stage
<*> (formatJID <$> iqFrom iq)
<*> pure (toUUID u)
parseid _ = Nothing
+decodePairingNotification _ = Nothing
diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs
index d784f316d..087a34879 100644
--- a/Assistant/XMPP/Buddies.hs
+++ b/Assistant/XMPP/Buddies.hs
@@ -17,9 +17,6 @@ import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
-genBuddyID :: JID -> BuddyID
-genBuddyID j = BuddyID $ formatJID j
-
genKey :: JID -> BuddyKey
genKey j = BuddyKey $ formatJID $ JID (jidNode j) (jidDomain j) Nothing
@@ -29,9 +26,9 @@ buddyName j = maybe (T.pack "") strNode (jidNode j)
{- Summary of info about a buddy.
-
- If the buddy has no clients at all anymore, returns Nothing. -}
-buddySummary :: Buddy -> Maybe (Text, Bool, Bool, BuddyID)
+buddySummary :: Buddy -> Maybe (Text, Bool, Bool, BuddyKey)
buddySummary b = case clients of
- ((Client j):_) -> Just (buddyName j, away, canpair, genBuddyID j)
+ ((Client j):_) -> Just (buddyName j, away, canpair, genKey j)
[] -> Nothing
where
away = S.null (buddyPresent b) && S.null (buddyAssistants b)
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-28 03:14:23 +0000