diff options
Diffstat (limited to 'Assistant/Threads/PushNotifier.hs')
| -rw-r--r-- | Assistant/Threads/PushNotifier.hs | 124 |
1 files changed, 0 insertions, 124 deletions
diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs deleted file mode 100644 index bdb9e1e12..000000000 --- a/Assistant/Threads/PushNotifier.hs +++ /dev/null @@ -1,124 +0,0 @@ -{- git-annex assistant push notification thread, using XMPP - - - - This handles both sending outgoing push notifications, and receiving - - incoming push notifications. - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -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 -import Utility.ThreadScheduler - -import Network.Protocol.XMPP -import Control.Concurrent -import qualified Data.Set as S -import qualified Git.Branch -import Data.Time.Clock - -pushNotifierThread :: NamedThread -pushNotifierThread = NamedThread "PushNotifier" $ do - iodebug <- asIO1 debug - iopull <- asIO1 pull - iowaitpush <- asIO waitPush - ioupdatebuddies <- asIO1 $ \p -> do - updateBuddyList (updateBuddies p) <<~ buddyList - debug =<< map show <$> getBuddyList <<~ buddyList - ioemptybuddies <- asIO $ - updateBuddyList (const noBuddies) <<~ buddyList - ioclient <- asIO $ - xmppClient iowaitpush iodebug iopull ioupdatebuddies ioemptybuddies - forever $ do - tid <- liftIO $ forkIO ioclient - waitRestart - liftIO $ killThread tid - -xmppClient - :: (IO [UUID]) - -> ([String] -> IO ()) - -> ([UUID] -> IO ()) - -> (Presence -> IO ()) - -> IO () - -> Assistant () -xmppClient iowaitpush iodebug iopull ioupdatebuddies ioemptybuddies = do - v <- liftAnnex getXMPPCreds - case v of - Nothing -> noop - Just c -> liftIO $ loop c =<< getCurrentTime - where - loop c starttime = do - void $ connectXMPP c $ \jid -> do - fulljid <- bindJID jid - liftIO $ iodebug ["XMPP connected", show fulljid] - {- The buddy list starts empty each time the client - - connects, so that stale info is not retained. -} - liftIO ioemptybuddies - putStanza $ gitAnnexPresence gitAnnexSignature - s <- getSession - _ <- liftIO $ forkIO $ void $ runXMPP s $ - receivenotifications fulljid - sendnotifications - now <- getCurrentTime - if diffUTCTime now starttime > 300 - then do - iodebug ["XMPP connection lost; reconnecting"] - loop c now - else do - iodebug ["XMPP connection failed; will retry"] - threadDelaySeconds (Seconds 300) - loop c =<< getCurrentTime - sendnotifications = forever $ do - us <- liftIO iowaitpush - putStanza $ gitAnnexPresence $ encodePushNotification us - receivenotifications fulljid = forever $ do - s <- getStanza - liftIO $ iodebug ["received XMPP:", show s] - case s of - ReceivedPresence p@(Presence { presenceFrom = from }) - | from == Just fulljid -> noop - | otherwise -> 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 - - notification, as an optimisation. - - - - Note that it might be possible (though very unlikely) for the push - - notification to take a while to be sent, and multiple pushes happen - - before it is sent, so it includes multiple remotes that were pushed - - to at different times. - - - - It could then be the case that the remote we choose had the earlier - - push sent to it, but then failed to get the later push, and so is not - - fully up-to-date. If that happens, the pushRetryThread will come along - - and retry the push, and we'll get another notification once it succeeds, - - and pull again. -} -pull :: [UUID] -> Assistant () -pull [] = noop -pull us = do - rs <- filter matching . syncRemotes <$> getDaemonStatus - debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs - pullone rs =<< liftAnnex (inRepo Git.Branch.current) - where - matching r = Remote.uuid r `S.member` s - s = S.fromList us - - pullone [] _ = noop - pullone (r:rs) branch = - unlessM (all id . fst <$> manualPull branch [r]) $ - pullone rs branch |