cleaned up AnnexState handling in transports
This commit is contained in:
parent
b3b07ab330
commit
fa0cf81b26
6 changed files with 95 additions and 42 deletions
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue