packages feed

git-annex 6.20160923 → 6.20161012

raw patch · 28 files changed

+400/−267 lines, 28 files

Files

Annex.hs view
@@ -139,6 +139,7 @@ 	, activeremotes :: MVar (S.Set (Types.Remote.RemoteA Annex)) 	, keysdbhandle :: Maybe Keys.DbHandle 	, cachedcurrentbranch :: Maybe Git.Branch+	, cachedgitenv :: Maybe [(String, String)] 	}  newState :: GitConfig -> Git.Repo -> IO AnnexState@@ -189,6 +190,7 @@ 		, activeremotes = emptyactiveremotes 		, keysdbhandle = Nothing 		, cachedcurrentbranch = Nothing+		, cachedgitenv = Nothing 		}  {- Makes an Annex state object for the specified git repo.@@ -241,10 +243,10 @@ 	mvar <- ask 	liftIO $ modifyMVar_ mvar $ return . modifier -withState :: (AnnexState -> (AnnexState, b)) -> Annex b+withState :: (AnnexState -> IO (AnnexState, b)) -> Annex b withState modifier = do 	mvar <- ask-	liftIO $ modifyMVar mvar $ return . modifier+	liftIO $ modifyMVar mvar modifier  {- Sets a flag to True -} setFlag :: String -> Annex ()
Annex/CatFile.hs view
@@ -49,6 +49,11 @@ 	h <- catFileHandle 	liftIO $ Git.CatFile.catObject h ref +catObjectMetaData :: Git.Ref -> Annex (Maybe (Integer, ObjectType))+catObjectMetaData ref = do+	h <- catFileHandle+	liftIO $ Git.CatFile.catObjectMetaData h ref+ catTree :: Git.Ref -> Annex [(FilePath, FileMode)] catTree ref = do 	h <- catFileHandle@@ -83,13 +88,20 @@  - nothing is using the handles, eg at shutdown. -} catFileStop :: Annex () catFileStop = do-	m <- Annex.withState $ \s ->+	m <- Annex.withState $ pure . \s -> 		(s { Annex.catfilehandles = M.empty }, Annex.catfilehandles s) 	liftIO $ mapM_ Git.CatFile.catFileStop (M.elems m)  {- From ref to a symlink or a pointer file, get the key. -} catKey :: Ref -> Annex (Maybe Key)-catKey ref = parseLinkOrPointer <$> catObject ref+catKey ref = go =<< catObjectMetaData ref+  where+	go (Just (sz, _))+		-- Avoid catting large files, that cannot be symlinks or+		-- pointer files, which would require buffering their+		-- content in memory, as well as a lot of IO.+		| sz <= maxPointerSz = parseLinkOrPointer <$> catObject ref+	go _ = return Nothing  {- Gets a symlink target. -} catSymLinkTarget :: Sha -> Annex String
Annex/DirHashes.hs view
@@ -14,6 +14,7 @@ 	dirHashes, 	hashDirMixed, 	hashDirLower,+	display_32bits_as_dir ) where  import Data.Bits@@ -74,7 +75,7 @@  -} display_32bits_as_dir :: Word32 -> String display_32bits_as_dir w = trim $ swap_pairs cs-  where +  where 	-- Need 32 characters to use. To avoid inaverdently making 	-- a real word, use letters that appear less frequently. 	chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF"
Annex/GitOverlay.hs view
@@ -22,9 +22,28 @@ withIndexFile f a = do 	f' <- liftIO $ indexEnvVal f 	withAltRepo-		(\g -> addGitEnv g indexEnv f')+		(usecachedgitenv $ \g -> liftIO $ addGitEnv g indexEnv f') 		(\g g' -> g' { gitEnv = gitEnv g }) 		a+  where+	-- This is an optimisation. Since withIndexFile is run repeatedly,+	-- and addGitEnv uses the slow copyGitEnv when gitEnv is Nothing, +	-- we cache the copied environment the first time, and reuse it in+	-- subsequent calls.+	--+	-- (This could be done at another level; eg when creating the+	-- Git object in the first place, but it's more efficient to let+	-- the enviroment be inherited in all calls to git where it+	-- does not need to be modified.)+	usecachedgitenv m g = case gitEnv g of+		Just _ -> m g+		Nothing -> do+			e <- Annex.withState $ \s -> case Annex.cachedgitenv s of+				Nothing -> do+					e <- copyGitEnv+					return (s { Annex.cachedgitenv = Just e }, e)+				Just e -> return (s, e)+			m (g { gitEnv = Just e })  {- Runs an action using a different git work tree.  -@@ -52,7 +71,7 @@ withWorkTreeRelated :: FilePath -> Annex a -> Annex a withWorkTreeRelated d = withAltRepo modrepo unmodrepo   where-	modrepo g = do+	modrepo g = liftIO $ do 		g' <- addGitEnv g "GIT_COMMON_DIR" =<< absPath (localGitDir g) 		g'' <- addGitEnv g' "GIT_DIR" d 		return (g'' { gitEnvOverridesGitDir = True })@@ -62,7 +81,7 @@ 		}  withAltRepo -	:: (Repo -> IO Repo)+	:: (Repo -> Annex Repo) 	-- ^ modify Repo 	-> (Repo -> Repo -> Repo) 	-- ^ undo modifications; first Repo is the original and second@@ -71,7 +90,7 @@ 	-> Annex a withAltRepo modrepo unmodrepo a = do 	g <- gitRepo-	g' <- liftIO $ modrepo g+	g' <- modrepo g 	q <- Annex.Queue.get 	v <- tryNonAsync $ do 		Annex.changeState $ \s -> s
Annex/Init.hs view
@@ -93,7 +93,8 @@ 		Database.Keys.scanAssociatedFiles 	v <- checkAdjustedClone 	case v of-		NeedUpgradeForAdjustedClone -> void $ upgrade True+		NeedUpgradeForAdjustedClone -> +			void $ upgrade True  versionForAdjustedClone 		InAdjustedClone -> return () 		NotInAdjustedClone -> 			ifM (crippledFileSystem <&&> (not <$> isBareRepo))
Annex/Link.hs view
@@ -26,7 +26,6 @@ import Utility.FileMode  import qualified Data.ByteString.Lazy as L-import Data.Int  type LinkTarget = String @@ -137,7 +136,8 @@  - Only looks at the first line, as pointer files can have subsequent  - lines. -} parseLinkOrPointer :: L.ByteString -> Maybe Key-parseLinkOrPointer = parseLinkOrPointer' . decodeBS . L.take maxPointerSz+parseLinkOrPointer = parseLinkOrPointer' +	. decodeBS . L.take (fromIntegral maxPointerSz)   where  {- Want to avoid buffering really big files in git into@@ -146,7 +146,7 @@  - 8192 bytes is plenty for a pointer to a key.  - Pad some more to allow for any pointer files that might have  - lines after the key explaining what the file is used for. -}-maxPointerSz :: Int64+maxPointerSz :: Integer maxPointerSz = 81920  parseLinkOrPointer' :: String -> Maybe Key
Annex/Locations.hs view
@@ -452,15 +452,25 @@  - can cause existing objects to get lost.  -} keyFile :: Key -> FilePath-keyFile key = replace "/" "%" $ replace ":" "&c" $-	replace "%" "&s" $ replace "&" "&a"  $ key2file key+keyFile = concatMap esc . key2file+  where+	esc '&' = "&a"+	esc '%' = "&s"+	esc ':' = "&c"+	esc '/' = "%"+	esc c = [c]  {- Reverses keyFile, converting a filename fragment (ie, the basename of  - the symlink target) into a key. -} fileKey :: FilePath -> Maybe Key-fileKey file = file2key $-	replace "&a" "&" $ replace "&s" "%" $-		replace "&c" ":" $ replace "%" "/" file+fileKey = file2key . unesc [] +  where+	unesc r [] = reverse r+	unesc r ('%':cs) = unesc ('/':r) cs+	unesc r ('&':'c':cs) = unesc (':':r) cs+	unesc r ('&':'s':cs) = unesc ('%':r) cs+	unesc r ('&':'a':cs) = unesc ('&':r) cs+	unesc r (c:cs) = unesc (c:r) cs  {- for quickcheck -} prop_isomorphic_fileKey :: String -> Bool
Annex/Version.hs view
@@ -22,7 +22,10 @@ latestVersion = "6"  supportedVersions :: [Version]-supportedVersions = ["5", "6"]+supportedVersions = ["3", "5", "6"]++versionForAdjustedClone :: Version+versionForAdjustedClone = "6"  upgradableVersions :: [Version] #ifndef mingw32_HOST_OS
Assistant/DaemonStatus.hs view
@@ -30,7 +30,7 @@ import qualified Data.Text as T  getDaemonStatus :: Assistant DaemonStatus-getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle+getDaemonStatus = (atomically . readTVar) <<~ daemonStatusHandle  modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant () modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ())@@ -40,8 +40,8 @@ 	dstatus <- getAssistant daemonStatusHandle 	liftIO $ do 		(s, b) <- atomically $ do-			r@(!s, _) <- a <$> takeTMVar dstatus-			putTMVar dstatus s+			r@(!s, _) <- a <$> readTVar dstatus+			writeTVar dstatus s 			return r 		sendNotification $ changeNotifier s 		return b@@ -102,7 +102,7 @@ 		flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus 	transfers <- M.fromList <$> getTransfers 	addsync <- calcSyncRemotes-	liftIO $ atomically $ newTMVar $ addsync $ status+	liftIO $ atomically $ newTVar $ addsync $ status 		{ scanComplete = False 		, sanityCheckRunning = False 		, currentTransfers = transfers@@ -162,14 +162,14 @@  - to the caller. -} adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM () adjustTransfersSTM dstatus a = do-	s <- takeTMVar dstatus+	s <- readTVar dstatus 	let !v = a (currentTransfers s)-	putTMVar dstatus $ s { currentTransfers = v }+	writeTVar dstatus $ s { currentTransfers = v }  {- Checks if a transfer is currently running. -} checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool checkRunningTransferSTM dstatus t = M.member t . currentTransfers-	<$> readTMVar dstatus+	<$> readTVar dstatus  {- Alters a transfer's info, if the transfer is in the map. -} alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()@@ -207,14 +207,14 @@ notifyTransfer = do 	dstatus <- getAssistant daemonStatusHandle 	liftIO $ sendNotification-		=<< transferNotifier <$> atomically (readTMVar dstatus)+		=<< transferNotifier <$> atomically (readTVar dstatus)  {- Send a notification when alerts are changed. -} notifyAlert :: Assistant () notifyAlert = do 	dstatus <- getAssistant daemonStatusHandle 	liftIO $ sendNotification-		=<< alertNotifier <$> atomically (readTMVar dstatus)+		=<< alertNotifier <$> atomically (readTVar dstatus)  {- Returns the alert's identifier, which can be used to remove it. -} addAlert :: Alert -> Assistant AlertId
Assistant/Types/DaemonStatus.hs view
@@ -86,8 +86,7 @@  type TransferMap = M.Map Transfer TransferInfo -{- This TMVar is never left empty, so accessing it will never block. -}-type DaemonStatusHandle = TMVar DaemonStatus+type DaemonStatusHandle = TVar DaemonStatus  newDaemonStatus :: IO DaemonStatus newDaemonStatus = DaemonStatus
Assistant/Types/TransferrerPool.hs view
@@ -13,8 +13,7 @@  import Control.Concurrent.STM hiding (check) -{- This TMVar is never left empty. -}-type TransferrerPool = TMVar (MkCheckTransferrer, [TransferrerPoolItem])+type TransferrerPool = TVar (MkCheckTransferrer, [TransferrerPoolItem])  type CheckTransferrer = IO Bool type MkCheckTransferrer = IO (IO Bool)@@ -31,24 +30,22 @@ 	}  newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool-newTransferrerPool c = newTMVarIO (c, [])+newTransferrerPool c = newTVarIO (c, [])  popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int) popTransferrerPool p = do-	(c, l) <- takeTMVar p+	(c, l) <- readTVar p 	case l of-		[] -> do-			putTMVar p (c, [])-			return (Nothing, 0)+		[] -> return (Nothing, 0) 		(i:is) -> do-			putTMVar p (c, is)+			writeTVar p (c, is) 			return $ (Just i, length is)  pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM () pushTransferrerPool p i = do-	(c, l) <- takeTMVar p+	(c, l) <- readTVar p 	let l' = i:l-	putTMVar p (c, l')+	writeTVar p (c, l')  {- Note that making a CheckTransferrer may allocate resources,  - such as a NotificationHandle, so it's important that the returned@@ -56,12 +53,12 @@  - garbage collected. -} mkTransferrerPoolItem :: TransferrerPool -> Transferrer -> IO TransferrerPoolItem mkTransferrerPoolItem p t = do-	mkcheck <- atomically $ fst <$> readTMVar p+	mkcheck <- atomically $ fst <$> readTVar p 	check <- mkcheck 	return $ TransferrerPoolItem (Just t) check  checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer checkNetworkConnections dstatushandle = do-	dstatus <- atomically $ readTMVar dstatushandle+	dstatus <- atomically $ readTVar dstatushandle 	h <- newNotificationHandle False (networkConnectedNotifier dstatus) 	return $ not <$> checkNotification h
Build/BundledPrograms.hs view
@@ -91,6 +91,8 @@ 	-- used to unpack the tarball when upgrading 	, Just "gunzip" 	, Just "tar"+	-- used by runshell to generate locales+	, Just "localedef" #endif 	-- nice, ionice, and nocache are not included in the bundle; 	-- we rely on the system's own version, which may better match
Build/LinuxMkLibs.hs view
@@ -5,8 +5,6 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Main where  import System.Environment@@ -73,18 +71,6 @@ 		[ "#!/bin/sh" 		, "GIT_ANNEX_PROGRAMPATH=\"$0\"" 		, "export GIT_ANNEX_PROGRAMPATH"-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if ! MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)-#define NEED_LOCPATH_WORKAROUND-#endif-#else-#define NEED_LOCPATH_WORKAROUND-#endif-#ifdef NEED_LOCPATH_WORKAROUND-		-- workaround for https://ghc.haskell.org/trac/ghc/ticket/7695-		, "LOCPATH=/dev/null"-		, "export LOCPATH"-#endif 		, "exec \"$GIT_ANNEX_DIR/" ++ exelink ++ "\" --library-path \"$GIT_ANNEX_LD_LIBRARY_PATH\" \"$GIT_ANNEX_DIR/shimmed/" ++ base ++ "/" ++ base ++ "\" \"$@\"" 		] 	modifyFileMode exe $ addModes executeModes
CHANGELOG view
@@ -1,3 +1,36 @@+git-annex (6.20161012) unstable; urgency=medium++  * Optimisations to time it takes git-annex to walk working tree and find+    files to work on. Sped up by around 18%.+  * Optimisations to git-annex branch query and setting, avoiding repeated+    copies of the environment. Speeds up commands like +    "git-annex find --in remote" by over 50%.+  * Optimised git-annex branch log file timestamp parsing.+  * Add "total-size" field to --json-progress output.+  * Make --json-progress output be shown even when the size of a object+    is not known.+  * Multiple external special remote processes for the same remote will be+    started as needed when using -J. This should not beak any existing+    external special remotes, because running multiple git-annex commands+    at the same time could already start multiple processes for the same+    external special remotes.+  * Linux standalone: Include locale files in the bundle, and generate+    locale definition files for the locales in use when starting runshell.+    (Currently only done for utf-8 locales.)+  * Avoid using a lot of memory when large objects are present in the git+    repository and have to be checked to see if they are a pointed to an+    annexed file. Cases where such memory use could occur included, but+    were not limited to:+    - git commit -a of a large unlocked file (in v5 mode)+    - git-annex adjust when a large file was checked into git directly+  * When auto-upgrading a v3 remote, avoid upgrading to version 6,+    instead keep it at version 5.+  * Support using v3 repositories without upgrading them to v5.+  * sync: Fix bug in adjusted branch merging that could cause recently+    added files to be lost when updating the adjusted branch.++ -- Joey Hess <id@joeyh.name>  Wed, 12 Oct 2016 09:37:41 -0400+ git-annex (6.20160923) unstable; urgency=medium    * Rate limit console progress display updates to 10 per second.
Command/Upgrade.hs view
@@ -26,5 +26,5 @@ 	showStart "upgrade" "." 	whenM (isNothing <$> getVersion) $ do 		initialize Nothing Nothing-	r <- upgrade False+	r <- upgrade False latestVersion 	next $ next $ return r
Command/WebApp.hs view
@@ -154,7 +154,7 @@ 	 - threadstate. -} 	let st = error "annex state not available" 	{- Get a DaemonStatus without running in the Annex monad. -}-	dstatus <- atomically . newTMVar =<< newDaemonStatus+	dstatus <- atomically . newTVar =<< newDaemonStatus 	d <- newAssistantData st dstatus 	urlrenderer <- newUrlRenderer 	v <- newEmptyMVar
Git/CatFile.hs view
@@ -16,6 +16,7 @@ 	catCommit, 	catObject, 	catObjectDetails,+	catObjectMetaData, ) where  import System.IO@@ -37,21 +38,28 @@ import Git.FilePath import qualified Utility.CoProcess as CoProcess -data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo+data CatFileHandle = CatFileHandle +	{ catFileProcess :: CoProcess.CoProcessHandle+	, checkFileProcess :: CoProcess.CoProcessHandle+	}  catFileStart :: Repo -> IO CatFileHandle catFileStart = catFileStart' True  catFileStart' :: Bool -> Repo -> IO CatFileHandle-catFileStart' restartable repo = do-	coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable+catFileStart' restartable repo = CatFileHandle+	<$> startp "--batch"+	<*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)"+  where+	startp p = CoProcess.rawMode =<< gitCoProcessStart restartable 		[ Param "cat-file"-		, Param "--batch"+		, Param p 		] repo-	return $ CatFileHandle coprocess repo  catFileStop :: CatFileHandle -> IO ()-catFileStop (CatFileHandle p _) = CoProcess.stop p+catFileStop h = do+	CoProcess.stop (catFileProcess h)+	CoProcess.stop (checkFileProcess h)  {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString@@ -68,31 +76,50 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object  catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))-catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive+catObjectDetails h object = query (catFileProcess h) object $ \from -> do+	header <- hGetLine from+	case parseResp object header of+		Just (ParsedResp sha size objtype) -> do+			content <- S.hGet from (fromIntegral size)+			eatchar '\n' from+			return $ Just (L.fromChunks [content], sha, objtype)+		Just DNE -> return Nothing+		Nothing -> error $ "unknown response from git cat-file " ++ show (header, object)   where-	query = fromRef object-	send to = hPutStrLn to query-	receive from = do-		header <- hGetLine from-		case words header of-			[sha, objtype, size]-				| length sha == shaSize ->-					case (readObjectType objtype, reads size) of-						(Just t, [(bytes, "")]) -> readcontent t bytes from sha-						_ -> dne-				| otherwise -> dne-			_-				| header == fromRef object ++ " missing" -> dne-				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, query)-	readcontent objtype bytes from sha = do-		content <- S.hGet from bytes-		eatchar '\n' from-		return $ Just (L.fromChunks [content], Ref sha, objtype)-	dne = return Nothing 	eatchar expected from = do 		c <- hGetChar from 		when (c /= expected) $ 			error $ "missing " ++ (show expected) ++ " from git cat-file"++{- Gets the size and type of an object, without reading its content. -}+catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType))+catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do+	resp <- hGetLine from+	case parseResp object resp of+		Just (ParsedResp _ size objtype) ->+			return $ Just (size, objtype)+		Just DNE -> return Nothing+		Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object)++data ParsedResp = ParsedResp Sha Integer ObjectType | DNE++query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a+query hdl object receive = CoProcess.query hdl send receive+  where+	send to = hPutStrLn to (fromRef object)++parseResp :: Ref -> String -> Maybe ParsedResp+parseResp object l = case words l of+	[sha, objtype, size]+		| length sha == shaSize ->+			case (readObjectType objtype, reads size) of+				(Just t, [(bytes, "")]) -> +					Just $ ParsedResp (Ref sha) bytes t+				_ -> Nothing+		| otherwise -> Nothing+	_+		| l == fromRef object ++ " missing" -> Just DNE+		| otherwise -> Nothing  {- Gets a list of files and directories in a tree. (Not recursive.) -} catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)]
Git/Env.hs view
@@ -18,22 +18,26 @@  - does not have any gitEnv yet. -} adjustGitEnv :: Repo -> ([(String, String)] -> [(String, String)]) -> IO Repo adjustGitEnv g adj = do-	e <- maybe copyenv return (gitEnv g)+	e <- maybe copyGitEnv return (gitEnv g) 	let e' = adj e 	return $ g { gitEnv = Just e' }   where-	copyenv = do++{- Copies the current environment, so it can be adjusted when running a git+ - command. -}+copyGitEnv :: IO [(String, String)]+copyGitEnv = do #ifdef __ANDROID__-		{- This should not be necessary on Android, but there is some-		 - weird getEnvironment breakage. See-		 - https://github.com/neurocyte/ghc-android/issues/7-		 - Use getEnv to get some key environment variables that-		 - git expects to have. -}-		let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"-		let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k-		catMaybes <$> forM keyenv getEnvPair+	{- This should not be necessary on Android, but there is some+	 - weird getEnvironment breakage. See+	 - https://github.com/neurocyte/ghc-android/issues/7+	 - Use getEnv to get some key environment variables that+	 - git expects to have. -}+	let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"+	let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k+	catMaybes <$> forM keyenv getEnvPair #else-		getEnvironment+	getEnvironment #endif  addGitEnv :: Repo -> String -> String -> IO Repo
Git/Tree.hs view
@@ -143,6 +143,16 @@ 	  where 		parent = takeDirectory d +{- Flattens the top N levels of a Tree. -}+flattenTree :: Int -> Tree -> Tree+flattenTree 0 t = t+flattenTree n (Tree l) = Tree (concatMap (go n) l)+  where+	go 0 c = [c]+	go _ b@(TreeBlob _ _ _) = [b]+	go n' (RecordedSubTree _ _ l') = concatMap (go (n'-1)) l'+	go n' (NewSubTree _ l') = concatMap (go (n'-1)) l'+ {- Applies an adjustment to items in a tree.  -  - While less flexible than using getTree and recordTree,@@ -163,41 +173,42 @@ adjustTree adjusttreeitem addtreeitems removefiles r repo = 	withMkTreeHandle repo $ \h -> do 		(l, cleanup) <- liftIO $ lsTreeWithObjects r repo-		(l', _, _) <- go h False [] inTopTree l-		l'' <- adjustlist h inTopTree (const True) l'+		(l', _, _) <- go h False [] 1 inTopTree l+		l'' <- adjustlist h 0 inTopTree (const True) l' 		sha <- liftIO $ mkTree h l'' 		void $ liftIO cleanup 		return sha   where-	go _ wasmodified c _ [] = return (c, wasmodified, [])-	go h wasmodified c intree (i:is)+	go _ wasmodified c _ _ [] = return (c, wasmodified, [])+	go h wasmodified c depth intree (i:is) 		| intree i = case readObjectType (LsTree.typeobj i) of 			Just BlobObject -> do 				let ti = TreeItem (LsTree.file i) (LsTree.mode i) (LsTree.sha i) 				v <- adjusttreeitem ti 				case v of-					Nothing -> go h True c intree is+					Nothing -> go h True c depth intree is 					Just ti'@(TreeItem f m s) -> 						let !modified = wasmodified || ti' /= ti 						    blob = TreeBlob f m s-						in go h modified (blob:c) intree is+						in go h modified (blob:c) depth intree is 			Just TreeObject -> do-				(sl, modified, is') <- go h False [] (beneathSubTree i) is-				sl' <- adjustlist h (inTree i) (beneathSubTree i) sl-				subtree <- if modified || sl' /= sl+				(sl, modified, is') <- go h False [] (depth+1) (beneathSubTree i) is+				sl' <- adjustlist h depth (inTree i) (beneathSubTree i) sl+				let slmodified = sl' /= sl+				subtree <- if modified || slmodified 					then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl' 					else return $ RecordedSubTree (LsTree.file i) (LsTree.sha i) [] -				let !modified' = modified || wasmodified-				go h modified' (subtree : c) intree is'+				let !modified' = modified || slmodified || wasmodified+				go h modified' (subtree : c) depth intree is' 			_ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") 		| otherwise = return (c, wasmodified, i:is) -	adjustlist h ishere underhere l = do+	adjustlist h depth ishere underhere l = do 		let (addhere, rest) = partition ishere addtreeitems 		let l' = filter (not . removed) $ 			map treeItemToTreeContent addhere ++ l 		let inl i = any (\t -> beneathSubTree t i) l'-		let (Tree addunderhere) = treeItemsToTree $+		let (Tree addunderhere) = flattenTree depth $ treeItemsToTree $ 			filter (\i -> underhere i && not (inl i)) rest 		addunderhere' <- liftIO $ mapM (recordSubTree h) addunderhere 		return (addunderhere'++l')
Logs/TimeStamp.hs view
@@ -1,6 +1,6 @@ {- log timestamp parsing  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -9,22 +9,31 @@  module Logs.TimeStamp where +import Utility.PartialPrelude+import Utility.Misc+ import Data.Time.Clock.POSIX import Data.Time+import Data.Ratio #if ! MIN_VERSION_time(1,5,0) import System.Locale #endif-import Control.Applicative-import Prelude  {- Parses how POSIXTime shows itself: "1431286201.113452s"  - Also handles the format with no fractional seconds. -} parsePOSIXTime :: String -> Maybe POSIXTime-#if MIN_VERSION_time(1,5,0)-parsePOSIXTime s = utcTimeToPOSIXSeconds <$> parseTimeM True defaultTimeLocale "%s%Qs" s-#else-parsePOSIXTime s = utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" s-#endif+parsePOSIXTime s = do+	let (sn, sd) = separate (== '.') s+	n <- readi sn+	if null sd +		then return (fromIntegral n)+		else do+			d <- readi sd+			let r = d % (10 ^ (length sd - 1))+			return (fromIntegral n + fromRational r)+  where+	readi :: String -> Maybe Integer+	readi = readish  formatPOSIXTime :: String -> POSIXTime -> String formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t)
Messages/JSON.hs view
@@ -95,16 +95,20 @@  -- Show JSON formatted progress, including the current state of the JSON  -- object for the action being performed.-progress :: Maybe Object -> Integer -> BytesProcessed -> IO ()-progress maction size bytesprocessed = emit $ case maction of+progress :: Maybe Object -> Maybe Integer -> BytesProcessed -> IO ()+progress maction msize bytesprocessed = emit $ case maction of 	Just action -> HM.insert "action" (Object action) o 	Nothing -> o   where 	n = fromBytesProcessed bytesprocessed :: Integer-	Object o = object-		[ "byte-progress" .= n-		, "percent-progress" .= showPercentage 2 (percentage size n)-		]+	Object o = case msize of+		Just size -> object+			[ "byte-progress" .= n+			, "percent-progress" .= showPercentage 2 (percentage size n)+			, "total-size" .= size+			]+		Nothing -> object+			[ "byte-progress" .= n ]  -- A value that can be displayed either normally, or as JSON. data DualDisp = DualDisp
Messages/Progress.hs view
@@ -30,12 +30,11 @@ {- Shows a progress meter while performing a transfer of a key.  - The action is passed a callback to use to update the meter. -} metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a-metered othermeter key a = case keySize key of-	Nothing -> nometer-	Just size -> withMessageState (go $ fromInteger size)+metered othermeter key a = withMessageState $ go (keySize key)   where 	go _ (MessageState { outputType = QuietOutput }) = nometer-	go size (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do+	go Nothing (MessageState { outputType = NormalOutput }) = nometer+	go (Just size) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do 		showOutput 		(progress, meter) <- mkmeter size 		m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do@@ -44,7 +43,7 @@ 		r <- a (combinemeter m) 		liftIO $ clearMeter stdout meter 		return r-	go size (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =+	go (Just size) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = #if WITH_CONCURRENTOUTPUT 		withProgressRegion $ \r -> do 			(progress, meter) <- mkmeter size@@ -57,10 +56,10 @@ 		nometer #endif 	go _ (MessageState { outputType = JSONOutput False }) = nometer-	go size (MessageState { outputType = JSONOutput True }) = do+	go msize (MessageState { outputType = JSONOutput True }) = do 		buf <- withMessageState $ return . jsonBuffer-		m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $-			JSON.progress buf size+		m <- liftIO $ rateLimitMeterUpdate 0.1 msize $+			JSON.progress buf msize 		a (combinemeter m)  	mkmeter size = do
Remote/External.hs view
@@ -1,6 +1,6 @@ {- External special remote interface.  -- - Copyright 2013-2015 Joey Hess <id@joeyh.name>+ - Copyright 2013-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -126,7 +126,8 @@ 				INITREMOTE_SUCCESS -> Just noop 				INITREMOTE_FAILURE errmsg -> Just $ error errmsg 				_ -> Nothing-			liftIO $ atomically $ readTMVar $ externalConfig external+			withExternalState external $+				liftIO . atomically . readTVar . externalConfig  	gitConfigSpecialRemote u c'' "externaltype" externaltype 	return (c'', u)@@ -201,27 +202,28 @@  - While the external remote is processing the Request, it may send  - any number of RemoteRequests, that are handled here.  -- - Only one request can be made at a time, so locking is used.+ - An external remote process can only handle one request at a time.+ - Concurrent requests will start up additional processes.  -  - May throw exceptions, for example on protocol errors, or  - when the repository cannot be used.  -} handleRequest :: External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a handleRequest external req mp responsehandler = -	withExternalLock external $ \lck ->-		handleRequest' lck external req mp responsehandler+	withExternalState external $ \st -> +		handleRequest' st external req mp responsehandler -handleRequest' :: ExternalLock -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a-handleRequest' lck external req mp responsehandler+handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a+handleRequest' st external req mp responsehandler 	| needsPREPARE req = do-		checkPrepared lck external+		checkPrepared st external 		go 	| otherwise = go   where 	go = do-		sendMessage lck external req+		sendMessage st external req 		loop-	loop = receiveMessage lck external responsehandler+	loop = receiveMessage st external responsehandler 		(\rreq -> Just $ handleRemoteRequest rreq >> loop) 		(\msg -> Just $ handleAsyncMessage msg >> loop) @@ -232,23 +234,23 @@ 	handleRemoteRequest (DIRHASH_LOWER k) =  		send $ VALUE $ hashDirLower def k 	handleRemoteRequest (SETCONFIG setting value) =-		liftIO $ atomically $ do-			let v = externalConfig external-			m <- takeTMVar v-			putTMVar v $ M.insert setting value m+		liftIO $ atomically $ modifyTVar' (externalConfig st) $+			M.insert setting value 	handleRemoteRequest (GETCONFIG setting) = do 		value <- fromMaybe "" . M.lookup setting-			<$> liftIO (atomically $ readTMVar $ externalConfig external)+			<$> liftIO (atomically $ readTVar $ externalConfig st) 		send $ VALUE value 	handleRemoteRequest (SETCREDS setting login password) = do-		c <- liftIO $ atomically $ readTMVar $ externalConfig external-		gc <- liftIO $ atomically $ readTMVar $ externalGitConfig external-		c' <- setRemoteCredPair encryptionAlreadySetup c gc (credstorage setting) $-			Just (login, password)-		void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'+		let v = externalConfig st+		c <- liftIO $ atomically $ readTVar v+		let gc = externalGitConfig external+		c' <- setRemoteCredPair encryptionAlreadySetup c gc+			(credstorage setting)+			(Just (login, password))+		void $ liftIO $ atomically $ swapTVar v c' 	handleRemoteRequest (GETCREDS setting) = do-		c <- liftIO $ atomically $ readTMVar $ externalConfig external-		gc <- liftIO $ atomically $ readTMVar $ externalGitConfig external+		c <- liftIO $ atomically $ readTVar $ externalConfig st+		let gc = externalGitConfig external 		creds <- fromMaybe ("", "") <$>  			getRemoteCredPair c gc (credstorage setting) 		send $ CREDS (fst creds) (snd creds)@@ -280,11 +282,11 @@ 		send (VALUE "") -- end of list 	handleRemoteRequest (DEBUG msg) = liftIO $ debugM "external" msg 	handleRemoteRequest (VERSION _) =-		sendMessage lck external $ ERROR "too late to send VERSION"+		sendMessage st external (ERROR "too late to send VERSION")  	handleAsyncMessage (ERROR err) = error $ "external special remote error: " ++ err -	send = sendMessage lck external+	send = sendMessage st external  	credstorage setting = CredPairStorage 		{ credPairFile = base@@ -297,34 +299,32 @@ 	withurl mk uri = handleRemoteRequest $ mk $ 		setDownloader (show uri) OtherDownloader -sendMessage :: Sendable m => ExternalLock -> External -> m -> Annex ()-sendMessage lck external m = -	fromExternal lck external externalSend $ \h ->-		liftIO $ do-			protocolDebug external True line-			hPutStrLn h line-			hFlush h+sendMessage :: Sendable m => ExternalState -> External -> m -> Annex ()+sendMessage st external m = liftIO $ do+	protocolDebug external st True line+	hPutStrLn h line+	hFlush h   where 	line = unwords $ formatMessage m+	h = externalSend st  {- Waits for a message from the external remote, and passes it to the  - apppropriate handler.   -  - If the handler returns Nothing, this is a protocol error.-} receiveMessage-	:: ExternalLock+	:: ExternalState 	-> External  	-> (Response -> Maybe (Annex a)) 	-> (RemoteRequest -> Maybe (Annex a)) 	-> (AsyncMessage -> Maybe (Annex a)) 	-> Annex a-receiveMessage lck external handleresponse handlerequest handleasync =-	go =<< fromExternal lck external externalReceive-		(liftIO . catchMaybeIO . hGetLine)+receiveMessage st external handleresponse handlerequest handleasync =+	go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive st)   where 	go Nothing = protocolError False "" 	go (Just s) = do-		liftIO $ protocolDebug external False s+		liftIO $ protocolDebug external st False s 		case parseMessage s :: Maybe Response of 			Just resp -> maybe (protocolError True s) id (handleresponse resp) 			Nothing -> case parseMessage s :: Maybe RemoteRequest of@@ -335,46 +335,47 @@ 	protocolError parsed s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++ 		if parsed then "(command not allowed at this time)" else "(unable to parse command)" -protocolDebug :: External -> Bool -> String -> IO ()-protocolDebug external sendto line = debugM "external" $ unwords-	[ externalRemoteProgram (externalType external)+protocolDebug :: External -> ExternalState -> Bool -> String -> IO ()+protocolDebug external st sendto line = debugM "external" $ unwords+	[ externalRemoteProgram (externalType external) ++ +		"[" ++ show (externalPid st) ++ "]" 	, if sendto then "<--" else "-->" 	, line 	] -{- Starts up the external remote if it's not yet running,- - and passes a value extracted from its state to an action.- -}-fromExternal :: ExternalLock -> External -> (ExternalState -> v) -> (v -> Annex a) -> Annex a-fromExternal lck external extractor a =-	go =<< liftIO (atomically (tryReadTMVar v))+{- While the action is running, the ExternalState provided to it will not+ - be available to any other calls.+ -+ - Starts up a new process if no ExternalStates are available. -}+withExternalState :: External -> (ExternalState -> Annex a) -> Annex a+withExternalState external = bracket alloc dealloc   where-	go (Just st) = run st-	go Nothing = do-		st <- startExternal $ externalType external-		void $ liftIO $ atomically $ do-			void $ tryReadTMVar v-			putTMVar v st--		{- Handle initial protocol startup; check the VERSION-		 - the remote sends. -}-		receiveMessage lck external-			(const Nothing)-			(checkVersion lck external)-			(const Nothing)--		run st--	run st = a $ extractor st 	v = externalState external -{- Starts an external remote process running, but does not handle checking- - VERSION, etc. -}-startExternal :: ExternalType -> Annex ExternalState-startExternal externaltype = do+	alloc = do+		ms <- liftIO $ atomically $ do+			l <- readTVar v+			case l of+				[] -> return Nothing+				(st:rest) -> do+					writeTVar v rest+					return (Just st)+		maybe (startExternal external) return ms+	+	dealloc st = liftIO $ atomically $ modifyTVar' v (st:)++{- Starts an external remote process running, and checks VERSION. -}+startExternal :: External -> Annex ExternalState+startExternal external = do 	errrelayer <- mkStderrRelayer-	g <- Annex.gitRepo-	liftIO $ do+	st <- start errrelayer =<< Annex.gitRepo+	receiveMessage st external+		(const Nothing)+		(checkVersion st external)+		(const Nothing)+	return st+  where+	start errrelayer g = liftIO $ do 		(cmd, ps) <- findShellCommand basecmd 		let basep = (proc cmd (toCommand ps)) 			{ std_in = CreatePipe@@ -382,23 +383,31 @@ 			, std_err = CreatePipe 			} 		p <- propgit g basep-		(Just hin, Just hout, Just herr, pid) <- +		(Just hin, Just hout, Just herr, ph) <-  			createProcess p `catchIO` runerr 		fileEncoding hin 		fileEncoding hout 		fileEncoding herr 		stderrelay <- async $ errrelayer herr-		checkearlytermination =<< getProcessExitCode pid+		checkearlytermination =<< getProcessExitCode ph+		cv <- newTVarIO $ externalDefaultConfig external+		pv <- newTVarIO Unprepared+		pid <- atomically $ do+			n <- succ <$> readTVar (externalLastPid external)+			writeTVar (externalLastPid external) n+			return n 		return $ ExternalState 			{ externalSend = hin 			, externalReceive = hout+			, externalPid = pid 			, externalShutdown = do 				cancel stderrelay-				void $ waitForProcess pid-			, externalPrepared = Unprepared+				void $ waitForProcess ph+			, externalPrepared = pv+			, externalConfig = cv 			}-  where-	basecmd = externalRemoteProgram externaltype+	+	basecmd = externalRemoteProgram $ externalType external  	propgit g p = do 		environ <- propGitEnv g@@ -415,50 +424,47 @@ 		)  stopExternal :: External -> Annex ()-stopExternal external = liftIO $ stop =<< atomically (tryReadTMVar v)+stopExternal external = liftIO $ do+	l <- atomically $ swapTVar (externalState external) []+	mapM_ stop l   where-	stop Nothing = noop-	stop (Just st) = do-		void $ atomically $ tryTakeTMVar v+	stop st = do 		hClose $ externalSend st 		hClose $ externalReceive st 		externalShutdown st-	v = externalState external  externalRemoteProgram :: ExternalType -> String externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype -checkVersion :: ExternalLock -> External -> RemoteRequest -> Maybe (Annex ())-checkVersion lck external (VERSION v) = Just $+checkVersion :: ExternalState -> External -> RemoteRequest -> Maybe (Annex ())+checkVersion st external (VERSION v) = Just $ 	if v `elem` supportedProtocolVersions 		then noop-		else sendMessage lck external (ERROR "unsupported VERSION")+		else sendMessage st external (ERROR "unsupported VERSION") checkVersion _ _ _ = Nothing  {- If repo has not been prepared, sends PREPARE.  -  - If the repo fails to prepare, or failed before, throws an exception with  - the error message. -}-checkPrepared :: ExternalLock -> External -> Annex ()-checkPrepared lck external = -	fromExternal lck external externalPrepared $ \prepared ->-		case prepared of-			Prepared -> noop-			FailedPrepare errmsg -> error errmsg-			Unprepared -> -				handleRequest' lck external PREPARE Nothing $ \resp ->-					case resp of-						PREPARE_SUCCESS -> Just $-							setprepared Prepared-						PREPARE_FAILURE errmsg -> Just $ do-							setprepared $ FailedPrepare errmsg-							error errmsg-						_ -> Nothing+checkPrepared :: ExternalState -> External -> Annex ()+checkPrepared st external = do+	v <- liftIO $ atomically $ readTVar $ externalPrepared st+	case v of+		Prepared -> noop+		FailedPrepare errmsg -> error errmsg+		Unprepared ->+			handleRequest' st external PREPARE Nothing $ \resp ->+				case resp of+					PREPARE_SUCCESS -> Just $+						setprepared Prepared+					PREPARE_FAILURE errmsg -> Just $ do+						setprepared $ FailedPrepare errmsg+						error errmsg+					_ -> Nothing   where-	setprepared status = liftIO . atomically $ do-		let v = externalState external-		st <- takeTMVar v-		void $ putTMVar v $ st { externalPrepared = status }+	setprepared status = liftIO $ atomically $ void $+		swapTVar (externalPrepared st) status  {- Caches the cost in the git config to avoid needing to start up an  - external special remote every time time just to ask it what its
Remote/External/Types.hs view
@@ -12,8 +12,6 @@ 	External(..), 	newExternal, 	ExternalType,-	ExternalLock,-	withExternalLock, 	ExternalState(..), 	PrepareStatus(..), 	Proto.parseMessage,@@ -44,28 +42,25 @@ import Control.Concurrent.STM import Network.URI --- If the remote is not yet running, the ExternalState TMVar is empty. data External = External 	{ externalType :: ExternalType 	, externalUUID :: UUID-	-- Empty until the remote is running.-	, externalState :: TMVar ExternalState-	-- Empty when a remote is in use.-	, externalLock :: TMVar ExternalLock-	-- Never left empty.-	, externalConfig :: TMVar RemoteConfig-	-- Never left empty.-	, externalGitConfig :: TMVar RemoteGitConfig+	, externalState :: TVar [ExternalState]+	-- ^ Contains states for external special remote processes+	-- that are not currently in use.+	, externalLastPid :: TVar PID+	, externalDefaultConfig :: RemoteConfig+	, externalGitConfig :: RemoteGitConfig 	}  newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex External newExternal externaltype u c gc = liftIO $ External 	<$> pure externaltype 	<*> pure u-	<*> atomically newEmptyTMVar-	<*> atomically (newTMVar ExternalLock)-	<*> atomically (newTMVar c)-	<*> atomically (newTMVar gc)+	<*> atomically (newTVar [])+	<*> atomically (newTVar 0)+	<*> pure c+	<*> pure gc  type ExternalType = String @@ -73,20 +68,14 @@ 	{ externalSend :: Handle 	, externalReceive :: Handle 	, externalShutdown :: IO ()-	, externalPrepared :: PrepareStatus+	, externalPid :: PID+	, externalPrepared :: TVar PrepareStatus+	, externalConfig :: TVar RemoteConfig 	} -data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg---- Constructor is not exported, and only created by newExternal.-data ExternalLock = ExternalLock+type PID = Int -withExternalLock :: External -> (ExternalLock -> Annex a) -> Annex a-withExternalLock external = bracketIO setup cleanup-  where-	setup = atomically $ takeTMVar v-	cleanup = atomically . putTMVar v-	v = externalLock external+data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg  -- Messages that can be sent to the external remote to request it do something. data Request
Test.hs view
@@ -234,6 +234,7 @@ 	, testCase "sync" test_sync 	, testCase "union merge regression" test_union_merge_regression 	, testCase "adjusted branch merge regression" test_adjusted_branch_merge_regression+	, testCase "adjusted branch subtree regression" test_adjusted_branch_subtree_regression 	, testCase "conflict resolution" test_conflict_resolution 	, testCase "conflict resolution (adjusted branch)" test_conflict_resolution_adjusted_branch 	, testCase "conflict resolution movein regression" test_conflict_resolution_movein_regression@@ -1424,6 +1425,27 @@ 		l <- getDirectoryContents "." 		conflictor `elem` l 			@? ("conflictor not present after merge in " ++ what)++{- Regression test for a bug in adjusted branch syncing code, where adding+ - a subtree to an existing tree lost files. -}+test_adjusted_branch_subtree_regression :: Assertion+test_adjusted_branch_subtree_regression = +	whenM Annex.AdjustedBranch.isGitVersionSupported $ +		withtmpclonerepo $ \r -> do+			indir r $ do+				disconnectOrigin+				git_annex "upgrade" [] @? "upgrade failed"+				git_annex "adjust" ["--unlock", "--force"] @? "adjust failed"+				createDirectoryIfMissing True "a/b/c"+				writeFile "a/b/c/d" "foo"+				git_annex "add" ["a/b/c"] @? "add a/b/c failed"+				git_annex "sync" [] @? "sync failed"+				createDirectoryIfMissing True "a/b/x"+				writeFile "a/b/x/y" "foo"+				git_annex "add" ["a/b/x"] @? "add a/b/x failed"+				git_annex "sync" [] @? "sync failed"+				boolSystem "git" [Param "checkout", Param "master"] @? "git checkout master failed"+				doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync")  {- Set up repos as remotes of each other. -} pair :: FilePath -> FilePath -> Assertion
Upgrade.hs view
@@ -26,7 +26,7 @@ needsUpgrade :: Version -> Annex (Maybe String) needsUpgrade v 	| v `elem` supportedVersions = ok-	| v `elem` autoUpgradeableVersions = ifM (upgrade True)+	| v `elem` autoUpgradeableVersions = ifM (upgrade True defaultVersion) 		( ok 		, err "Automatic upgrade failed!" 		)@@ -37,13 +37,14 @@ 		" is not supported. " ++ msg 	ok = return Nothing -upgrade :: Bool -> Annex Bool-upgrade automatic = do+upgrade :: Bool -> Version -> Annex Bool+upgrade automatic destversion = do 	upgraded <- go =<< getVersion 	when upgraded $-		setVersion latestVersion+		setVersion destversion 	return upgraded   where+	go (Just v) | v >= destversion = return True #ifndef mingw32_HOST_OS 	go (Just "0") = Upgrade.V0.upgrade 	go (Just "1") = Upgrade.V1.upgrade
Upgrade/V1.hs view
@@ -19,7 +19,6 @@ import qualified Git import qualified Git.LsFiles as LsFiles import Backend-import Annex.Version import Utility.FileMode import Utility.Tmp import qualified Upgrade.V2@@ -52,16 +51,13 @@ 	showAction "v1 to v2" 	 	ifM (fromRepo Git.repoIsLocalBare)-		( do-			moveContent-			setVersion latestVersion+		( moveContent 		, do 			moveContent 			updateSymlinks 			moveLocationLogs 	 			Annex.Queue.flush-			setVersion latestVersion 		) 	 	Upgrade.V2.upgrade
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20160923+Version: 6.20161012 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>