115 lines
3.1 KiB
Haskell
115 lines
3.1 KiB
Haskell
|
{- git-remote-daemon core
|
||
|
|
-
|
||
|
|
- Copyright 2014 Joey Hess <joey@kitenet.net>
|
||
|
|
-
|
||
|
|
- Licensed under the GNU GPL version 3 or higher.
|
||
|
|
-}
|
||
|
|
|
||
|
|
module RemoteDaemon.Core (runForeground) where
|
||
|
|
|
||
|
|
import qualified Annex
|
||
|
|
import Common
|
||
|
|
import Types.GitConfig
|
||
|
|
import RemoteDaemon.Types
|
||
|
|
import RemoteDaemon.Transport
|
||
|
|
import qualified Git
|
||
|
|
import qualified Git.Types as Git
|
||
|
|
import qualified Git.CurrentRepo
|
||
|
|
import Utility.SimpleProtocol
|
||
|
|
|
||
|
|
import Control.Concurrent.Async
|
||
|
|
import Control.Concurrent.Chan
|
||
|
|
import Network.URI
|
||
|
|
import qualified Data.Map as M
|
||
|
|
|
||
|
|
runForeground :: IO ()
|
||
|
|
runForeground = do
|
||
|
|
ichan <- newChan :: IO (Chan Consumed)
|
||
|
|
ochan <- newChan :: IO (Chan Emitted)
|
||
|
|
|
||
|
|
void $ async $ controller ichan ochan
|
||
|
|
|
||
|
|
let reader = forever $ do
|
||
|
|
l <- getLine
|
||
|
|
case parseMessage l of
|
||
|
|
Nothing -> error $ "protocol error: " ++ l
|
||
|
|
Just cmd -> writeChan ichan cmd
|
||
|
|
let writer = forever $ do
|
||
|
|
msg <- readChan ochan
|
||
|
|
putStrLn $ unwords $ formatMessage msg
|
||
|
|
hFlush stdout
|
||
|
|
|
||
|
|
-- If the reader or writer fails, for example because stdin/stdout
|
||
|
|
-- gets closed, kill the other one, and throw an exception which
|
||
|
|
-- will take down the daemon.
|
||
|
|
void $ concurrently reader writer
|
||
|
|
|
||
|
|
type RemoteMap = M.Map Git.Repo (IO (), Chan Consumed)
|
||
|
|
|
||
|
|
-- Runs the transports, dispatching messages to them, and handling
|
||
|
|
-- the main control messages.
|
||
|
|
controller :: Chan Consumed -> Chan Emitted -> IO ()
|
||
|
|
controller ichan ochan = do
|
||
|
|
m <- getRemoteMap ochan
|
||
|
|
startrunning m
|
||
|
|
go False m
|
||
|
|
where
|
||
|
|
go paused m = do
|
||
|
|
cmd <- readChan ichan
|
||
|
|
case cmd of
|
||
|
|
RELOAD -> do
|
||
|
|
m' <- getRemoteMap 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)
|
||
|
|
PAUSE -> do
|
||
|
|
stoprunning m
|
||
|
|
go True m
|
||
|
|
RESUME -> do
|
||
|
|
when paused $
|
||
|
|
startrunning m
|
||
|
|
go False m
|
||
|
|
STOP -> exitSuccess
|
||
|
|
-- All remaining messages are sent to
|
||
|
|
-- all Transports.
|
||
|
|
msg -> do
|
||
|
|
unless paused $
|
||
|
|
forM_ chans (`writeChan` msg)
|
||
|
|
go paused m
|
||
|
|
where
|
||
|
|
chans = map snd (M.elems m)
|
||
|
|
|
||
|
|
startrunning m = forM_ (M.elems m) startrunning'
|
||
|
|
startrunning' (transport, _) = void $ async transport
|
||
|
|
|
||
|
|
-- Ask the transport nicely to stop.
|
||
|
|
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
|
||
|
|
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
|
||
|
|
| remoteAnnexSync (extractRemoteGitConfig r (Git.repoDescribe r)) -> do
|
||
|
|
ichan <- newChan :: IO (Chan Consumed)
|
||
|
|
return $ Just
|
||
|
|
( r
|
||
|
|
, (transport r (Git.repoDescribe r) annexstate ichan ochan, ichan)
|
||
|
|
)
|
||
|
|
_ -> return Nothing
|
||
|
|
_ -> return Nothing
|