diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Alert.hs | 10 | ||||
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 64 | ||||
| -rw-r--r-- | Assistant/Types/Buddies.hs | 9 | ||||
| -rw-r--r-- | Assistant/XMPP.hs | 14 | ||||
| -rw-r--r-- | Assistant/XMPP/Buddies.hs | 7 |
5 files changed, 70 insertions, 34 deletions
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) |