xmpp buddy list tracking

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"