From 8de1359bbbb3a5bd8a4a5588bacef88eb234bb7b Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 9 Apr 2014 14:10:29 -0400
Subject: 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.
---
 Assistant/Threads/RemoteControl.hs | 76 ++++++++++++++++++++++++++++----------
 1 file changed, 56 insertions(+), 20 deletions(-)

(limited to 'Assistant/Threads')

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')
-- 
cgit v1.2.3