diff options
author | Joey Hess <joey@kitenet.net> | 2012-11-02 12:59:31 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-11-02 14:28:36 -0400 |
commit | c3bd80207051ca96d9d172e29ba600dec25df113 (patch) | |
tree | 7e7d0b485e23168d0b6625628fab08b5d5dc3213 /Assistant/XMPP | |
parent | f22a85ee6fa271ee799c10497ccd4ced3134f1ad (diff) |
xmpp buddy list tracking
Diffstat (limited to 'Assistant/XMPP')
-rw-r--r-- | Assistant/XMPP/Buddies.hs | 80 | ||||
-rw-r--r-- | Assistant/XMPP/Client.hs | 84 |
2 files changed, 164 insertions, 0 deletions
diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs new file mode 100644 index 000000000..de2b570c6 --- /dev/null +++ b/Assistant/XMPP/Buddies.hs @@ -0,0 +1,80 @@ +{- xmpp buddies + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.XMPP.Buddies where + +import Assistant.XMPP +import Common.Annex + +import Network.Protocol.XMPP +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Ord + +newtype Client = Client JID + deriving (Eq, Show) + +instance Ord Client where + compare = comparing show + +data Buddy = Buddy + { buddyPresent :: S.Set Client + , buddyAway :: S.Set Client + , buddyAssistants :: S.Set Client + } + deriving (Eq, Show) + +{- Note that the buddy map includes one buddy for the user's own JID, + - so that we can track other git-annex assistant's sharing the same + - account. -} +type Buddies = M.Map String Buddy + +genKey :: JID -> String +genKey j = show $ JID (jidNode j) (jidDomain j) Nothing + +{- Updates the buddies with XMPP presence info. -} +updateBuddies :: Presence -> Buddies -> Buddies +updateBuddies p@(Presence { presenceFrom = Just jid }) = M.alter update key + where + key = genKey jid + update (Just b) = Just $ applyPresence p b + update Nothing = newBuddy p +updateBuddies _ = id + +{- Creates a new buddy based on XMPP presence info. -} +newBuddy :: Presence -> Maybe Buddy +newBuddy p + | presenceType p == PresenceAvailable = go + | presenceType p == PresenceUnavailable = go + | otherwise = Nothing + where + go = make <$> presenceFrom p + make _jid = applyPresence p $ Buddy + { buddyPresent = S.empty + , buddyAway = S.empty + , buddyAssistants = S.empty + } + +applyPresence :: Presence -> Buddy -> Buddy +applyPresence p b = fromMaybe b $! go <$> presenceFrom p + where + go jid + | isGitAnnexPresence p = b + { buddyAssistants = addto $ buddyAssistants b } + | presenceType p == PresenceAvailable = b + { buddyPresent = addto $ buddyPresent b + , buddyAway = removefrom $ buddyAway b + } + | presenceType p == PresenceUnavailable = b + { buddyAway = addto $ buddyAway b + , buddyPresent = removefrom $ buddyPresent b + } + | otherwise = b + where + client = Client jid + removefrom = S.filter (/= client) + addto = S.insert client diff --git a/Assistant/XMPP/Client.hs b/Assistant/XMPP/Client.hs new file mode 100644 index 000000000..79ac26500 --- /dev/null +++ b/Assistant/XMPP/Client.hs @@ -0,0 +1,84 @@ +{- xmpp client support + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.XMPP.Client where + +import Assistant.Common +import Utility.FileMode +import Utility.SRV + +import Network.Protocol.XMPP +import Network +import Control.Concurrent +import qualified Data.Text as T +import Control.Exception (SomeException) + +{- Everything we need to know to connect to an XMPP server. -} +data XMPPCreds = XMPPCreds + { xmppUsername :: T.Text + , xmppPassword :: T.Text + , xmppHostname :: HostName + , xmppPort :: Int + , xmppJID :: T.Text + } + deriving (Read, Show) + +connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ()) +connectXMPP c a = case parseJID (xmppJID c) of + Nothing -> error "bad JID" + Just jid -> connectXMPP' jid c a + +{- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -} +connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ()) +connectXMPP' jid c a = go =<< lookupSRV srvrecord + where + srvrecord = mkSRVTcp "xmpp-client" $ + T.unpack $ strDomain $ jidDomain jid + serverjid = JID Nothing (jidDomain jid) Nothing + + go [] = run (xmppHostname c) + (PortNumber $ fromIntegral $ xmppPort c) + (a jid) + go ((h,p):rest) = do + {- Try each SRV record in turn, until one connects, + - at which point the MVar will be full. -} + mv <- newEmptyMVar + r <- run h p $ do + liftIO $ putMVar mv () + a jid + ifM (isEmptyMVar mv) (go rest, return r) + + {- Async exceptions are let through so the XMPP thread can + - be killed. -} + run h p a' = tryNonAsync $ + runClientError (Server serverjid h p) jid + (xmppUsername c) (xmppPassword c) (void a') + +{- XMPP runClient, that throws errors rather than returning an Either -} +runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a +runClientError s j u p x = either (error . show) return =<< runClient s j u p x + +getXMPPCreds :: Annex (Maybe XMPPCreds) +getXMPPCreds = do + f <- xmppCredsFile + s <- liftIO $ catchMaybeIO $ readFile f + return $ readish =<< s + +setXMPPCreds :: XMPPCreds -> Annex () +setXMPPCreds creds = do + f <- xmppCredsFile + liftIO $ do + h <- openFile f WriteMode + modifyFileMode f $ removeModes + [groupReadMode, otherReadMode] + hPutStr h (show creds) + hClose h + +xmppCredsFile :: Annex FilePath +xmppCredsFile = do + dir <- fromRepo gitAnnexCredsDir + return $ dir </> "notify-xmpp" |