xmpp buddy list tracking
This commit is contained in:
parent
ec7a51727a
commit
2ae43e71e0
8 changed files with 267 additions and 85 deletions
|
@ -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)
|
||||
|
|
|
@ -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,10 +82,12 @@ xmppClient iowaitpush iodebug iopull = do
|
|||
s <- getStanza
|
||||
liftIO $ iodebug ["received XMPP:", show s]
|
||||
case s of
|
||||
ReceivedPresence p@(Presence { presenceType = PresenceAvailable }) ->
|
||||
liftIO $ iopull $ concat $ catMaybes $
|
||||
map decodePushNotification $
|
||||
presencePayloads p
|
||||
ReceivedPresence p -> do
|
||||
liftIO $ ioupdatebuddies p
|
||||
when (isGitAnnexPresence p) $
|
||||
liftIO $ iopull $ concat $ catMaybes $
|
||||
map decodePushNotification $
|
||||
presencePayloads p
|
||||
_ -> noop
|
||||
|
||||
{- We only pull from one remote out of the set listed in the push
|
||||
|
|
57
Assistant/Types/Buddies.hs
Normal file
57
Assistant/Types/Buddies.hs
Normal 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
|
|
@ -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")
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
80
Assistant/XMPP/Buddies.hs
Normal 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
84
Assistant/XMPP/Client.hs
Normal 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"
|
Loading…
Reference in a new issue