xmpp buddy list tracking

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)

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
+	iowaitpush <- asIO waitPush
-	ioclient <- asIO2 $ xmppClient $ iowaitpush
+	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
-xmppClient iowaitpush iodebug iopull = do
+	:: (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

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

Assistant/WebApp/Configurators.hs

@@ -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")

Assistant/WebApp/Configurators/XMPP.hs

@@ -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

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 Common.Annex
-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 (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

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

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"