From 1d04dff4f0e2f220a8c1b3062dc4519d15007a30 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 26 Oct 2012 14:44:36 -0400 Subject: [PATCH] split out xmpp utilities --- Assistant/Threads/PushNotifier.hs | 108 +--------------------- Assistant/WebApp/Configurators/XMPP.hs | 3 +- Assistant/XMPP.hs | 118 +++++++++++++++++++++++++ 3 files changed, 120 insertions(+), 109 deletions(-) create mode 100644 Assistant/XMPP.hs diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index 983f0089d4..8c71138d75 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -11,22 +11,17 @@ module Assistant.Threads.PushNotifier where import Assistant.Common +import Assistant.XMPP import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.Pushes import Assistant.Sync import qualified Remote -import Utility.FileMode -import Utility.SRV import Network.Protocol.XMPP -import Network import Control.Concurrent -import qualified Data.Text as T import qualified Data.Set as S import qualified Git.Branch -import Data.XML.Types -import Control.Exception as E thisThread :: ThreadName thisThread = "PushNotifier" @@ -62,107 +57,6 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do presencePayloads p _ -> noop -{- 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) - -{- Note that this must be run in a bound thread; gnuTLS requires it. -} -connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ()) -connectXMPP c a = case parseJID (xmppJID c) of - Nothing -> error "bad JID" - Just jid -> runInBoundThread $ 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) - - run h p a' = do - liftIO $ debug thisThread ["XMPP trying", h] - E.try (runClientError (Server serverjid h p) jid (xmppUsername c) (xmppPassword c) (void a')) :: IO (Either SomeException ()) - -{- 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" - -{- Marks the client as extended away. -} -extendedAway :: Element -extendedAway = Element (Name (T.pack "show") Nothing Nothing) [] - [NodeContent $ ContentText $ T.pack "xa"] - -{- Name of a git-annex tag, in our own XML namespace. - - (Not using a namespace URL to avoid unnecessary bloat.) -} -gitAnnexTagName :: Name -gitAnnexTagName = Name (T.pack "git-annex") (Just $ T.pack "git-annex") Nothing - -pushAttr :: Name -pushAttr = Name (T.pack "push") Nothing Nothing - -uuidSep :: T.Text -uuidSep = T.pack "," - -{- git-annex tag with one push attribute per UUID pushed to. -} -encodePushNotification :: [UUID] -> Element -encodePushNotification us = Element gitAnnexTagName - [(pushAttr, [ContentText pushvalue])] [] - where - pushvalue = T.intercalate uuidSep $ - map (T.pack . fromUUID) us - -decodePushNotification :: Element -> Maybe [UUID] -decodePushNotification (Element name attrs _nodes) - | name == gitAnnexTagName && not (null us) = Just us - | otherwise = Nothing - where - us = map (toUUID . T.unpack) $ - concatMap (T.splitOn uuidSep . T.concat . map fromContent . snd) $ - filter ispush attrs - ispush (k, _) = k == pushAttr - fromContent (ContentText t) = t - fromContent (ContentEntity t) = t - {- We only pull from one remote out of the set listed in the push - notification, as an optimisation. - diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index bcc712dc14..160e42cf5e 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -16,7 +16,7 @@ import Assistant.WebApp.SideBar import Utility.Yesod #ifdef WITH_XMPP import Assistant.Common -import Assistant.Threads.PushNotifier +import Assistant.XMPP import Utility.SRV #endif @@ -26,7 +26,6 @@ import Network import Network.Protocol.XMPP import Data.Text (Text) import qualified Data.Text as T -import Control.Concurrent #endif getXMPPR :: Handler RepHtml diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs new file mode 100644 index 0000000000..d71bd7eafe --- /dev/null +++ b/Assistant/XMPP.hs @@ -0,0 +1,118 @@ +{- xmpp support + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.XMPP 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 Data.XML.Types +import Control.Exception as E + +{- 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) + +{- Note that this must be run in a bound thread; gnuTLS requires it. -} +connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ()) +connectXMPP c a = case parseJID (xmppJID c) of + Nothing -> error "bad JID" + Just jid -> runInBoundThread $ 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) + + run h p a' = E.try (runClientError (Server serverjid h p) jid (xmppUsername c) (xmppPassword c) (void a')) :: IO (Either SomeException ()) + +{- 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" + +{- Marks the client as extended away. -} +extendedAway :: Element +extendedAway = Element (Name (T.pack "show") Nothing Nothing) [] + [NodeContent $ ContentText $ T.pack "xa"] + +{- Name of a git-annex tag, in our own XML namespace. + - (Not using a namespace URL to avoid unnecessary bloat.) -} +gitAnnexTagName :: Name +gitAnnexTagName = Name (T.pack "git-annex") (Just $ T.pack "git-annex") Nothing + +pushAttr :: Name +pushAttr = Name (T.pack "push") Nothing Nothing + +uuidSep :: T.Text +uuidSep = T.pack "," + +{- git-annex tag with one push attribute per UUID pushed to. -} +encodePushNotification :: [UUID] -> Element +encodePushNotification us = Element gitAnnexTagName + [(pushAttr, [ContentText pushvalue])] [] + where + pushvalue = T.intercalate uuidSep $ + map (T.pack . fromUUID) us + +decodePushNotification :: Element -> Maybe [UUID] +decodePushNotification (Element name attrs _nodes) + | name == gitAnnexTagName && not (null us) = Just us + | otherwise = Nothing + where + us = map (toUUID . T.unpack) $ + concatMap (T.splitOn uuidSep . T.concat . map fromContent . snd) $ + filter ispush attrs + ispush (k, _) = k == pushAttr + fromContent (ContentText t) = t + fromContent (ContentEntity t) = t