summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-11-03 16:00:38 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-11-03 16:01:09 -0400
commitefa88a0f1589a82a91a06ed3a3cbd5f4106aabb4 (patch)
tree013133783caef5e5f693b2734024935fd494551b /Assistant
parent2798e659c701a3c6122930ece994411b3ec8b266 (diff)
XMPP pairing notifications are now sent
Rest of pairing process still to do.
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Threads/XMPPClient.hs75
-rw-r--r--Assistant/Types/NetMessager.hs11
-rw-r--r--Assistant/XMPP.hs52
-rw-r--r--Assistant/XMPP/Buddies.hs6
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