diff options
| -rw-r--r-- | Assistant/Monad.hs | 5 | ||||
| -rw-r--r-- | Assistant/Threads/PushNotifier.hs | 35 | ||||
| -rw-r--r-- | Assistant/Types/Buddies.hs | 57 | ||||
| -rw-r--r-- | Assistant/XMPP.hs | 81 | ||||
| -rw-r--r-- | Assistant/XMPP/Buddies.hs | 80 | ||||
| -rw-r--r-- | Assistant/XMPP/Client.hs | 84 |
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" |