split out xmpp utilities

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.
  -

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

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