cleaned up AnnexState handling in transports

Config.hs

@@ -32,7 +32,10 @@ getConfigMaybe (ConfigKey key) = fromRepo $ Git.Config.getMaybe key
 setConfig :: ConfigKey -> String -> Annex ()
 setConfig (ConfigKey key) value = do
 	inRepo $ Git.Command.run [Param "config", Param key, Param value]
-	Annex.changeGitRepo =<< inRepo Git.Config.reRead
+	reloadConfig
+
+reloadConfig :: Annex ()
+reloadConfig = Annex.changeGitRepo =<< inRepo Git.Config.reRead
 
 {- Unsets a git config setting. (Leaves it in state currently.) -}
 unsetConfig :: ConfigKey -> Annex ()

RemoteDaemon/Common.hs

@@ -0,0 +1,42 @@
+{- git-remote-daemon utilities
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module RemoteDaemon.Common
+	( liftAnnex
+	, inLocalRepo
+	, checkNewShas
+	) where
+
+import qualified Annex
+import Common.Annex
+import RemoteDaemon.Types
+import qualified Git
+import Annex.CatFile
+
+import Control.Concurrent
+
+-- Runs an Annex action. Long-running actions should be avoided,
+-- since only one liftAnnex can be running at a time, amoung all
+-- transports.
+liftAnnex :: TransportHandle -> Annex a -> IO a
+liftAnnex (TransportHandle _ annexstate) a = do
+	st <- takeMVar annexstate
+	(r, st') <- Annex.run st a
+	putMVar annexstate st'
+	return r
+
+inLocalRepo :: TransportHandle -> (Git.Repo -> IO a) -> IO a
+inLocalRepo (TransportHandle g _) a = a g
+
+-- Check if any of the shas are actally new in the local git repo,
+-- to avoid unnecessary fetching.
+checkNewShas :: TransportHandle -> [Git.Sha] -> IO Bool
+checkNewShas transporthandle = check
+  where
+	check [] = return True
+	check (r:rs) = maybe (check rs) (const $ return False)
+		=<< liftAnnex transporthandle (catObjectDetails r)

RemoteDaemon/Core.hs

@@ -10,15 +10,17 @@ module RemoteDaemon.Core (runForeground) where
 import qualified Annex
 import Common
 import Types.GitConfig
+import RemoteDaemon.Common
 import RemoteDaemon.Types
 import RemoteDaemon.Transport
 import qualified Git
 import qualified Git.Types as Git
 import qualified Git.CurrentRepo
 import Utility.SimpleProtocol
+import Config
 
 import Control.Concurrent.Async
-import Control.Concurrent.Chan
+import Control.Concurrent
 import Network.URI
 import qualified Data.Map as M
 
@@ -50,36 +52,38 @@ type RemoteMap = M.Map Git.Repo (IO (), Chan Consumed)
 -- the main control messages.
 controller :: Chan Consumed -> Chan Emitted -> IO ()
 controller ichan ochan = do
-	m <- getRemoteMap ochan
+	h <- genTransportHandle
+	m <- genRemoteMap h ochan
 	startrunning m
-	go False m
+	go h False m
   where
-	go paused m = do
+	go h paused m = do
 		cmd <- readChan ichan
 		case cmd of
 			RELOAD -> do
-				m' <- getRemoteMap ochan
+				liftAnnex h reloadConfig
+				m' <- genRemoteMap h ochan
 				let common = M.intersection m m'
 				let new = M.difference m' m
 				let old = M.difference m m'
 				stoprunning old
 				unless paused $
 					startrunning new
-				go paused (M.union common new)
+				go h paused (M.union common new)
 			PAUSE -> do
 				stoprunning m
-				go True m
+				go h True m
 			RESUME -> do
 				when paused $
 					startrunning m
-				go False m
+				go h False m
 			STOP -> exitSuccess
 			-- All remaining messages are sent to
 			-- all Transports.
 			msg -> do
 				unless paused $
 					forM_ chans (`writeChan` msg)
-				go paused m
+				go h paused m
 	  where
 		chans = map snd (M.elems m)
 
@@ -90,17 +94,12 @@ controller ichan ochan = do
 	stoprunning m = forM_ (M.elems m) stoprunning'
 	stoprunning' (_, c) = writeChan c STOP
 
-getRemoteMap :: Chan Emitted -> IO RemoteMap
-getRemoteMap ochan = do
-	annexstate <- Annex.new =<< Git.CurrentRepo.get
-	genRemoteMap annexstate ochan
-
 -- Generates a map with a transport for each supported remote in the git repo,
 -- except those that have annex.sync = false
-genRemoteMap :: Annex.AnnexState -> Chan Emitted -> IO RemoteMap
-genRemoteMap annexstate ochan = M.fromList . catMaybes <$> mapM gen rs
+genRemoteMap :: TransportHandle -> Chan Emitted -> IO RemoteMap
+genRemoteMap h@(TransportHandle g _) ochan =
+	M.fromList . catMaybes <$> mapM gen (Git.remotes g)
   where
-	rs = Git.remotes (Annex.repo annexstate)
 	gen r = case Git.location r of
 		Git.Url u -> case M.lookup (uriScheme u) remoteTransports of
 			Just transport
@@ -108,7 +107,13 @@ genRemoteMap annexstate ochan = M.fromList . catMaybes <$> mapM gen rs
 					ichan <- newChan :: IO (Chan Consumed)
 					return $ Just
 						( r
-						, (transport r (Git.repoDescribe r) annexstate ichan ochan, ichan)
+						, (transport r (Git.repoDescribe r) h ichan ochan, ichan)
 						)
 			_ -> return Nothing
 		_ -> return Nothing
+
+genTransportHandle :: IO TransportHandle
+genTransportHandle = do
+	annexstate <- newMVar =<< Annex.new =<< Git.CurrentRepo.get
+	g <- Annex.repo <$> readMVar annexstate
+	return $ TransportHandle g annexstate

RemoteDaemon/Transport/Ssh.hs

@@ -8,13 +8,11 @@
 module RemoteDaemon.Transport.Ssh (transport) where
 
 import Common.Annex
-import qualified Annex
 import RemoteDaemon.Types
-import qualified RemoteDaemon.Transport.Ssh.Types as SshRemote
+import RemoteDaemon.Common
 import Remote.Helper.Ssh
+import qualified RemoteDaemon.Transport.Ssh.Types as SshRemote
 import Utility.SimpleProtocol
-import qualified Git
-import Annex.CatFile
 import Git.Command
 
 import Control.Concurrent.Chan
@@ -22,13 +20,12 @@ import Control.Concurrent.Async
 import System.Process (std_in, std_out)
 
 transport :: Transport
-transport r remotename annexstate ichan ochan = Annex.eval annexstate $ do
-	v <- git_annex_shell r "notifychanges" [] []
+transport r remotename transporthandle ichan ochan = do
+	v <- liftAnnex transporthandle $ git_annex_shell r "notifychanges" [] []
 	case v of
 		Nothing -> noop
-		Just (cmd, params) -> liftIO $ go cmd (toCommand params)
+		Just (cmd, params) -> go cmd (toCommand params)
   where
-	send msg = writeChan ochan (msg remotename)
 	go cmd params = do
 		(Just toh, Just fromh, _, pid) <- createProcess (proc cmd params)
 			{ std_in = CreatePipe
@@ -45,9 +42,9 @@ transport r remotename annexstate ichan ochan = Annex.eval annexstate $ do
 			l <- hGetLine fromh
 			case parseMessage l of
 				Just SshRemote.READY -> send CONNECTED
-				Just (SshRemote.CHANGED refs) ->
-					Annex.eval annexstate $
-						fetchNew remotename refs
+				Just (SshRemote.CHANGED shas) ->
+					whenM (checkNewShas transporthandle shas) $
+						fetch
 				Nothing -> shutdown
 
 		-- The only control message that matters is STOP.
@@ -66,10 +63,10 @@ transport r remotename annexstate ichan ochan = Annex.eval annexstate $ do
 		void $ tryIO $ concurrently fromshell handlecontrol
 		shutdown
 
--- Check if any of the shas are actally new, to avoid unnecessary fetching.
-fetchNew :: RemoteName -> [Git.Sha] -> Annex ()
-fetchNew remotename = check
-  where
-	check [] = void $ inRepo $ runBool [Param "fetch", Param remotename]
-	check (r:rs) = maybe (check rs) (const noop)
-		=<< catObjectDetails r
+	send msg = writeChan ochan (msg remotename)
+
+	fetch = do
+		send SYNCING
+		ok <- inLocalRepo transporthandle $
+			runBool [Param "fetch", Param remotename]
+		send (DONESYNCING ok)

RemoteDaemon/Types.hs

@@ -18,14 +18,20 @@ import Control.Concurrent
 
 -- A Transport for a particular git remote consumes some messages
 -- from a Chan, and emits others to another Chan.
-type Transport = Git.Repo -> RemoteName -> Annex.AnnexState -> Chan Consumed -> Chan Emitted -> IO ()
+type Transport = RemoteRepo -> RemoteName -> TransportHandle -> Chan Consumed -> Chan Emitted -> IO ()
+
+type RemoteRepo = Git.Repo
+type LocalRepo = Git.Repo
+
+-- All Transports share a single AnnexState MVar
+data TransportHandle = TransportHandle LocalRepo (MVar Annex.AnnexState)
 
 -- Messages that the daemon emits.
 data Emitted
 	= CONNECTED RemoteName
 	| DISCONNECTED RemoteName
 	| SYNCING RemoteName
-	| DONESYNCING RemoteName Bool
+	| DONESYNCING Bool RemoteName
 
 -- Messages that the deamon consumes.
 data Consumed
@@ -45,8 +51,8 @@ instance Proto.Sendable Emitted where
 		["DISCONNECTED", Proto.serialize remote]
 	formatMessage (SYNCING remote) =
 		["SYNCING", Proto.serialize remote]
-	formatMessage (DONESYNCING remote status) =
-		["DONESYNCING", Proto.serialize remote, Proto.serialize status]
+	formatMessage (DONESYNCING status remote) =
+		["DONESYNCING", Proto.serialize status, Proto.serialize remote]
 
 instance Proto.Sendable Consumed where
 	formatMessage PAUSE = ["PAUSE"]

doc/design/git-remote-daemon.mdwn

@@ -82,7 +82,7 @@ the webapp.
   Indicates that a pull or a push with a remote is in progress.
   Always followed by DONESYNCING.
 
-* `DONESYNCING $remote 1|0`
+* `DONESYNCING 1|0 $remote`
 
   Indicates that syncing with a remote is done, and either succeeded
   (1) or failed (0).