summaryrefslogtreecommitdiff
path: root/Assistant/Threads/RemoteControl.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-04-09 14:10:29 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-04-09 14:14:55 -0400
commit8de1359bbbb3a5bd8a4a5588bacef88eb234bb7b (patch)
tree1ae689b9883bef374a6328229c693b3e9e636eca /Assistant/Threads/RemoteControl.hs
parent8014dafedf59f7feaac4153af5e330ab84a9cf8b (diff)
make git-remote-daemon ssh transport robust
* Remote system might be available, and connection get lost. Should reconnect, but needs to avoid bad behavior (ie, constant reconnect attempts.) Use exponential backoff. * Detect if old system had a too old git-annex-shell, and show the user a nice message in the webapp. Required parsing error messages, so perhaps this code shoudl be removed once enough time has passed.. * Switch the protocol to using remote URI's, rather than remote names. Names change. Also avoids issues with serialization of names containing whitespace. This is nearly ready for merge into master now. I'd still like to make the ssh transport smarter about reusing ssh connection caching during git pull. This commit was sponsored by Jim Paris.
Diffstat (limited to 'Assistant/Threads/RemoteControl.hs')
-rw-r--r--Assistant/Threads/RemoteControl.hs76
1 files changed, 56 insertions, 20 deletions
diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs
index b67b0e07f..d33a4858d 100644
--- a/Assistant/Threads/RemoteControl.hs
+++ b/Assistant/Threads/RemoteControl.hs
@@ -15,11 +15,16 @@ import Utility.SimpleProtocol
import Assistant.Alert
import Assistant.Alert.Utility
import Assistant.DaemonStatus
+import qualified Git
+import qualified Git.Types as Git
+import qualified Remote
+import qualified Types.Remote as Remote
import Control.Concurrent
import Control.Concurrent.Async
import System.Process (std_in, std_out)
import qualified Data.Map as M
+import Network.URI
remoteControlThread :: NamedThread
remoteControlThread = namedThread "RemoteControl" $ do
@@ -32,8 +37,10 @@ remoteControlThread = namedThread "RemoteControl" $ do
, std_out = CreatePipe
}
+ urimap <- liftIO . newMVar =<< liftAnnex getURIMap
+
controller <- asIO $ remoteControllerThread toh
- responder <- asIO $ remoteResponderThread fromh
+ responder <- asIO $ remoteResponderThread fromh urimap
-- run controller and responder until the remotedaemon dies
liftIO $ do
@@ -50,31 +57,60 @@ remoteControllerThread toh = do
hFlush toh
-- read status messages emitted by the remotedaemon and handle them
-remoteResponderThread :: Handle -> Assistant ()
-remoteResponderThread fromh = go M.empty
+remoteResponderThread :: Handle -> MVar (M.Map URI Remote) -> Assistant ()
+remoteResponderThread fromh urimap = go M.empty
where
go syncalerts = do
+ let cont = go syncalerts
+ let withr uri = withRemote uri urimap cont
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 (CONNECTED _uri) -> do
+ cont
+ Just (DISCONNECTED _uri) -> do
+ cont
+ Just (SYNCING uri) -> withr uri $ \r ->
+ if M.member (Remote.uuid r) syncalerts
+ then go syncalerts
+ else do
+ i <- addAlert $ syncAlert [r]
+ go (M.insert (Remote.uuid r) i syncalerts)
+ Just (DONESYNCING uri status) -> withr uri $ \r ->
+ case M.lookup (Remote.uuid r) syncalerts of
+ Nothing -> cont
Just i -> do
let (succeeded, failed) = if status
- then ([rn], [])
- else ([], [rn])
+ then ([r], [])
+ else ([], [r])
updateAlertMap $ mergeAlert i $
- syncResultAlert' succeeded failed
- go (M.delete rn syncalerts)
+ syncResultAlert succeeded failed
+ go (M.delete (Remote.uuid r) syncalerts)
+ Just (WARNING (RemoteURI uri) msg) -> do
+ void $ addAlert $
+ warningAlert ("RemoteControl "++ show uri) msg
+ cont
Nothing -> do
debug ["protocol error from remotedaemon: ", l]
- go syncalerts
+ cont
+
+getURIMap :: Annex (M.Map URI Remote)
+getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo)
+ where
+ mkk (Git.Url u) = Just u
+ mkk _ = Nothing
+
+withRemote
+ :: RemoteURI
+ -> MVar (M.Map URI Remote)
+ -> Assistant a
+ -> (Remote -> Assistant a)
+ -> Assistant a
+withRemote (RemoteURI uri) remotemap noremote a = do
+ m <- liftIO $ readMVar remotemap
+ case M.lookup uri m of
+ Just r -> a r
+ Nothing -> do
+ {- Reload map, in case a new remote has been added. -}
+ m' <- liftAnnex getURIMap
+ void $ liftIO $ swapMVar remotemap $ m'
+ maybe noremote a (M.lookup uri m')