From 2c788a28a1dc67884a799561dbf8e40a682e261d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 23 Oct 2012 20:24:23 -0400 Subject: [PATCH 01/31] added network-protocol-xmpp and -DWITH_XMPP --- Makefile | 2 +- debian/control | 1 + debian/rules | 4 ++-- doc/install/fromscratch.mdwn | 1 + git-annex.cabal | 7 +++++++ 5 files changed, 12 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index 796e6af8b6..1da32ebc7a 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ BASEFLAGS=-Wall $(IGNORE) -outputdir $(GIT_ANNEX_TMP_BUILD_DIR) -IUtility # you can turn off some of these features. # # If you're using an old version of yesod, enable -DWITH_OLD_YESOD -FEATURES?=$(GIT_ANNEX_LOCAL_FEATURES) -DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBAPP -DWITH_PAIRING +FEATURES?=$(GIT_ANNEX_LOCAL_FEATURES) -DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBAPP -DWITH_PAIRING -DWITH_XMPP bins=git-annex mans=git-annex.1 git-annex-shell.1 diff --git a/debian/control b/debian/control index 24464f980f..a233f239e7 100644 --- a/debian/control +++ b/debian/control @@ -40,6 +40,7 @@ Build-Depends: libghc-network-multicast-dev, libghc-network-info-dev, libghc-safesemaphore-dev, + libghc-network-protocol-xmpp-dev, ikiwiki, perlmagick, git, diff --git a/debian/rules b/debian/rules index c0fbd9aa49..4a5532027c 100755 --- a/debian/rules +++ b/debian/rules @@ -2,9 +2,9 @@ ARCH = $(shell dpkg-architecture -qDEB_BUILD_ARCH) ifeq (install ok installed,$(shell dpkg-query -W -f '$${Status}' libghc-yesod-dev 2>/dev/null)) -export FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_OLD_YESOD -DWITH_WEBAPP -DWITH_PAIRING +export FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_OLD_YESOD -DWITH_WEBAPP -DWITH_PAIRING -DWITH_XMPP else -export FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_PAIRING +export FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_PAIRING -DWITH_XMPP endif %: diff --git a/doc/install/fromscratch.mdwn b/doc/install/fromscratch.mdwn index 4410a59b9f..f79ae7dc73 100644 --- a/doc/install/fromscratch.mdwn +++ b/doc/install/fromscratch.mdwn @@ -42,6 +42,7 @@ quite a lot. * [clientsession](http://hackage.haskell.org/package/clientsession) * [network-multicast](http://hackage.haskell.org/package/network-multicast) * [network-info](http://hackage.haskell.org/package/network-info) + * [network-protocol-xmpp](http://hackage.haskell.org/package/network-protocol-xmpp) * Shell commands * [git](http://git-scm.com/) * [uuid](http://www.ossp.org/pkg/lib/uuid/) diff --git a/git-annex.cabal b/git-annex.cabal index a2a89479bf..0bbec1b08a 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -43,6 +43,9 @@ Flag Webapp Flag Pairing Description: Enable pairing +Flag XMPP + Description: Enable notifications using XMPP + Executable git-annex Main-Is: git-annex.hs Build-Depends: MissingH, hslogger, directory, filepath, @@ -91,6 +94,10 @@ Executable git-annex Build-Depends: network-multicast, network-info CPP-Options: -DWITH_PAIRING + if flag(XMPP) && flag(Assistant) + Build-Depends: network-protocol-xmpp + CPP-Options: -DWITH_XMPP + Test-Suite test Type: exitcode-stdio-1.0 Main-Is: test.hs From 6b6ce30b42d44e5459d4a966539d8d3fe6c8249b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 24 Oct 2012 13:15:31 -0400 Subject: [PATCH 02/31] use a newtype for better type safety --- Assistant/BranchChange.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/Assistant/BranchChange.hs b/Assistant/BranchChange.hs index b166c87778..d1d1c20dfe 100644 --- a/Assistant/BranchChange.hs +++ b/Assistant/BranchChange.hs @@ -8,14 +8,15 @@ module Assistant.BranchChange where import Control.Concurrent.MSampleVar +import Assistant.Common -type BranchChangeHandle = MSampleVar () +newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ()) newBranchChangeHandle :: IO BranchChangeHandle -newBranchChangeHandle = newEmptySV +newBranchChangeHandle = BranchChangeHandle <$> newEmptySV branchChanged :: BranchChangeHandle -> IO () -branchChanged = flip writeSV () +branchChanged (BranchChangeHandle h) = writeSV h () waitBranchChange :: BranchChangeHandle -> IO () -waitBranchChange = readSV +waitBranchChange (BranchChangeHandle h) = readSV h From ae8a3ab31e2469820b2ee9dd9d813da3b136c77a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 24 Oct 2012 13:35:43 -0400 Subject: [PATCH 03/31] added push notifier thread, currently a no-op Hooked up everything that needs to notify on pushes. Note that syncNewRemote does not notify. This is probably ok, and I'd need to thread more state through to make it do so. This is only set up to support a single push notification method; I didn't use a NotificationBroadcaster. Partly because I don't yet know what info about pushes needs to be communicated, so my data types are only preliminary. --- Assistant.hs | 22 +++++++++++++------ Assistant/Pushes.hs | 13 ++++++++++++ Assistant/Sync.hs | 20 +++++++++++------- Assistant/Threads/MountWatcher.hs | 35 ++++++++++++++++--------------- Assistant/Threads/NetWatcher.hs | 27 ++++++++++++------------ Assistant/Threads/PushNotifier.hs | 21 +++++++++++++++++++ Assistant/Threads/Pusher.hs | 12 +++++------ 7 files changed, 100 insertions(+), 50 deletions(-) create mode 100644 Assistant/Threads/PushNotifier.hs diff --git a/Assistant.hs b/Assistant.hs index cb94ca462e..b935d45dc8 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -69,7 +69,9 @@ - Thread 18: ConfigMonitor - Triggered by changes to the git-annex branch, checks for changed - config files, and reloads configs. - - Thread 19: WebApp + - Thread 19: PushNotifier + - Notifies other repositories of pushes, using out of band signaling. + - Thread 20: WebApp - Spawns more threads as necessary to handle clients. - Displays the DaemonStatus. - @@ -100,6 +102,11 @@ - ScanRemotes (STM TMVar) - Remotes that have been disconnected, and should be scanned - are indicated by writing to this TMVar. + - BranchChanged (STM SampleVar) + - Changes to the git-annex branch are indicated by updating this + - SampleVar. + - PushNotifier (STM SampleVar) + - After successful pushes, this SampleVar is updated. - UrlRenderer (MVar) - A Yesod route rendering function is stored here. This allows - things that need to render Yesod routes to block until the webapp @@ -133,6 +140,7 @@ import Assistant.Threads.NetWatcher import Assistant.Threads.TransferScanner import Assistant.Threads.TransferPoller import Assistant.Threads.ConfigMonitor +import Assistant.Threads.PushNotifier #ifdef WITH_WEBAPP import Assistant.WebApp import Assistant.Threads.WebApp @@ -180,6 +188,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do transferslots <- newTransferSlots scanremotes <- newScanRemoteMap branchhandle <- newBranchChangeHandle + pushnotifier <- newPushNotifier #ifdef WITH_WEBAPP urlrenderer <- newUrlRenderer #endif @@ -191,19 +200,20 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do , assist $ pairListenerThread st dstatus scanremotes urlrenderer #endif #endif - , assist $ pushThread st dstatus commitchan pushmap - , assist $ pushRetryThread st dstatus pushmap + , assist $ pushThread st dstatus commitchan pushmap pushnotifier + , assist $ pushRetryThread st dstatus pushmap pushnotifier , assist $ mergeThread st dstatus transferqueue branchhandle , assist $ transferWatcherThread st dstatus transferqueue , assist $ transferPollerThread st dstatus , assist $ transfererThread st dstatus transferqueue transferslots , assist $ daemonStatusThread st dstatus , assist $ sanityCheckerThread st dstatus transferqueue changechan - , assist $ mountWatcherThread st dstatus scanremotes - , assist $ netWatcherThread st dstatus scanremotes - , assist $ netWatcherFallbackThread st dstatus scanremotes + , assist $ mountWatcherThread st dstatus scanremotes pushnotifier + , assist $ netWatcherThread st dstatus scanremotes pushnotifier + , assist $ netWatcherFallbackThread st dstatus scanremotes pushnotifier , assist $ transferScannerThread st dstatus scanremotes transferqueue , assist $ configMonitorThread st dstatus branchhandle commitchan + , assist $ pushNotifierThread pushnotifier , watch $ watchThread st dstatus transferqueue changechan ] waitForTermination diff --git a/Assistant/Pushes.hs b/Assistant/Pushes.hs index f411dda07d..649975fd1f 100644 --- a/Assistant/Pushes.hs +++ b/Assistant/Pushes.hs @@ -10,6 +10,7 @@ module Assistant.Pushes where import Common.Annex import Control.Concurrent.STM +import Control.Concurrent.MSampleVar import Data.Time.Clock import qualified Data.Map as M @@ -17,6 +18,9 @@ import qualified Data.Map as M type PushMap = M.Map Remote UTCTime type FailedPushMap = TMVar PushMap +{- Used to notify about successful pushes. -} +newtype PushNotifier = PushNotifier (MSampleVar ()) + {- The TMVar starts empty, and is left empty when there are no - failed pushes. This way we can block until there are some failed pushes. -} @@ -44,3 +48,12 @@ changeFailedPushMap v a = atomically $ store m | m == M.empty = noop | otherwise = putTMVar v $! m + +newPushNotifier :: IO PushNotifier +newPushNotifier = PushNotifier <$> newEmptySV + +notifyPush :: PushNotifier -> IO () +notifyPush (PushNotifier sv) = writeSV sv () + +waitPush :: PushNotifier -> IO () +waitPush (PushNotifier sv) = readSV sv diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 6c167e2eaa..e333877f20 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -36,9 +36,9 @@ import Control.Concurrent - the remotes have diverged from the local git-annex branch. Otherwise, - it's sufficient to requeue failed transfers. -} -reconnectRemotes :: ThreadName -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> [Remote] -> IO () -reconnectRemotes _ _ _ _ [] = noop -reconnectRemotes threadname st dstatus scanremotes rs = void $ +reconnectRemotes :: ThreadName -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Maybe PushNotifier -> [Remote] -> IO () +reconnectRemotes _ _ _ _ _ [] = noop +reconnectRemotes threadname st dstatus scanremotes pushnotifier rs = void $ alertWhile dstatus (syncAlert rs) $ do (ok, diverged) <- sync =<< runThreadState st (inRepo Git.Branch.current) @@ -50,7 +50,7 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $ sync (Just branch) = do diverged <- manualPull st (Just branch) gitremotes now <- getCurrentTime - ok <- pushToRemotes threadname now st Nothing gitremotes + ok <- pushToRemotes threadname now st pushnotifier Nothing gitremotes return (ok, diverged) {- No local branch exists yet, but we can try pulling. -} sync Nothing = do @@ -81,8 +81,8 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $ - them. While ugly, those branches are reserved for pushing by us, and - so our pushes will succeed. -} -pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> Maybe FailedPushMap -> [Remote] -> IO Bool -pushToRemotes threadname now st mpushmap remotes = do +pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> Maybe PushNotifier -> Maybe FailedPushMap -> [Remote] -> IO Bool +pushToRemotes threadname now st mpushnotifier mpushmap remotes = do (g, branch, u) <- runThreadState st $ (,,) <$> gitRepo <*> inRepo Git.Branch.current @@ -100,7 +100,9 @@ pushToRemotes threadname now st mpushmap remotes = do updatemap succeeded [] let ok = null failed if ok - then return ok + then do + maybe noop notifyPush mpushnotifier + return ok else if shouldretry then retry branch g u failed else fallback branch g u failed @@ -124,6 +126,8 @@ pushToRemotes threadname now st mpushmap remotes = do ] (succeeded, failed) <- inParallel (pushfallback g u branch) rs updatemap succeeded failed + unless (null succeeded) $ + maybe noop notifyPush mpushnotifier return $ null failed push g branch remote = Command.Sync.pushBranch remote branch g @@ -157,4 +161,4 @@ manualPull st currentbranch remotes = do syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO () syncNewRemote st dstatus scanremotes remote = do runThreadState st $ updateSyncRemotes dstatus - void $ forkIO $ reconnectRemotes "SyncRemote" st dstatus scanremotes [remote] + void $ forkIO $ reconnectRemotes "SyncRemote" st dstatus scanremotes Nothing [remote] diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 462f5843c2..c36b544a78 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -15,6 +15,7 @@ import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.ScanRemotes import Assistant.Sync +import Assistant.Pushes import qualified Annex import qualified Git import Utility.ThreadScheduler @@ -38,20 +39,20 @@ import qualified Control.Exception as E thisThread :: ThreadName thisThread = "MountWatcher" -mountWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread -mountWatcherThread st handle scanremotes = thread $ +mountWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> NamedThread +mountWatcherThread st handle scanremotes pushnotifier = thread $ #if WITH_DBUS - dbusThread st handle scanremotes + dbusThread st handle scanremotes pushnotifier #else - pollingThread st handle scanremotes + pollingThread st handle scanremotes pushnotifier #endif where thread = NamedThread thisThread #if WITH_DBUS -dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO () -dbusThread st dstatus scanremotes = E.catch (go =<< connectSession) onerr +dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO () +dbusThread st dstatus scanremotes pushnotifier = E.catch (go =<< connectSession) onerr where go client = ifM (checkMountMonitor client) ( do @@ -64,7 +65,7 @@ dbusThread st dstatus scanremotes = E.catch (go =<< connectSession) onerr listen client matcher $ \_event -> do nowmounted <- currentMountPoints wasmounted <- swapMVar mvar nowmounted - handleMounts st dstatus scanremotes wasmounted nowmounted + handleMounts st dstatus scanremotes pushnotifier wasmounted nowmounted , do runThreadState st $ warning "No known volume monitor available through dbus; falling back to mtab polling" @@ -75,7 +76,7 @@ dbusThread st dstatus scanremotes = E.catch (go =<< connectSession) onerr runThreadState st $ warning $ "Failed to use dbus; falling back to mtab polling (" ++ show e ++ ")" pollinstead - pollinstead = pollingThread st dstatus scanremotes + pollinstead = pollingThread st dstatus scanremotes pushnotifier {- Examine the list of services connected to dbus, to see if there - are any we can use to monitor mounts. If not, will attempt to start one. -} @@ -137,24 +138,24 @@ mountChanged = [gvfs True, gvfs False, kde, kdefallback] #endif -pollingThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO () -pollingThread st dstatus scanremotes = go =<< currentMountPoints +pollingThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO () +pollingThread st dstatus scanremotes pushnotifier = go =<< currentMountPoints where go wasmounted = do threadDelaySeconds (Seconds 10) nowmounted <- currentMountPoints - handleMounts st dstatus scanremotes wasmounted nowmounted + handleMounts st dstatus scanremotes pushnotifier wasmounted nowmounted go nowmounted -handleMounts :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> MountPoints -> MountPoints -> IO () -handleMounts st dstatus scanremotes wasmounted nowmounted = - mapM_ (handleMount st dstatus scanremotes . mnt_dir) $ +handleMounts :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> MountPoints -> MountPoints -> IO () +handleMounts st dstatus scanremotes pushnotifier wasmounted nowmounted = + mapM_ (handleMount st dstatus scanremotes pushnotifier . mnt_dir) $ S.toList $ newMountPoints wasmounted nowmounted -handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> FilePath -> IO () -handleMount st dstatus scanremotes dir = do +handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> FilePath -> IO () +handleMount st dstatus scanremotes pushnotifier dir = do debug thisThread ["detected mount of", dir] - reconnectRemotes thisThread st dstatus scanremotes + reconnectRemotes thisThread st dstatus scanremotes (Just pushnotifier) =<< filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder st dstatus dir diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index a8daa94350..2c637f4143 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -15,6 +15,7 @@ import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.ScanRemotes import Assistant.Sync +import Assistant.Pushes import Utility.ThreadScheduler import Remote.List import qualified Types.Remote as Remote @@ -32,12 +33,12 @@ import qualified Control.Exception as E thisThread :: ThreadName thisThread = "NetWatcher" -netWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread +netWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> NamedThread #if WITH_DBUS -netWatcherThread st dstatus scanremotes = thread $ - dbusThread st dstatus scanremotes +netWatcherThread st dstatus scanremotes pushnotifier = thread $ + dbusThread st dstatus scanremotes pushnotifier #else -netWatcherThread _ _ _ = thread noop +netWatcherThread _ _ _ _ = thread noop #endif where thread = NamedThread thisThread @@ -47,17 +48,17 @@ netWatcherThread _ _ _ = thread noop - any networked remotes that may have not been routable for a - while (despite the local network staying up), are synced with - periodically. -} -netWatcherFallbackThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread -netWatcherFallbackThread st dstatus scanremotes = thread $ +netWatcherFallbackThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> NamedThread +netWatcherFallbackThread st dstatus scanremotes pushnotifier = thread $ runEvery (Seconds 3600) $ - handleConnection st dstatus scanremotes + handleConnection st dstatus scanremotes pushnotifier where thread = NamedThread thisThread #if WITH_DBUS -dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO () -dbusThread st dstatus scanremotes = E.catch (go =<< connectSystem) onerr +dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO () +dbusThread st dstatus scanremotes pushnotifier = E.catch (go =<< connectSystem) onerr where go client = ifM (checkNetMonitor client) ( do @@ -72,7 +73,7 @@ dbusThread st dstatus scanremotes = E.catch (go =<< connectSystem) onerr warning $ "Failed to use dbus; falling back to polling (" ++ show e ++ ")" handle = do debug thisThread ["detected network connection"] - handleConnection st dstatus scanremotes + handleConnection st dstatus scanremotes pushnotifier {- Examine the list of services connected to dbus, to see if there - are any we can use to monitor network connections. -} @@ -126,9 +127,9 @@ listenWicdConnections client callback = #endif -handleConnection :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO () -handleConnection st dstatus scanremotes = - reconnectRemotes thisThread st dstatus scanremotes +handleConnection :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO () +handleConnection st dstatus scanremotes pushnotifier = + reconnectRemotes thisThread st dstatus scanremotes (Just pushnotifier) =<< networkRemotes st {- Finds network remotes. -} diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs new file mode 100644 index 0000000000..cc53097121 --- /dev/null +++ b/Assistant/Threads/PushNotifier.hs @@ -0,0 +1,21 @@ +{- git-annex assistant push notification thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.PushNotifier where + +import Assistant.Common +import Assistant.Pushes + +thisThread :: ThreadName +thisThread = "PushNotifier" + +pushNotifierThread :: PushNotifier -> NamedThread +pushNotifierThread pushnotifier = thread $ forever $ do + waitPush pushnotifier + -- TODO + where + thread = NamedThread thisThread diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 4f3a2dd091..295ceddc9f 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -24,8 +24,8 @@ thisThread :: ThreadName thisThread = "Pusher" {- This thread retries pushes that failed before. -} -pushRetryThread :: ThreadState -> DaemonStatusHandle -> FailedPushMap -> NamedThread -pushRetryThread st dstatus pushmap = thread $ runEvery (Seconds halfhour) $ do +pushRetryThread :: ThreadState -> DaemonStatusHandle -> FailedPushMap -> PushNotifier -> NamedThread +pushRetryThread st dstatus pushmap pushnotifier = thread $ runEvery (Seconds halfhour) $ do -- We already waited half an hour, now wait until there are failed -- pushes to retry. topush <- getFailedPushesBefore pushmap (fromIntegral halfhour) @@ -37,14 +37,14 @@ pushRetryThread st dstatus pushmap = thread $ runEvery (Seconds halfhour) $ do ] now <- getCurrentTime void $ alertWhile dstatus (pushRetryAlert topush) $ - pushToRemotes thisThread now st (Just pushmap) topush + pushToRemotes thisThread now st (Just pushnotifier) (Just pushmap) topush where halfhour = 1800 thread = NamedThread thisThread {- This thread pushes git commits out to remotes soon after they are made. -} -pushThread :: ThreadState -> DaemonStatusHandle -> CommitChan -> FailedPushMap -> NamedThread -pushThread st dstatus commitchan pushmap = thread $ runEvery (Seconds 2) $ do +pushThread :: ThreadState -> DaemonStatusHandle -> CommitChan -> FailedPushMap -> PushNotifier -> NamedThread +pushThread st dstatus commitchan pushmap pushnotifier = thread $ runEvery (Seconds 2) $ do -- We already waited two seconds as a simple rate limiter. -- Next, wait until at least one commit has been made commits <- getCommits commitchan @@ -56,7 +56,7 @@ pushThread st dstatus commitchan pushmap = thread $ runEvery (Seconds 2) $ do <$> getDaemonStatus dstatus unless (null remotes) $ void $ alertWhile dstatus (pushAlert remotes) $ - pushToRemotes thisThread now st (Just pushmap) remotes + pushToRemotes thisThread now st (Just pushnotifier) (Just pushmap) remotes else do debug thisThread [ "delaying push of" From 04ab4bd93aa94baf1440c74db1a2ff55863050be Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 24 Oct 2012 14:39:38 -0400 Subject: [PATCH 04/31] avoid building pushnotifier when there's no xmpp library installed --- Assistant.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/Assistant.hs b/Assistant.hs index b935d45dc8..4ac4375e4d 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -140,7 +140,9 @@ import Assistant.Threads.NetWatcher import Assistant.Threads.TransferScanner import Assistant.Threads.TransferPoller import Assistant.Threads.ConfigMonitor +#ifdef WITH_XMPP import Assistant.Threads.PushNotifier +#endif #ifdef WITH_WEBAPP import Assistant.WebApp import Assistant.Threads.WebApp @@ -213,7 +215,9 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do , assist $ netWatcherFallbackThread st dstatus scanremotes pushnotifier , assist $ transferScannerThread st dstatus scanremotes transferqueue , assist $ configMonitorThread st dstatus branchhandle commitchan - , assist $ pushNotifierThread pushnotifier +#ifdef WITH_XMPP + , assist $ pushNotifierThread dstatus pushnotifier +#endif , watch $ watchThread st dstatus transferqueue changechan ] waitForTermination From 9856641ef1ad2d84ba6908a558b126a4606250cc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 24 Oct 2012 14:43:32 -0400 Subject: [PATCH 05/31] deal with mtl/monads-tf conflict I had been using -ignore-package monads-tf to deal with this, but the XMPP library uses monads-tf, so that also ignores it. Instead, use PackageImports to force use of mtl in my own code. --- Annex.hs | 4 ++-- Command/Status.hs | 4 ++-- Common.hs | 4 +++- Makefile | 2 +- Utility/State.hs | 4 +++- 5 files changed, 11 insertions(+), 7 deletions(-) diff --git a/Annex.hs b/Annex.hs index f1897e1e69..3c83790198 100644 --- a/Annex.hs +++ b/Annex.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-} +{-# LANGUAGE PackageImports, GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-} module Annex ( Annex, @@ -30,7 +30,7 @@ module Annex ( fromRepo, ) where -import Control.Monad.State.Strict +import "mtl" Control.Monad.State.Strict import Control.Monad.Trans.Control (StM, MonadBaseControl, liftBaseWith, restoreM) import Control.Monad.Base (liftBase, MonadBase) import System.Posix.Types (Fd) diff --git a/Command/Status.hs b/Command/Status.hs index ab7dbb0076..a16e143172 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -5,11 +5,11 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports, BangPatterns #-} module Command.Status where -import Control.Monad.State.Strict +import "mtl" Control.Monad.State.Strict import qualified Data.Map as M import Text.JSON import Data.Tuple diff --git a/Common.hs b/Common.hs index 04ec1e044e..5b53f37352 100644 --- a/Common.hs +++ b/Common.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE PackageImports #-} + module Common (module X) where import Control.Monad as X hiding (join) import Control.Monad.IfElse as X import Control.Applicative as X -import Control.Monad.State.Strict as X (liftIO) +import "mtl" Control.Monad.State.Strict as X (liftIO) import Control.Exception.Extensible as X (IOException) import Data.Maybe as X diff --git a/Makefile b/Makefile index 1da32ebc7a..d0409d64bd 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ CFLAGS=-Wall GIT_ANNEX_TMP_BUILD_DIR?=tmp -IGNORE=-ignore-package monads-fd -ignore-package monads-tf +IGNORE=-ignore-package monads-fd BASEFLAGS=-Wall $(IGNORE) -outputdir $(GIT_ANNEX_TMP_BUILD_DIR) -IUtility # If you get build failures due to missing haskell libraries, diff --git a/Utility/State.hs b/Utility/State.hs index c27f3c2610..7f89190823 100644 --- a/Utility/State.hs +++ b/Utility/State.hs @@ -5,9 +5,11 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE PackageImports #-} + module Utility.State where -import Control.Monad.State.Strict +import "mtl" Control.Monad.State.Strict {- Modifies Control.Monad.State's state, forcing a strict update. - This avoids building thunks in the state and leaking. From 21c27fed216f19d7e04fa12336e733265576a9e3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 24 Oct 2012 14:46:31 -0400 Subject: [PATCH 06/31] also remove -ignore-package monads-fd My previous change should mean I no longer need that hack. --- Makefile | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Makefile b/Makefile index d0409d64bd..40e229455c 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,6 @@ CFLAGS=-Wall GIT_ANNEX_TMP_BUILD_DIR?=tmp -IGNORE=-ignore-package monads-fd -BASEFLAGS=-Wall $(IGNORE) -outputdir $(GIT_ANNEX_TMP_BUILD_DIR) -IUtility +BASEFLAGS=-Wall -outputdir $(GIT_ANNEX_TMP_BUILD_DIR) -IUtility # If you get build failures due to missing haskell libraries, # you can turn off some of these features. From 32497feb2ac7e71d00885941778791020a01e3a4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 24 Oct 2012 15:42:02 -0400 Subject: [PATCH 07/31] initial implementation of XMPP push notifier (untested) Lacking error handling, reconnection, credentials configuration, and doesn't actually do anything when it receives an incoming notification. Other than that, it might work! :) --- Assistant.hs | 4 +- Assistant/Pushes.hs | 14 ++-- Assistant/Sync.hs | 4 +- Assistant/Threads/PushNotifier.hs | 119 ++++++++++++++++++++++++++++-- 4 files changed, 124 insertions(+), 17 deletions(-) diff --git a/Assistant.hs b/Assistant.hs index 4ac4375e4d..7ab9cea516 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -105,7 +105,7 @@ - BranchChanged (STM SampleVar) - Changes to the git-annex branch are indicated by updating this - SampleVar. - - PushNotifier (STM SampleVar) + - PushNotifier (STM TChan) - After successful pushes, this SampleVar is updated. - UrlRenderer (MVar) - A Yesod route rendering function is stored here. This allows @@ -216,7 +216,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do , assist $ transferScannerThread st dstatus scanremotes transferqueue , assist $ configMonitorThread st dstatus branchhandle commitchan #ifdef WITH_XMPP - , assist $ pushNotifierThread dstatus pushnotifier + , assist $ pushNotifierThread st dstatus pushnotifier #endif , watch $ watchThread st dstatus transferqueue changechan ] diff --git a/Assistant/Pushes.hs b/Assistant/Pushes.hs index 649975fd1f..7842c18848 100644 --- a/Assistant/Pushes.hs +++ b/Assistant/Pushes.hs @@ -8,9 +8,9 @@ module Assistant.Pushes where import Common.Annex +import Utility.TSet import Control.Concurrent.STM -import Control.Concurrent.MSampleVar import Data.Time.Clock import qualified Data.Map as M @@ -19,7 +19,7 @@ type PushMap = M.Map Remote UTCTime type FailedPushMap = TMVar PushMap {- Used to notify about successful pushes. -} -newtype PushNotifier = PushNotifier (MSampleVar ()) +newtype PushNotifier = PushNotifier (TSet UUID) {- The TMVar starts empty, and is left empty when there are no - failed pushes. This way we can block until there are some failed pushes. @@ -50,10 +50,10 @@ changeFailedPushMap v a = atomically $ | otherwise = putTMVar v $! m newPushNotifier :: IO PushNotifier -newPushNotifier = PushNotifier <$> newEmptySV +newPushNotifier = PushNotifier <$> newTSet -notifyPush :: PushNotifier -> IO () -notifyPush (PushNotifier sv) = writeSV sv () +notifyPush :: [UUID] -> PushNotifier -> IO () +notifyPush us (PushNotifier s) = putTSet s us -waitPush :: PushNotifier -> IO () -waitPush (PushNotifier sv) = readSV sv +waitPush :: PushNotifier -> IO [UUID] +waitPush (PushNotifier s) = getTSet s diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index e333877f20..f9a513d94e 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -101,7 +101,7 @@ pushToRemotes threadname now st mpushnotifier mpushmap remotes = do let ok = null failed if ok then do - maybe noop notifyPush mpushnotifier + maybe noop (notifyPush $ map Remote.uuid succeeded) mpushnotifier return ok else if shouldretry then retry branch g u failed @@ -127,7 +127,7 @@ pushToRemotes threadname now st mpushnotifier mpushmap remotes = do (succeeded, failed) <- inParallel (pushfallback g u branch) rs updatemap succeeded failed unless (null succeeded) $ - maybe noop notifyPush mpushnotifier + maybe noop (notifyPush $ map Remote.uuid succeeded) mpushnotifier return $ null failed push g branch remote = Command.Sync.pushBranch remote branch g diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index cc53097121..12cbb32060 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -1,4 +1,7 @@ -{- git-annex assistant push notification thread +{- git-annex assistant push notification thread, using XMPP + - + - This handles both sending outgoing push notifications, and receiving + - incoming push notifications. - - Copyright 2012 Joey Hess - @@ -8,14 +11,118 @@ module Assistant.Threads.PushNotifier where import Assistant.Common +import Assistant.ThreadedMonad +import Assistant.DaemonStatus import Assistant.Pushes +import qualified Remote + +import Network.Protocol.XMPP +import Network +import Control.Concurrent +import qualified Data.Text as T +import qualified Data.Set as S +import Utility.FileMode thisThread :: ThreadName thisThread = "PushNotifier" -pushNotifierThread :: PushNotifier -> NamedThread -pushNotifierThread pushnotifier = thread $ forever $ do - waitPush pushnotifier - -- TODO +pushNotifierThread :: ThreadState -> DaemonStatusHandle -> PushNotifier -> NamedThread +pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do + v <- runThreadState st $ getXMPPCreds + case v of + Nothing -> nocreds + Just c -> case parseJID (xmppUsername c) of + Nothing -> nocreds + Just jid -> void $ client c jid where - thread = NamedThread thisThread + nocreds = do + -- TODO alert + return () -- exit thread + + client c jid = runClient server jid (xmppUsername c) (xmppPassword c) $ do + void $ bindJID jid + void $ putStanza $ emptyPresence PresenceUnavailable + s <- getSession + _ <- liftIO $ forkIO $ void $ sendnotifications s + receivenotifications + where + server = Server + (JID Nothing (jidDomain jid) Nothing) + (xmppHostname c) + (PortNumber $ fromIntegral $ xmppPort c) + + sendnotifications session = runXMPP session $ forever $ do + us <- liftIO $ waitPush pushnotifier + {- Toggle presence to send the notification. -} + putStanza $ (emptyPresence PresenceAvailable) + { presenceID = Just $ encodePushNotification us } + putStanza $ emptyPresence PresenceUnavailable + + receivenotifications = forever $ do + s <- getStanza + case s of + ReceivedPresence (Presence { presenceType = PresenceAvailable, presenceID = Just t }) -> + maybe noop (liftIO . pull dstatus) + (decodePushNotification t) + _ -> noop + +{- Everything we need to know to connect to an XMPP server. -} +data XMPPCreds = XMPPCreds + { xmppUsername :: T.Text + , xmppPassword :: T.Text + , xmppHostname :: HostName + , xmppPort :: Int + } + deriving (Read, Show) + +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 push notification is encoded in the id field of an XMPP presence + - notification, in the form: "git-annex-push:uuid[:uuid:...] + - + - Git repos can be pushed to that do not have a git-annex uuid; an empty + - string is used for those. + -} +prefix :: T.Text +prefix = T.pack "git-annex-push:" + +delim :: T.Text +delim = T.pack ":" + +encodePushNotification :: [UUID] -> T.Text +encodePushNotification us = T.concat + [ prefix + , T.intercalate delim $ map (T.pack . fromUUID) us + ] + +decodePushNotification :: T.Text -> Maybe [UUID] +decodePushNotification t = map (toUUID . T.unpack) . T.splitOn delim + <$> T.stripPrefix prefix t + +pull :: DaemonStatusHandle -> [UUID] -> IO () +pull _ [] = noop +pull dstatus us = do + rs <- filter matching . syncRemotes <$> getDaemonStatus dstatus + print ("TODO pull from", rs) + where + matching r = Remote.uuid r `S.member` s + s = S.fromList us From 422b426460fcd457028d16397e1f3ca4a44ce23e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 24 Oct 2012 16:21:45 -0400 Subject: [PATCH 08/31] pull from one of the remotes in a push notification Still need to do something about transfer queueing, however. This could be a real can of worms. --- Assistant/Sync.hs | 10 +++++----- Assistant/Threads/PushNotifier.hs | 32 ++++++++++++++++++++++++++----- doc/design/assistant/cloud.mdwn | 7 +++++++ 3 files changed, 39 insertions(+), 10 deletions(-) diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index f9a513d94e..e332d78565 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -48,13 +48,13 @@ reconnectRemotes threadname st dstatus scanremotes pushnotifier rs = void $ (gitremotes, _specialremotes) = partition (Git.repoIsUrl . Remote.repo) rs sync (Just branch) = do - diverged <- manualPull st (Just branch) gitremotes + diverged <- snd <$> manualPull st (Just branch) gitremotes now <- getCurrentTime ok <- pushToRemotes threadname now st pushnotifier Nothing gitremotes return (ok, diverged) {- No local branch exists yet, but we can try pulling. -} sync Nothing = do - diverged <- manualPull st Nothing gitremotes + diverged <- snd <$> manualPull st Nothing gitremotes return (True, diverged) {- Updates the local sync branch, then pushes it to all remotes, in @@ -147,15 +147,15 @@ pushToRemotes threadname now st mpushnotifier mpushmap remotes = do where s = show $ Git.Ref.base b {- Manually pull from remotes and merge their branches. -} -manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO Bool +manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO ([Bool], Bool) manualPull st currentbranch remotes = do g <- runThreadState st gitRepo - forM_ remotes $ \r -> + results <- forM remotes $ \r -> Git.Command.runBool "fetch" [Param $ Remote.name r] g haddiverged <- runThreadState st Annex.Branch.forceUpdate forM_ remotes $ \r -> runThreadState st $ Command.Sync.mergeRemote r currentbranch - return haddiverged + return (results, haddiverged) {- Start syncing a newly added remote, using a background thread. -} syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO () diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index 12cbb32060..8d761dc556 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -14,6 +14,7 @@ import Assistant.Common import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.Pushes +import Assistant.Sync import qualified Remote import Network.Protocol.XMPP @@ -22,6 +23,7 @@ import Control.Concurrent import qualified Data.Text as T import qualified Data.Set as S import Utility.FileMode +import qualified Git.Branch thisThread :: ThreadName thisThread = "PushNotifier" @@ -62,7 +64,7 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do s <- getStanza case s of ReceivedPresence (Presence { presenceType = PresenceAvailable, presenceID = Just t }) -> - maybe noop (liftIO . pull dstatus) + maybe noop (liftIO . pull st dstatus) (decodePushNotification t) _ -> noop @@ -118,11 +120,31 @@ decodePushNotification :: T.Text -> Maybe [UUID] decodePushNotification t = map (toUUID . T.unpack) . T.splitOn delim <$> T.stripPrefix prefix t -pull :: DaemonStatusHandle -> [UUID] -> IO () -pull _ [] = noop -pull dstatus us = do +{- 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 :: ThreadState -> DaemonStatusHandle -> [UUID] -> IO () +pull _ _ [] = noop +pull st dstatus us = do rs <- filter matching . syncRemotes <$> getDaemonStatus dstatus - print ("TODO pull from", rs) + debug thisThread $ "push notification for" : + map (fromUUID . Remote.uuid ) rs + pullone rs =<< runThreadState st (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 st branch [r]) $ + pullone rs branch diff --git a/doc/design/assistant/cloud.mdwn b/doc/design/assistant/cloud.mdwn index b815c5d2dd..264011de45 100644 --- a/doc/design/assistant/cloud.mdwn +++ b/doc/design/assistant/cloud.mdwn @@ -52,6 +52,13 @@ the assistant will transfer the file from the cloud to Bob. * Make the git-annex clients invisible, so a user can use their regular account without always seeming to be present when git-annex is logged in. See +* webapp configuration +* After pulling from a remote, may need to scan for transfers, which + could involve other remotes (ie, S3). Since the remote client is not able to + talk to us directly, it won't be able to upload any new files to us. + Need a fast way to find new files, and get them transferring. The expensive + transfer scan may be needed to get fully in sync, but is too expensive to + run every time this happens. ### jabber security From 145202f21e0c0e419511f9281eeb3b122d303784 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 24 Oct 2012 17:23:21 -0400 Subject: [PATCH 09/31] flip availablility Seems presence notifications are not sent to clients that have marked themselves unavailable. (Testing with google talk.) This is the death knell for the presence hack, because it has to stay available, and even the toggle to unavailable and back could cause it to miss a notification. Still, flipped it so it basically works, for now. --- Assistant/Threads/PushNotifier.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index 8d761dc556..39072b85eb 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -43,25 +43,26 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do client c jid = runClient server jid (xmppUsername c) (xmppPassword c) $ do void $ bindJID jid - void $ putStanza $ emptyPresence PresenceUnavailable s <- getSession - _ <- liftIO $ forkIO $ void $ sendnotifications s - receivenotifications + _ <- liftIO $ forkIO $ void $ runXMPP s $ + receivenotifications + sendnotifications where server = Server (JID Nothing (jidDomain jid) Nothing) (xmppHostname c) (PortNumber $ fromIntegral $ xmppPort c) - sendnotifications session = runXMPP session $ forever $ do + sendnotifications = forever $ do us <- liftIO $ waitPush pushnotifier {- Toggle presence to send the notification. -} + putStanza $ emptyPresence PresenceUnavailable putStanza $ (emptyPresence PresenceAvailable) { presenceID = Just $ encodePushNotification us } - putStanza $ emptyPresence PresenceUnavailable receivenotifications = forever $ do s <- getStanza + liftIO $ print s case s of ReceivedPresence (Presence { presenceType = PresenceAvailable, presenceID = Just t }) -> maybe noop (liftIO . pull st dstatus) From 52d380d7f0d1bc8611d86dc0638c10a393db6488 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 24 Oct 2012 19:09:02 -0400 Subject: [PATCH 10/31] add a separate field for the JID --- Assistant/Threads/PushNotifier.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index 39072b85eb..82638b804c 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -33,7 +33,7 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do v <- runThreadState st $ getXMPPCreds case v of Nothing -> nocreds - Just c -> case parseJID (xmppUsername c) of + Just c -> case parseJID (xmppJID c) of Nothing -> nocreds Just jid -> void $ client c jid where @@ -75,6 +75,9 @@ data XMPPCreds = XMPPCreds , xmppPassword :: T.Text , xmppHostname :: HostName , xmppPort :: Int + {- Something like username@hostname, but not necessarily the same + - username or hostname used to connect to the server. -} + , xmppJID :: T.Text } deriving (Read, Show) From 91c0c7b9efb5c68aec051d8abfc3aa4bcc3ef609 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 25 Oct 2012 13:04:43 -0400 Subject: [PATCH 11/31] switch from presence toggle hack to git-annex tag in presence extended content Push notifications are actually working over XMPP now! --- Assistant/Threads/PushNotifier.hs | 61 ++++++++++++++++++------------- 1 file changed, 35 insertions(+), 26 deletions(-) diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index 82638b804c..872b189944 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -24,6 +24,7 @@ import qualified Data.Text as T import qualified Data.Set as S import Utility.FileMode import qualified Git.Branch +import Data.XML.Types thisThread :: ThreadName thisThread = "PushNotifier" @@ -38,7 +39,7 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do Just jid -> void $ client c jid where nocreds = do - -- TODO alert + error "no creds" -- TODO alert return () -- exit thread client c jid = runClient server jid (xmppUsername c) (xmppPassword c) $ do @@ -55,18 +56,19 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do sendnotifications = forever $ do us <- liftIO $ waitPush pushnotifier - {- Toggle presence to send the notification. -} - putStanza $ emptyPresence PresenceUnavailable + let payload = [extendedAway, encodePushNotification us] putStanza $ (emptyPresence PresenceAvailable) - { presenceID = Just $ encodePushNotification us } + { presencePayloads = payload } receivenotifications = forever $ do s <- getStanza - liftIO $ print s + liftIO $ debug thisThread ["received XMPP:", show s] case s of - ReceivedPresence (Presence { presenceType = PresenceAvailable, presenceID = Just t }) -> - maybe noop (liftIO . pull st dstatus) - (decodePushNotification t) + ReceivedPresence p@(Presence { presenceType = PresenceAvailable }) -> + liftIO $ pull st dstatus $ + concat $ catMaybes $ + map decodePushNotification $ + presencePayloads p _ -> noop {- Everything we need to know to connect to an XMPP server. -} @@ -102,27 +104,34 @@ xmppCredsFile = do dir <- fromRepo gitAnnexCredsDir return $ dir "notify-xmpp" -{- A push notification is encoded in the id field of an XMPP presence - - notification, in the form: "git-annex-push:uuid[:uuid:...] - - - - Git repos can be pushed to that do not have a git-annex uuid; an empty - - string is used for those. - -} -prefix :: T.Text -prefix = T.pack "git-annex-push:" +{- Marks the client as extended away. -} +extendedAway :: Element +extendedAway = Element (Name (T.pack "show") Nothing Nothing) [] + [NodeContent $ ContentText $ T.pack "xa"] -delim :: T.Text -delim = T.pack ":" +{- Name of a git-annex tag, in our own XML namespace. + - (Not using a namespace URL to avoid unnecessary bloat.) -} +gitAnnexTagName :: Name +gitAnnexTagName = Name (T.pack "git-annex") (Just $ T.pack "git-annex") Nothing -encodePushNotification :: [UUID] -> T.Text -encodePushNotification us = T.concat - [ prefix - , T.intercalate delim $ map (T.pack . fromUUID) us - ] +pushAttr :: Name +pushAttr = Name (T.pack "push") Nothing Nothing -decodePushNotification :: T.Text -> Maybe [UUID] -decodePushNotification t = map (toUUID . T.unpack) . T.splitOn delim - <$> T.stripPrefix prefix t +{- git-annex tag with one push attribute per UUID pushed to. -} +encodePushNotification :: [UUID] -> Element +encodePushNotification us = Element gitAnnexTagName + [(pushAttr, map (ContentText . T.pack . fromUUID) us)] [] + +decodePushNotification :: Element -> Maybe [UUID] +decodePushNotification (Element name attrs _nodes) + | name == gitAnnexTagName && not (null us) = Just us + | otherwise = Nothing + where + us = concatMap (map (toUUID . T.unpack . fromContent) . snd) $ + filter ispush attrs + ispush (k, _) = k == pushAttr + fromContent (ContentText t) = t + fromContent (ContentEntity t) = t {- We only pull from one remote out of the set listed in the push - notification, as an optimisation. From 8c9c8e3110f6f6faa7324219071c7f1ff4decf13 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 25 Oct 2012 13:29:18 -0400 Subject: [PATCH 12/31] only use one push attribute When pushing to multiple UUIDs, combine them all into a single push attribute. --- Assistant/Threads/PushNotifier.hs | 14 +++++++++++--- doc/design/assistant/xmpp.mdwn | 7 ++++--- 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index 872b189944..84fe4952ab 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -57,8 +57,9 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do sendnotifications = forever $ do us <- liftIO $ waitPush pushnotifier let payload = [extendedAway, encodePushNotification us] - putStanza $ (emptyPresence PresenceAvailable) + let notification = (emptyPresence PresenceAvailable) { presencePayloads = payload } + putStanza notification receivenotifications = forever $ do s <- getStanza @@ -117,17 +118,24 @@ gitAnnexTagName = Name (T.pack "git-annex") (Just $ T.pack "git-annex") Nothing pushAttr :: Name pushAttr = Name (T.pack "push") Nothing Nothing +uuidSep :: T.Text +uuidSep = T.pack "," + {- git-annex tag with one push attribute per UUID pushed to. -} encodePushNotification :: [UUID] -> Element encodePushNotification us = Element gitAnnexTagName - [(pushAttr, map (ContentText . T.pack . fromUUID) us)] [] + [(pushAttr, [ContentText pushvalue])] [] + where + pushvalue = T.intercalate uuidSep $ + map (T.pack . fromUUID) us decodePushNotification :: Element -> Maybe [UUID] decodePushNotification (Element name attrs _nodes) | name == gitAnnexTagName && not (null us) = Just us | otherwise = Nothing where - us = concatMap (map (toUUID . T.unpack . fromContent) . snd) $ + us = map (toUUID . T.unpack) $ + concatMap (T.splitOn uuidSep . T.concat . map fromContent . snd) $ filter ispush attrs ispush (k, _) = k == pushAttr fromContent (ContentText t) = t diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index 6d5384e435..d008d3fdcd 100644 --- a/doc/design/assistant/xmpp.mdwn +++ b/doc/design/assistant/xmpp.mdwn @@ -42,11 +42,12 @@ using presence messages. These always mark it as extended away. To this, it adds its own tag as [extended content](http://xmpp.org/rfcs/rfc6121.html#presence-extended). The xml namespace is "git-annex" (not an URL because I hate wasting bandwidth). -To indicate it's pushed changes to a git repo, a client uses: +To indicate it's pushed changes to a git repo with a given UUID, a client uses: - + -The push attribute can be repeated when the push was sent to multiple repos. +Multiple UUIDs can be listed when multiple clients were pushed. If the +git repo does not have a git-annex UUID, an empty string is used. ### security From fe96b28b4d54064cdfaad85d0509451c357f1835 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 25 Oct 2012 15:30:49 -0400 Subject: [PATCH 13/31] convert the assistant to use a bound thread for XMPP This *may* solve the segfault I was seeing when the XMPP library called startTLS. My hypothesis is as follows: * TLS is documented (http://www.gnu.org/software/gnutls/manual/gnutls.html#Thread-safety) thread safe, but only when a single thread accesses it. * forkIO threads are not bound to an OS thread, so it was possible for the threaded runtime to run part of the XMPP code on one thread, and then switch to another thread later. So, forkOS, with its bound threads, should be used for the XMPP thread. Since the crash doesn't happen reliably, I am not yet sure about this fix. Note that I kept all the other threads in the assistant unbound, because bound threads have significantly higher overhead. --- Assistant.hs | 7 ++++++- Assistant/Threads/PushNotifier.hs | 2 +- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/Assistant.hs b/Assistant.hs index 7ab9cea516..77790b9c65 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -223,7 +223,12 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do waitForTermination watch a = (True, a) assist a = (False, a) + + {- Each named thread is started in a bound thread. + - (forkOS rather than forkIO). There are not too many, + - and this deals with libraries like gnuTLS that + - require only one thread access them. -} startthread dstatus (watcher, t) - | watcher || assistant = void $ forkIO $ + | watcher || assistant = void $ forkOS $ runNamedThread dstatus t | otherwise = noop diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index 84fe4952ab..088e97ec4b 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -45,7 +45,7 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do client c jid = runClient server jid (xmppUsername c) (xmppPassword c) $ do void $ bindJID jid s <- getSession - _ <- liftIO $ forkIO $ void $ runXMPP s $ + _ <- liftIO $ forkOS $ void $ runXMPP s $ receivenotifications sendnotifications where From 4aaa8665e1cc565e78aefe2cb7fb1f242a984046 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 25 Oct 2012 16:50:41 -0400 Subject: [PATCH 14/31] add template for xmpp, not used yet --- templates/configurators/xmpp.hamlet | 35 +++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) create mode 100644 templates/configurators/xmpp.hamlet diff --git a/templates/configurators/xmpp.hamlet b/templates/configurators/xmpp.hamlet new file mode 100644 index 0000000000..564b161ed4 --- /dev/null +++ b/templates/configurators/xmpp.hamlet @@ -0,0 +1,35 @@ +
+

+ Configuring jabber account +

+ A jabber account is used by git-annex to communicate changes between # + repositories. It can also be used to pair up with a friend's repository, # + if you want to. It's fine to reuse an existing account; git-annex won't # + post any messages to it. +

+ If you have a Gmail account, you can use # + Google Talk. Just enter your full Gmail address (you@gmail.com) # + and password below. + $if needserver +

+ Unable to find a Jabber server for # + #{jid}. Please enter the server name and port below. + $if connectfail +

+ Unable to connect to the Jabber server. # + Maybe you entered the wrong password? +

+

+
+ ^{form} + ^{authtoken} +
+