diff options
| -rw-r--r-- | Command/TransferKeys.hs | 21 | ||||
| -rw-r--r-- | Config.hs | 5 | ||||
| -rw-r--r-- | RemoteDaemon/Common.hs | 42 | ||||
| -rw-r--r-- | RemoteDaemon/Core.hs | 62 | ||||
| -rw-r--r-- | RemoteDaemon/Transport/Ssh.hs | 33 | ||||
| -rw-r--r-- | RemoteDaemon/Types.hs | 14 | ||||
| -rw-r--r-- | Utility/SimpleProtocol.hs | 19 | ||||
| -rw-r--r-- | doc/contribute.mdwn | 12 | ||||
| -rw-r--r-- | doc/design/git-remote-daemon.mdwn | 8 | ||||
| -rw-r--r-- | doc/index.mdwn | 3 |
10 files changed, 143 insertions, 76 deletions
diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 8f4498eb1..05129005b 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -16,8 +16,7 @@ import Logs.Location import Annex.Transfer import qualified Remote import Types.Key - -import GHC.IO.Handle +import Utility.SimpleProtocol (ioHandles) data TransferRequest = TransferRequest Direction Remote Key AssociatedFile @@ -29,7 +28,8 @@ seek :: CommandSeek seek = withNothing start start :: CommandStart -start = withHandles $ \(readh, writeh) -> do +start = do + (readh, writeh) <- liftIO ioHandles runRequests readh writeh runner stop where @@ -44,21 +44,6 @@ start = withHandles $ \(readh, writeh) -> do download (Remote.uuid remote) key file forwardRetry $ \p -> getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p -{- stdin and stdout are connected with the caller, to be used for - - communication with it. But doing a transfer might involve something - - that tries to read from stdin, or write to stdout. To avoid that, close - - stdin, and duplicate stderr to stdout. Return two new handles - - that are duplicates of the original (stdin, stdout). -} -withHandles :: ((Handle, Handle) -> Annex a) -> Annex a -withHandles a = do - readh <- liftIO $ hDuplicate stdin - writeh <- liftIO $ hDuplicate stdout - liftIO $ do - nullh <- openFile devNull ReadMode - nullh `hDuplicateTo` stdin - stderr `hDuplicateTo` stdout - a (readh, writeh) - runRequests :: Handle -> Handle @@ -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 () diff --git a/RemoteDaemon/Common.hs b/RemoteDaemon/Common.hs new file mode 100644 index 000000000..29aeb00d3 --- /dev/null +++ b/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) diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs index 8960bf8d3..b32be98ef 100644 --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -10,76 +10,79 @@ 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 runForeground :: IO () runForeground = do + (readh, writeh) <- ioHandles ichan <- newChan :: IO (Chan Consumed) ochan <- newChan :: IO (Chan Emitted) - void $ async $ controller ichan ochan - let reader = forever $ do - l <- getLine + l <- hGetLine readh 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 + hPutStrLn writeh $ unwords $ formatMessage msg + hFlush writeh + let controller = runController ichan ochan - -- 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 + -- If any thread fails, the rest will be killed. + void $ tryIO $ + reader `concurrently` writer `concurrently` controller 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 +runController :: Chan Consumed -> Chan Emitted -> IO () +runController ichan ochan = do + 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 +93,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 +106,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 diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs index 8f4d007e8..557a3dce9 100644 --- a/RemoteDaemon/Transport/Ssh.hs +++ b/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) diff --git a/RemoteDaemon/Types.hs b/RemoteDaemon/Types.hs index 5cb0ef758..025c602df 100644 --- a/RemoteDaemon/Types.hs +++ b/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"] diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs index 9cc25bc91..1119cd986 100644 --- a/Utility/SimpleProtocol.hs +++ b/Utility/SimpleProtocol.hs @@ -16,12 +16,13 @@ module Utility.SimpleProtocol ( parse1, parse2, parse3, + ioHandles, ) where -import Control.Applicative import Data.Char +import GHC.IO.Handle -import Utility.Misc +import Common -- Messages that can be sent. class Sendable m where @@ -73,3 +74,17 @@ parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 splitWord :: String -> (String, String) splitWord = separate isSpace + +{- When a program speaks a simple protocol over stdio, any other output + - to stdout (or anything that attempts to read from stdin) + - will mess up the protocol. To avoid that, close stdin, and + - and duplicate stderr to stdout. Return two new handles + - that are duplicates of the original (stdin, stdout). -} +ioHandles :: IO (Handle, Handle) +ioHandles = do + readh <- hDuplicate stdin + writeh <- hDuplicate stdout + nullh <- openFile devNull ReadMode + nullh `hDuplicateTo` stdin + stderr `hDuplicateTo` stdout + return (readh, writeh) diff --git a/doc/contribute.mdwn b/doc/contribute.mdwn new file mode 100644 index 000000000..5dc3eb5ed --- /dev/null +++ b/doc/contribute.mdwn @@ -0,0 +1,12 @@ +Help make git-annex better! + +* This website is a wiki, so you can edit and improve any page. +* Write a [[new_tip|tips]] explaining how to accomplish something with + git-annex. +* [[download]] the source code and send patches! +* If you know Haskell, git-annex has lots of Haskell code that + could be improved. See the [[coding_style]] and have at it. +* If you don't know Haskell, git-annex has many other coding opportunities. + You could work to improve the Android port (Java etc) or improve the + Javascript and CSS of the git-annex webapp, or work on porting libraries + needed by the Windows port. diff --git a/doc/design/git-remote-daemon.mdwn b/doc/design/git-remote-daemon.mdwn index db56bd633..6b8e0646f 100644 --- a/doc/design/git-remote-daemon.mdwn +++ b/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). @@ -114,6 +114,10 @@ the webapp. Indicates that configs have changed. Daemon should reload .git/config and/or restart. + Possible config changes include adding a new remote, removing a remote, + or setting `remote.<name>.annex-sync` to configure whether to sync with a + particular remote. + * `STOP` Shut down git-remote-daemon @@ -156,8 +160,6 @@ No pushing is done for CHANGED, since git handles ssh natively. TODO: -* It already detects changes and pulls, but it then dies with a protocol - error. * Remote system might not be available. Find a smart way to detect it, ideally w/o generating network traffic. One way might be to check if the ssh connection caching control socket exists, for example. diff --git a/doc/index.mdwn b/doc/index.mdwn index 57bfe2408..9536ee148 100644 --- a/doc/index.mdwn +++ b/doc/index.mdwn @@ -39,7 +39,8 @@ files with git. ---- -git-annex is [[Free Software|license]] +git-annex is [[Free Software|license]], written in Haskell. +You can [[contribute]]! git-annex's wiki is powered by [Ikiwiki](http://ikiwiki.info/) and hosted by [Branchable](http://branchable.com/). |