diff options
Diffstat (limited to 'Assistant/XMPP/Client.hs')
-rw-r--r-- | Assistant/XMPP/Client.hs | 83 |
1 files changed, 0 insertions, 83 deletions
diff --git a/Assistant/XMPP/Client.hs b/Assistant/XMPP/Client.hs deleted file mode 100644 index 6d09d32e6..000000000 --- a/Assistant/XMPP/Client.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- xmpp client support - - - - Copyright 2012 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.XMPP.Client where - -import Assistant.Common -import Utility.SRV -import Creds - -import Network.Protocol.XMPP -import Network -import Control.Concurrent -import qualified Data.Text as T - -{- 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 [(HostPort, 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 [(HostPort, Either SomeException ())] -connectXMPP' jid c a = reverse <$> (handlesrv =<< lookupSRV srvrecord) - where - srvrecord = mkSRVTcp "xmpp-client" $ - T.unpack $ strDomain $ jidDomain jid - serverjid = JID Nothing (jidDomain jid) Nothing - - handlesrv [] = do - let h = xmppHostname c - let p = PortNumber $ fromIntegral $ xmppPort c - r <- run h p $ a jid - return [r] - handlesrv srvs = go [] srvs - - go l [] = return l - go l ((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 (r : l) rest - , return (r : l) - ) - - {- Async exceptions are let through so the XMPP thread can - - be killed. -} - run h p a' = do - r <- tryNonAsync $ - runClientError (Server serverjid h p) jid - (xmppUsername c) (xmppPassword c) (void a') - return ((h, p), r) - -{- 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 = parse <$> readCacheCreds xmppCredsFile - where - parse s = readish =<< s - -setXMPPCreds :: XMPPCreds -> Annex () -setXMPPCreds creds = writeCacheCreds (show creds) xmppCredsFile - -xmppCredsFile :: FilePath -xmppCredsFile = "xmpp" |