cleaned up AnnexState handling in transports

This commit is contained in:
Joey Hess 2014-04-08 13:41:36 -04:00
parent b3b07ab330
commit fa0cf81b26
6 changed files with 95 additions and 42 deletions

View file

@ -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