Merge branch 'master' of ssh://git-annex.branchable.com

.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

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
 	}

Command/TransferKeys.hs

@@ -16,8 +16,7 @@ import Logs.Location
 import Annex.Transfer
 import qualified Remote
 import Types.Key
-
+import Utility.SimpleProtocol (ioHandles)
-import GHC.IO.Handle
 
 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

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 ()

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)

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
+		hPutStrLn writeh $ unwords $ formatMessage msg
-		hFlush stdout
+		hFlush writeh
+	let controller = runController ichan ochan
 	
-	-- If the reader or writer fails, for example because stdin/stdout
+	-- If any thread fails, the rest will be killed.
-	-- gets closed, kill the other one, and throw an exception which
+	void $ tryIO $
-	-- will take down the daemon.
+		reader `concurrently` writer `concurrently` controller
-	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 ()
+runController :: Chan Consumed -> Chan Emitted -> IO ()
-controller ichan ochan = do
+runController 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 +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 :: TransportHandle -> Chan Emitted -> IO RemoteMap
-genRemoteMap annexstate ochan = M.fromList . catMaybes <$> mapM gen rs
+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

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
+transport r remotename transporthandle ichan ochan = do
-	v <- git_annex_shell r "notifychanges" [] []
+	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) ->
+				Just (SshRemote.CHANGED shas) ->
-					Annex.eval annexstate $
+					whenM (checkNewShas transporthandle shas) $
-						fetchNew remotename refs
+						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.
+	send msg = writeChan ochan (msg remotename)
-fetchNew :: RemoteName -> [Git.Sha] -> Annex ()
+
-fetchNew remotename = check
+	fetch = do
-  where
+		send SYNCING
-	check [] = void $ inRepo $ runBool [Param "fetch", Param remotename]
+		ok <- inLocalRepo transporthandle $
-	check (r:rs) = maybe (check rs) (const noop)
+			runBool [Param "fetch", Param remotename]
-		=<< catObjectDetails r
+		send (DONESYNCING ok)

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) =
+	formatMessage (DONESYNCING status remote) =
-		["DONESYNCING", Proto.serialize remote, Proto.serialize status]
+		["DONESYNCING", Proto.serialize status, Proto.serialize remote]
 
 instance Proto.Sendable Consumed where
 	formatMessage PAUSE = ["PAUSE"]

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)

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.

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.

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/).