aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Assistant.hs2
-rw-r--r--Assistant/Alert.hs17
-rw-r--r--Assistant/Monad.hs3
-rw-r--r--Assistant/RemoteControl.hs21
-rw-r--r--Assistant/Sync.hs2
-rw-r--r--Assistant/Threads/NetWatcher.hs8
-rw-r--r--Assistant/Threads/RemoteControl.hs80
-rw-r--r--Assistant/Types/RemoteControl.hs16
-rw-r--r--debian/changelog4
-rw-r--r--doc/design/assistant/telehash.mdwn2
-rw-r--r--doc/design/git-remote-daemon.mdwn2
11 files changed, 150 insertions, 7 deletions
diff --git a/Assistant.hs b/Assistant.hs
index 67398f23b..b5caceac2 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 192952f56..018fbf583 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 7c28c7f6f..350e3d33b 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 000000000..86d13cc56
--- /dev/null
+++ b/Assistant/RemoteControl.hs
@@ -0,0 +1,21 @@
+{- git-annex assistant RemoteDaemon control
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - 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 fc95419ab..c748f6e1a 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 0b009647c..912893b87 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 000000000..b67b0e07f
--- /dev/null
+++ b/Assistant/Threads/RemoteControl.hs
@@ -0,0 +1,80 @@
+{- git-annex assistant communication with remotedaemon
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - 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 000000000..523cd8b8d
--- /dev/null
+++ b/Assistant/Types/RemoteControl.hs
@@ -0,0 +1,16 @@
+{- git-annex assistant RemoteDaemon control
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - 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 996f0ef04..fcbef3fce 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 <joeyh@debian.org> Mon, 07 Apr 2014 16:22:02 -0400
diff --git a/doc/design/assistant/telehash.mdwn b/doc/design/assistant/telehash.mdwn
index 3b427b42f..2ecf9ec71 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 6b8e0646f..169ca321b 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