summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-10-26 14:44:36 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-10-26 14:44:36 -0400
commitd2b9c300b12a025de66f39efafd7962dc591a330 (patch)
treea238516bbf7a97c4ba4759a669b23401f9c0ff64
parent0666f5108543a5f4433615ca8413c582dc6f94f7 (diff)
split out xmpp utilities
-rw-r--r--Assistant/Threads/PushNotifier.hs108
-rw-r--r--Assistant/XMPP.hs118
2 files changed, 119 insertions, 107 deletions
diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs
index 983f0089d..8c71138d7 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/XMPP.hs b/Assistant/XMPP.hs
new file mode 100644
index 000000000..d71bd7eaf
--- /dev/null
+++ b/Assistant/XMPP.hs
@@ -0,0 +1,118 @@
+{- xmpp support
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - 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