git-annex 7.20181105 → 7.20181121

raw patch · 36 files changed

+364/−164 lines, 36 filesdep −esqueleto

Dependencies removed: esqueleto

Files

• Annex/Content.hs +2/−0
• Annex/Export.hs +10/−2
• Annex/LockFile.hs +2/−2
• Annex/LockPool/PosixOrPid.hs +3/−3
• Annex/Ssh.hs +1/−1
• Annex/Transfer.hs +8/−3
• Assistant/Unused.hs +1/−1
• CHANGELOG +35/−0
• CmdLine/Action.hs +15/−12
• CmdLine/GitAnnex.hs +2/−2
• Command/Drop.hs +1/−1
• Command/Export.hs +13/−8
• Command/Smudge.hs +16/−5
• Command/Sync.hs +1/−3
• Command/Test.hs +5/−6
• Common.hs +1/−0
• Database/Export.hs +22/−29
• Database/Fsck.hs +3/−5
• Database/Handle.hs +0/−2
• Database/Init.hs +28/−6
• Database/Keys/SQL.hs +13/−22
• Logs/Transfer.hs +1/−1
• Messages.hs +2/−2
• Messages/Concurrent.hs +4/−2
• P2P/Annex.hs +67/−19
• P2P/Protocol.hs +6/−0
• Remote/Git.hs +3/−1
• Remote/Helper/Export.hs +21/−4
• Test.hs +7/−10
• Test/Framework.hs +1/−1
• Utility/DebugLocks.hs +43/−0
• Utility/LockPool/LockHandle.hs +3/−2
• Utility/Url.hs +8/−1
• doc/git-annex-fsck.mdwn +0/−2
• git-annex.cabal +11/−4
• stack.yaml +5/−2

@@ -220,6 +220,8 @@  {- Exclusively locks content, while performing an action that  - might remove it.+ -+ - If locking fails, throws an exception rather than running the action.  -} lockContentForRemoval :: Key -> (ContentRemovalLock -> Annex a) -> Annex a lockContentForRemoval key a = lockContentUsing lock key $ 

@@ -9,10 +9,12 @@  import Annex import Annex.CatFile+import Types import Types.Key-import Types.Remote import qualified Git+import qualified Types.Remote as Remote import Config+import Messages  import qualified Data.Map as M import Control.Applicative@@ -41,5 +43,11 @@ 		, keyChunkNum = Nothing 		} -exportTree :: RemoteConfig -> Bool+exportTree :: Remote.RemoteConfig -> Bool exportTree c = fromMaybe False $ yesNo =<< M.lookup "exporttree" c++warnExportConflict :: Remote -> Annex ()+warnExportConflict r = toplevelWarning True $+	"Export conflict detected. Different trees have been exported to " ++ +	Remote.name r ++ +	". Use git-annex export to resolve this conflict."

@@ -61,7 +61,7 @@ {- Runs an action with an exclusive lock held. If the lock is already  - held, blocks until it becomes free. -} withExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a-withExclusiveLock getlockfile a = do+withExclusiveLock getlockfile a = debugLocks $ do 	lockfile <- fromRepo getlockfile 	createAnnexDirectory $ takeDirectory lockfile 	mode <- annexFileMode@@ -76,7 +76,7 @@ {- Tries to take an exclusive lock and run an action. If the lock is  - already held, returns Nothing. -} tryExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex (Maybe a)-tryExclusiveLock getlockfile a = do+tryExclusiveLock getlockfile a = debugLocks $ do 	lockfile <- fromRepo getlockfile 	createAnnexDirectory $ takeDirectory lockfile 	mode <- annexFileMode

@@ -69,11 +69,11 @@ 	)  pidLockCheck :: IO a -> (LockFile -> IO a) -> Annex a-pidLockCheck posixcheck pidcheck = +pidLockCheck posixcheck pidcheck = debugLocks $ 	liftIO . maybe posixcheck pidcheck =<< pidLockFile  pidLock :: Maybe FileMode -> LockFile -> IO LockHandle -> Annex LockHandle-pidLock m f posixlock = go =<< pidLockFile+pidLock m f posixlock = debugLocks $ go =<< pidLockFile   where 	go Nothing = liftIO posixlock 	go (Just pidlock) = do@@ -83,7 +83,7 @@ 			Pid.waitLock timeout pidlock  tryPidLock :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle)-tryPidLock m f posixlock = liftIO . go =<< pidLockFile+tryPidLock m f posixlock = debugLocks $ liftIO . go =<< pidLockFile   where 	go Nothing = posixlock 	go (Just pidlock) = do

@@ -198,7 +198,7 @@ 	-- When the LockCache already has the socketlock in it, 	-- the connection has already been started. Otherwise, 	-- get the connection started now.-	makeconnection socketlock =+	makeconnection socketlock = debugLocks $ 		whenM (isNothing <$> fromLockCache socketlock) $ 			-- See if ssh can connect in batch mode, 			-- if so there's no need to block for a password

@@ -10,6 +10,7 @@ module Annex.Transfer ( 	module X, 	upload,+	alwaysUpload, 	download, 	runTransfer, 	alwaysRunTransfer,@@ -39,6 +40,10 @@ upload u key f d a _witness = guardHaveUUID u $  	runTransfer (Transfer Upload u key) f d a +alwaysUpload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v+alwaysUpload u key f d a _witness = guardHaveUUID u $ +	alwaysRunTransfer (Transfer Upload u key) f d a+ download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v download u key f d a _witness = guardHaveUUID u $ 	runTransfer (Transfer Download u key) f d a@@ -72,7 +77,7 @@ alwaysRunTransfer = runTransfer' True  runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v-runTransfer' ignorelock t afile retrydecider transferaction = checkSecureHashes t $ do+runTransfer' ignorelock t afile retrydecider transferaction = debugLocks $ checkSecureHashes t $ do 	shouldretry <- retrydecider 	info <- liftIO $ startTransferInfo afile 	(meter, tfile, createtfile, metervar) <- mkProgressUpdater t info@@ -205,7 +210,7 @@ {- Retries a number of times with growing delays in between when enabled  - by git configuration. -} configuredRetry :: RetryDecider-configuredRetry = do+configuredRetry = debugLocks $ do 	retrycounter <- liftIO $ newMVar 0 	return $ \_old new -> do 		(maxretries, Seconds initretrydelay) <- getcfg $ @@ -238,7 +243,7 @@  - increase total transfer speed.  -} pickRemote :: Observable v => [Remote] -> (Remote -> Annex v) -> Annex v-pickRemote l a = go l =<< Annex.getState Annex.concurrency+pickRemote l a = debugLocks $ go l =<< Annex.getState Annex.concurrency   where 	go [] _ = return observeFailure 	go (r:[]) _ = a r

@@ -75,7 +75,7 @@ 	let oldkeys = M.keys $ M.filter (tooold now) m 	forM_ oldkeys $ \k -> do 		debug ["removing old unused key", key2file k]-		liftAnnex $ do+		liftAnnex $ tryNonAsync $ do 			lockContentForRemoval k removeAnnex 			logStatus k InfoMissing   where

@@ -1,3 +1,38 @@+git-annex (7.20181121) upstream; urgency=medium++  * git-annex-shell: Fix hang when transferring the same objects to two+    different clients at the same time. (Or when annex.pidlock is used,+    two different objects.)+  * Fixed some other potential hangs in the P2P protocol.+  * Fix bash completion of "git annex" to propertly handle files with+    spaces and other problem characters. (Completion of "git-annex"+    already did.)+  * Fix resume of download of url when the whole file content is+    already actually downloaded.+  * When an export conflict prevents accessing a special remote,+    be clearer about what the problem is and how to resolve it.+  * export, sync --content: Avoid unnecessarily trying to upload files+    to an exporttree remote that already contains the files.+  * smudge: When passed a file located outside the working tree, eg by git+    diff, avoid erroring out.+  * drop -J: Avoid processing the same key twice at the same time when+    multiple annexed files use it.+  * When a command is operating on multiple files and there's an error+    with one, try harder to continue to the rest. (As was already done+    for many types of errors including IO errors.)+  * Fixed a crash when using -J with ssh password prompts in+    --quiet/--json mode.+    Thanks to Yaroslav Halchenko and the DataLad&ReproNim team for+    helping to track down this bug.+  * Remove esqueleto dependency to allow upgrading other dependencies to+    newer versions.+    Thanks Sean Parsons.+  * Fix build with persistent-sqlite older than 2.6.3.+  * Updated stack.yaml to lts-12.19; added stack-lts-9.9.yaml+    to support old versions of stack.++ -- Joey Hess <id@joeyh.name>  Wed, 21 Nov 2018 14:22:47 -0400+ git-annex (7.20181105) upstream; urgency=medium    * Fix test suite failure when git-annex test is not run inside a git

@@ -43,8 +43,7 @@  {- Runs one of the actions needed to perform a command.  - Individual actions can fail without stopping the whole command,- - including by throwing IO errors (but other errors terminate the whole- - command).+ - including by throwing non-async exceptions.  -   - When concurrency is enabled, a thread is forked off to run the action  - in the background, as soon as a free slot is available.@@ -128,14 +127,16 @@  {- Like commandAction, but without the concurrency. -} includeCommandAction :: CommandStart -> CommandCleanup-includeCommandAction a = account =<< tryIO (callCommandAction a)+includeCommandAction a = account =<< tryNonAsync (callCommandAction a)   where 	account (Right True) = return True 	account (Right False) = incerr-	account (Left err) = do-		toplevelWarning True (show err)-		implicitMessage showEndFail-		incerr+	account (Left err) = case fromException err of+		Just exitcode -> liftIO $ exitWith exitcode+		Nothing -> do+			toplevelWarning True (show err)+			implicitMessage showEndFail+			incerr 	incerr = do 		Annex.incError 		return False@@ -181,11 +182,13 @@ 		c <- liftIO getNumCapabilities 		when (n > c) $ 			liftIO $ setNumCapabilities n-		ifM (liftIO concurrentOutputSupported)-			( Regions.displayConsoleRegions $-				goconcurrent' True-			, goconcurrent' False-			)+		withMessageState $ \s -> case outputType s of+			NormalOutput -> ifM (liftIO concurrentOutputSupported)+				( Regions.displayConsoleRegions $+					goconcurrent' True+				, goconcurrent' False+				)+			_ -> goconcurrent' False 	goconcurrent' b = bracket_ (setup b) cleanup a 	setup = setconcurrentoutputenabled 	cleanup = do

@@ -123,7 +123,7 @@ import qualified Command.Benchmark #endif -cmds :: Parser TestOptions -> Maybe TestRunner -> [Command]+cmds :: Parser TestOptions -> TestRunner -> [Command] cmds testoptparser testrunner =  	[ Command.Help.cmd 	, Command.Add.cmd@@ -233,7 +233,7 @@ #endif 	] -run :: Parser TestOptions -> Maybe TestRunner -> [String] -> IO ()+run :: Parser TestOptions -> TestRunner -> [String] -> IO () run testoptparser testrunner args = go envmodes   where 	go [] = dispatch True args 

@@ -68,7 +68,7 @@ 	afile = AssociatedFile (Just file)  start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart-start' o key afile ai = do+start' o key afile ai = onlyActionOn key $ do 	from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o) 	checkDropAuto (autoMode o) from afile key $ \numcopies -> 		stopUnless (want from) $

@@ -204,15 +204,19 @@ startExport :: Remote -> ExportActions Annex -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart startExport r ea db cvar ti = do 	ek <- exportKey (Git.LsTree.sha ti)-	stopUnless (notpresent ek) $ do+	stopUnless (notrecordedpresent ek) $ do 		showStart ("export " ++ name r) f-		liftIO $ modifyMVar_ cvar (pure . const True)-		next $ performExport r ea db ek af (Git.LsTree.sha ti) loc+		ifM (either (const False) id <$> tryNonAsync (checkPresentExport ea (asKey ek) loc))+			( next $ next $ cleanupExport r db ek loc False+			, do+				liftIO $ modifyMVar_ cvar (pure . const True)+				next $ performExport r ea db ek af (Git.LsTree.sha ti) loc+			)   where 	loc = mkExportLocation f 	f = getTopFilePath (Git.LsTree.file ti) 	af = AssociatedFile (Just f)-	notpresent ek = (||)+	notrecordedpresent ek = (||) 		<$> liftIO (notElem loc <$> getExportedLocation db (asKey ek)) 		-- If content was removed from the remote, the export db 		-- will still list it, so also check location tracking.@@ -245,13 +249,14 @@ 				liftIO $ hClose h 				storer tmp sha1k loc m 	if sent-		then next $ cleanupExport r db ek loc+		then next $ cleanupExport r db ek loc True 		else stop -cleanupExport :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> CommandCleanup-cleanupExport r db ek loc = do+cleanupExport :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> Bool -> CommandCleanup+cleanupExport r db ek loc sent = do 	liftIO $ addExportedLocation db (asKey ek) loc-	logChange (asKey ek) (uuid r) InfoPresent+	when sent $+		logChange (asKey ek) (uuid r) InfoPresent 	return True  startUnexport :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart

@@ -18,6 +18,7 @@ import qualified Database.Keys import qualified Git.BuildVersion import Git.FilePath+import qualified Git import qualified Git.Ref import Backend @@ -77,11 +78,14 @@ clean :: FilePath -> CommandStart clean file = do 	b <- liftIO $ B.hGetContents stdin-	case parseLinkOrPointer b of-		Just k -> do-			getMoveRaceRecovery k file-			liftIO $ B.hPut stdout b-		Nothing -> go b =<< catKeyFile file+	ifM fileoutsiderepo+		( liftIO $ B.hPut stdout b+		, case parseLinkOrPointer b of+			Just k -> do+				getMoveRaceRecovery k file+				liftIO $ B.hPut stdout b+			Nothing -> go b =<< catKeyFile file+		) 	stop   where 	go b oldkey = ifM (shouldAnnex file oldkey)@@ -129,6 +133,13 @@ 		{ lockingFile = False 		, hardlinkFileTmp = False 		}++	-- git diff can run the clean filter on files outside the+	-- repository; can't annex those+	fileoutsiderepo = do+	        repopath <- liftIO . absPath =<< fromRepo Git.repoPath+		filepath <- liftIO $ absPath file+		return $ not $ dirContains repopath filepath  -- New files are annexed as configured by annex.largefiles, with a default -- of annexing them.

@@ -720,9 +720,7 @@ 	fillexport r ea db (Exported { exportedTreeish = t }:[]) = 		Command.Export.fillExport r ea db t 	fillexport r _ _ _ = do-		warning $ "Export conflict detected. Different trees have been exported to " ++ -			Remote.name r ++ -			". Use git-annex export to resolve this conflict."+		warnExportConflict r 		return False  cleanupLocal :: CurrBranch -> CommandStart

@@ -10,21 +10,20 @@ import Command import Types.Test -cmd :: Parser TestOptions -> Maybe TestRunner -> Command+cmd :: Parser TestOptions -> TestRunner -> Command cmd optparser runner = noRepo (startIO runner <$$> const optparser) $ 	dontCheck repoExists $ 		command "test" SectionTesting 			"run built-in test suite" 			paramNothing (seek runner <$$> const optparser) -seek :: Maybe TestRunner -> TestOptions -> CommandSeek+seek :: TestRunner -> TestOptions -> CommandSeek seek runner o = commandAction $ start runner o -start :: Maybe TestRunner -> TestOptions -> CommandStart+start :: TestRunner -> TestOptions -> CommandStart start runner o = do 	liftIO $ startIO runner o 	stop -startIO :: Maybe TestRunner -> TestOptions -> IO ()-startIO Nothing _ = warningIO "git-annex was built without its test suite; not testing"-startIO (Just runner) o = runner o+startIO :: TestRunner -> TestOptions -> IO ()+startIO runner o = runner o

@@ -19,6 +19,7 @@  import Utility.Misc as X import Utility.Exception as X+import Utility.DebugLocks as X import Utility.SafeCommand as X import Utility.Process as X import Utility.Path as X

@@ -32,6 +32,7 @@ 	ExportedDirectoryId, 	ExportTreeId, 	ExportTreeCurrentId,+	ExportUpdateResult(..), ) where  import Database.Types@@ -48,8 +49,8 @@ import Git.FilePath import qualified Git.DiffTree +import Database.Persist.Sql hiding (Key) import Database.Persist.TH-import Database.Esqueleto hiding (Key)  data ExportHandle = ExportHandle H.DbQueue UUID @@ -107,17 +108,14 @@  recordExportTreeCurrent :: ExportHandle -> Sha -> IO () recordExportTreeCurrent h s = queueDb h $ do-	delete $ from $ \r -> do-		where_ (r ^. ExportTreeCurrentTree ==. r ^. ExportTreeCurrentTree)+	deleteWhere ([] :: [Filter ExportTreeCurrent]) 	void $ insertUnique $ ExportTreeCurrent $ toSRef s  getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha) getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do-	l <- select $ from $ \r -> do-		where_ (r ^. ExportTreeCurrentTree ==. r ^. ExportTreeCurrentTree)-		return (r ^. ExportTreeCurrentTree)+	l <- selectList ([] :: [Filter ExportTreeCurrent]) [] 	case l of-		(s:[]) -> return $ Just $ fromSRef $ unValue s+		(s:[]) -> return $ Just $ fromSRef $ exportTreeCurrentTree $ entityVal s 		_ -> return Nothing  addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()@@ -137,13 +135,10 @@  removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () removeExportedLocation h k el = queueDb h $ do-	delete $ from $ \r -> do-		where_ (r ^. ExportedKey ==. val ik &&. r ^. ExportedFile ==. val ef)+	deleteWhere [ExportedKey ==. ik, ExportedFile ==. ef] 	let subdirs = map (toSFilePath . fromExportDirectory) 		(exportDirectories el)-	delete $ from $ \r -> do-		where_ (r ^. ExportedDirectoryFile ==. val ef-			&&. r ^. ExportedDirectorySubdir `in_` valList subdirs)+	deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs]   where 	ik = toIKey k 	ef = toSFilePath (fromExportLocation el)@@ -151,19 +146,15 @@ {- Note that this does not see recently queued changes. -} getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation] getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do-	l <- select $ from $ \r -> do-		where_ (r ^. ExportedKey ==. val ik)-		return (r ^. ExportedFile)-	return $ map (mkExportLocation . fromSFilePath . unValue) l+	l <- selectList [ExportedKey ==. ik] []+	return $ map (mkExportLocation . fromSFilePath . exportedFile . entityVal) l   where 	ik = toIKey k  {- Note that this does not see recently queued changes. -} isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do-	l <- select $ from $ \r -> do-		where_ (r ^. ExportedDirectorySubdir ==. val ed)-		return (r ^. ExportedDirectoryFile)+	l <- selectList [ExportedDirectorySubdir ==. ed] [] 	return $ null l   where 	ed = toSFilePath $ fromExportDirectory d@@ -171,10 +162,8 @@ {- Get locations in the export that might contain a key. -} getExportTree :: ExportHandle -> Key -> IO [ExportLocation] getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do-	l <- select $ from $ \r -> do-		where_ (r ^. ExportTreeKey ==. val ik)-		return (r ^. ExportTreeFile)-	return $ map (mkExportLocation . fromSFilePath . unValue) l+	l <- selectList [ExportTreeKey ==. ik] []+	return $ map (mkExportLocation . fromSFilePath . exportTreeFile . entityVal) l   where 	ik = toIKey k @@ -186,9 +175,8 @@ 	ef = toSFilePath (fromExportLocation loc)  removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()-removeExportTree h k loc = queueDb h $ -	delete $ from $ \r ->-		where_ (r ^. ExportTreeKey ==. val ik &&. r ^. ExportTreeFile ==. val ef)+removeExportTree h k loc = queueDb h $+	deleteWhere [ExportTreeKey ==. ik, ExportTreeFile ==. ef]   where 	ik = toIKey k 	ef = toSFilePath (fromExportLocation loc)@@ -218,16 +206,21 @@ 		Just k -> liftIO $ addExportTree h (asKey k) loc   where 	loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i-			-updateExportTreeFromLog :: ExportHandle -> Annex ()++data ExportUpdateResult = ExportUpdateSuccess | ExportUpdateConflict+	deriving (Eq)++updateExportTreeFromLog :: ExportHandle -> Annex ExportUpdateResult updateExportTreeFromLog db@(ExportHandle _ u) =  	withExclusiveLock (gitAnnexExportLock u) $ do 		old <- liftIO $ fromMaybe emptyTree 			<$> getExportTreeCurrent db 		l <- Log.getExport u 		case map Log.exportedTreeish l of+			[] -> return ExportUpdateSuccess 			(new:[]) | new /= old -> do 				updateExportTree db old new 				liftIO $ recordExportTreeCurrent db new 				liftIO $ flushDbQueue db-			_ -> return ()+				return ExportUpdateSuccess+			_ts -> return ExportUpdateConflict

@@ -28,8 +28,8 @@ import Annex.Common import Annex.LockFile +import Database.Persist.Sql hiding (Key) import Database.Persist.TH-import Database.Esqueleto hiding (Key) import Data.Time.Clock  data FsckHandle = FsckHandle H.DbQueue UUID@@ -72,7 +72,7 @@ 	unlockFile =<< fromRepo (gitAnnexFsckDbLock u)  addDb :: FsckHandle -> Key -> IO ()-addDb (FsckHandle h _) k = H.queueDb h checkcommit $ +addDb (FsckHandle h _) k = H.queueDb h checkcommit $ 	void $ insertUnique $ Fscked sk   where 	sk = toSKey k@@ -90,7 +90,5 @@  inDb' :: SKey -> SqlPersistM Bool inDb' sk = do-	r <- select $ from $ \r -> do-		where_ (r ^. FsckedKey ==. val sk)-		return (r ^. FsckedKey)+	r <- selectList [FsckedKey ==. sk] [] 	return $ not $ null r

@@ -5,8 +5,6 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE BangPatterns #-}- module Database.Handle ( 	DbHandle, 	DbConcurrency(..),

@@ -5,6 +5,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Database.Init where  import Annex.Common@@ -14,7 +16,11 @@ import Database.Persist.Sqlite import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T+#if MIN_VERSION_persistent_sqlite(2,6,2) import Lens.Micro+#else+import qualified Database.Sqlite as Sqlite+#endif  {- Ensures that the database is freshly initialized. Deletes any  - existing database. Pass the migration action for the database.@@ -29,9 +35,15 @@ 	let dbdir = takeDirectory db 	let tmpdbdir = dbdir ++ ".tmp" 	let tmpdb = tmpdbdir </> "db"+	let tdb = T.pack tmpdb	 	liftIO $ do 		createDirectoryIfMissing True tmpdbdir-		runSqliteInfo (mkConnInfo tmpdb) migration+#if MIN_VERSION_persistent_sqlite(2,6,2)+		runSqliteInfo (enableWAL tdb) migration+#else+		enableWAL tdb+		runSqlite tdb migration+#endif 	setAnnexDirPerm tmpdbdir 	-- Work around sqlite bug that prevents it from honoring 	-- less restrictive umasks.@@ -44,11 +56,21 @@ {- Make sure that the database uses WAL mode, to prevent readers  - from blocking writers, and prevent a writer from blocking readers.  -- - This is the default in persistent-sqlite currently, but force it on just- - in case. + - This is the default in recent persistent-sqlite versions, but + - force it on just in case.   -  - Note that once WAL mode is enabled, it will persist whenever the  - database is opened. -}-mkConnInfo :: FilePath -> SqliteConnectionInfo-mkConnInfo db = over walEnabled (const True) $ -	mkSqliteConnectionInfo (T.pack db)+#if MIN_VERSION_persistent_sqlite(2,6,2)+enableWAL :: T.Text -> SqliteConnectionInfo+enableWAL db = over walEnabled (const True) $ +	mkSqliteConnectionInfo db+#else+enableWAL :: T.Text -> IO ()+enableWAL db = do+	conn <- Sqlite.open db+	stmt <- Sqlite.prepare conn (T.pack "PRAGMA journal_mode=WAL;")+	void $ Sqlite.step stmt+	void $ Sqlite.finalize stmt+	Sqlite.close conn+#endif

@@ -18,8 +18,8 @@ import Utility.InodeCache import Git.FilePath +import Database.Persist.Sql import Database.Persist.TH-import Database.Esqueleto hiding (Key) import Data.Time.Clock import Control.Monad @@ -62,8 +62,7 @@ addAssociatedFile ik f = queueDb $ do 	-- If the same file was associated with a different key before, 	-- remove that.-	delete $ from $ \r -> do-		where_ (r ^. AssociatedFile ==. val af &&. not_ (r ^. AssociatedKey ==. val ik))+	deleteWhere [AssociatedFile ==. af, AssociatedKey !=. ik] 	void $ insertUnique $ Associated ik af   where 	af = toSFilePath (getTopFilePath f)@@ -78,32 +77,27 @@  dropAllAssociatedFiles :: WriteHandle -> IO () dropAllAssociatedFiles = queueDb $-	delete $ from $ \(_r :: SqlExpr (Entity Associated)) -> return ()+	deleteWhere ([] :: [Filter Associated])  {- Note that the files returned were once associated with the key, but  - some of them may not be any longer. -} getAssociatedFiles :: IKey -> ReadHandle -> IO [TopFilePath] getAssociatedFiles ik = readDb $ do-	l <- select $ from $ \r -> do-		where_ (r ^. AssociatedKey ==. val ik)-		return (r ^. AssociatedFile)-	return $ map (asTopFilePath . fromSFilePath . unValue) l+	l <- selectList [AssociatedKey ==. ik] []+	return $ map (asTopFilePath . fromSFilePath . associatedFile . entityVal) l  {- Gets any keys that are on record as having a particular associated file.  - (Should be one or none but the database doesn't enforce that.) -} getAssociatedKey :: TopFilePath -> ReadHandle -> IO [IKey] getAssociatedKey f = readDb $ do-	l <- select $ from $ \r -> do-		where_ (r ^. AssociatedFile ==. val af)-		return (r ^. AssociatedKey)-	return $ map unValue l+	l <- selectList [AssociatedFile ==. af] []+	return $ map (associatedKey . entityVal) l   where 	af = toSFilePath (getTopFilePath f)  removeAssociatedFile :: IKey -> TopFilePath -> WriteHandle -> IO ()-removeAssociatedFile ik f = queueDb $ -	delete $ from $ \r -> do-		where_ (r ^. AssociatedKey ==. val ik &&. r ^. AssociatedFile ==. val af)+removeAssociatedFile ik f = queueDb $+	deleteWhere [AssociatedKey ==. ik, AssociatedFile ==. af]   where 	af = toSFilePath (getTopFilePath f) @@ -115,12 +109,9 @@  - for each pointer file that is a copy of it. -} getInodeCaches :: IKey -> ReadHandle -> IO [InodeCache] getInodeCaches ik = readDb $ do-	l <- select $ from $ \r -> do-		where_ (r ^. ContentKey ==. val ik)-		return (r ^. ContentCache)-	return $ map (fromSInodeCache . unValue) l+	l <- selectList [ContentKey ==. ik] []+	return $ map (fromSInodeCache . contentCache . entityVal) l  removeInodeCaches :: IKey -> WriteHandle -> IO ()-removeInodeCaches ik = queueDb $ -	delete $ from $ \r -> do-		where_ (r ^. ContentKey ==. val ik)+removeInodeCaches ik = queueDb $+	deleteWhere [ContentKey ==. ik]

@@ -95,7 +95,7 @@  - interrupted.  -} checkTransfer :: Transfer -> Annex (Maybe TransferInfo)-checkTransfer t = do+checkTransfer t = debugLocks $ do 	tfile <- fromRepo $ transferFile t 	let lck = transferLockFile tfile 	let cleanstale = do

@@ -262,7 +262,7 @@  - the user.  -} prompt :: Annex a -> Annex a-prompt a = go =<< Annex.getState Annex.concurrency+prompt a = debugLocks $ go =<< Annex.getState Annex.concurrency   where 	go NonConcurrent = a 	go (Concurrent {}) = withMessageState $ \s -> do@@ -270,4 +270,4 @@ 		bracketIO 			(takeMVar l) 			(putMVar l)-			(const $ hideRegionsWhile a)+			(const $ hideRegionsWhile s a)

@@ -123,9 +123,11 @@  - This needs a new enough version of concurrent-output; otherwise  - the regions will not be hidden, but the action still runs, garbling the  - display. -}-hideRegionsWhile :: Annex a -> Annex a+hideRegionsWhile :: MessageState -> Annex a -> Annex a #if MIN_VERSION_concurrent_output(1,9,0)-hideRegionsWhile a = bracketIO setup cleanup go+hideRegionsWhile s a +	| concurrentOutputEnabled s = bracketIO setup cleanup go+	| otherwise = a   where 	setup = Regions.waitDisplayChange $ swapTMVar Regions.regionList [] 	cleanup = void . atomically . swapTMVar Regions.regionList

@@ -26,6 +26,7 @@ import Utility.Metered  import Control.Monad.Free+import Control.Concurrent.STM  -- Full interpreter for Proto, that can receive and send objects. runFullProto :: RunState -> P2PConnection -> Proto a -> Annex (Either ProtoFailure a)@@ -56,27 +57,46 @@ 				Left e -> return $ Left $ ProtoFailureException e 				Right (Left e) -> return $ Left e 				Right (Right ok) -> runner (next ok)+		-- If the content is not present, or the transfer doesn't+		-- run for any other reason, the sender action still must+		-- be run, so is given empty and Invalid data.+		let fallback = runner (sender mempty (return Invalid)) 		v <- tryNonAsync $ prepSendAnnex k 		case v of-			Right (Just (f, checkchanged)) -> proceed $-				transfer upload k af $-					sinkfile f o checkchanged sender- 			Right Nothing -> proceed $-				runner (sender mempty (return Invalid))+			Right (Just (f, checkchanged)) -> proceed $ do+				-- alwaysUpload to allow multiple uploads of the same key.+				let runtransfer ti = transfer alwaysUpload k af $ \p ->+					sinkfile f o checkchanged sender p ti+				checktransfer runtransfer fallback+ 			Right Nothing -> proceed fallback 			Left e -> return $ Left $ ProtoFailureException e 	StoreContent k af o l getb validitycheck next -> do 		-- This is the same as the retrievalSecurityPolicy of-		-- Remote.P2P and Remote.Git. +		-- Remote.P2P and Remote.Git. 		let rsp = RetrievalAllKeysSecure-		ok <- flip catchNonAsync (const $ return False) $-			transfer download k af $ \p ->-				getViaTmp rsp DefaultVerify k $ \tmp -> do-					storefile tmp o l getb validitycheck p-		runner (next ok)+		v <- tryNonAsync $ do+			let runtransfer ti = +				Right <$> transfer download k af (\p ->+					getViaTmp rsp DefaultVerify k $ \tmp ->+						storefile tmp o l getb validitycheck p ti)+			let fallback = return $ Left $+				ProtoFailureMessage "transfer already in progress, or unable to take transfer lock"+			checktransfer runtransfer fallback+		case v of+			Left e -> return $ Left $ ProtoFailureException e+			Right (Left e) -> return $ Left e+			Right (Right ok) -> runner (next ok) 	StoreContentTo dest o l getb validitycheck next -> do-		res <- flip catchNonAsync (const $ return (False, UnVerified)) $-			storefile dest o l getb validitycheck nullMeterUpdate-		runner (next res)+		v <- tryNonAsync $ do+			let runtransfer ti = Right+				<$> storefile dest o l getb validitycheck nullMeterUpdate ti+			let fallback = return $ Left $+				ProtoFailureMessage "transfer failed"+			checktransfer runtransfer fallback+		case v of+			Left e -> return $ Left $ ProtoFailureException e+			Right (Left e) -> return $ Left e+			Right (Right ok) -> runner (next ok) 	SetPresent k u next -> do 		v <- tryNonAsync $ logChange k u InfoPresent 		case v of@@ -122,7 +142,7 @@ 	UpdateMeterTotalSize m sz next -> do 		liftIO $ setMeterTotalSize m sz 		runner next-	RunValidityCheck check next -> runner . next =<< check+	RunValidityCheck checkaction next -> runner . next =<< checkaction   where 	transfer mk k af ta = case runst of 		-- Update transfer logs when serving.@@ -132,8 +152,8 @@ 		-- Transfer logs are updated higher in the stack when 		-- a client. 		Client _ -> ta nullMeterUpdate-	-	storefile dest (Offset o) (Len l) getb validitycheck p = do++	storefile dest (Offset o) (Len l) getb validitycheck p ti = do 		let p' = offsetMeterUpdate p (toBytesProcessed o) 		v <- runner getb 		case v of@@ -142,6 +162,8 @@ 					when (o /= 0) $ 						hSeek h AbsoluteSeek o 					meteredWrite p' h b+				indicatetransferred ti+ 				rightsize <- do 					sz <- liftIO $ getFileSize dest 					return (toInteger sz == l + o)@@ -157,7 +179,7 @@ 						return (rightsize, MustVerify) 			Left e -> error $ describeProtoFailure e 	-	sinkfile f (Offset o) checkchanged sender p = bracket setup cleanup go+	sinkfile f (Offset o) checkchanged sender p ti = bracket setup cleanup go 	  where 		setup = liftIO $ openBinaryFile f ReadMode 		cleanup = liftIO . hClose@@ -166,8 +188,34 @@ 			when (o /= 0) $ 				liftIO $ hSeek h AbsoluteSeek o 			b <- liftIO $ hGetContentsMetered h p'+ 			let validitycheck = local $ runValidityCheck $  				checkchanged >>= return . \case 					False -> Invalid 					True -> Valid-			runner (sender b validitycheck)+			r <- runner (sender b validitycheck)+			indicatetransferred ti+			return r+	+	-- This allows using actions like download and viaTmp+	-- that may abort a transfer, and clean up the protocol after them.+	--+	-- Runs an action that may make a transfer, passing a transfer+	-- indicator. The action should call indicatetransferred on it,+	-- only after it's actually sent/received the all data.+	--+	-- If the action ends without having called indicatetransferred,+	-- runs the fallback action, which can close the protoocol+	-- connection or otherwise clean up after the transfer not having+	-- occurred.+	--+	-- If the action throws an exception, the fallback is not run.+	checktransfer ta fallback = do+		ti <- liftIO $ newTVarIO False+		r <- ta ti+		ifM (liftIO $ atomically $ readTVar ti)+			( return r+			, fallback+			)++	indicatetransferred ti = liftIO $ atomically $ writeTVar ti True

@@ -238,8 +238,11 @@ 	-- present. 	| ReadContent Key AssociatedFile Offset (L.ByteString -> Proto Validity -> Proto Bool) (Bool -> c) 	-- ^ Reads the content of a key and sends it to the callback.+	-- Must run the callback, or terminate the protocol connection.+	-- 	-- May send any amount of data, including L.empty if the content is 	-- not available. The callback must deal with that.+	-- 	-- And the content may change while it's being sent. 	-- The callback is passed a validity check that it can run after 	-- sending the content to detect when this happened.@@ -247,6 +250,9 @@ 	-- ^ Stores content to the key's temp file starting at an offset. 	-- Once the whole content of the key has been stored, moves the 	-- temp file into place as the content of the key, and returns True.+	--+	-- Must consume the whole lazy ByteString, or if unable to do+	-- so, terminate the protocol connection. 	-- 	-- If the validity check is provided and fails, the content was 	-- changed while it was being sent, so verificiation of the

@@ -377,7 +377,9 @@ dropKey :: Remote -> State -> Key -> Annex Bool dropKey r st key = do 	repo <- getRepo r-	dropKey' repo r st key+	catchNonAsync+		(dropKey' repo r st key)+		(\e -> warning (show e) >> return False)  dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex Bool dropKey' repo r (State connpool duc _) key

@@ -107,6 +107,8 @@ 				liftIO $ atomically $ 					writeTVar updateflag (Just False) 		+		exportinconflict <- liftIO $ newTVarIO False+ 		-- Get export locations for a key. Checks once 		-- if the export log is different than the database and 		-- updates the database, to notice when an export has been@@ -114,7 +116,12 @@ 		let getexportlocs = \k -> do 			bracket startupdateonce doneupdateonce $ \updatenow -> 				when updatenow $-					updateExportTreeFromLog db+					updateExportTreeFromLog db >>= \case+						ExportUpdateSuccess -> return ()+						ExportUpdateConflict -> do+							warnExportConflict r+							liftIO $ atomically $+								writeTVar exportinconflict True 			liftIO $ getExportTree db k  		return $ r@@ -136,7 +143,7 @@ 			-- so don't need to use retrieveExport. 			, retrieveKeyFile = if appendonly r 				then retrieveKeyFile r-				else retrieveKeyFileFromExport getexportlocs+				else retrieveKeyFileFromExport getexportlocs exportinconflict 			, retrieveKeyFileCheap = if appendonly r 				then retrieveKeyFileCheap r 				else \_ _ _ -> return False@@ -170,18 +177,28 @@ 					ea <- exportActions r 					anyM (checkPresentExport ea k) 						=<< getexportlocs k+			-- checkPresent from an export is more expensive+			-- than otherwise, so not cheap. Also, this+			-- avoids things that look at checkPresentCheap and+			-- silently skip non-present files from behaving+			-- in confusing ways when there's an export+			-- conflict.+			, checkPresentCheap = False 			, mkUnavailable = return Nothing 			, getInfo = do 				is <- getInfo r 				return (is++[("export", "yes")]) 			}-	retrieveKeyFileFromExport getexportlocs k _af dest p = unVerified $+	retrieveKeyFileFromExport getexportlocs exportinconflict k _af dest p = unVerified $ 		if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k)) 			then do 				locs <- getexportlocs k 				case locs of 					[] -> do-						warning "unknown export location"+						ifM (liftIO $ atomically $ readTVar exportinconflict)+							( warning "unknown export location, likely due to the export conflict"+							, warning "unknown export location"+							) 						return False 					(l:_) -> do 						ea <- exportActions r

@@ -103,28 +103,25 @@ 		) 	<*> cmdParams "non-options are for internal use only" -runner :: Maybe (TestOptions -> IO ())-runner = Just go+runner :: TestOptions -> IO ()+runner opts+	| fakeSsh opts = runFakeSsh (internalData opts)+	| otherwise = runsubprocesstests =<< Utility.Env.getEnv subenv   where-	go opts-		| fakeSsh opts = runFakeSsh (internalData opts)-		| otherwise = runsubprocesstests opts-			=<< Utility.Env.getEnv subenv-	 	-- Run git-annex test in a subprocess, so that any files 	-- it may open will be closed before running finalCleanup. 	-- This should prevent most failures to clean up after the test 	-- suite. 	subenv = "GIT_ANNEX_TEST_SUBPROCESS"-	runsubprocesstests opts Nothing = do+	runsubprocesstests Nothing = do 		pp <- Annex.Path.programPath 		Utility.Env.Set.setEnv subenv "1" True 		ps <- getArgs-		(Nothing, Nothing, Nothing, pid) <-createProcess (proc pp ps)+		(Nothing, Nothing, Nothing, pid) <- createProcess (proc pp ps) 		exitcode <- waitForProcess pid 		unless (keepFailuresOption opts) finalCleanup 		exitWith exitcode-	runsubprocesstests opts (Just _) = isolateGitConfig $ do+	runsubprocesstests (Just _) = isolateGitConfig $ do 		ensuretmpdir 		crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' tmpdir 		case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem opts) of

@@ -65,7 +65,7 @@ 	-- catch all errors, including normally fatal errors 	try run ::IO (Either SomeException ())   where-	run = GitAnnex.run dummyTestOptParser Nothing (command:"-q":params)+	run = GitAnnex.run dummyTestOptParser (\_ -> noop) (command:"-q":params) 	dummyTestOptParser = pure mempty  {- Runs git-annex and returns its output. -}

@@ -0,0 +1,43 @@+{- Pinpointing location of MVar/STM deadlocks+ -+ - Copyright 2018 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Utility.DebugLocks where++import Control.Monad.Catch+import Control.Monad.IO.Class+#ifdef DEBUGLOCKS+import Control.Exception (BlockedIndefinitelyOnSTM, BlockedIndefinitelyOnMVar)+import GHC.Stack+import System.IO+#endif++{- Wrap around any action, and if it dies due to deadlock, will display+ - a call stack on stderr when DEBUGLOCKS is defined.+ -+ - Should be zero cost to call when DEBUGLOCKS is not defined.+ -}+#ifdef DEBUGLOCKS+debugLocks :: HasCallStack => (MonadCatch m, MonadIO m) => m a -> m a+debugLocks a = a `catches`+	[ Handler (\ (e :: BlockedIndefinitelyOnMVar) -> go "MVar" e callStack)+	, Handler (\ (e :: BlockedIndefinitelyOnSTM) -> go "STM" e callStack)+	]+  where+	go ty e cs = do+		liftIO $ do+			hPutStrLn stderr $ +				ty ++ " deadlock detected " ++ prettyCallStack cs+			hFlush stderr+		throwM e+#else+-- No HasCallStack constraint.+debugLocks :: (MonadCatch m, MonadIO m) => m a -> m a+debugLocks a = a+#endif

@@ -20,6 +20,7 @@  import qualified Utility.LockPool.STM as P import Utility.LockPool.STM (LockFile)+import Utility.DebugLocks  import Control.Concurrent.STM import Control.Exception@@ -49,8 +50,8 @@ makeLockHandle :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM P.LockHandle) -> (LockFile -> IO FileLockOps) -> IO LockHandle makeLockHandle pool file pa fa = bracketOnError setup cleanup go   where-	setup = atomically (pa pool file)-	cleanup ph = P.releaseLock ph+	setup = debugLocks $ atomically (pa pool file)+	cleanup ph = debugLocks $ P.releaseLock ph 	go ph = mkLockHandle pool file ph =<< fa file  tryMakeLockHandle :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM (Maybe P.LockHandle)) -> (LockFile -> IO (Maybe FileLockOps)) -> IO (Maybe LockHandle)

@@ -348,7 +348,14 @@ 			-- This could be improved by fixing 			-- https://github.com/aristidb/http-types/issues/87 			Just crh -> crh == B8.fromString ("bytes */" ++ show sz)-			Nothing -> False+			-- Some http servers send no Content-Range header when+			-- the range extends beyond the end of the file.+			-- There is no way to distinguish between the file+			-- being the same size on the http server, vs+			-- it being shorter than the file we already have.+			-- So assume we have the whole content of the file+			-- already, the same as wget and curl do.+			Nothing -> True  	-- Resume download from where a previous download was interrupted,  	-- when supported by the http server. The server may also opt to

@@ -103,8 +103,6 @@   Messages that would normally be output to standard error are included in   the json instead. -# OPTIONS- # SEE ALSO  [[git-annex]](1)

@@ -1,5 +1,5 @@ Name: git-annex-Version: 7.20181105+Version: 7.20181121 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -279,6 +279,10 @@   Description: Enable benchmarking   Default: False +Flag DebugLocks+  Description: Debug location of MVar/STM deadlocks+  Default: False+ Flag Dbus   Description: Enable dbus support @@ -297,7 +301,7 @@    base (>= 4.9 && < 5.0),    network (>= 2.6.3.0),    network-uri (>= 2.6),-   optparse-applicative (>= 0.11.0), +   optparse-applicative (>= 0.11.0),    containers (>= 0.5.7.1),    exceptions (>= 0.6),    stm (>= 2.3),@@ -335,8 +339,7 @@    conduit,    time,    old-locale,-   esqueleto,-   persistent-sqlite (>= 2.1.3), +   persistent-sqlite (>= 2.1.3),    persistent,    persistent-template,    microlens,@@ -586,6 +589,9 @@     Build-Depends: criterion, deepseq     CPP-Options: -DWITH_BENCHMARK     Other-Modules: Command.Benchmark+  +  if flag(DebugLocks)+    CPP-Options: -DDEBUGLOCKS    Other-Modules:     Annex@@ -995,6 +1001,7 @@     Utility.Daemon     Utility.Data     Utility.DataUnits+    Utility.DebugLocks     Utility.DirWatcher     Utility.DirWatcher.Types     Utility.Directory

@@ -9,12 +9,15 @@     webapp: true     magicmime: false     dbus: false+    debuglocks: false packages: - '.' extra-deps:-- aws-0.17.1+- IfElse-0.85+- aws-0.20 - bloomfilter-2.0.1.0+- tasty-rerun-1.1.13 - torrent-10000.1.1 explicit-setup-deps:   git-annex: true-resolver: lts-9.9+resolver: lts-12.19