xmpp buddy list tracking

This commit is contained in:
Joey Hess 2012-11-02 12:59:31 -04:00
parent ec7a51727a
commit 2ae43e71e0
8 changed files with 267 additions and 85 deletions

View file

@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE PackageImports, GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-}
{-# LANGUAGE PackageImports, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
module Assistant.Monad (
Assistant,
@ -34,6 +34,7 @@ import Assistant.Types.Pushes
import Assistant.Types.BranchChange
import Assistant.Types.Commits
import Assistant.Types.Changes
import Assistant.Types.Buddies
newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
deriving (
@ -59,6 +60,7 @@ data AssistantData = AssistantData
, commitChan :: CommitChan
, changeChan :: ChangeChan
, branchChangeHandle :: BranchChangeHandle
, buddyList :: BuddyList
}
newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
@ -74,6 +76,7 @@ newAssistantData st dstatus = AssistantData
<*> newCommitChan
<*> newChangeChan
<*> newBranchChangeHandle
<*> newBuddyList
runAssistant :: Assistant a -> AssistantData -> IO a
runAssistant a = runReaderT (mkAssistant a)

View file

@ -12,7 +12,10 @@ module Assistant.Threads.PushNotifier where
import Assistant.Common
import Assistant.XMPP
import Assistant.XMPP.Client
import Assistant.Pushes
import Assistant.Types.Buddies
import Assistant.XMPP.Buddies
import Assistant.Sync
import Assistant.DaemonStatus
import qualified Remote
@ -28,15 +31,27 @@ pushNotifierThread :: NamedThread
pushNotifierThread = NamedThread "PushNotifier" $ do
iodebug <- asIO1 debug
iopull <- asIO1 pull
iowaitpush <- asIO $ waitPush
ioclient <- asIO2 $ xmppClient $ iowaitpush
iowaitpush <- asIO waitPush
ioupdatebuddies <- asIO1 $ \p -> do
updateBuddyList (updateBuddies p) <<~ buddyList
debug =<< map show <$> getBuddyList <<~ buddyList
ioclient <- asIO $
xmppClient iowaitpush iodebug iopull ioupdatebuddies
forever $ do
tid <- liftIO $ forkIO $ ioclient iodebug iopull
{- The buddy list starts empty each time the client connects,
- so that stale info is not retained. -}
updateBuddyList (const noBuddies) <<~ buddyList
tid <- liftIO $ forkIO ioclient
waitRestart
liftIO $ killThread tid
xmppClient :: (IO [UUID]) -> ([String] -> IO ()) -> ([UUID] -> IO ()) -> Assistant ()
xmppClient iowaitpush iodebug iopull = do
xmppClient
:: (IO [UUID])
-> ([String] -> IO ())
-> ([UUID] -> IO ())
-> (Presence -> IO ())
-> Assistant ()
xmppClient iowaitpush iodebug iopull ioupdatebuddies = do
v <- liftAnnex getXMPPCreds
case v of
Nothing -> noop
@ -67,7 +82,9 @@ xmppClient iowaitpush iodebug iopull = do
s <- getStanza
liftIO $ iodebug ["received XMPP:", show s]
case s of
ReceivedPresence p@(Presence { presenceType = PresenceAvailable }) ->
ReceivedPresence p -> do
liftIO $ ioupdatebuddies p
when (isGitAnnexPresence p) $
liftIO $ iopull $ concat $ catMaybes $
map decodePushNotification $
presencePayloads p

View file

@ -0,0 +1,57 @@
{- git-annex assistant buddies
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Types.Buddies where
import Common.Annex
import qualified Data.Map as M
import Control.Concurrent.STM
import Utility.NotificationBroadcaster
{- When XMPP is enabled, this is an XMPP buddy map.
- Otherwise, it's an empty map, for simplicity. -}
#ifdef WITH_XMPP
import Assistant.XMPP.Buddies
#else
type Buddies = M.Map String Buddy
data Buddy
deriving (Eq)
#endif
{- A list of buddies, and a way to notify when it changes. -}
type BuddyList = (TMVar Buddies, NotificationBroadcaster)
noBuddies :: Buddies
noBuddies = M.empty
newBuddyList :: IO BuddyList
newBuddyList = (,)
<$> atomically (newTMVar noBuddies)
<*> newNotificationBroadcaster
getBuddyList :: BuddyList -> IO [Buddy]
getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)
{- Applies a function to modify the buddy list, and if it's changed,
- sends notifications to any listeners. -}
updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO ()
updateBuddyList a (v, caster) = do
changed <- atomically $ do
buds <- takeTMVar v
let buds' = a buds
putTMVar v buds'
return $ buds /= buds'
when changed $
sendNotification caster
{- Allocates a notification handle for a client to use to listen for
- changes to the buddy list. -}
newBuddyListNotificationHandle :: BuddyList -> IO NotificationHandle
newBuddyListNotificationHandle (_, caster) = newNotificationHandle caster

View file

@ -16,7 +16,6 @@ import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.WebApp.Utility
import Assistant.WebApp.Configurators.Local
import Assistant.XMPP
import Utility.Yesod
import qualified Remote
import qualified Types.Remote as Remote
@ -24,6 +23,9 @@ import Annex.UUID (getUUID)
import Logs.Remote
import Logs.Trust
import Config
#ifdef WITH_XMPP
import Assistant.XMPP.Client
#endif
import Yesod
import Data.Text (Text)
@ -34,7 +36,11 @@ getConfigR :: Handler RepHtml
getConfigR = ifM (inFirstRun)
( getFirstRepositoryR
, bootstrap (Just Config) $ do
#ifdef WITH_XMPP
xmppconfigured <- lift $ runAnnex False $ isJust <$> getXMPPCreds
#else
let xmppconfigured = False
#endif
sideBarDisplay
setTitle "Configuration"
$(widgetFile "configurators/main")

View file

@ -18,7 +18,7 @@ import Assistant.DaemonStatus
import Utility.Yesod
#ifdef WITH_XMPP
import Assistant.Common
import Assistant.XMPP
import Assistant.XMPP.Client
import Assistant.Pushes
import Utility.SRV
#endif

View file

@ -1,4 +1,4 @@
{- xmpp support
{- core xmpp support
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
@ -7,82 +7,11 @@
module Assistant.XMPP where
import Assistant.Common
import Utility.FileMode
import Utility.SRV
import Common.Annex
import Network.Protocol.XMPP
import Network
import Control.Concurrent
import qualified Data.Text as T
import Data.XML.Types
import Control.Exception (SomeException)
{- 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)
connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ())
connectXMPP c a = case parseJID (xmppJID c) of
Nothing -> error "bad JID"
Just jid -> 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)
{- Async exceptions are let through so the XMPP thread can
- be killed. -}
run h p a' = tryNonAsync $
runClientError (Server serverjid h p) jid
(xmppUsername c) (xmppPassword c) (void a')
{- 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"
{- A presence with a git-annex tag in it. -}
gitAnnexPresence :: Element -> Presence
@ -92,6 +21,12 @@ gitAnnexPresence tag = (emptyPresence PresenceAvailable)
extendedAway = Element (Name (T.pack "show") Nothing Nothing) []
[NodeContent $ ContentText $ T.pack "xa"]
{- Does a presence contain a gitp-annex tag? -}
isGitAnnexPresence :: Presence -> Bool
isGitAnnexPresence p = any matchingtag (presencePayloads p)
where
matchingtag t = elementName t == gitAnnexTagName
{- Name of a git-annex tag, in our own XML namespace.
- (Not using a namespace URL to avoid unnecessary bloat.) -}
gitAnnexTagName :: Name

80
Assistant/XMPP/Buddies.hs Normal file
View file

@ -0,0 +1,80 @@
{- xmpp buddies
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.XMPP.Buddies where
import Assistant.XMPP
import Common.Annex
import Network.Protocol.XMPP
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Ord
newtype Client = Client JID
deriving (Eq, Show)
instance Ord Client where
compare = comparing show
data Buddy = Buddy
{ buddyPresent :: S.Set Client
, buddyAway :: S.Set Client
, buddyAssistants :: S.Set Client
}
deriving (Eq, Show)
{- Note that the buddy map includes one buddy for the user's own JID,
- so that we can track other git-annex assistant's sharing the same
- account. -}
type Buddies = M.Map String Buddy
genKey :: JID -> String
genKey j = show $ JID (jidNode j) (jidDomain j) Nothing
{- Updates the buddies with XMPP presence info. -}
updateBuddies :: Presence -> Buddies -> Buddies
updateBuddies p@(Presence { presenceFrom = Just jid }) = M.alter update key
where
key = genKey jid
update (Just b) = Just $ applyPresence p b
update Nothing = newBuddy p
updateBuddies _ = id
{- Creates a new buddy based on XMPP presence info. -}
newBuddy :: Presence -> Maybe Buddy
newBuddy p
| presenceType p == PresenceAvailable = go
| presenceType p == PresenceUnavailable = go
| otherwise = Nothing
where
go = make <$> presenceFrom p
make _jid = applyPresence p $ Buddy
{ buddyPresent = S.empty
, buddyAway = S.empty
, buddyAssistants = S.empty
}
applyPresence :: Presence -> Buddy -> Buddy
applyPresence p b = fromMaybe b $! go <$> presenceFrom p
where
go jid
| isGitAnnexPresence p = b
{ buddyAssistants = addto $ buddyAssistants b }
| presenceType p == PresenceAvailable = b
{ buddyPresent = addto $ buddyPresent b
, buddyAway = removefrom $ buddyAway b
}
| presenceType p == PresenceUnavailable = b
{ buddyAway = addto $ buddyAway b
, buddyPresent = removefrom $ buddyPresent b
}
| otherwise = b
where
client = Client jid
removefrom = S.filter (/= client)
addto = S.insert client

84
Assistant/XMPP/Client.hs Normal file
View file

@ -0,0 +1,84 @@
{- xmpp client support
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.XMPP.Client 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 Control.Exception (SomeException)
{- 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)
connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ())
connectXMPP c a = case parseJID (xmppJID c) of
Nothing -> error "bad JID"
Just jid -> 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)
{- Async exceptions are let through so the XMPP thread can
- be killed. -}
run h p a' = tryNonAsync $
runClientError (Server serverjid h p) jid
(xmppUsername c) (xmppPassword c) (void a')
{- 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"