summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Monad.hs5
-rw-r--r--Assistant/Threads/PushNotifier.hs35
-rw-r--r--Assistant/Types/Buddies.hs57
-rw-r--r--Assistant/XMPP.hs81
-rw-r--r--Assistant/XMPP/Buddies.hs80
-rw-r--r--Assistant/XMPP/Client.hs84
6 files changed, 259 insertions, 83 deletions
diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs
index fb4cb3340..64718a7a1 100644
--- a/Assistant/Monad.hs
+++ b/Assistant/Monad.hs
@@ -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)
diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs
index d2d5e08bf..8830d9459 100644
--- a/Assistant/Threads/PushNotifier.hs
+++ b/Assistant/Threads/PushNotifier.hs
@@ -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
diff --git a/Assistant/Types/Buddies.hs b/Assistant/Types/Buddies.hs
new file mode 100644
index 000000000..06ac5526d
--- /dev/null
+++ b/Assistant/Types/Buddies.hs
@@ -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
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index a2197cd26..43bf4ac75 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -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
diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs
new file mode 100644
index 000000000..de2b570c6
--- /dev/null
+++ b/Assistant/XMPP/Buddies.hs
@@ -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
diff --git a/Assistant/XMPP/Client.hs b/Assistant/XMPP/Client.hs
new file mode 100644
index 000000000..79ac26500
--- /dev/null
+++ b/Assistant/XMPP/Client.hs
@@ -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"