From 3a7068ffe621d273fe8dfb22ef9073b7a5af1131 Mon Sep 17 00:00:00 2001 From: Fraser Tweedale Date: Tue, 8 Apr 2014 19:49:43 +1000 Subject: [PATCH 1/7] fix build failure with flags -Webapp -Quvi --- Annex.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/Annex.hs b/Annex.hs index f00276e2fc..8233e18b9f 100644 --- a/Annex.hs +++ b/Annex.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PackageImports #-} module Annex ( Annex, @@ -63,7 +63,9 @@ import Types.DesktopNotify import Types.CleanupActions import qualified Data.Map as M import qualified Data.Set as S +#ifdef WITH_QUVI import Utility.Quvi (QuviVersion) +#endif {- git-annex's monad is a ReaderT around an AnnexState stored in a MVar. - This allows modifying the state in an exception-safe fashion. @@ -117,7 +119,9 @@ data AnnexState = AnnexState , useragent :: Maybe String , errcounter :: Integer , unusedkeys :: Maybe (S.Set Key) +#ifdef WITH_QUVI , quviversion :: Maybe QuviVersion +#endif , existinghooks :: M.Map Git.Hook.Hook Bool , desktopnotify :: DesktopNotify } @@ -160,7 +164,9 @@ newState c r = AnnexState , useragent = Nothing , errcounter = 0 , unusedkeys = Nothing +#ifdef WITH_QUVI , quviversion = Nothing +#endif , existinghooks = M.empty , desktopnotify = mempty } From fbb30eac1310eabbc23f131773f8936c0c5da7f5 Mon Sep 17 00:00:00 2001 From: Fraser Tweedale Date: Tue, 8 Apr 2014 23:37:04 +1000 Subject: [PATCH 2/7] .gitignore: add cabal sandbox dir and config files --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index b842cc93c1..624675d275 100644 --- a/.gitignore +++ b/.gitignore @@ -23,6 +23,9 @@ html dist # Sandboxed builds cabal-dev +.cabal-sandbox +cabal.sandbox.config +cabal.config # Project-local emacs configuration .dir-locals.el # OSX related From b3b07ab330a43086fa552983a252d1c0c40c86ab Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Apr 2014 12:09:24 -0400 Subject: [PATCH 3/7] clarify --- doc/design/git-remote-daemon.mdwn | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/design/git-remote-daemon.mdwn b/doc/design/git-remote-daemon.mdwn index db56bd6332..5599a6f305 100644 --- a/doc/design/git-remote-daemon.mdwn +++ b/doc/design/git-remote-daemon.mdwn @@ -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..annex-sync` to configure whether to sync with a + particular remote. + * `STOP` Shut down git-remote-daemon From fa0cf81b260abe043d416a7d7ef0da5f44e8ea70 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Apr 2014 13:41:36 -0400 Subject: [PATCH 4/7] cleaned up AnnexState handling in transports --- Config.hs | 5 +++- RemoteDaemon/Common.hs | 42 +++++++++++++++++++++++++++++++ RemoteDaemon/Core.hs | 41 +++++++++++++++++------------- RemoteDaemon/Transport/Ssh.hs | 33 +++++++++++------------- RemoteDaemon/Types.hs | 14 ++++++++--- doc/design/git-remote-daemon.mdwn | 2 +- 6 files changed, 95 insertions(+), 42 deletions(-) create mode 100644 RemoteDaemon/Common.hs diff --git a/Config.hs b/Config.hs index 10d4fd190f..32644263f2 100644 --- a/Config.hs +++ b/Config.hs @@ -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 0000000000..29aeb00d3b --- /dev/null +++ b/RemoteDaemon/Common.hs @@ -0,0 +1,42 @@ +{- git-remote-daemon utilities + - + - Copyright 2014 Joey Hess + - + - 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 8960bf8d37..cd4a0aaeda 100644 --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -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 diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs index 8f4d007e8f..557a3dce90 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 5cb0ef7584..025c602df0 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/doc/design/git-remote-daemon.mdwn b/doc/design/git-remote-daemon.mdwn index 5599a6f305..ad41fa4474 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). From 9a4a3bfb43bcd404ed59ea3bdaf7daa5757d8008 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Apr 2014 13:51:49 -0400 Subject: [PATCH 5/7] fix STOP --- RemoteDaemon/Core.hs | 14 ++++++-------- doc/design/git-remote-daemon.mdwn | 2 -- 2 files changed, 6 insertions(+), 10 deletions(-) diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs index cd4a0aaeda..a220e58074 100644 --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -29,8 +29,6 @@ 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 @@ -40,18 +38,18 @@ runForeground = do msg <- readChan ochan putStrLn $ unwords $ formatMessage msg hFlush stdout + 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 +runController :: Chan Consumed -> Chan Emitted -> IO () +runController ichan ochan = do h <- genTransportHandle m <- genRemoteMap h ochan startrunning m diff --git a/doc/design/git-remote-daemon.mdwn b/doc/design/git-remote-daemon.mdwn index ad41fa4474..6b8e0646ff 100644 --- a/doc/design/git-remote-daemon.mdwn +++ b/doc/design/git-remote-daemon.mdwn @@ -160,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. From cbcb7f50d87a240fca7c3fb3f1caeb6605959f39 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Apr 2014 14:02:25 -0400 Subject: [PATCH 6/7] remotedaemon: avoid extraneous stdout output --- Command/TransferKeys.hs | 21 +++------------------ RemoteDaemon/Core.hs | 7 ++++--- Utility/SimpleProtocol.hs | 19 +++++++++++++++++-- 3 files changed, 24 insertions(+), 23 deletions(-) diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 8f4498eb14..05129005b7 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 diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs index a220e58074..b32be98ef4 100644 --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -26,18 +26,19 @@ import qualified Data.Map as M runForeground :: IO () runForeground = do + (readh, writeh) <- ioHandles ichan <- newChan :: IO (Chan Consumed) ochan <- newChan :: IO (Chan Emitted) 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 any thread fails, the rest will be killed. diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs index 9cc25bc913..1119cd986a 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) From e4ea97427bd2e879ad57e28ea689566b1e1c4e39 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Apr 2014 15:37:22 -0400 Subject: [PATCH 7/7] add contribute page, mention haskell on front page --- doc/contribute.mdwn | 12 ++++++++++++ doc/index.mdwn | 3 ++- 2 files changed, 14 insertions(+), 1 deletion(-) create mode 100644 doc/contribute.mdwn diff --git a/doc/contribute.mdwn b/doc/contribute.mdwn new file mode 100644 index 0000000000..5dc3eb5edd --- /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/index.mdwn b/doc/index.mdwn index 57bfe2408c..9536ee148b 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/).