summaryrefslogtreecommitdiff
path: root/Assistant/XMPP.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant/XMPP.hs')
-rw-r--r--Assistant/XMPP.hs81
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