diff options
Diffstat (limited to 'Assistant/XMPP.hs')
| -rw-r--r-- | Assistant/XMPP.hs | 81 |
1 files changed, 8 insertions, 73 deletions
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index a2197cd26..43bf4ac75 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -1,4 +1,4 @@ -{- xmpp support +{- core xmpp support - - Copyright 2012 Joey Hess <joey@kitenet.net> - @@ -7,82 +7,11 @@ module Assistant.XMPP where -import Assistant.Common -import Utility.FileMode -import Utility.SRV +import Common.Annex import Network.Protocol.XMPP -import Network -import Control.Concurrent import qualified Data.Text as T import Data.XML.Types -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" {- A presence with a git-annex tag in it. -} gitAnnexPresence :: Element -> Presence @@ -92,6 +21,12 @@ gitAnnexPresence tag = (emptyPresence PresenceAvailable) extendedAway = Element (Name (T.pack "show") Nothing Nothing) [] [NodeContent $ ContentText $ T.pack "xa"] +{- Does a presence contain a gitp-annex tag? -} +isGitAnnexPresence :: Presence -> Bool +isGitAnnexPresence p = any matchingtag (presencePayloads p) + where + matchingtag t = elementName t == gitAnnexTagName + {- Name of a git-annex tag, in our own XML namespace. - (Not using a namespace URL to avoid unnecessary bloat.) -} gitAnnexTagName :: Name |