diff options
author | Joey Hess <joey@kitenet.net> | 2012-11-03 16:00:38 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-11-03 16:01:09 -0400 |
commit | efa88a0f1589a82a91a06ed3a3cbd5f4106aabb4 (patch) | |
tree | 013133783caef5e5f693b2734024935fd494551b /Assistant | |
parent | 2798e659c701a3c6122930ece994411b3ec8b266 (diff) |
XMPP pairing notifications are now sent
Rest of pairing process still to do.
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/Threads/XMPPClient.hs | 75 | ||||
-rw-r--r-- | Assistant/Types/NetMessager.hs | 11 | ||||
-rw-r--r-- | Assistant/XMPP.hs | 52 | ||||
-rw-r--r-- | Assistant/XMPP/Buddies.hs | 6 |
4 files changed, 78 insertions, 66 deletions
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 113bc06ab..6aeabb24b 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -33,7 +33,7 @@ xmppClientThread = NamedThread "XMPPClient" $ do updateBuddyList (updateBuddies p) <<~ buddyList ioemptybuddies <- asIO $ updateBuddyList (const noBuddies) <<~ buddyList - iorelay <- asIO relayNetMessage + iorelay <- asIO1 relayNetMessage ioclientthread <- asIO $ go iorelay iodebug iopull ioupdatebuddies ioemptybuddies restartableClient ioclientthread @@ -45,6 +45,7 @@ xmppClientThread = NamedThread "XMPPClient" $ do Just c -> liftIO $ loop 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. -} @@ -59,6 +60,7 @@ xmppClientThread = NamedThread "XMPPClient" $ do void $ iodebug ["connection failed; will retry"] threadDelaySeconds (Seconds 300) loop c =<< getCurrentTime + runclient c = void $ connectXMPP c $ \jid -> do fulljid <- bindJID jid debug' ["connected", show fulljid] @@ -69,47 +71,62 @@ xmppClientThread = NamedThread "XMPPClient" $ do putStanza $ gitAnnexPresence gitAnnexSignature xmppThread $ receivenotifications fulljid forever $ do - a <- liftIO iorelay + a <- liftIO $ iorelay fulljid a + receivenotifications fulljid = forever $ do s <- getStanza - let v = decodeStanza fulljid s - debug' ["received:", show v] - case v of - PresenceMessage p -> void $ liftIO $ ioupdatebuddies p - PresenceQuery p -> do - void $ liftIO $ ioupdatebuddies p - putStanza $ gitAnnexPresence gitAnnexSignature - PushNotification us -> void $ liftIO $ iopull us - Ignorable _ -> noop - Unknown _ -> noop + let vs = decodeStanza fulljid s + debug' ["received:", show vs] + mapM_ handle vs -{- Waits for a NetMessager message to be sent, and relays it to XMPP. -} -relayNetMessage :: Assistant (XMPP ()) -relayNetMessage = convert <$> waitNetMessage - where - convert (NotifyPush us) = putStanza $ pushNotification us - convert QueryPresence = putStanza presenceQuery + handle (PresenceMessage p) = + void $ liftIO $ ioupdatebuddies p + handle (GotNetMessage QueryPresence) = + 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 (Ignorable _) = noop + handle (Unknown _) = noop -data DecodedStanza - = PresenceMessage Presence - | PresenceQuery Presence - | PushNotification [UUID] +data XMPPEvent + = GotNetMessage NetMessage + | PresenceMessage Presence | Ignorable Presence | Unknown ReceivedStanza deriving Show -decodeStanza :: JID -> ReceivedStanza -> DecodedStanza +{- Decodes an XMPP stanza into one or more events. -} +decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent] decodeStanza fulljid (ReceivedPresence p) - | presenceFrom p == Nothing = Ignorable p - | presenceFrom p == Just fulljid = Ignorable p - | isPresenceQuery p = PresenceQuery p - | null pushed = PresenceMessage p - | otherwise = PushNotification pushed + | presenceFrom p == Nothing = [Ignorable p] + | presenceFrom p == Just fulljid = [Ignorable p] + | not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed + | isPresenceQuery p = impliedp $ GotNetMessage QueryPresence + | otherwise = [PresenceMessage p] where + -- Some things are sent via presence, so imply a presence message, + -- along with their real value. + impliedp v = [PresenceMessage p, v] pushed = concat $ catMaybes $ map decodePushNotification $ presencePayloads p -decodeStanza _ s = Unknown s +decodeStanza _ s@(ReceivedIQ iq) = 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. -} +relayNetMessage :: JID -> Assistant (XMPP ()) +relayNetMessage fulljid = convert <$> waitNetMessage + where + convert (NotifyPush us) = putStanza $ pushNotification us + convert QueryPresence = putStanza $ presenceQuery + convert (PairingNotification stage t u) = case parseJID t of + Nothing -> noop + Just tojid -> putStanza $ pairingNotification stage u tojid fulljid {- Runs the client, handing restart events. -} restartableClient :: IO () -> Assistant () diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs index 6bc9ec34a..79342b666 100644 --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -8,7 +8,9 @@ module Assistant.Types.NetMessager where import Common.Annex +import Assistant.Pairing +import Data.Text (Text) import Control.Concurrent.STM import Control.Concurrent.MSampleVar @@ -18,12 +20,11 @@ data NetMessage = NotifyPush [UUID] -- requests other clients to inform us of their presence | QueryPresence + -- notification about a stage in the pairing process, + -- involving another client identified by the Text, and a UUID. + | PairingNotification PairStage Text UUID + deriving (Show) -{- Controls for the XMPP client. - - - - It can be fed XMPP messages to send. - - - - It can also be sent a signal when it should restart for some reason. -} data NetMessagerControl = NetMessagerControl { netMessages :: TChan (NetMessage) , netMessagerRestart :: MSampleVar () diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index 834055fbc..04eea50f6 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -8,7 +8,7 @@ module Assistant.XMPP where import Assistant.Common -import Annex.UUID +import Assistant.Types.NetMessager import Assistant.Pairing import Network.Protocol.XMPP @@ -45,22 +45,9 @@ queryAttr = Name (T.pack "query") Nothing Nothing pushAttr :: Name pushAttr = Name (T.pack "push") Nothing Nothing -pairingAttr :: Name -pairingAttr = Name (T.pack "pairing") Nothing Nothing - isAttr :: Name -> (Name, [Content]) -> Bool isAttr attr (k, _) = k == attr -getAttr :: Name -> [(Name, [Content])] -> Maybe String -getAttr wantattr attrs = content <$> headMaybe (filter (isAttr wantattr) attrs) - where - content (_name, cs) = T.unpack $ T.concat $ map unpack cs - unpack (ContentText t) = t - unpack (ContentEntity t) = t - -uuidAttr :: Name -uuidAttr = Name (T.pack "uuid") Nothing Nothing - uuidSep :: T.Text uuidSep = T.pack "," @@ -98,20 +85,25 @@ isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of [] -> False ((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs -{- A notification about a stage of pairing. -} -pairingNotification :: PairStage -> Annex Presence -pairingNotification pairstage = do - u <- getUUID - return $ gitAnnexPresence $ Element gitAnnexTagName - [ (pairingAttr, [ContentText $ T.pack $ show pairstage]) - , (uuidAttr, [ContentText $ T.pack $ fromUUID u]) +{- A notification about a stage of pairing. Sent as an XMPP ping. + - The pairing info is sent using its id attribute. -} +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 + , fromUUID u ] - [] - -isPairingNotification :: Presence -> Maybe (PairStage, UUID) -isPairingNotification p = case filter isGitAnnexTag (presencePayloads p) of - [] -> Nothing - ((Element _name attrs _nodes):_) -> - (,) - <$> (readish =<< getAttr pairingAttr attrs) - <*> (toUUID <$> getAttr uuidAttr attrs) + } + +decodePairingNotification :: IQ -> Maybe NetMessage +decodePairingNotification iq = parseid =<< words . T.unpack <$> iqID iq + where + parseid ["git-annex", stage, u] = + PairingNotification + <$> readish stage + <*> (formatJID <$> iqFrom iq) + <*> pure (toUUID u) + parseid _ = Nothing diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs index 217870dc6..d784f316d 100644 --- a/Assistant/XMPP/Buddies.hs +++ b/Assistant/XMPP/Buddies.hs @@ -23,15 +23,17 @@ genBuddyID j = BuddyID $ formatJID j genKey :: JID -> BuddyKey genKey j = BuddyKey $ formatJID $ JID (jidNode j) (jidDomain j) Nothing +buddyName :: JID -> Text +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 b = case clients of - ((Client j):_) -> Just (buddyname j, away, canpair, genBuddyID j) + ((Client j):_) -> Just (buddyName j, away, canpair, genBuddyID j) [] -> Nothing where - buddyname j = maybe (T.pack "") strNode (jidNode j) away = S.null (buddyPresent b) && S.null (buddyAssistants b) canpair = not $ S.null (buddyAssistants b) clients = S.toList $ buddyPresent b `S.union` buddyAway b `S.union` buddyAssistants b |