diff options
author | Joey Hess <joey@kitenet.net> | 2012-10-26 14:44:36 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-10-26 14:44:36 -0400 |
commit | d2b9c300b12a025de66f39efafd7962dc591a330 (patch) | |
tree | a238516bbf7a97c4ba4759a669b23401f9c0ff64 /Assistant/XMPP.hs | |
parent | 0666f5108543a5f4433615ca8413c582dc6f94f7 (diff) |
split out xmpp utilities
Diffstat (limited to 'Assistant/XMPP.hs')
-rw-r--r-- | Assistant/XMPP.hs | 118 |
1 files changed, 118 insertions, 0 deletions
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 |