diff options
Diffstat (limited to 'RemoteDaemon/Core.hs')
-rw-r--r-- | RemoteDaemon/Core.hs | 114 |
1 files changed, 114 insertions, 0 deletions
diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs new file mode 100644 index 000000000..8960bf8d3 --- /dev/null +++ b/RemoteDaemon/Core.hs @@ -0,0 +1,114 @@ +{- 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 |