packages feed

git-annex 8.20200309 → 8.20200330

raw patch · 17 files changed

+153/−109 lines, 17 files

Files

Annex.hs view
@@ -325,7 +325,11 @@ 	}  {- Adds an adjustment to the Repo data. Adjustments persist across reloads- - of the repo's config. -}+ - of the repo's config.+ -+ - Note that the action may run more than once, and should avoid eg,+ - appending the same value to a repo's config when run repeatedly.+ -} adjustGitRepo :: (Git.Repo -> IO Git.Repo) -> Annex () adjustGitRepo a = do 	changeState $ \s -> s { repoadjustment = \r -> repoadjustment s r >>= a }
Annex/AdjustedBranch.hs view
@@ -57,7 +57,6 @@ import Annex.GitOverlay import Utility.Tmp.Dir import Utility.CopyFile-import Utility.Directory import qualified Database.Keys import Config
Annex/Locations.hs view
@@ -66,7 +66,6 @@ 	gitAnnexJournalDir', 	gitAnnexJournalLock, 	gitAnnexGitQueueLock,-	gitAnnexPreCommitLock, 	gitAnnexMergeLock, 	gitAnnexIndex, 	gitAnnexIndexStatus,@@ -468,10 +467,6 @@  - other git state that should only have one writer at a time. -} gitAnnexGitQueueLock :: Git.Repo -> FilePath gitAnnexGitQueueLock r = fromRawFilePath $ gitAnnexDir r P.</> "gitqueue.lck"--{- Lock file for the pre-commit hook. -}-gitAnnexPreCommitLock :: Git.Repo -> FilePath-gitAnnexPreCommitLock r = fromRawFilePath $ gitAnnexDir r P.</> "precommit.lck"  {- Lock file for direct mode merge. -} gitAnnexMergeLock :: Git.Repo -> FilePath
Annex/Ssh.hs view
@@ -37,8 +37,8 @@ import Types.Concurrency import Git.Env import Git.Ssh-#ifndef mingw32_HOST_OS import Annex.Perms+#ifndef mingw32_HOST_OS import Annex.LockPool #endif
Assistant/WebApp/Configurators/WebDAV.hs view
@@ -15,7 +15,7 @@ import qualified Remote.WebDAV as WebDAV import Assistant.WebApp.MakeRemote import qualified Remote-import Types.Remote (RemoteConfig)+import Types.Remote (RemoteConfig, config) import Types.StandardGroups import Logs.Remote import Git.Types (RemoteName)@@ -89,16 +89,16 @@  #ifdef WITH_WEBDAV makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler ()-makeWebDavRemote maker name creds config = +makeWebDavRemote maker name creds c =  	setupCloudRemote TransferGroup Nothing $-		maker name WebDAV.remote (Just creds) config+		maker name WebDAV.remote (Just creds) c  {- Only returns creds previously used for the same hostname. -} previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair) previouslyUsedWebDAVCreds hostname = 	previouslyUsedCredPair WebDAV.davCreds WebDAV.remote samehost   where-	samehost url = case urlHost =<< WebDAV.configUrl url of+	samehost r = case urlHost =<< WebDAV.configUrl (config r) of 		Nothing -> False 		Just h -> h == hostname #endif
Backend/Hash.hs view
@@ -157,7 +157,8 @@ validInExtension :: Word8 -> Bool validInExtension c 	| isAlphaNum (chr (fromIntegral c)) = True-	| c <= 127 = False -- other ascii, spaces, punctuation, control chars+	| fromIntegral c == ord '.' = True+	| c <= 127 = False -- other ascii: spaces, punctuation, control chars 	| otherwise = True -- utf8 is allowed, also other encodings  {- Upgrade keys that have the \ prefix on their hash due to a bug, or
CHANGELOG view
@@ -1,3 +1,22 @@+git-annex (8.20200330) upstream; urgency=medium++  * fsck: Fix reversion in 8.20200226 that made it incorrectly warn+    that hashed keys with an extension should be upgraded.+  * add --force-small: Fix a bug that, when adding a symbolic link,+    checked in the content of the file the symlink pointed to.+    Thanks, Kyle Meyer for the patch.+  * add --force-small: Fix failure when passed a modified submodule.+    Thanks, Kyle Meyer for the patch.+  * When syncing changes back from an adjusted branch to the basis branch,+    include changes to submodules.+    Thanks, Kyle Meyer for the patch.+  * webdav: Made exporttree remotes faster by caching connection to the+    server.+  * Fix a minor bug that caused options provided with -c to be passed+    multiple times to git.++ -- Joey Hess <id@joeyh.name>  Mon, 30 Mar 2020 12:14:50 -0400+ git-annex (8.20200309) upstream; urgency=medium    * Fix bug that caused unlocked annexed dotfiles to be added to git by the
CmdLine/GitAnnex/Options.hs view
@@ -93,8 +93,11 @@   where 	setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n } 	setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v }-	setgitconfig v = Annex.adjustGitRepo $ \r -> Git.Config.store (encodeBS' v) $ -		r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] }+	setgitconfig v = Annex.adjustGitRepo $ \r -> +		if Param v `elem` gitGlobalOpts r+			then return r+			else Git.Config.store (encodeBS' v) $ +				r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] } 	setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v }  {- Parser that accepts all non-option params. -}
Command/Add.hs view
@@ -107,8 +107,8 @@ addSmallOverridden file = do 	showNote "adding content to git repository" 	let file' = fromRawFilePath file-	s <- liftIO $ getFileStatus file'-	if isSymbolicLink s+	s <- liftIO $ getSymbolicLinkStatus file'+	if not (isRegularFile s) 		then addFile file  		else do 			-- Can't use addFile because the clean filter will
Command/PreCommit.hs view
@@ -32,7 +32,7 @@ 	(withParams seek)  seek :: CmdParams -> CommandSeek-seek ps = lockPreCommitHook $ do+seek ps = do 	l <- workTreeItems ps 	-- fix symlinks to files being committed 	flip withFilesToBeCommitted l $ \f -> commandAction $@@ -74,7 +74,3 @@ 	showset v 		| isSet v = "+" 		| otherwise = "-"--{- Takes exclusive lock; blocks until available. -}-lockPreCommitHook :: Annex a -> Annex a-lockPreCommitHook = withExclusiveLock gitAnnexPreCommitLock
Git/Tree.hs view
@@ -237,8 +237,12 @@ 				let !modified' = modified || slmodified || wasmodified 				go h modified' (subtree : c) depth intree is' 			Just CommitObject -> do-				let ti = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i)-				go h wasmodified (ti:c) depth intree is+				let ti = TreeItem (LsTree.file i) (LsTree.mode i) (LsTree.sha i)+				v <- adjusttreeitem ti+				let commit = tc $ fromMaybe ti v+				go h wasmodified (commit:c) depth intree is+				where+					tc (TreeItem f m s) = TreeCommit f m s 			_ -> error ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"") 		| otherwise = return (c, wasmodified, i:is)
Remote/Helper/Hooks.hs view
@@ -17,9 +17,7 @@ import qualified Annex import Annex.LockFile import Annex.LockPool-#ifndef mingw32_HOST_OS import Annex.Perms-#endif  {- Modifies a remote's access functions to first run the  - annex-start-command hook, and trigger annex-stop-command on shutdown.
Remote/WebDAV.hs view
@@ -22,6 +22,7 @@ import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO) import System.Log.Logger (debugM)+import Control.Concurrent.STM hiding (check)  import Annex.Common import Types.Remote@@ -64,15 +65,18 @@ davcredsField = Accepted "davcreds"  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u rc gc rs = new-	<$> parsedRemoteConfig remote rc-	<*> remoteCost gc expensiveRemoteCost+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc+	new+		<$> pure c+		<*> remoteCost gc expensiveRemoteCost+		<*> mkDavHandleVar c gc u   where-	new c cst = Just $ specialRemote c-		(prepareDAV this $ store chunkconfig)-		(prepareDAV this $ retrieve chunkconfig)-		(prepareDAV this $ remove)-		(prepareDAV this $ checkKey this chunkconfig)+	new c cst hdl = Just $ specialRemote c+		(simplyPrepare $ store hdl chunkconfig)+		(simplyPrepare $ retrieve hdl chunkconfig)+		(simplyPrepare $ remove hdl)+		(simplyPrepare $ checkKey hdl this chunkconfig) 		this 	  where 		this = Remote@@ -90,13 +94,13 @@ 			, checkPresent = checkPresentDummy 			, checkPresentCheap = False 			, exportActions = ExportActions-				{ storeExport = storeExportDav this-				, retrieveExport = retrieveExportDav this-				, checkPresentExport = checkPresentExportDav this-				, removeExport = removeExportDav this+				{ storeExport = storeExportDav hdl+				, retrieveExport = retrieveExportDav hdl+				, checkPresentExport = checkPresentExportDav hdl this+				, removeExport = removeExportDav hdl 				, removeExportDirectory = Just $-					removeExportDirectoryDav this-				, renameExport = renameExportDav this+					removeExportDirectoryDav hdl+				, renameExport = renameExportDav hdl 				} 			, importActions = importUnsupported 			, whereisKey = Nothing@@ -133,18 +137,20 @@ 	c'' <- setRemoteCredPair encsetup c' gc (davCreds u) creds 	return (c'', u) -prepareDAV :: Remote -> (Maybe DavHandle -> helper) -> Preparer helper-prepareDAV = resourcePrepare . const . withDAVHandle--store :: ChunkConfig -> Maybe DavHandle -> Storer-store _ Nothing = byteStorer $ \_k _b _p -> return False-store (LegacyChunks chunksize) (Just dav) = fileStorer $ \k f p -> liftIO $-	withMeteredFile f p $ storeLegacyChunked chunksize k dav-store _  (Just dav) = httpStorer $ \k reqbody -> liftIO $ goDAV dav $ do-	let tmp = keyTmpLocation k-	let dest = keyLocation k-	storeHelper dav tmp dest reqbody-	return True+store :: DavHandleVar -> ChunkConfig -> Storer+store hv (LegacyChunks chunksize) = fileStorer $ \k f p -> +	withDavHandle hv $ \case+		Nothing -> return False+		Just dav -> liftIO $+			withMeteredFile f p $ storeLegacyChunked chunksize k dav+store hv _ = httpStorer $ \k reqbody -> +	withDavHandle hv $ \case+		Nothing -> return False+		Just dav -> liftIO $ goDAV dav $ do+			let tmp = keyTmpLocation k+			let dest = keyLocation k+			storeHelper dav tmp dest reqbody+			return True  storeHelper :: DavHandle -> DavLocation -> DavLocation -> RequestBody -> DAVT IO () storeHelper dav tmp dest reqbody = do@@ -164,11 +170,14 @@ retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False -retrieve :: ChunkConfig -> Maybe DavHandle -> Retriever-retrieve _ Nothing = giveup "unable to connect"-retrieve (LegacyChunks _) (Just dav) = retrieveLegacyChunked dav-retrieve _ (Just dav) = fileRetriever $ \d k p -> liftIO $-	goDAV dav $ retrieveHelper (keyLocation k) d p+retrieve :: DavHandleVar -> ChunkConfig -> Retriever+retrieve hv cc = fileRetriever $ \d k p ->+	withDavHandle hv $ \case+		Nothing -> giveup "unable to connect"+		Just dav -> case cc of+			LegacyChunks _ -> retrieveLegacyChunked d k p dav+			_ -> liftIO $+				goDAV dav $ retrieveHelper (keyLocation k) d p  retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> DAVT IO () retrieveHelper loc d p = do@@ -176,12 +185,13 @@ 	inLocation loc $ 		withContentM $ httpBodyRetriever d p -remove :: Maybe DavHandle -> Remover-remove Nothing _ = return False-remove (Just dav) k = liftIO $ goDAV dav $-	-- Delete the key's whole directory, including any-	-- legacy chunked files, etc, in a single action.-	removeHelper (keyDir k)+remove :: DavHandleVar -> Remover+remove hv k = withDavHandle hv $ \case+	Nothing -> return False+	Just dav -> liftIO $ goDAV dav $+		-- Delete the key's whole directory, including any+		-- legacy chunked files, etc, in a single action.+		removeHelper (keyDir k)  removeHelper :: DavLocation -> DAVT IO Bool removeHelper d = do@@ -195,20 +205,21 @@ 				Right False -> return True 				_ -> return False -checkKey :: Remote -> ChunkConfig -> Maybe DavHandle -> CheckPresent-checkKey r _ Nothing _ = giveup $ name r ++ " not configured"-checkKey r chunkconfig (Just dav) k = do-	showChecking r-	case chunkconfig of-		LegacyChunks _ -> checkKeyLegacyChunked dav k-		_ -> do-			v <- liftIO $ goDAV dav $-				existsDAV (keyLocation k)-			either giveup return v+checkKey :: DavHandleVar -> Remote -> ChunkConfig -> CheckPresent+checkKey hv r chunkconfig k = withDavHandle hv $ \case+	Nothing -> giveup $ name r ++ " not configured"+	Just dav -> do+		showChecking r+		case chunkconfig of+			LegacyChunks _ -> checkKeyLegacyChunked dav k+			_ -> do+				v <- liftIO $ goDAV dav $+					existsDAV (keyLocation k)+				either giveup return v -storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool-storeExportDav r f k loc p = case exportLocation loc of-	Right dest -> withDAVHandle r $ \mh -> runExport mh $ \dav -> do+storeExportDav :: DavHandleVar -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool+storeExportDav hdl f k loc p = case exportLocation loc of+	Right dest -> withDavHandle hdl $ \mh -> runExport mh $ \dav -> do 		reqbody <- liftIO $ httpBodyStorer f p 		storeHelper dav (keyTmpLocation k) dest reqbody 		return True@@ -216,25 +227,25 @@ 		warning err 		return False -retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool-retrieveExportDav r  _k loc d p = case exportLocation loc of-	Right src -> withDAVHandle r $ \mh -> runExport mh $ \_dav -> do+retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool+retrieveExportDav hdl  _k loc d p = case exportLocation loc of+	Right src -> withDavHandle hdl $ \mh -> runExport mh $ \_dav -> do 		retrieveHelper src d p 		return True 	Left _err -> return False -checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool-checkPresentExportDav r _k loc = case exportLocation loc of-	Right p -> withDAVHandle r $ \case+checkPresentExportDav :: DavHandleVar -> Remote -> Key -> ExportLocation -> Annex Bool+checkPresentExportDav hdl r _k loc = case exportLocation loc of+	Right p -> withDavHandle hdl $ \case 		Nothing -> giveup $ name r ++ " not configured" 		Just h -> liftIO $ do 			v <- goDAV h $ existsDAV p 			either giveup return v 	Left err -> giveup err -removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool-removeExportDav r _k loc = case exportLocation loc of-	Right p -> withDAVHandle r $ \mh -> runExport mh $ \_dav ->+removeExportDav :: DavHandleVar-> Key -> ExportLocation -> Annex Bool+removeExportDav hdl _k loc = case exportLocation loc of+	Right p -> withDavHandle hdl $ \mh -> runExport mh $ \_dav -> 		removeHelper p 	-- When the exportLocation is not legal for webdav, 	-- the content is certianly not stored there, so it's ok for@@ -243,16 +254,16 @@ 	-- this will be called to make sure it's gone. 	Left _err -> return True -removeExportDirectoryDav :: Remote -> ExportDirectory -> Annex Bool-removeExportDirectoryDav r dir = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do+removeExportDirectoryDav :: DavHandleVar -> ExportDirectory -> Annex Bool+removeExportDirectoryDav hdl dir = withDavHandle hdl $ \mh -> runExport mh $ \_dav -> do 	let d = fromRawFilePath $ fromExportDirectory dir 	debugDav $ "delContent " ++ d 	safely (inLocation d delContentM) 		>>= maybe (return False) (const $ return True) -renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)-renameExportDav r _k src dest = case (exportLocation src, exportLocation dest) of-	(Right srcl, Right destl) -> withDAVHandle r $ \case+renameExportDav :: DavHandleVar -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)+renameExportDav hdl _k src dest = case (exportLocation src, exportLocation dest) of+	(Right srcl, Right destl) -> withDavHandle hdl $ \case 		Just h 			-- box.com's DAV endpoint has buggy handling of renames, 			-- so avoid renaming when using it.@@ -270,8 +281,8 @@ runExport Nothing _ = return False runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h)) -configUrl :: Remote -> Maybe URLString-configUrl r = fixup <$> getRemoteConfigValue urlField (config r)+configUrl :: ParsedRemoteConfig -> Maybe URLString+configUrl c = fixup <$> getRemoteConfigValue urlField c   where 	-- box.com DAV url changed 	fixup = replace "https://www.box.com/dav/" boxComUrl@@ -407,15 +418,28 @@  data DavHandle = DavHandle DAVContext DavUser DavPass URLString -withDAVHandle :: Remote -> (Maybe DavHandle -> Annex a) -> Annex a-withDAVHandle r a = do-	mcreds <- getCreds (config r) (gitconfig r) (uuid r)-	case (mcreds, configUrl r) of-		(Just (user, pass), Just baseurl) ->-			withDAVContext baseurl $ \ctx ->-				a (Just (DavHandle ctx (toDavUser user) (toDavPass pass) baseurl))-		_ -> a Nothing+type DavHandleVar = TVar (Either (Annex (Maybe DavHandle)) (Maybe DavHandle)) +{- Prepares a DavHandle for later use. Does not connect to the server or do+ - anything else expensive. -}+mkDavHandleVar :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex DavHandleVar+mkDavHandleVar c gc u = liftIO $ newTVarIO $ Left $ do+	mcreds <- getCreds c gc u+	case (mcreds, configUrl c) of+		(Just (user, pass), Just baseurl) -> do+			ctx <- mkDAVContext baseurl+			let h = DavHandle ctx (toDavUser user) (toDavPass pass) baseurl+			return (Just h)+		_ -> return Nothing++withDavHandle :: DavHandleVar -> (Maybe DavHandle -> Annex a) -> Annex a+withDavHandle hv a = liftIO (readTVarIO hv) >>= \case+	Right hdl -> a hdl+	Left mkhdl -> do+		hdl <- mkhdl+		liftIO $ atomically $ writeTVar hv (Right hdl)+		a hdl+ goDAV :: DavHandle -> DAVT IO a -> IO a goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do 	prepDAV user pass@@ -464,8 +488,8 @@ 	tmp = addTrailingPathSeparator $ keyTmpLocation k 	dest = keyLocation k -retrieveLegacyChunked :: DavHandle -> Retriever-retrieveLegacyChunked dav = fileRetriever $ \d k p -> liftIO $+retrieveLegacyChunked :: FilePath -> Key -> MeterUpdate -> DavHandle -> Annex ()+retrieveLegacyChunked d k p dav = liftIO $ 	withStoredFilesLegacyChunked k dav onerr $ \locs -> 		Legacy.meteredWriteFileChunks p d locs $ \l -> 			goDAV dav $ do
Test.hs view
@@ -1574,10 +1574,13 @@   where 	gpgcmd = Utility.Gpg.mkGpgCmd Nothing 	testscheme scheme = do-		gpgtmp <- (</> "gpgtest") <$> absPath tmpdir+		abstmp <- absPath tmpdir+		testscheme' scheme abstmp+	testscheme' scheme abstmp = intmpclonerepo $ whenM (Utility.Path.inPath (Utility.Gpg.unGpgCmd gpgcmd)) $ do+		-- Use a relative path to avoid too long path to gpg's+		-- agent socket.+		gpgtmp <- (</> "gpgtmp") <$> relPathCwdToFile abstmp 		createDirectoryIfMissing False gpgtmp-		testscheme' scheme gpgtmp-	testscheme' scheme gpgtmp = intmpclonerepo $ whenM (Utility.Path.inPath (Utility.Gpg.unGpgCmd gpgcmd)) $ do 		Utility.Gpg.testTestHarness gpgtmp gpgcmd  			@? "test harness self-test failed" 		Utility.Gpg.testHarness gpgtmp gpgcmd $ do
Utility/Directory.hs view
@@ -14,12 +14,12 @@ 	module Utility.SystemDirectory ) where -import System.IO.Error import Control.Monad import System.FilePath import System.PosixCompat.Files import Control.Applicative import Control.Monad.IO.Class+import Control.Monad.IfElse import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error import Data.Maybe@@ -27,7 +27,6 @@  #ifndef mingw32_HOST_OS import Utility.SafeCommand-import Control.Monad.IfElse #endif  import Utility.SystemDirectory
doc/git-annex-add.mdwn view
@@ -25,7 +25,6 @@ modification of their content unless unlocked by [[git-annex-unlock]](1). (This is not the case however when a repository is in a filesystem not supporting symlinks.)-To add a file to the annex in unlocked form, `git add` can be used instead.  This command can also be used to add symbolic links, both symlinks to annexed content, and other symlinks.
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20200309+Version: 8.20200330 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>