From fac7bca05bee8c0871faee320ac7194e295d7cfb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Apr 2014 15:23:50 -0400 Subject: [PATCH] assistant: Now detects immediately when other repositories push changes to a ssh remote, and pulls. XMPP is no longer needed in this configuration! Requires the remote server have git-annex-shell with notifychanges support. (untested) This commit was sponsored by Geog Wechslberger. --- Assistant.hs | 2 + Assistant/Alert.hs | 17 +++++-- Assistant/Monad.hs | 3 ++ Assistant/RemoteControl.hs | 21 ++++++++ Assistant/Sync.hs | 2 + Assistant/Threads/NetWatcher.hs | 8 ++- Assistant/Threads/RemoteControl.hs | 80 ++++++++++++++++++++++++++++++ Assistant/Types/RemoteControl.hs | 16 ++++++ debian/changelog | 4 ++ doc/design/assistant/telehash.mdwn | 2 +- doc/design/git-remote-daemon.mdwn | 2 + 11 files changed, 150 insertions(+), 7 deletions(-) create mode 100644 Assistant/RemoteControl.hs create mode 100644 Assistant/Threads/RemoteControl.hs create mode 100644 Assistant/Types/RemoteControl.hs diff --git a/Assistant.hs b/Assistant.hs index 67398f23b8..b5caceac2d 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -21,6 +21,7 @@ import Assistant.Threads.Pusher import Assistant.Threads.Merger import Assistant.Threads.TransferWatcher import Assistant.Threads.Transferrer +import Assistant.Threads.RemoteControl import Assistant.Threads.SanityChecker import Assistant.Threads.Cronner import Assistant.Threads.ProblemFixer @@ -147,6 +148,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = , assist $ transferWatcherThread , assist $ transferPollerThread , assist $ transfererThread + , assist $ remoteControlThread , assist $ daemonStatusThread , assist $ sanityCheckerDailyThread urlrenderer , assist $ sanityCheckerHourlyThread diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 192952f56b..018fbf5830 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -16,6 +16,7 @@ import qualified Remote import Utility.Tense import Logs.Transfer import Types.Distribution +import Git.Types (RemoteName) import Data.String import qualified Data.Text as T @@ -117,11 +118,14 @@ commitAlert :: Alert commitAlert = activityAlert Nothing [Tensed "Committing" "Committed", "changes to git"] -showRemotes :: [Remote] -> TenseChunk -showRemotes = UnTensed . T.intercalate ", " . map (T.pack . Remote.name) +showRemotes :: [RemoteName] -> TenseChunk +showRemotes = UnTensed . T.intercalate ", " . map T.pack syncAlert :: [Remote] -> Alert -syncAlert rs = baseActivityAlert +syncAlert = syncAlert' . map Remote.name + +syncAlert' :: [RemoteName] -> Alert +syncAlert' rs = baseActivityAlert { alertName = Just SyncAlert , alertHeader = Just $ tenseWords [Tensed "Syncing" "Synced", "with", showRemotes rs] @@ -130,7 +134,12 @@ syncAlert rs = baseActivityAlert } syncResultAlert :: [Remote] -> [Remote] -> Alert -syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $ +syncResultAlert succeeded failed = syncResultAlert' + (map Remote.name succeeded) + (map Remote.name failed) + +syncResultAlert' :: [RemoteName] -> [RemoteName] -> Alert +syncResultAlert' succeeded failed = makeAlertFiller (not $ null succeeded) $ baseActivityAlert { alertName = Just SyncAlert , alertHeader = Just $ tenseWords msg diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 7c28c7f6fd..350e3d33ba 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -43,6 +43,7 @@ import Assistant.Types.RepoProblem import Assistant.Types.Buddies import Assistant.Types.NetMessager import Assistant.Types.ThreadName +import Assistant.Types.RemoteControl newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a } deriving ( @@ -68,6 +69,7 @@ data AssistantData = AssistantData , branchChangeHandle :: BranchChangeHandle , buddyList :: BuddyList , netMessager :: NetMessager + , remoteControl :: RemoteControl } newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData @@ -86,6 +88,7 @@ newAssistantData st dstatus = AssistantData <*> newBranchChangeHandle <*> newBuddyList <*> newNetMessager + <*> newRemoteControl runAssistant :: AssistantData -> Assistant a -> IO a runAssistant d a = runReaderT (mkAssistant a) d diff --git a/Assistant/RemoteControl.hs b/Assistant/RemoteControl.hs new file mode 100644 index 0000000000..86d13cc567 --- /dev/null +++ b/Assistant/RemoteControl.hs @@ -0,0 +1,21 @@ +{- git-annex assistant RemoteDaemon control + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.RemoteControl ( + sendRemoteControl, + RemoteDaemon.Consumed(..) +) where + +import Assistant.Common +import qualified RemoteDaemon.Types as RemoteDaemon + +import Control.Concurrent + +sendRemoteControl :: RemoteDaemon.Consumed -> Assistant () +sendRemoteControl msg = do + clicker <- getAssistant remoteControl + liftIO $ writeChan clicker msg diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index fc95419ab8..c748f6e1ac 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -15,6 +15,7 @@ import Assistant.Alert import Assistant.Alert.Utility import Assistant.DaemonStatus import Assistant.ScanRemotes +import Assistant.RemoteControl import qualified Command.Sync import Utility.Parallel import qualified Git @@ -258,6 +259,7 @@ changeSyncable Nothing enable = do changeSyncable (Just r) True = do liftAnnex $ changeSyncFlag r True syncRemote r + sendRemoteControl RELOAD changeSyncable (Just r) False = do liftAnnex $ changeSyncFlag r False updateSyncRemotes diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index 0b009647c1..912893b87c 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -15,6 +15,7 @@ import Assistant.Sync import Utility.ThreadScheduler import qualified Types.Remote as Remote import Assistant.DaemonStatus +import Assistant.RemoteControl import Utility.NotificationBroadcaster #if WITH_DBUS @@ -44,8 +45,9 @@ netWatcherThread = thread noop - while (despite the local network staying up), are synced with - periodically. - - - Note that it does not call notifyNetMessagerRestart, because - - it doesn't know that the network has changed. + - Note that it does not call notifyNetMessagerRestart, or + - signal the RemoteControl, because it doesn't know that the + - network has changed. -} netWatcherFallbackThread :: NamedThread netWatcherFallbackThread = namedThread "NetWatcherFallback" $ @@ -69,8 +71,10 @@ dbusThread = do ) handleconn = do debug ["detected network connection"] + sendRemoteControl PAUSE notifyNetMessagerRestart handleConnection + sendRemoteControl RESUME onerr e _ = do liftAnnex $ warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")" diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs new file mode 100644 index 0000000000..b67b0e07f1 --- /dev/null +++ b/Assistant/Threads/RemoteControl.hs @@ -0,0 +1,80 @@ +{- git-annex assistant communication with remotedaemon + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.RemoteControl where + +import Assistant.Common +import RemoteDaemon.Types +import Config.Files +import Utility.Batch +import Utility.SimpleProtocol +import Assistant.Alert +import Assistant.Alert.Utility +import Assistant.DaemonStatus + +import Control.Concurrent +import Control.Concurrent.Async +import System.Process (std_in, std_out) +import qualified Data.Map as M + +remoteControlThread :: NamedThread +remoteControlThread = namedThread "RemoteControl" $ do + program <- liftIO readProgramFile + (cmd, params) <- liftIO $ toBatchCommand + (program, [Param "remotedaemon"]) + let p = proc cmd (toCommand params) + (Just toh, Just fromh, _, pid) <- liftIO $ createProcess p + { std_in = CreatePipe + , std_out = CreatePipe + } + + controller <- asIO $ remoteControllerThread toh + responder <- asIO $ remoteResponderThread fromh + + -- run controller and responder until the remotedaemon dies + liftIO $ do + void $ controller `concurrently` responder + forceSuccessProcess p pid + +-- feed from the remoteControl channel into the remotedaemon +remoteControllerThread :: Handle -> Assistant () +remoteControllerThread toh = do + clicker <- getAssistant remoteControl + liftIO $ forever $ do + msg <- readChan clicker + hPutStrLn toh $ unwords $ formatMessage msg + hFlush toh + +-- read status messages emitted by the remotedaemon and handle them +remoteResponderThread :: Handle -> Assistant () +remoteResponderThread fromh = go M.empty + where + go syncalerts = do + l <- liftIO $ hGetLine fromh + case parseMessage l of + Just (CONNECTED _rn) -> do + go syncalerts + Just (DISCONNECTED _rn) -> do + go syncalerts + Just (SYNCING rn) + | M.member rn syncalerts -> go syncalerts + | otherwise -> do + i <- addAlert $ syncAlert' [rn] + go (M.insert rn i syncalerts) + Just (DONESYNCING status rn) -> + case M.lookup rn syncalerts of + Nothing -> go syncalerts + Just i -> do + let (succeeded, failed) = if status + then ([rn], []) + else ([], [rn]) + updateAlertMap $ mergeAlert i $ + syncResultAlert' succeeded failed + go (M.delete rn syncalerts) + Nothing -> do + debug ["protocol error from remotedaemon: ", l] + go syncalerts diff --git a/Assistant/Types/RemoteControl.hs b/Assistant/Types/RemoteControl.hs new file mode 100644 index 0000000000..523cd8b8dd --- /dev/null +++ b/Assistant/Types/RemoteControl.hs @@ -0,0 +1,16 @@ +{- git-annex assistant RemoteDaemon control + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.RemoteControl where + +import qualified RemoteDaemon.Types as RemoteDaemon +import Control.Concurrent + +type RemoteControl = Chan RemoteDaemon.Consumed + +newRemoteControl :: IO RemoteControl +newRemoteControl = newChan diff --git a/debian/changelog b/debian/changelog index 996f0ef043..fcbef3fcec 100644 --- a/debian/changelog +++ b/debian/changelog @@ -2,6 +2,10 @@ git-annex (5.20140406) UNRELEASED; urgency=medium * importfeed: Filename template can now contain an itempubdate variable. Needs feed 0.3.9.2. + * assistant: Now detects immediately when other repositories push + changes to a ssh remote, and pulls. + XMPP is no longer needed in this configuration! + Requires the remote server have git-annex-shell with notifychanges support. -- Joey Hess Mon, 07 Apr 2014 16:22:02 -0400 diff --git a/doc/design/assistant/telehash.mdwn b/doc/design/assistant/telehash.mdwn index 3b427b42f0..2ecf9ec718 100644 --- a/doc/design/assistant/telehash.mdwn +++ b/doc/design/assistant/telehash.mdwn @@ -83,7 +83,7 @@ Advantages: exchange protocols implemented in such a daemon to allow SSH-less transfers. * Security holes in telehash would not need to compromise the entire - git-annex. gathd could be sandboxed in one way or another. + git-annex. daemon could be sandboxed in one way or another. Disadvantages: diff --git a/doc/design/git-remote-daemon.mdwn b/doc/design/git-remote-daemon.mdwn index 6b8e0646ff..169ca321b5 100644 --- a/doc/design/git-remote-daemon.mdwn +++ b/doc/design/git-remote-daemon.mdwn @@ -167,6 +167,8 @@ TODO: reconnect, but needs to avoid bad behavior (ie, constant reconnect attempts.) * Detect if old system had a too old git-annex-shell and avoid bad behavior +* CONNECTED and DISCONNECTED are not wired into any webapp UI; could be + used to show an icon when a ssh remote is available ## telehash