split out xmpp utilities
This commit is contained in:
Joey Hess
parent
82b7e835e4
commit
1d04dff4f0
3 changed files with 120 additions and 109 deletions
|
|
@ -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.
|
||||
-
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
118
Assistant/XMPP.hs
Normal file
118
Assistant/XMPP.hs
Normal file
|
|
@ -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
|
||||
Loading…
Reference in a new issue