packages feed

git-annex 8.20200330 → 8.20200501

raw patch · 136 files changed

+1833/−872 lines, 136 files

Files

Annex.hs view
@@ -43,7 +43,6 @@ import qualified Git.Config import qualified Git.Construct import Annex.Fixup-import Git.CatFile import Git.HashObject import Git.CheckAttr import Git.CheckIgnore@@ -67,9 +66,12 @@ import Types.CleanupActions import Types.AdjustedBranch import Types.WorkerPool+import Types.IndexFiles+import Types.CatFileHandles import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url+import Utility.ResourcePool  import "mtl" Control.Monad.Reader import Control.Concurrent@@ -108,7 +110,6 @@ 	, gitremotes :: Maybe [Git.Repo] 	, backend :: Maybe (BackendA Annex) 	, remotes :: [Types.Remote.RemoteA Annex]-	, remoteannexstate :: M.Map UUID AnnexState 	, output :: MessageState 	, concurrency :: Concurrency 	, force :: Bool@@ -116,10 +117,10 @@ 	, daemon :: Bool 	, branchstate :: BranchState 	, repoqueue :: Maybe (Git.Queue.Queue Annex)-	, catfilehandles :: M.Map FilePath CatFileHandle+	, catfilehandles :: CatFileHandles 	, hashobjecthandle :: Maybe HashObjectHandle-	, checkattrhandle :: Maybe CheckAttrHandle-	, checkignorehandle :: Maybe CheckIgnoreHandle+	, checkattrhandle :: Maybe (ResourcePool CheckAttrHandle)+	, checkignorehandle :: Maybe (ResourcePool CheckIgnoreHandle) 	, forcebackend :: Maybe String 	, globalnumcopies :: Maybe NumCopies 	, forcenumcopies :: Maybe NumCopies@@ -146,9 +147,9 @@ 	, workers :: Maybe (TMVar (WorkerPool AnnexState)) 	, activekeys :: TVar (M.Map Key ThreadId) 	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)-	, keysdbhandle :: Maybe Keys.DbHandle+	, keysdbhandle :: Keys.DbHandle 	, cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment))-	, cachedgitenv :: Maybe (FilePath, [(String, String)])+	, cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)]) 	, urloptions :: Maybe UrlOptions 	} @@ -158,6 +159,7 @@ 	emptyactivekeys <- newTVarIO M.empty 	o <- newMessageState 	sc <- newTMVarIO False+	kh <- Keys.newDbHandle 	return $ AnnexState 		{ repo = r 		, repoadjustment = return@@ -166,7 +168,6 @@ 		, gitremotes = Nothing 		, backend = Nothing 		, remotes = []-		, remoteannexstate = M.empty 		, output = o 		, concurrency = NonConcurrent 		, force = False@@ -174,7 +175,7 @@ 		, daemon = False 		, branchstate = startBranchState 		, repoqueue = Nothing-		, catfilehandles = M.empty+		, catfilehandles = catFileHandlesNonConcurrent 		, hashobjecthandle = Nothing 		, checkattrhandle = Nothing 		, checkignorehandle = Nothing@@ -204,7 +205,7 @@ 		, workers = Nothing 		, activekeys = emptyactivekeys 		, activeremotes = emptyactiveremotes-		, keysdbhandle = Nothing+		, keysdbhandle = kh 		, cachedcurrentbranch = Nothing 		, cachedgitenv = Nothing 		, urloptions = Nothing@@ -232,7 +233,7 @@ 	flush s' 	return (r, s')   where-	flush = maybe noop Keys.flushDbQueue . keysdbhandle+	flush = Keys.flushDbQueue . keysdbhandle  {- Performs an action in the Annex monad from a starting state,   - and throws away the new state. -}
Annex/Action.hs view
@@ -23,7 +23,10 @@ import Annex.Common import qualified Annex import Annex.Content-import Annex.Concurrent+import Annex.CatFile+import Annex.CheckAttr+import Annex.HashObject+import Annex.CheckIgnore  {- Actions to perform each time ran. -} startup :: Annex ()@@ -36,6 +39,14 @@ 	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup 	stopCoProcesses 	liftIO reapZombies -- zombies from long-running git processes++{- Stops all long-running git query processes. -}+stopCoProcesses :: Annex ()+stopCoProcesses = do+	catFileStop+	checkAttrStop+	hashObjectStop+	checkIgnoreStop  {- Reaps any zombie processes that may be hanging around.  -
Annex/AdjustedBranch.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, OverloadedStrings #-}  module Annex.AdjustedBranch ( 	Adjustment(..),@@ -61,6 +61,7 @@ import Config  import qualified Data.Map as M+import qualified Data.ByteString as S  -- How to perform various adjustments to a TreeItem. class AdjustTreeItem t where@@ -128,7 +129,7 @@ -- refs/basis/adjusted/master(unlocked). basisBranch :: AdjBranch -> BasisBranch basisBranch (AdjBranch adjbranch) = BasisBranch $-	Ref ("refs/basis/" ++ fromRef (Git.Ref.base adjbranch))+	Ref ("refs/basis/" <> fromRef' (Git.Ref.base adjbranch))  getAdjustment :: Branch -> Maybe Adjustment getAdjustment = fmap fst . adjustedToOriginal@@ -405,7 +406,8 @@ 					<||> (resolveMerge (Just updatedorig) tomerge True <&&> commitResolvedMerge commitmode) 				if merged 					then do-						!mergecommit <- liftIO $ extractSha <$> readFile (tmpgit </> "HEAD")+						!mergecommit <- liftIO $ extractSha+							<$> S.readFile (tmpgit </> "HEAD") 						-- This is run after the commit lock is dropped. 						return $ postmerge mergecommit 					else return $ return False
Annex/AdjustedBranch/Name.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.AdjustedBranch.Name ( 	originalToAdjusted, 	adjustedToOriginal,@@ -18,14 +20,15 @@ import Utility.Misc  import Control.Applicative-import Data.List+import Data.Char+import qualified Data.ByteString as S -adjustedBranchPrefix :: String+adjustedBranchPrefix :: S.ByteString adjustedBranchPrefix = "refs/heads/adjusted/"  class SerializeAdjustment t where-	serializeAdjustment :: t -> String-	deserializeAdjustment :: String -> Maybe t+	serializeAdjustment :: t -> S.ByteString+	deserializeAdjustment :: S.ByteString -> Maybe t  instance SerializeAdjustment Adjustment where 	serializeAdjustment (LinkAdjustment l) =@@ -33,7 +36,7 @@ 	serializeAdjustment (PresenceAdjustment p Nothing) = 		serializeAdjustment p 	serializeAdjustment (PresenceAdjustment p (Just l)) = -		serializeAdjustment p ++ "-" ++ serializeAdjustment l+		serializeAdjustment p <> "-" <> serializeAdjustment l 	deserializeAdjustment s =  		(LinkAdjustment <$> deserializeAdjustment s) 			<|>@@ -41,7 +44,7 @@ 			<|> 		(PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing) 	  where-		(s1, s2) = separate (== '-') s+		(s1, s2) = separate' (== (fromIntegral (ord '-'))) s  instance SerializeAdjustment LinkAdjustment where 	serializeAdjustment UnlockAdjustment = "unlocked"@@ -65,19 +68,21 @@  originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch originalToAdjusted orig adj = AdjBranch $ Ref $-	adjustedBranchPrefix ++ base ++ '(' : serializeAdjustment adj ++ ")"+	adjustedBranchPrefix <> base <> "(" <> serializeAdjustment adj <> ")"   where-	base = fromRef (Git.Ref.base orig)+	base = fromRef' (Git.Ref.base orig)  type OrigBranch = Branch  adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch) adjustedToOriginal b-	| adjustedBranchPrefix `isPrefixOf` bs = do-		let (base, as) = separate (== '(') (drop prefixlen bs)-		adj <- deserializeAdjustment (takeWhile (/= ')') as)+	| adjustedBranchPrefix `S.isPrefixOf` bs = do+		let (base, as) = separate' (== openparen) (S.drop prefixlen bs)+		adj <- deserializeAdjustment (S.takeWhile (/= closeparen) as) 		Just (adj, Git.Ref.branchRef (Ref base)) 	| otherwise = Nothing   where-	bs = fromRef b-	prefixlen = length adjustedBranchPrefix+	bs = fromRef' b+	prefixlen = S.length adjustedBranchPrefix+	openparen = fromIntegral (ord '(')+	closeparen = fromIntegral (ord ')')
Annex/Branch.hs view
@@ -1,10 +1,12 @@ {- management of the git-annex branch  -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.Branch ( 	fullname, 	name,@@ -12,6 +14,7 @@ 	hasSibling, 	siblingBranches, 	create,+	UpdateMade(..), 	update, 	forceUpdate, 	updateTo,@@ -29,7 +32,9 @@ 	withIndex, ) where +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Char8 as B8 import qualified Data.Set as S import qualified Data.Map as M import Data.Function@@ -38,6 +43,7 @@ import Control.Concurrent (threadDelay)  import Annex.Common+import Types.BranchState import Annex.BranchState import Annex.Journal import Annex.GitOverlay@@ -55,7 +61,7 @@ import Git.LsTree (lsTreeParams) import qualified Git.HashObject import Annex.HashObject-import Git.Types (Ref(..), fromRef, RefDate, TreeItemType(..))+import Git.Types (Ref(..), fromRef, fromRef', RefDate, TreeItemType(..)) import Git.FilePath import Annex.CatFile import Annex.Perms@@ -77,11 +83,11 @@  {- Fully qualified name of the branch. -} fullname :: Git.Ref-fullname = Git.Ref $ "refs/heads/" ++ fromRef name+fullname = Git.Ref $ "refs/heads/" <> fromRef' name  {- Branch's name in origin. -} originname :: Git.Ref-originname = Git.Ref $ "origin/" ++ fromRef name+originname = Git.Ref $ "origin/" <> fromRef' name  {- Does origin/git-annex exist? -} hasOrigin :: Annex Bool@@ -119,13 +125,18 @@  {- Ensures that the branch and index are up-to-date; should be  - called before data is read from it. Runs only once per git-annex run. -}-update :: Annex ()-update = runUpdateOnce $ void $ updateTo =<< siblingBranches+update :: Annex BranchState+update = runUpdateOnce $ journalClean <$$> updateTo =<< siblingBranches  {- Forces an update even if one has already been run. -}-forceUpdate :: Annex Bool+forceUpdate :: Annex UpdateMade forceUpdate = updateTo =<< siblingBranches +data UpdateMade = UpdateMade+	{ refsWereMerged :: Bool+	, journalClean :: Bool+	}+ {- Merges the specified Refs into the index, if they have any changes not  - already in it. The Branch names are only used in the commit message;  - it's even possible that the provided Branches have not been updated to@@ -144,13 +155,13 @@  -  - Returns True if any refs were merged in, False otherwise.  -}-updateTo :: [(Git.Sha, Git.Branch)] -> Annex Bool+updateTo :: [(Git.Sha, Git.Branch)] -> Annex UpdateMade updateTo pairs = ifM (annexMergeAnnexBranches <$> Annex.getGitConfig) 	( updateTo' pairs-	, return False+	, return (UpdateMade False False) 	) -updateTo' :: [(Git.Sha, Git.Branch)] -> Annex Bool+updateTo' :: [(Git.Sha, Git.Branch)] -> Annex UpdateMade updateTo' pairs = do 	-- ensure branch exists, and get its current ref 	branchref <- getBranch@@ -162,20 +173,35 @@ 		else do 			mergedrefs <- getMergedRefs 			filterM isnewer (excludeset mergedrefs unignoredrefs)-	if null tomerge+	journalclean <- if null tomerge 		{- Even when no refs need to be merged, the index 		 - may still be updated if the branch has gotten ahead -		 - of the index. -}-		then do-			whenM (needUpdateIndex branchref) $ lockJournal $ \jl -> do+		 - of the index, or just if the journal is dirty. -}+		then ifM (needUpdateIndex branchref)+			( lockJournal $ \jl -> do 				forceUpdateIndex jl branchref 				{- When there are journalled changes 				 - as well as the branch being updated, 				 - a commit needs to be done. -} 				when dirty $-					go branchref True [] jl-		else lockJournal $ go branchref dirty tomerge-	return $ not $ null tomerge+					go branchref dirty [] jl+				return True+			, if dirty+				then ifM (annexAlwaysCommit <$> Annex.getGitConfig)+					( do+						lockJournal $ go branchref dirty []+						return True+					, return False+					)+				else return True+			)+		else do+			lockJournal $ go branchref dirty tomerge+			return True+	return $ UpdateMade+		{ refsWereMerged = not (null tomerge)+		, journalClean = journalclean+		}   where 	excludeset s = filter (\(r, _) -> S.notMember r s) 	isnewer (r, _) = inRepo $ Git.Branch.changed fullname r@@ -217,8 +243,10 @@  - Returns an empty string if the file doesn't exist yet. -} get :: RawFilePath -> Annex L.ByteString get file = do-	update-	getLocal file+	st <- update+	if journalIgnorable st+		then getRef fullname file+		else getLocal file  {- Like get, but does not merge the branch, so the info returned may not  - reflect changes in remotes.@@ -270,7 +298,9 @@  {- Records new content of a file into the journal -} set :: Journalable content => JournalLocked -> RawFilePath -> content -> Annex ()-set = setJournalFile+set jl f c = do+	journalChanged+	setJournalFile jl f c  {- Commit message used when making a commit of whatever data has changed  - to the git-annex brach. -}@@ -327,9 +357,9 @@   where 	-- look for "parent ref" lines and return the refs 	commitparents = map (Git.Ref . snd) . filter isparent .-		map (toassoc . decodeBL) . L.split newline+		map (toassoc . L.toStrict) . L.split newline 	newline = fromIntegral (ord '\n')-	toassoc = separate (== ' ')+	toassoc = separate' (== (fromIntegral (ord ' '))) 	isparent (k,_) = k == "parent" 		 	{- The race can be detected by checking the commit's@@ -355,7 +385,7 @@  - that have not been committed yet. There may be duplicates in the list. -} files :: Annex [RawFilePath] files = do-	update+	_  <- update 	-- ++ forces the content of the first list to be buffered in memory, 	-- so use getJournalledFilesStale which should be much smaller most 	-- of the time. branchFiles will stream as the list is consumed.@@ -388,8 +418,8 @@ mergeIndex jl branches = do 	prepareModifyIndex jl 	hashhandle <- hashObjectHandle-	ch <- catFileHandle-	inRepo $ \g -> Git.UnionMerge.mergeIndex hashhandle ch g branches+	withCatFileHandle $ \ch ->+		inRepo $ \g -> Git.UnionMerge.mergeIndex hashhandle ch g branches  {- Removes any stale git lock file, to avoid git falling over when  - updating the index.@@ -410,14 +440,12 @@ withIndex :: Annex a -> Annex a withIndex = withIndex' False withIndex' :: Bool -> Annex a -> Annex a-withIndex' bootstrapping a = do-	f <- fromRepo gitAnnexIndex-	withIndexFile f $ do-		checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do-			unless bootstrapping create-			createAnnexDirectory $ takeDirectory f-			unless bootstrapping $ inRepo genIndex-		a+withIndex' bootstrapping a = withIndexFile AnnexIndexFile $ \f -> do+	checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do+		unless bootstrapping create+		createAnnexDirectory $ takeDirectory f+		unless bootstrapping $ inRepo genIndex+	a  {- Updates the branch's index to reflect the current contents of the branch.  - Any changes staged in the index will be preserved.@@ -438,8 +466,8 @@ needUpdateIndex :: Git.Ref -> Annex Bool needUpdateIndex branchref = do 	f <- fromRepo gitAnnexIndexStatus-	committedref <- Git.Ref . firstLine <$>-		liftIO (catchDefaultIO "" $ readFileStrict f)+	committedref <- Git.Ref . firstLine' <$>+		liftIO (catchDefaultIO mempty $ B.readFile f) 	return (committedref /= branchref)  {- Record that the branch's index has been updated to correspond to a@@ -621,11 +649,12 @@ 		unlines $ map fromRef $ S.elems s  getIgnoredRefs :: Annex (S.Set Git.Sha)-getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content+getIgnoredRefs = +	S.fromList . mapMaybe Git.Sha.extractSha . B8.lines <$> content   where 	content = do 		f <- fromRepo gitAnnexIgnoredRefs-		liftIO $ catchDefaultIO "" $ readFile f+		liftIO $ catchDefaultIO mempty $ B.readFile f  addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex () addMergedRefs [] = return ()@@ -643,11 +672,11 @@ getMergedRefs' :: Annex [(Git.Sha, Git.Branch)] getMergedRefs' = do 	f <- fromRepo gitAnnexMergedRefs-	s <- liftIO $ catchDefaultIO "" $ readFile f-	return $ map parse $ lines s+	s <- liftIO $ catchDefaultIO mempty $ B.readFile f+	return $ map parse $ B8.lines s   where 	parse l = -		let (s, b) = separate (== '\t') l+		let (s, b) = separate' (== (fromIntegral (ord '\t'))) l 		in (Ref s, Ref b)  {- Grafts a treeish into the branch at the specified location,
Annex/BranchState.hs view
@@ -2,7 +2,7 @@  -  - Runtime state about the git-annex branch.  -- - Copyright 2011-2012 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -28,14 +28,55 @@ 	changeState $ \s -> s { indexChecked = True }  {- Runs an action to update the branch, if it's not been updated before- - in this run of git-annex. -}-runUpdateOnce :: Annex () -> Annex ()-runUpdateOnce a = unlessM (branchUpdated <$> getState) $ do-	a-	disableUpdate+ - in this run of git-annex. + -+ - The action should return True if anything that was in the journal+ - before got staged (or if the journal was empty). That lets an opmisation+ - be done: The journal then does not need to be checked going forward,+ - until new information gets written to it.+ -}+runUpdateOnce :: Annex Bool -> Annex BranchState+runUpdateOnce a = do+	st <- getState+	if branchUpdated st+		then return st+		else do+			journalstaged <- a+			let stf = \st' -> st'+				{ branchUpdated = True+				, journalIgnorable = journalstaged +					&& not (journalNeverIgnorable st')+				}+			changeState stf+			return (stf st)  {- Avoids updating the branch. A useful optimisation when the branch  - is known to have not changed, or git-annex won't be relying on info  - from it. -} disableUpdate :: Annex () disableUpdate = changeState $ \s -> s { branchUpdated = True }++{- Called when a change is made to the journal. -}+journalChanged :: Annex ()+journalChanged = do+	-- Optimisation: Typically journalIgnorable will already be True+	-- (when one thing gets journalled, often other things do to),+	-- so avoid an unnecessary write to the MVar that changeState+	-- would do.+	--+	-- This assumes that another thread is not changing journalIgnorable+	-- at the same time, but since runUpdateOnce is the only+	-- thing that changes it, and it only runs once, that+	-- should not happen.+	st <- getState +	when (journalIgnorable st) $+		changeState $ \st' -> st' { journalIgnorable = False }++{- When git-annex is somehow interactive, eg in --batch mode,+ - and needs to always notice changes made to the journal by other+ - processes, this disables optimisations that avoid normally reading the+ - journal.+ -}+enableInteractiveJournalAccess :: Annex ()+enableInteractiveJournalAccess = changeState $+	\s -> s { journalNeverIgnorable = True }
Annex/CatFile.hs view
@@ -1,10 +1,12 @@ {- git cat-file interface, with handle automatically stored in the Annex monad  -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE BangPatterns #-}+ module Annex.CatFile ( 	catFile, 	catFileDetails,@@ -12,7 +14,7 @@ 	catTree, 	catCommit, 	catObjectDetails,-	catFileHandle,+	withCatFileHandle, 	catObjectMetaData, 	catFileStop, 	catKey,@@ -27,6 +29,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import System.PosixCompat.Types+import Control.Concurrent.STM  import Annex.Common import qualified Git@@ -39,64 +42,94 @@ import Annex.Link import Annex.CurrentBranch import Types.AdjustedBranch+import Types.CatFileHandles+import Utility.ResourcePool  catFile :: Git.Branch -> RawFilePath -> Annex L.ByteString-catFile branch file = do-	h <- catFileHandle+catFile branch file = withCatFileHandle $ \h ->  	liftIO $ Git.CatFile.catFile h branch file  catFileDetails :: Git.Branch -> RawFilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType))-catFileDetails branch file = do-	h <- catFileHandle+catFileDetails branch file = withCatFileHandle $ \h ->  	liftIO $ Git.CatFile.catFileDetails h branch file  catObject :: Git.Ref -> Annex L.ByteString-catObject ref = do-	h <- catFileHandle+catObject ref = withCatFileHandle $ \h -> 	liftIO $ Git.CatFile.catObject h ref  catObjectMetaData :: Git.Ref -> Annex (Maybe (Sha, Integer, ObjectType))-catObjectMetaData ref = do-	h <- catFileHandle+catObjectMetaData ref = withCatFileHandle $ \h -> 	liftIO $ Git.CatFile.catObjectMetaData h ref  catTree :: Git.Ref -> Annex [(FilePath, FileMode)]-catTree ref = do-	h <- catFileHandle+catTree ref = withCatFileHandle $ \h ->  	liftIO $ Git.CatFile.catTree h ref  catCommit :: Git.Ref -> Annex (Maybe Commit)-catCommit ref = do-	h <- catFileHandle+catCommit ref = withCatFileHandle $ \h ->  	liftIO $ Git.CatFile.catCommit h ref  catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha, ObjectType))-catObjectDetails ref = do-	h <- catFileHandle+catObjectDetails ref = withCatFileHandle $ \h -> 	liftIO $ Git.CatFile.catObjectDetails h ref  {- There can be multiple index files, and a different cat-file is needed- - for each. This is selected by setting GIT_INDEX_FILE in the gitEnv. -}-catFileHandle :: Annex Git.CatFile.CatFileHandle-catFileHandle = do-	m <- Annex.getState Annex.catfilehandles+ - for each. That is selected by setting GIT_INDEX_FILE in the gitEnv+ - before running this. -}+withCatFileHandle :: (Git.CatFile.CatFileHandle -> Annex a) -> Annex a+withCatFileHandle a = do+	cfh <- Annex.getState Annex.catfilehandles 	indexfile <- fromMaybe "" . maybe Nothing (lookup indexEnv) 		<$> fromRepo gitEnv-	case M.lookup indexfile m of-		Just h -> return h-		Nothing -> do-			h <- inRepo Git.CatFile.catFileStart-			let m' = M.insert indexfile h m-			Annex.changeState $ \s -> s { Annex.catfilehandles = m' }-			return h+	p <- case cfh of+		CatFileHandlesNonConcurrent m -> case M.lookup indexfile m of+			Just p -> return p+			Nothing -> do+				p <- mkResourcePoolNonConcurrent startcatfile+				let !m' = M.insert indexfile p m+				Annex.changeState $ \s -> s { Annex.catfilehandles = CatFileHandlesNonConcurrent m' }+				return p+		CatFileHandlesPool tm -> do+			m <- liftIO $ atomically $ takeTMVar tm+			case M.lookup indexfile m of+				Just p -> do+					liftIO $ atomically $ putTMVar tm m+					return p+				Nothing -> do+					p  <- mkResourcePool maxCatFiles+					let !m' = M.insert indexfile p m+					liftIO $ atomically $ putTMVar tm m'+					return p+	withResourcePool p startcatfile a+  where+	startcatfile = inRepo Git.CatFile.catFileStart +{- A lot of git cat-file processes are unlikely to improve concurrency,+ - because a query to them takes only a little bit of CPU, and tends to be+ - bottlenecked on disk. Also, they each open a number of files, so+ - using too many might run out of file handles. So, only start a maximum+ - of 2.+ -+ - Note that each different index file gets its own pool of cat-files;+ - this is the size of each pool. In all, 4 times this many cat-files+ - may end up running.+ -}+maxCatFiles :: Int+maxCatFiles = 2+ {- Stops all running cat-files. Should only be run when it's known that  - nothing is using the handles, eg at shutdown. -} catFileStop :: Annex () catFileStop = do-	m <- Annex.withState $ pure . \s ->-		(s { Annex.catfilehandles = M.empty }, Annex.catfilehandles s)-	liftIO $ mapM_ Git.CatFile.catFileStop (M.elems m)+	cfh <- Annex.getState Annex.catfilehandles+	m <- case cfh of+		CatFileHandlesNonConcurrent m -> do+			Annex.changeState $ \s -> s { Annex.catfilehandles = CatFileHandlesNonConcurrent M.empty }+			return m+		CatFileHandlesPool tm ->+			liftIO $ atomically $ swapTMVar tm M.empty+	liftIO $ forM_ (M.elems m) $ \p ->+		freeResourcePool p Git.CatFile.catFileStop  {- From ref to a symlink or a pointer file, get the key. -} catKey :: Ref -> Annex (Maybe Key)
Annex/ChangedRefs.hs view
@@ -1,6 +1,6 @@ {- Waiting for changed git refs  -- - Copyright 2014-216 Joey Hess <id@joeyh.name>+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -24,13 +24,14 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Concurrent.STM.TBMChan+import qualified Data.ByteString as S  newtype ChangedRefs = ChangedRefs [Git.Ref] 	deriving (Show)  instance Proto.Serializable ChangedRefs where 	serialize (ChangedRefs l) = unwords $ map Git.fromRef l-	deserialize = Just . ChangedRefs . map Git.Ref . words+	deserialize = Just . ChangedRefs . map (Git.Ref . encodeBS) . words  data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha) @@ -97,7 +98,7 @@ 	| ".lock" `isSuffixOf` reffile = noop 	| otherwise = void $ do 		sha <- catchDefaultIO Nothing $-			extractSha <$> readFile reffile+			extractSha <$> S.readFile reffile 		-- When the channel is full, there is probably no reader 		-- running, or ref changes have been occuring very fast, 		-- so it's ok to not write the change to it.
Annex/CheckAttr.hs view
@@ -1,19 +1,22 @@ {- git check-attr interface, with handle automatically stored in the Annex monad  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}  module Annex.CheckAttr ( 	checkAttr,-	checkAttrHandle, 	checkAttrStop,+	mkConcurrentCheckAttrHandle, ) where  import Annex.Common import qualified Git.CheckAttr as Git import qualified Annex+import Utility.ResourcePool+import Types.Concurrency+import Annex.Concurrent.Utility  {- All gitattributes used by git-annex. -} annexAttrs :: [Git.Attr]@@ -24,21 +27,38 @@ 	]  checkAttr :: Git.Attr -> FilePath -> Annex String-checkAttr attr file = do-	h <- checkAttrHandle+checkAttr attr file = withCheckAttrHandle $ \h ->  	liftIO $ Git.checkAttr h attr file -checkAttrHandle :: Annex Git.CheckAttrHandle-checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle+withCheckAttrHandle :: (Git.CheckAttrHandle -> Annex a) -> Annex a+withCheckAttrHandle a = +	maybe mkpool go =<< Annex.getState Annex.checkattrhandle   where-	startup = do-		h <- inRepo $ Git.checkAttrStart annexAttrs-		Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h }-		return h+	go p = withResourcePool p start a+	start = inRepo $ Git.checkAttrStart annexAttrs+	mkpool = do+		-- This only runs in non-concurrent code paths;+		-- a concurrent pool is set up earlier when needed.+		p <- mkResourcePoolNonConcurrent start+		Annex.changeState $ \s -> s { Annex.checkattrhandle = Just p }+		go p +mkConcurrentCheckAttrHandle :: Concurrency -> Annex (ResourcePool Git.CheckAttrHandle)+mkConcurrentCheckAttrHandle c =+	Annex.getState Annex.checkattrhandle >>= \case+		Just p@(ResourcePool {}) -> return p+		_ -> mkResourcePool =<< liftIO (maxCheckAttrs c)++{- git check-attr is typically CPU bound, and is not likely to be the main+ - bottleneck for any command. So limit to the number of CPU cores, maximum,+ - while respecting the -Jn value.+ -}+maxCheckAttrs :: Concurrency -> IO Int+maxCheckAttrs = concurrencyUpToCpus+ checkAttrStop :: Annex () checkAttrStop = maybe noop stop =<< Annex.getState Annex.checkattrhandle   where-	stop h = do-		liftIO $ Git.checkAttrStop h+	stop p = do+		liftIO $ freeResourcePool p Git.checkAttrStop 		Annex.changeState $ \s -> s { Annex.checkattrhandle = Nothing }
Annex/CheckIgnore.hs view
@@ -1,37 +1,57 @@ {- git check-ignore interface, with handle automatically stored in  - the Annex monad  -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}  module Annex.CheckIgnore ( 	checkIgnored,-	checkIgnoreHandle,-	checkIgnoreStop+	checkIgnoreStop,+	mkConcurrentCheckIgnoreHandle, ) where  import Annex.Common import qualified Git.CheckIgnore as Git import qualified Annex+import Utility.ResourcePool+import Types.Concurrency+import Annex.Concurrent.Utility  checkIgnored :: FilePath -> Annex Bool-checkIgnored file = go =<< checkIgnoreHandle-  where-	go h = liftIO $ Git.checkIgnored h file+checkIgnored file = withCheckIgnoreHandle $ \h ->+	liftIO $ Git.checkIgnored h file -checkIgnoreHandle :: Annex Git.CheckIgnoreHandle-checkIgnoreHandle = maybe startup return =<< Annex.getState Annex.checkignorehandle+withCheckIgnoreHandle :: (Git.CheckIgnoreHandle -> Annex a) -> Annex a+withCheckIgnoreHandle a =+	maybe mkpool go =<< Annex.getState Annex.checkignorehandle   where-	startup = do-		h <- inRepo Git.checkIgnoreStart-		Annex.changeState $ \s -> s { Annex.checkignorehandle = Just h }-		return h+	go p = withResourcePool p start a+	start = inRepo Git.checkIgnoreStart+	mkpool = do+		-- This only runs in non-concurrent code paths;+		-- a concurrent pool is set up earlier when needed.+		p <- mkResourcePoolNonConcurrent start+		Annex.changeState $ \s -> s { Annex.checkignorehandle = Just p }+		go p +mkConcurrentCheckIgnoreHandle :: Concurrency -> Annex (ResourcePool Git.CheckIgnoreHandle)+mkConcurrentCheckIgnoreHandle c =+	Annex.getState Annex.checkignorehandle >>= \case+		Just p@(ResourcePool {}) -> return p+		_ -> mkResourcePool =<< liftIO (maxCheckIgnores c)++{- git check-ignore is typically CPU bound, and is not likely to be the main+ - bottleneck for any command. So limit to the number of CPU cores, maximum,+ - while respecting the -Jn value.+ -}+maxCheckIgnores :: Concurrency -> IO Int+maxCheckIgnores = concurrencyUpToCpus+ checkIgnoreStop :: Annex () checkIgnoreStop = maybe noop stop =<< Annex.getState Annex.checkignorehandle   where-	stop h = do-		liftIO $ Git.checkIgnoreStop h+	stop p = do+		liftIO $ freeResourcePool p Git.checkIgnoreStop 		Annex.changeState $ \s -> s { Annex.checkignorehandle = Nothing }
Annex/Concurrent.hs view
@@ -1,6 +1,6 @@ {- git-annex concurrent state  -- - Copyright 2015-2019 Joey Hess <id@joeyh.name>+ - Copyright 2015-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -10,16 +10,36 @@ import Annex import Annex.Common import qualified Annex.Queue-import Annex.CatFile+import Annex.Action+import Types.Concurrency+import Types.WorkerPool+import Types.CatFileHandles import Annex.CheckAttr-import Annex.HashObject import Annex.CheckIgnore-import Types.WorkerPool+import Remote.List  import Control.Concurrent import Control.Concurrent.STM import qualified Data.Map as M +setConcurrency :: Concurrency -> Annex ()+setConcurrency NonConcurrent = Annex.changeState $ \s -> s +	{ Annex.concurrency = NonConcurrent+	}+setConcurrency c = do+	cfh <- Annex.getState Annex.catfilehandles+	cfh' <- case cfh of+		CatFileHandlesNonConcurrent _ -> liftIO catFileHandlesPool+		CatFileHandlesPool _ -> pure cfh+	cah <- mkConcurrentCheckAttrHandle c+	cih <- mkConcurrentCheckIgnoreHandle c+	Annex.changeState $ \s -> s+		{ Annex.concurrency = c+		, Annex.catfilehandles = cfh'+		, Annex.checkattrhandle = Just cah+		, Annex.checkignorehandle = Just cih+		}+ {- Allows forking off a thread that uses a copy of the current AnnexState  - to run an Annex action.  -@@ -46,14 +66,22 @@  -} dupState :: Annex AnnexState dupState = do+	-- Make sure that some expensive actions have been done before+	-- starting threads. This way the state has them already run,+	-- and each thread won't try to do them.+	_ <- remoteList+ 	st <- Annex.getState id-	return $ st+	-- Make sure that concurrency is enabled, if it was not already,+	-- so the concurrency-safe resource pools are set up.+	st' <- case Annex.concurrency st of+		NonConcurrent -> do+			setConcurrency (Concurrent 1)+			Annex.getState id+		_ -> return st+	return $ st' 		-- each thread has its own repoqueue 		{ Annex.repoqueue = Nothing-		-- avoid sharing eg, open file handles-		, Annex.catfilehandles = M.empty-		, Annex.checkattrhandle = Nothing-		, Annex.checkignorehandle = Nothing 		}  {- Merges the passed AnnexState into the current Annex state.@@ -65,14 +93,6 @@ 		uncurry addCleanup 	Annex.Queue.mergeFrom st' 	changeState $ \s -> s { errcounter = errcounter s + errcounter st' }--{- Stops all long-running git query processes. -}-stopCoProcesses :: Annex ()-stopCoProcesses = do-	catFileStop-	checkAttrStop-	hashObjectStop-	checkIgnoreStop  {- Runs an action and makes the current thread have the specified stage  - while doing so. If too many other threads are running in the specified
+ Annex/Concurrent/Utility.hs view
@@ -0,0 +1,23 @@+{- git-annex concurrency utilities+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.Concurrent.Utility where++import Types.Concurrency++import GHC.Conc++{- Honor the requested level of concurrency, but only up to the number of+ - CPU cores. Useful for things that are known to be CPU bound. -}+concurrencyUpToCpus :: Concurrency -> IO Int+concurrencyUpToCpus c = do+	let cn = case c of+		Concurrent n -> n+		NonConcurrent -> 1+		ConcurrentPerCpu -> 1+	pn <- getNumProcessors+	return (min cn pn)
Annex/Content.hs view
@@ -74,6 +74,7 @@ import Annex.Perms import Annex.Link import Annex.LockPool+import Annex.WorkerPool import Messages.Progress import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..)) import qualified Types.Remote@@ -87,7 +88,6 @@ import Utility.InodeCache import Annex.Content.LowLevel import Annex.Content.PointerFile-import Annex.Concurrent import Types.WorkerPool import qualified Utility.RawFilePath as R
Annex/Export.hs view
@@ -14,7 +14,6 @@ import qualified Git import qualified Types.Remote as Remote import Messages-import Utility.FileSystemEncoding  import Control.Applicative import Data.Maybe@@ -34,7 +33,7 @@   where 	mk (Just k) = AnnexKey k 	mk Nothing = GitKey $ mkKey $ \k -> k-		{ keyName = encodeBS $ Git.fromRef sha+		{ keyName = Git.fromRef' sha 		, keyVariety = SHA1Key (HasExt False) 		, keySize = Nothing 		, keyMtime = Nothing
Annex/GitOverlay.hs view
@@ -1,15 +1,19 @@ {- Temporarily changing the files git uses.  -- - Copyright 2014-2016 Joey Hess <id@joeyh.name>+ - Copyright 2014-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} -module Annex.GitOverlay where+module Annex.GitOverlay (+	module Annex.GitOverlay,+	AltIndexFile(..),+) where  import qualified Control.Exception as E  import Annex.Common+import Types.IndexFiles import Git import Git.Types import Git.Index@@ -18,13 +22,8 @@ import qualified Annex.Queue  {- Runs an action using a different git index file. -}-withIndexFile :: FilePath -> Annex a -> Annex a-withIndexFile f a = do-	f' <- liftIO $ indexEnvVal f-	withAltRepo-		(usecachedgitenv f' $ \g -> addGitEnv g indexEnv f')-		(\g g' -> g' { gitEnv = gitEnv g })-		a+withIndexFile :: AltIndexFile -> (FilePath -> Annex a) -> Annex a+withIndexFile i = withAltRepo usecachedgitenv restoregitenv   where 	-- This is an optimisation. Since withIndexFile is run repeatedly, 	-- typically with the same file, and addGitEnv uses the slow@@ -37,22 +36,40 @@ 	-- Git object in the first place, but it's more efficient to let 	-- the environment be inherited in all calls to git where it 	-- does not need to be modified.)-	usecachedgitenv f' m g = case gitEnv g of-		Just _ -> liftIO $ m g+	--+	-- Also, the use of AltIndexFile avoids needing to construct+	-- the FilePath each time, which saves enough time to be worth the+	-- added complication.+	usecachedgitenv g = case gitEnv g of 		Nothing -> Annex.withState $ \s -> case Annex.cachedgitenv s of-			Just (cachedf, cachede) | f' == cachedf ->-				return (s, g { gitEnv = Just cachede })+			Just (cachedi, cachedf, cachede) | i == cachedi ->+				return (s, (g { gitEnv = Just cachede }, cachedf)) 			_ -> do-				g' <- m g-				return (s { Annex.cachedgitenv = (,) <$> Just f' <*> gitEnv g' }, g')+				r@(g', f) <- addindex g+				let cache = (,,)+					<$> Just i+					<*> Just f+					<*> gitEnv g'+				return (s { Annex.cachedgitenv = cache }, r)+		Just _ -> liftIO $ addindex g+	+	addindex g = do+		f <- indexEnvVal $ case i of+			AnnexIndexFile -> gitAnnexIndex g+			ViewIndexFile -> gitAnnexViewIndex g+		g' <- addGitEnv g indexEnv f+		return (g', f)+	+	restoregitenv g g' = g' { gitEnv = gitEnv g }  {- Runs an action using a different git work tree.  -  - Smudge and clean filters are disabled in this work tree. -} withWorkTree :: FilePath -> Annex a -> Annex a-withWorkTree d = withAltRepo-	(\g -> return $ g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ disableSmudgeConfig })+withWorkTree d a = withAltRepo+	(\g -> return $ (g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ disableSmudgeConfig }, ())) 	(\g g' -> g' { location = location g, gitGlobalOpts = gitGlobalOpts g })+	(const a)   where 	modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) } 	modlocation _ = error "withWorkTree of non-local git repo"@@ -70,29 +87,29 @@  - Needs git 2.2.0 or newer.  -} withWorkTreeRelated :: FilePath -> Annex a -> Annex a-withWorkTreeRelated d = withAltRepo modrepo unmodrepo+withWorkTreeRelated d a = withAltRepo modrepo unmodrepo (const a)   where 	modrepo g = liftIO $ do 		g' <- addGitEnv g "GIT_COMMON_DIR" 			=<< absPath (fromRawFilePath (localGitDir g)) 		g'' <- addGitEnv g' "GIT_DIR" d-		return (g'' { gitEnvOverridesGitDir = True })+		return (g'' { gitEnvOverridesGitDir = True }, ()) 	unmodrepo g g' = g' 		{ gitEnv = gitEnv g 		, gitEnvOverridesGitDir = gitEnvOverridesGitDir g 		}  withAltRepo -	:: (Repo -> Annex Repo)+	:: (Repo -> Annex (Repo, t)) 	-- ^ modify Repo 	-> (Repo -> Repo -> Repo) 	-- ^ undo modifications; first Repo is the original and second 	-- is the one after running the action.-	-> Annex a+	-> (t -> Annex a) 	-> Annex a withAltRepo modrepo unmodrepo a = do 	g <- gitRepo-	g' <- modrepo g+	(g', t) <- modrepo g 	q <- Annex.Queue.get 	v <- tryNonAsync $ do 		Annex.changeState $ \s -> s@@ -101,7 +118,7 @@ 			-- with the modified repo. 			, Annex.repoqueue = Nothing 			}-		a+		a t 	void $ tryNonAsync Annex.Queue.flush 	Annex.changeState $ \s -> s 		{ Annex.repo = unmodrepo g (Annex.repo s)
Annex/Import.hs view
@@ -122,7 +122,9 @@ 			Nothing -> pure committedtree 			Just dir ->  				let subtreeref = Ref $-					fromRef committedtree ++ ":" ++ fromRawFilePath (getTopFilePath dir)+					fromRef' committedtree +						<> ":"+						<> getTopFilePath dir 				in fromMaybe emptyTree 					<$> inRepo (Git.Ref.tree subtreeref) 		updateexportdb importedtree
Annex/Multicast.hs view
@@ -7,7 +7,7 @@  module Annex.Multicast where -import Config.Files+import Annex.Path import Utility.Env import Utility.PartialPrelude @@ -22,7 +22,7 @@  multicastCallbackEnv :: IO (FilePath, [(String, String)], Handle) multicastCallbackEnv = do-	gitannex <- readProgramFile+	gitannex <- programPath 	-- This will even work on Windows 	(rfd, wfd) <- createPipeFd 	rh <- fdToHandle rfd
Annex/Path.hs view
@@ -32,5 +32,16 @@ 		exe <- getExecutablePath 		p <- if isAbsolute exe 			then return exe-			else readProgramFile+			else fromMaybe exe <$> readProgramFile 		maybe cannotFindProgram return =<< searchPath p++{- Returns the path for git-annex that is recorded in the programFile. -}+readProgramFile :: IO (Maybe FilePath)+readProgramFile = do+	programfile <- programFile+	headMaybe . lines <$> readFile programfile++cannotFindProgram :: IO a+cannotFindProgram = do+	f <- programFile+	giveup $ "cannot find git-annex program in PATH or in " ++ f
Annex/SpecialRemote.hs view
@@ -22,7 +22,6 @@ import Remote.List import Logs.Remote import Logs.Trust-import qualified Git.Config import qualified Types.Remote as Remote import Git.Types (RemoteName) @@ -99,7 +98,7 @@ 			_ -> return ()   where 	configured rc = fromMaybe False $-		Git.Config.isTrueFalse . fromProposedAccepted+		trueFalseParser' . fromProposedAccepted 			=<< M.lookup autoEnableField rc 	canenable u = (/= DeadTrusted) <$> lookupTrust u 	getenabledremotes = M.fromList
Annex/SpecialRemote/Config.hs view
@@ -17,7 +17,6 @@ import Types.ProposedAccepted import Types.RemoteConfig import Types.GitConfig-import qualified Git.Config  import qualified Data.Map as M import qualified Data.Set as S@@ -242,8 +241,16 @@ 	yesno _ = Nothing  trueFalseParser :: RemoteConfigField -> Bool -> FieldDesc -> RemoteConfigFieldParser-trueFalseParser f v fd = genParser Git.Config.isTrueFalse f v fd+trueFalseParser f v fd = genParser trueFalseParser' f v fd 	(Just (ValueDesc "true or false"))++-- Not using Git.Config.isTrueFalse because git supports+-- a lot of other values for true and false in its configs,+-- and this is not a git config and we want to avoid that mess.+trueFalseParser' :: String -> Maybe Bool+trueFalseParser' "true" = Just True+trueFalseParser' "false" = Just False+trueFalseParser' _ = Nothing  genParser 	:: Typeable t
Annex/TaggedPush.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.TaggedPush where  import Annex.Common@@ -16,6 +18,8 @@ import qualified Git.Branch import Utility.Base64 +import qualified Data.ByteString as S+ {- Converts a git branch into a branch that is tagged with a UUID, typically  - the UUID of the repo that will be pushing it, and possibly with other  - information.@@ -31,11 +35,11 @@  - refs, per git-check-ref-format.  -} toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Ref-toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes+toTaggedBranch u info b = Git.Ref $ S.intercalate "/" $ catMaybes 	[ Just "refs/synced" 	, Just $ fromUUID u-	, toB64 <$> info-	, Just $ Git.fromRef $ Git.Ref.base b+	, toB64' . encodeBS <$> info+	, Just $ Git.fromRef' $ Git.Ref.base b 	]  fromTaggedBranch :: Git.Ref -> Maybe (UUID, Maybe String)
Annex/Transfer.hs view
@@ -30,9 +30,9 @@ import Annex.LockPool import Types.Key import qualified Types.Remote as Remote-import Annex.Concurrent import Types.Concurrency import Types.WorkerPool+import Annex.WorkerPool  import Control.Concurrent import qualified Data.Map.Strict as M
Annex/UUID.hs view
@@ -111,7 +111,7 @@ setUUID :: Git.Repo -> UUID -> IO Git.Repo setUUID r u = do 	let s = encodeBS' $ show configkeyUUID ++ "=" ++ fromUUID u-	Git.Config.store s r+	Git.Config.store s Git.Config.ConfigList r  -- Dummy uuid for the whole web. Do not alter. webUUID :: UUID
Annex/Url.hs view
@@ -177,9 +177,5 @@ 	Right b -> return b 	Left err -> warning err >> return False -getUrlInfo :: U.URLString -> U.UrlOptions -> Annex U.UrlInfo-getUrlInfo url uo = liftIO (U.getUrlInfo url uo) >>= \case-	Right i -> return i-	Left err -> do-		warning err-		return $ U.UrlInfo False Nothing Nothing+getUrlInfo :: U.URLString -> U.UrlOptions -> Annex (Either String U.UrlInfo)+getUrlInfo url uo = liftIO (U.getUrlInfo url uo)
Annex/View.hs view
@@ -412,9 +412,7 @@  - Note that the file does not necessarily exist, or can contain  - info staged for an old view. -} withViewIndex :: Annex a -> Annex a-withViewIndex a = do-	f <- fromRepo gitAnnexViewIndex-	withIndexFile f a+withViewIndex = withIndexFile ViewIndexFile . const  {- Generates a branch for a view, using the view index file  - to make a commit to the view branch. The view branch is not
+ Annex/WorkerPool.hs view
@@ -0,0 +1,126 @@+{- git-annex worker thread pool+ -+ - Copyright 2015-2019 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.WorkerPool where++import Annex+import Annex.Common+import Types.WorkerPool++import Control.Concurrent+import Control.Concurrent.STM++{- Runs an action and makes the current thread have the specified stage+ - while doing so. If too many other threads are running in the specified+ - stage, waits for one of them to become idle.+ -+ - Noop if the current thread already has the requested stage, or if the+ - current thread is not in the worker pool, or if concurrency is not+ - enabled.+ -+ - Also a noop if the stage is not one of the stages that the worker pool+ - uses.+ -}+enteringStage :: WorkerStage -> Annex a -> Annex a+enteringStage newstage a = Annex.getState Annex.workers >>= \case+	Nothing -> a+	Just tv -> do+		mytid <- liftIO myThreadId+		let set = changeStageTo mytid tv (const newstage)+		let restore = maybe noop (void . changeStageTo mytid tv . const)+		bracket set restore (const a)++{- Transition the current thread to the initial stage.+ - This is done once the thread is ready to begin work.+ -}+enteringInitialStage :: Annex ()+enteringInitialStage = Annex.getState Annex.workers >>= \case+	Nothing -> noop+	Just tv -> do+		mytid <- liftIO myThreadId+		void $ changeStageTo mytid tv initialStage++{- This needs to leave the WorkerPool with the same number of+ - idle and active threads, and with the same number of threads for each+ - WorkerStage. So, all it can do is swap the WorkerStage of our thread's+ - ActiveWorker with an IdleWorker.+ -+ - Must avoid a deadlock if all worker threads end up here at the same+ - time, or if there are no suitable IdleWorkers left. So if necessary+ - we first replace our ActiveWorker with an IdleWorker in the pool, to allow+ - some other thread to use it, before waiting for a suitable IdleWorker+ - for us to use.+ -+ - Note that the spareVals in the WorkerPool does not get anything added to+ - it when adding the IdleWorker, so there will for a while be more IdleWorkers+ - in the pool than spareVals. That does not prevent other threads that call+ - this from using them though, so it's fine.+ -}+changeStageTo :: ThreadId -> TMVar (WorkerPool AnnexState) -> (UsedStages -> WorkerStage) -> Annex (Maybe WorkerStage)+changeStageTo mytid tv getnewstage = liftIO $+	replaceidle >>= maybe+		(return Nothing)+		(either waitidle (return . Just))+  where+	replaceidle = atomically $ do+		pool <- takeTMVar tv+		let newstage = getnewstage (usedStages pool)+		let notchanging = do+			putTMVar tv pool+			return Nothing+		if memberStage newstage (usedStages pool)+			then case removeThreadIdWorkerPool mytid pool of+				Just ((myaid, oldstage), pool')+					| oldstage /= newstage -> case getIdleWorkerSlot newstage pool' of+						Nothing -> do+							putTMVar tv $+								addWorkerPool (IdleWorker oldstage) pool'+							return $ Just $ Left (myaid, newstage, oldstage)+						Just pool'' -> do+							-- optimisation+							putTMVar tv $+								addWorkerPool (IdleWorker oldstage) $+									addWorkerPool (ActiveWorker myaid newstage) pool''+							return $ Just $ Right oldstage+					| otherwise -> notchanging+				_ -> notchanging+			else notchanging+	+	waitidle (myaid, newstage, oldstage) = atomically $ do+		pool <- waitIdleWorkerSlot newstage =<< takeTMVar tv+		putTMVar tv $ addWorkerPool (ActiveWorker myaid newstage) pool+		return (Just oldstage)++-- | Waits until there's an idle StartStage worker in the worker pool,+-- removes it from the pool, and returns its state.+--+-- If the worker pool is not already allocated, returns Nothing.+waitStartWorkerSlot :: TMVar (WorkerPool Annex.AnnexState) -> STM (Maybe (Annex.AnnexState, WorkerStage))+waitStartWorkerSlot tv = do+	pool <- takeTMVar tv+	st <- go pool+	return $ Just (st, StartStage)+  where+	go pool = case spareVals pool of+		[] -> retry+		(v:vs) -> do+			let pool' = pool { spareVals = vs }+			putTMVar tv =<< waitIdleWorkerSlot StartStage pool'+			return v++waitIdleWorkerSlot :: WorkerStage -> WorkerPool Annex.AnnexState -> STM (WorkerPool Annex.AnnexState)+waitIdleWorkerSlot wantstage = maybe retry return . getIdleWorkerSlot wantstage++getIdleWorkerSlot :: WorkerStage -> WorkerPool Annex.AnnexState -> Maybe (WorkerPool Annex.AnnexState)+getIdleWorkerSlot wantstage pool = do+	l <- findidle [] (workerList pool)+	return $ pool { workerList = l }+  where+	findidle _ [] = Nothing+	findidle c ((IdleWorker stage):rest)+		| stage == wantstage = Just (c ++ rest)+	findidle c (w:rest) = findidle (w:c) rest
Assistant.hs view
@@ -50,6 +50,7 @@ import Utility.HumanTime import qualified BuildInfo import Annex.Perms+import Annex.BranchState import Utility.LogFile #ifdef mingw32_HOST_OS import Utility.Env@@ -70,8 +71,8 @@  - stdout and stderr descriptors. -} startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do-	 	Annex.changeState $ \s -> s { Annex.daemon = True }+	enableInteractiveJournalAccess 	pidfile <- fromRepo gitAnnexPidFile 	logfile <- fromRepo gitAnnexLogFile 	liftIO $ debugM desc $ "logging to " ++ logfile
Assistant/Sync.hs view
@@ -216,7 +216,8 @@ 				, return $ Just r 				) 		else return Nothing-	haddiverged <- liftAnnex Annex.Branch.forceUpdate+	haddiverged <- Annex.Branch.refsWereMerged+		<$> liftAnnex Annex.Branch.forceUpdate 	forM_ remotes $ \r -> 		liftAnnex $ Command.Sync.mergeRemote r 			currentbranch Command.Sync.mergeConfig def
Assistant/Threads/Merger.hs view
@@ -65,7 +65,8 @@ 	| ".lock" `isSuffixOf` file = noop 	| isAnnexBranch file = do 		branchChanged-		diverged <- liftAnnex Annex.Branch.forceUpdate+		diverged <- Annex.Branch.refsWereMerged+			<$> liftAnnex Annex.Branch.forceUpdate 		when diverged $ do 			updateExportTreeFromLogAll 			queueDeferredDownloads "retrying deferred download" Later@@ -109,6 +110,6 @@ 	n = '/' : Git.fromRef Annex.Branch.name  fileToBranch :: FilePath -> Git.Ref-fileToBranch f = Git.Ref $ "refs" </> base+fileToBranch f = Git.Ref $ encodeBS' $ "refs" </> base   where 	base = Prelude.last $ split "/refs/" f
Assistant/Threads/Watcher.hs view
@@ -330,7 +330,7 @@ addLink file link mk = do 	debug ["add symlink", file] 	liftAnnex $ do-		v <- catObjectDetails $ Ref $ ':':file+		v <- catObjectDetails $ Ref $ encodeBS' $ ':':file 		case v of 			Just (currlink, sha, _type) 				| s2w8 link == L.unpack currlink ->
Assistant/Upgrade.hs view
@@ -225,20 +225,22 @@  {- Finds where the old version was installed. -} oldVersionLocation :: IO FilePath-oldVersionLocation = do-	pdir <- parentDir <$> readProgramFile+oldVersionLocation = readProgramFile >>= \case+	Nothing -> error "Cannot find old distribution bundle; not upgrading."+	Just pf -> do+		let pdir = parentDir pf #ifdef darwin_HOST_OS-	let dirs = splitDirectories pdir-	{- It will probably be deep inside a git-annex.app directory. -}-	let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of-		Nothing -> pdir-		Just i -> joinPath (take (i + 1) dirs)+		let dirs = splitDirectories pdir+		{- It will probably be deep inside a git-annex.app directory. -}+		let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of+			Nothing -> pdir+			Just i -> joinPath (take (i + 1) dirs) #else-	let olddir = pdir+		let olddir = pdir #endif-	when (null olddir) $-		error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"-	return olddir+		when (null olddir) $+			error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"+		return olddir  {- Finds a place to install the new version.  - Generally, put it in the parent directory of where the old version was@@ -344,10 +346,9 @@  - trustedkeys.gpg, next to the git-annex program.  -} verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool-verifyDistributionSig gpgcmd sig = do-	p <- readProgramFile-	if isAbsolute p-		then withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do+verifyDistributionSig gpgcmd sig = readProgramFile >>= \case+	Just p | isAbsolute p ->+		withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do 			let trustedkeys = takeDirectory p </> "trustedkeys.gpg" 			boolGpgCmd gpgcmd 				[ Param "--no-default-keyring"@@ -360,4 +361,4 @@ 				, Param "--verify" 				, File sig 				]-		else return False+	_ -> return False
Assistant/WebApp/Configurators/Pairing.hs view
@@ -33,7 +33,7 @@ import Command.P2P (unusedPeerRemoteName, PairingResult(..)) import P2P.Address import Git-import Config.Files+import Annex.Path import Utility.Process.Transcript  import qualified Data.Map as M@@ -72,7 +72,7 @@  enableTor :: Handler () enableTor = do-	gitannex <- liftIO readProgramFile+	gitannex <- liftIO programPath 	(transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing 	if ok 		-- Reload remotedameon so it's serving the tor hidden
Benchmark.hs view
@@ -28,7 +28,7 @@ 	-- so skewing the runtime of the first action that will be 	-- benchmarked. 	Annex.Branch.commit "benchmarking"-	Annex.Branch.update+	_ <- Annex.Branch.update 	l <- mapM parsesubcommand $ split [";"] userinput 	return $ do 		forM_ l $ \(cmd, seek, st) ->
CHANGELOG view
@@ -1,3 +1,52 @@+git-annex (8.20200501) upstream; urgency=medium++  * Improve git-annex's ability to find the path to its program,+    especially when it needs to run itself in another repo to upgrade it.+  * adb: Better messages when the adb command is not installed.+  * Sped up query commands that read the git-annex branch by around 9%.+  * Various speed improvements gained by using ByteStrings for git refs and+    shas.+  * Fix a potential failure to parse git config.+  * Support boolean git configs that are represented by the name of the+    setting with no value, eg "core.bare" is the same as "core.bare = true".+  * When parsing git configs, support all the documented ways to write+    true and false, including "yes", "on", "1", etc.+  * Fix --batch commands (and git-annex info) to accept absolute filenames +    for unlocked files, which already worked for locked files.+  * Avoid repeatedly opening keys db when accessing a local git remote+    and -J is used.+  * Avoid running a large number of git cat-file child processes when run+    with a large -J value.+  * Avoid running with more git check-attr and check-ignore processes than+    there are CPU cores when run with a large -J value.+  * get --from, move --from: When used with a local git remote, these used+    to silently skip files that the location log thought were present on the+    remote, when the remote actually no longer contained them. Since that+    behavior could be surprising, now instead display a warning.+  * external special remotes: remote.name.annex-readonly=true no longer+    disables running the external special remote program. Instead, it just+    makes the remote operate in a readonly mode, same as any remote.+    To disable running the external special remote program, now need to set+    remote.name.annex-externaltype=readonly. That is done when+    git-annex enableremote is passed readonly=true.+  * Stop storing readonly=true in remote.log of external special remotes;+    it is a local setting only.+  * sync: When some remotes to sync with are specified, and --fast is too,+    pick the lowest cost of the specified remotes, do not sync with a+    faster remote that was not specified.+  * addurl: When run with --fast on an url that +    annex.security.allowed-ip-addresses prevents accessing, display+    a more useful message.+  * When the required content is set to "groupwanted", use whatever+    expression has been set in groupwanted as the required content of the+    repo, similar to how setting required content to "standard" already+    worked.+  * Avoid a test suite failure when the environment does not let gpg be+    tested due to eg, too long a path to the agent socket.+  * test: Include testremote tests, run on a directory special remote.++ -- Joey Hess <id@joeyh.name>  Fri, 01 May 2020 13:09:24 -0400+ git-annex (8.20200330) upstream; urgency=medium    * fsck: Fix reversion in 8.20200226 that made it incorrectly warn
CmdLine/Action.hs view
@@ -17,7 +17,6 @@ import Messages.Concurrent import Types.Messages import Types.WorkerPool-import Remote.List  import Control.Concurrent import Control.Concurrent.Async@@ -200,8 +199,7 @@ startConcurrency usedstages a = do 	fromcmdline <- Annex.getState Annex.concurrency 	fromgitcfg <- annexJobs <$> Annex.getGitConfig-	let usegitcfg = Annex.changeState $ -		\c -> c { Annex.concurrency = fromgitcfg }+	let usegitcfg = setConcurrency fromgitcfg 	case (fromcmdline, fromgitcfg) of 		(NonConcurrent, NonConcurrent) -> a 		(Concurrent n, _) ->@@ -245,11 +243,6 @@ 			liftIO $ setNumCapabilities n 	 	initworkerpool n = do-		-- Generate the remote list now, to avoid each thread-		-- generating it, which would be more expensive and-		-- could cause threads to contend over eg, calls to-		-- setConfig.-		_ <- remoteList 		tv <- liftIO newEmptyTMVarIO 		Annex.changeState $ \s -> s { Annex.workers = Just tv } 		st <- dupState
CmdLine/Batch.hs view
@@ -14,6 +14,7 @@ import Options.Applicative import Limit import Types.FileMatcher+import Annex.BranchState  data BatchMode = Batch BatchFormat | NoBatch @@ -49,7 +50,7 @@ 	batchseeker (opts, NoBatch, params) = 		mapM_ (go NoBatch opts) params 	batchseeker (opts, batchmode@(Batch fmt), _) = -		batchInput fmt Right (go batchmode opts)+		batchInput fmt (pure . Right) (go batchmode opts)  	go batchmode opts p = 		unlessM (handler opts p) $@@ -61,18 +62,26 @@ batchBadInput NoBatch = liftIO exitFailure batchBadInput (Batch _) = liftIO $ putStrLn "" --- Reads lines of batch mode input and passes to the action to handle.-batchInput :: BatchFormat -> (String -> Either String a) -> (a -> Annex ()) -> Annex ()+-- Reads lines of batch mode input, runs a parser, and passes the result+-- to the action.+--+-- Note that if the batch input includes a worktree filename, it should+-- be converted to relative. Normally, filename parameters are passed+-- through git ls-files, which makes them relative, but batch mode does+-- not use that, and absolute worktree files are likely to cause breakage.+batchInput :: BatchFormat -> (String -> Annex (Either String a)) -> (a -> Annex ()) -> Annex () batchInput fmt parser a = go =<< batchLines fmt   where 	go [] = return () 	go (l:rest) = do-		either parseerr a (parser l)+		either parseerr a =<< parser l 		go rest 	parseerr s = giveup $ "Batch input parse failure: " ++ s  batchLines :: BatchFormat -> Annex [String]-batchLines fmt = liftIO $ splitter <$> getContents+batchLines fmt = do+	enableInteractiveJournalAccess+	liftIO $ splitter <$> getContents   where 	splitter = case fmt of 		BatchLine -> lines@@ -92,9 +101,12 @@ -- Reads lines of batch input and passes the filepaths to a CommandStart -- to handle them. --+-- Absolute filepaths are converted to relative.+-- -- File matching options are not checked.-batchStart :: BatchFormat -> (String -> CommandStart) -> Annex ()-batchStart fmt a = batchInput fmt Right $ batchCommandAction . a+batchStart :: BatchFormat -> (FilePath -> CommandStart) -> Annex ()+batchStart fmt a = batchInput fmt (Right <$$> liftIO . relPathCwdToFile) $+	batchCommandAction . a  -- Like batchStart, but checks the file matching options -- and skips non-matching files.
CmdLine/GitAnnex/Options.hs view
@@ -36,6 +36,7 @@ import qualified Backend import qualified Types.Backend as Backend import Utility.HumanTime+import Annex.Concurrent  -- Global options that are accepted by all git-annex sub-commands, -- although not always used.@@ -96,7 +97,7 @@ 	setgitconfig v = Annex.adjustGitRepo $ \r ->  		if Param v `elem` gitGlobalOpts r 			then return r-			else Git.Config.store (encodeBS' v) $ +			else Git.Config.store (encodeBS' v) Git.Config.ConfigList $  				r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] } 	setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } @@ -395,7 +396,7 @@ -- action in `allowConcurrentOutput`. jobsOption :: [GlobalOption] jobsOption = -	[ globalSetter set $ +	[ globalSetter setConcurrency $  		option (maybeReader parseConcurrency) 			( long "jobs" <> short 'J'  			<> metavar (paramNumber `paramOr` "cpus")@@ -403,8 +404,6 @@ 			<> hidden 			) 	]-  where-	set v = Annex.changeState $ \s -> s { Annex.concurrency = v }  timeLimitOption :: [GlobalOption] timeLimitOption =
Command/AddUrl.hs view
@@ -103,7 +103,7 @@ 			else checkUrl addunlockedmatcher r o' u 	forM_ (addUrls o) (\u -> go (o, u)) 	case batchOption o of-		Batch fmt -> batchInput fmt (parseBatchInput o) go+		Batch fmt -> batchInput fmt (pure . parseBatchInput o) go 		NoBatch -> noop  parseBatchInput :: AddUrlOptions -> String -> Either String (AddUrlOptions, URLString)@@ -194,11 +194,16 @@   where 	bad = fromMaybe (giveup $ "bad url " ++ urlstring) $ 		Url.parseURIRelaxed $ urlstring-	go url = startingAddUrl urlstring o $ do+	go url = startingAddUrl urlstring o $+		if relaxedOption (downloadOptions o)+			then go' url Url.assumeUrlExists+			else Url.withUrlOptions (Url.getUrlInfo urlstring) >>= \case+				Right urlinfo -> go' url urlinfo+				Left err -> do+					warning err+					next $ return False+	go' url urlinfo = do 		pathmax <- liftIO $ fileNameLengthLimit "."-		urlinfo <- if relaxedOption (downloadOptions o)-			then pure Url.assumeUrlExists-			else Url.withUrlOptions $ Url.getUrlInfo urlstring 		file <- adjustFile o <$> case fileOption (downloadOptions o) of 			Just f -> pure f 			Nothing -> case Url.urlSuggestedFile urlinfo of
Command/CheckPresentKey.hs view
@@ -38,7 +38,7 @@ 			(rn:[]) -> toRemote rn >>= \r -> return (flip check (Just r)) 			[] -> return (flip check Nothing) 			_ -> wrongnumparams-		batchInput fmt Right $ checker >=> batchResult+		batchInput fmt (pure . Right) $ checker >=> batchResult   where 	wrongnumparams = giveup "Wrong number of parameters"
Command/Config.hs view
@@ -69,8 +69,9 @@ seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $ 	startingCustomOutput (ActionItemOther Nothing) $ do 		getGlobalConfig ck >>= \case-			Nothing -> return () 			Just (ConfigValue v) -> liftIO $ S8.putStrLn v+			Just NoConfigValue -> return ()+			Nothing -> return () 		next $ return True  checkIsGlobalConfig :: ConfigKey -> Annex a -> Annex a
Command/DropKey.hs view
@@ -35,7 +35,8 @@ 		giveup "dropkey can cause data loss; use --force if you're sure you want to do this" 	withKeys (commandAction . start) (toDrop o) 	case batchOption o of-		Batch fmt -> batchInput fmt parsekey $ batchCommandAction . start+		Batch fmt -> batchInput fmt (pure . parsekey) $+			batchCommandAction . start 		NoBatch -> noop   where 	parsekey = maybe (Left "bad key") Right . deserializeKey
Command/EnableTor.hs view
@@ -16,7 +16,7 @@ import Utility.Tor import Annex.UUID #ifndef mingw32_HOST_OS-import Config.Files+import Annex.Path #endif import P2P.IO import qualified P2P.Protocol as P2P@@ -53,7 +53,7 @@ 			Nothing -> giveup "Need user-id parameter." 			Just userid -> go userid 		else starting "enable-tor" (ActionItemOther Nothing) $ do-			gitannex <- liftIO readProgramFile+			gitannex <- liftIO programPath 			let ps = [Param (cmdname cmd), Param (show curruserid)] 			sucommand <- liftIO $ mkSuCommand gitannex ps 			maybe noop showLongNote
Command/Export.hs view
@@ -37,6 +37,7 @@ import Utility.Metered import Utility.Matcher +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import Control.Concurrent@@ -112,7 +113,7 @@ 		return (fmap (tb, ) commitsha) 	| otherwise = return Nothing   where-	baseref = Ref $ takeWhile (/= ':') $ fromRef $ +	baseref = Ref $ S8.takeWhile (/= ':') $ fromRef' $  		Git.Ref.removeBase refsheads treeish 	refsheads = "refs/heads"
Command/FindRef.hs view
@@ -22,6 +22,6 @@   where 	o' = o  		{ Find.keyOptions = Just $ WantBranchKeys $-			map Git.Ref (Find.findThese o)+			map (Git.Ref . encodeBS') (Find.findThese o) 		, Find.findThese = [] 		}
Command/Forget.hs view
@@ -45,7 +45,7 @@ perform ts True = do 	recordTransitions Branch.change ts 	-- get branch committed before contining with the transition-	Branch.update+	_ <- Branch.update 	void $ Branch.performTransitions ts True [] 	next $ return True perform _ False = do
Command/FromKey.hs view
@@ -47,11 +47,14 @@ seekBatch :: BatchFormat -> CommandSeek seekBatch fmt = batchInput fmt parse commandAction   where-	parse s = +	parse s = do 		let (keyname, file) = separate (== ' ') s-		in if not (null keyname) && not (null file)-			then Right $ go file (keyOpt keyname)-			else Left "Expected pairs of key and filename"+		if not (null keyname) && not (null file)+			then do+				file' <- liftIO $ relPathCwdToFile file+				return $ Right $ go file' (keyOpt keyname)+			else return $+				Left "Expected pairs of key and filename" 	go file key = starting "fromkey" (mkActionItem (key, toRawFilePath file)) $ 		perform key file
Command/Import.hs view
@@ -66,7 +66,7 @@ 			[bs] ->  				let (branch, subdir) = separate (== ':') bs 				in RemoteImportOptions r-					(Ref branch)+					(Ref (encodeBS' branch)) 					(if null subdir then Nothing else Just subdir) 			_ -> giveup "expected BRANCH[:SUBDIR]"
Command/ImportFeed.hs view
@@ -162,10 +162,6 @@ 			r <- Remote.claimingUrl url 			if Remote.uuid r == webUUID || rawOption (downloadOptions opts) 				then do-					urlinfo <- if relaxedOption (downloadOptions opts)-						then pure Url.assumeUrlExists-						else Url.withUrlOptions $-							Url.getUrlInfo url 					let dlopts = (downloadOptions opts) 						-- force using the filename 						-- chosen here@@ -173,7 +169,14 @@ 						-- don't use youtube-dl 						, rawOption = True 						}-					maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f+					let go urlinfo = maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f+					if relaxedOption (downloadOptions opts)+						then go Url.assumeUrlExists+						else Url.withUrlOptions (Url.getUrlInfo url) >>= \case+							Right urlinfo -> go urlinfo+							Left err -> do+								warning err+								return [] 				else do 					res <- tryNonAsync $ maybe 						(error $ "unable to checkUrl of " ++ Remote.name r)
Command/Info.hs view
@@ -119,7 +119,7 @@ seek :: InfoOptions -> CommandSeek seek o = case batchOption o of 	NoBatch -> withWords (commandAction . start o) (infoFor o)-	Batch fmt -> batchInput fmt Right (itemInfo o)+	Batch fmt -> batchInput fmt (pure . Right) (itemInfo o)  start :: InfoOptions -> [String] -> CommandStart start o [] = do@@ -152,9 +152,11 @@ 				v' <- Remote.nameToUUID' p 				case v' of 					Right u -> uuidInfo o u-					Left _ -> ifAnnexed (toRawFilePath p)-						(fileInfo o p)-						(treeishInfo o p)+					Left _ -> do+						relp <- liftIO $ relPathCwdToFile p+						ifAnnexed (toRawFilePath relp)+							(fileInfo o relp)+							(treeishInfo o p) 	)   where 	isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)@@ -181,7 +183,7 @@  treeishInfo :: InfoOptions -> String -> Annex () treeishInfo o t = do-	mi <- getTreeStatInfo o (Git.Ref t)+	mi <- getTreeStatInfo o (Git.Ref (encodeBS' t)) 	case mi of 		Nothing -> noInfo t 		Just i -> showCustom (unwords ["info", t]) $ do
Command/Log.hs view
@@ -264,7 +264,8 @@ parseRawChangeLine :: String -> Maybe (Git.Ref, Git.Ref) parseRawChangeLine = go . words   where-	go (_:_:oldsha:newsha:_) = Just (Git.Ref oldsha, Git.Ref newsha)+	go (_:_:oldsha:newsha:_) = +		Just (Git.Ref (encodeBS oldsha), Git.Ref (encodeBS newsha)) 	go _ = Nothing  parseTimeStamp :: String -> POSIXTime
Command/Map.hs view
@@ -222,18 +222,18 @@ 		Nothing -> return $ Just r 	| otherwise = liftIO $ safely $ Git.Config.read r   where-	pipedconfig pcmd params = liftIO $ safely $+	pipedconfig st pcmd params = liftIO $ safely $ 		withHandle StdoutHandle createProcessSuccess p $-			Git.Config.hRead r+			Git.Config.hRead r st 	  where 		p = proc pcmd $ toCommand params  	configlist = Ssh.onRemote NoConsumeStdin r-		(pipedconfig, return Nothing) "configlist" [] []+		(pipedconfig Git.Config.ConfigList, return Nothing) "configlist" [] [] 	manualconfiglist = do 		gc <- Annex.getRemoteGitConfig r 		(sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r gc remotecmd-		liftIO $ pipedconfig sshcmd sshparams+		liftIO $ pipedconfig Git.Config.ConfigNullList sshcmd sshparams 	  where 		remotecmd = "sh -c " ++ shellEscape 			(cddir ++ " && " ++ "git config --null --list")
Command/Merge.hs view
@@ -26,11 +26,11 @@ 	commandAction mergeSyncedBranch seek bs = do 	prepMerge-	forM_ bs (commandAction . mergeBranch . Git.Ref)+	forM_ bs (commandAction . mergeBranch . Git.Ref . encodeBS')  mergeAnnexBranch :: CommandStart mergeAnnexBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do-	Annex.Branch.update+	_ <- Annex.Branch.update 	-- commit explicitly, in case no remote branches were merged 	Annex.Branch.commit =<< Annex.Branch.commitMessage 	next $ return True
Command/MetaData.hs view
@@ -119,8 +119,9 @@ cleanup :: Key -> CommandCleanup cleanup k = do 	m <- getCurrentMetaData k-	let Object o = toJSON' (MetaDataFields m)-	maybeShowJSON $ AesonObject o+	case toJSON' (MetaDataFields m) of+		Object o -> maybeShowJSON $ AesonObject o+		_ -> noop 	showLongNote $ unlines $ concatMap showmeta $ 		map unwrapmeta (fromMetaData m) 	return True@@ -147,16 +148,21 @@ fieldsField :: T.Text fieldsField = T.pack "fields" -parseJSONInput :: String -> Either String (Either RawFilePath Key, MetaData)-parseJSONInput i = do-	v <- eitherDecode (BU.fromString i)-	let m = case itemAdded v of-		Nothing -> emptyMetaData-		Just (MetaDataFields m') -> m'-	case (itemKey v, itemFile v) of-		(Just k, _) -> Right (Right k, m)-		(Nothing, Just f) -> Right (Left (toRawFilePath f), m)-		(Nothing, Nothing) -> Left "JSON input is missing either file or key"+parseJSONInput :: String -> Annex (Either String (Either RawFilePath Key, MetaData))+parseJSONInput i = case eitherDecode (BU.fromString i) of+	Left e -> return (Left e)+	Right v -> do+		let m = case itemAdded v of+			Nothing -> emptyMetaData+			Just (MetaDataFields m') -> m'+		case (itemKey v, itemFile v) of+			(Just k, _) -> return $+				Right (Right k, m)+			(Nothing, Just f) -> do+				f' <- liftIO $ relPathCwdToFile f+				return $ Right (Left (toRawFilePath f'), m)+			(Nothing, Nothing) -> return $ +				Left "JSON input is missing either file or key"  startBatch :: (Either RawFilePath Key, MetaData) -> CommandStart startBatch (i, (MetaData m)) = case i of
Command/Move.hs view
@@ -187,16 +187,10 @@ 			fromPerform src removewhen key afile  fromOk :: Remote -> Key -> Annex Bool-fromOk src key -	| Remote.hasKeyCheap src =-		either (const checklog) return =<< haskey-	| otherwise = checklog-  where-	haskey = Remote.hasKey src key-	checklog = do-		u <- getUUID-		remotes <- Remote.keyPossibilities key-		return $ u /= Remote.uuid src && elem src remotes+fromOk src key = do+	u <- getUUID+	remotes <- Remote.keyPossibilities key+	return $ u /= Remote.uuid src && elem src remotes  fromPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform fromPerform src removewhen key afile = do
Command/PreCommit.hs view
@@ -16,7 +16,6 @@ import Annex.Link import Annex.View import Annex.View.ViewedFile-import Annex.LockFile import Logs.View import Logs.MetaData import Types.View
Command/ReKey.hs view
@@ -39,17 +39,21 @@  -- Split on the last space, since a FilePath can contain whitespace, -- but a Key very rarely does.-batchParser :: String -> Either String (RawFilePath, Key)+batchParser :: String -> Annex (Either String (RawFilePath, Key)) batchParser s = case separate (== ' ') (reverse s) of 	(rk, rf)-		| null rk || null rf -> Left "Expected: \"file key\""+		| null rk || null rf -> return $ Left "Expected: \"file key\"" 		| otherwise -> case deserializeKey (reverse rk) of-			Nothing -> Left "bad key"-			Just k -> Right (toRawFilePath (reverse rf), k)+			Nothing -> return $ Left "bad key"+			Just k -> do+				let f = reverse rf+				f' <- liftIO $ relPathCwdToFile f+				return $ Right (toRawFilePath f', k)  seek :: ReKeyOptions -> CommandSeek seek o = case batchOption o of-	Batch fmt -> batchInput fmt batchParser (batchCommandAction . start)+	Batch fmt -> batchInput fmt batchParser $+		batchCommandAction . start 	NoBatch -> withPairs (commandAction . start . parsekey) (reKeyThese o)   where 	parsekey (file, skey) =
Command/ResolveMerge.hs view
@@ -13,6 +13,8 @@ import qualified Git.Branch import Annex.AutoMerge +import qualified Data.ByteString as S+ cmd :: Command cmd = command "resolvemerge" SectionPlumbing 	"resolve merge conflicts"@@ -27,7 +29,7 @@ 	d <- fromRawFilePath <$> fromRepo Git.localGitDir 	let merge_head = d </> "MERGE_HEAD" 	them <- fromMaybe (error nomergehead) . extractSha-		<$> liftIO (readFile merge_head)+		<$> liftIO (S.readFile merge_head) 	ifM (resolveMerge (Just us) them False) 		( do 			void $ commitResolvedMerge Git.Branch.ManualCommit
Command/RmUrl.hs view
@@ -30,16 +30,20 @@  seek :: RmUrlOptions -> CommandSeek seek o = case batchOption o of-	Batch fmt -> batchInput fmt batchParser (batchCommandAction . start)+	Batch fmt -> batchInput fmt batchParser+		(batchCommandAction . start) 	NoBatch -> withPairs (commandAction . start) (rmThese o)  -- Split on the last space, since a FilePath can contain whitespace, -- but a url should not.-batchParser :: String -> Either String (FilePath, URLString)+batchParser :: String -> Annex (Either String (FilePath, URLString)) batchParser s = case separate (== ' ') (reverse s) of 	(ru, rf)-		| null ru || null rf -> Left "Expected: \"file url\""-		| otherwise -> Right (reverse rf, reverse ru)+		| null ru || null rf -> return $ Left "Expected: \"file url\""+		| otherwise -> do+			let f = reverse rf+			f' <- liftIO $ relPathCwdToFile f+			return $ Right (f', reverse ru)  start :: (FilePath, URLString) -> CommandStart start (file, url) = flip whenAnnexed file' $ \_ key ->
Command/SetPresentKey.hs view
@@ -31,7 +31,7 @@ seek :: SetPresentKeyOptions -> CommandSeek seek o = case batchOption o of 	Batch fmt -> batchInput fmt-		(parseKeyStatus . words)+		(pure . parseKeyStatus . words) 		(batchCommandAction . start) 	NoBatch -> either giveup (commandAction . start) 		(parseKeyStatus $ params o)
Command/Sync.hs view
@@ -46,7 +46,7 @@ import Config.GitConfig import Annex.SpecialRemote.Config import Config.DynamicConfig-import Config.Files+import Annex.Path import Annex.Wanted import Annex.Content import Command.Get (getKey')@@ -72,6 +72,8 @@  import Control.Concurrent.MVar import qualified Data.Map as M+import qualified Data.ByteString as S+import Data.Char  cmd :: Command cmd = withGlobalOptions [jobsOption] $@@ -289,10 +291,8 @@  syncRemotes' :: [String] -> [Remote] -> Annex [Remote] syncRemotes' ps available = -	ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )+	ifM (Annex.getState Annex.fast) ( fastest <$> wanted , wanted )   where-	pickfast = (++) <$> listed <*> (filterM good (fastest available))-	 	wanted 		| null ps = filterM good (concat $ Remote.byCost available) 		| otherwise = listed@@ -444,11 +444,11 @@ 	| otherwise = case remoteAnnexTrackingBranch (Remote.gitconfig remote) of 		Nothing -> noop 		Just tb -> do-			let (b, s) = separate (== ':') (Git.fromRef tb)+			let (b, p) = separate' (== (fromIntegral (ord ':'))) (Git.fromRef' tb) 			let branch = Git.Ref b-			let subdir = if null s+			let subdir = if S.null p 				then Nothing-				else Just (asTopFilePath (toRawFilePath s))+				else Just (asTopFilePath p) 			Command.Import.seekRemote remote branch subdir 			void $ mergeRemote remote currbranch mergeconfig o   where@@ -509,13 +509,13 @@ 		Nothing -> return True 		Just wt -> ifM needemulation 			( liftIO $ do-				p <- readProgramFile+				p <- programPath 				boolSystem' p [Param "post-receive"] 					(\cp -> cp { cwd = Just (fromRawFilePath wt) }) 			, return True 			) 	  where-		needemulation = Remote.Git.onLocal repo remote $+		needemulation = Remote.Git.onLocalRepo repo $ 			(annexCrippledFileSystem <$> Annex.getGitConfig) 				<&&> 			needUpdateInsteadEmulation
Command/TestRemote.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE RankNTypes #-}+ module Command.TestRemote where  import Command@@ -27,9 +29,8 @@ import Types.RemoteConfig import Types.ProposedAccepted import Annex.SpecialRemote.Config (exportTreeField)-import Remote.Helper.ExportImport import Remote.Helper.Chunked-import Remote.Helper.Encryptable (describeEncryption, encryptionField, highRandomQualityField)+import Remote.Helper.Encryptable (encryptionField, highRandomQualityField) import Git.Types  import Test.Tasty@@ -39,6 +40,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Map as M+import Control.Concurrent.STM hiding (check)  cmd :: Command cmd = command "testremote" SectionTesting@@ -83,58 +85,63 @@ 	let r' = if null (testReadonlyFile o) 		then r 		else r { Remote.readonly = True }-	rs <- if Remote.readonly r'-		then return [r']-		else do-			rs <- catMaybes <$> mapM (adjustChunkSize r') (chunkSizes basesz fast)-			concat <$> mapM encryptionVariants rs-	unavailrs  <- catMaybes <$> mapM Remote.mkUnavailable [r']-	exportr <- if Remote.readonly r'+	let drs = if Remote.readonly r'+		then [Described "remote" (pure (Just r'))]+		else remoteVariants (Described "remote" (pure r')) basesz fast+	unavailr  <- Remote.mkUnavailable r'+	let exportr = if Remote.readonly r' 		then return Nothing 		else exportTreeVariant r'-	perform rs unavailrs exportr ks+	perform drs unavailr exportr ks   where 	basesz = fromInteger $ sizeOption o -perform :: [Remote] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform-perform rs unavailrs exportr ks = do-	let ea = maybe exportUnsupported Remote.exportActions exportr-	st <- Annex.getState id-	let tests = testGroup "Remote Tests" $ concat-		[ [ testGroup "unavailable remote" (testUnavailable st r (Prelude.head ks)) | r <- unavailrs ]-		, [ testGroup (desc r k) (test st r k) | k <- ks, r <- rs ]-		, [ testGroup (descexport k1 k2) (testExportTree st exportr ea k1 k2) | k1 <- take 2 ks, k2 <- take 2 (reverse ks) ]-		]+perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform+perform drs unavailr exportr ks = do+	st <- liftIO . newTVarIO =<< Annex.getState id+	let tests = testGroup "Remote Tests" $ mkTestTrees+		(runTestCase st) +		drs+		(pure unavailr)+		exportr+		(map (\k -> Described (desck k) (pure k)) ks) 	ok <- case tryIngredients [consoleTestReporter] mempty tests of 		Nothing -> error "No tests found!?" 		Just act -> liftIO act+	rs <- catMaybes <$> mapM getVal drs 	next $ cleanup rs ks ok   where-	desc r' k = intercalate "; " $ map unwords-		[ [ "key size", show (fromKey keySize k) ]-		, [ show (getChunkConfig (Remote.config r')) ]-		, ["encryption", describeEncryption (Remote.config r')]-		]-	descexport k1 k2 = intercalate "; " $ map unwords-		[ [ "exporttree=yes" ]-		, [ "key1 size", show (fromKey keySize k1) ]-		, [ "key2 size", show (fromKey keySize k2) ]-		]+	desck k = unwords [ "key size", show (fromKey keySize k) ] +remoteVariants :: Described (Annex Remote) -> Int -> Bool -> [Described (Annex (Maybe Remote))]+remoteVariants dr basesz fast = +	concatMap encryptionVariants $+		map chunkvariant (chunkSizes basesz fast)+  where+	chunkvariant sz = Described (getDesc dr ++ " chunksize=" ++ show sz) $ do+		r <- getVal dr+		adjustChunkSize r sz+ adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote) adjustChunkSize r chunksize = adjustRemoteConfig r $ 	M.insert chunkField (Proposed (show chunksize))  -- Variants of a remote with no encryption, and with simple shared -- encryption. Gpg key based encryption is not tested.-encryptionVariants :: Remote -> Annex [Remote]-encryptionVariants r = do-	noenc <- adjustRemoteConfig r $-		M.insert encryptionField (Proposed "none")-	sharedenc <- adjustRemoteConfig r $-		M.insert encryptionField (Proposed "shared") .-		M.insert highRandomQualityField (Proposed "false")-	return $ catMaybes [noenc, sharedenc]+encryptionVariants :: Described (Annex (Maybe Remote)) -> [Described (Annex (Maybe Remote))]+encryptionVariants dr = [noenc, sharedenc]+  where+	noenc = Described (getDesc dr ++ " encryption=none") $+		getVal dr >>= \case+			Nothing -> return Nothing+			Just r -> adjustRemoteConfig r $+				M.insert encryptionField (Proposed "none")+	sharedenc = Described (getDesc dr ++ " encryption=shared") $+		getVal dr >>= \case+			Nothing -> return Nothing+			Just r -> adjustRemoteConfig r $+				M.insert encryptionField (Proposed "shared") .+				M.insert highRandomQualityField (Proposed "false")  -- Variant of a remote with exporttree disabled. disableExportTree :: Remote -> Annex Remote@@ -162,19 +169,65 @@ 		(Remote.gitconfig r) 		(Remote.remoteStateHandle r) -test :: Annex.AnnexState -> Remote -> Key -> [TestTree]-test st r k = catMaybes-	[ whenwritable $ check "removeKey when not present" remove-	, whenwritable $ present False-	, whenwritable $ check "storeKey" store-	, whenwritable $ present True-	, whenwritable $ check "storeKey when already present" store-	, Just $ present True-	, Just $ check "retrieveKeyFile" $ do+data Described t = Described+	{ getDesc :: String+	, getVal :: t+	}++type RunAnnex = forall a. Annex a -> IO a++runTestCase :: TVar Annex.AnnexState -> RunAnnex+runTestCase stv a = do+	st <- atomically $ readTVar stv+	(r, st') <- Annex.run st $ do+		Annex.setOutput QuietOutput +		a+	atomically $ writeTVar stv st'+	return r++-- Note that the same remotes and keys should be produced each time+-- the provided actions are called.+mkTestTrees+	:: RunAnnex+	-> [Described (Annex (Maybe Remote))]+	-> Annex (Maybe Remote)+	-> Annex (Maybe Remote)+	-> [Described (Annex Key)]+	-> [TestTree]+mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $+	[ [ testGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (Prelude.head mkks))) ]+	, [ testGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- mkks, mkr <- mkrs ]+	, [ testGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 mkks, mkk2 <- take 2 (reverse mkks) ]+	]+   where+	desc r k = intercalate "; " $ map unwords+		[ [ getDesc k ]+		, [ getDesc r ]+		]+	descexport k1 k2 = intercalate "; " $ map unwords+		[ [ "exporttree=yes" ]+		, [ getDesc k1 ]+		, [ getDesc k2 ]+		]++test :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree]+test runannex mkr mkk =+	[ check "removeKey when not present" $ \r k ->+		whenwritable r $ remove r k+	, check ("present " ++ show False) $ \r k ->+		whenwritable r $ present r k False+	, check "storeKey" $ \r k ->+		whenwritable r $ store r k+	, check ("present " ++ show True) $ \r k ->+		whenwritable r $ present r k True+	, check "storeKey when already present" $ \r k ->+		whenwritable r $ store r k+	, check ("present " ++ show True) $ \r k -> present r k True+	, check "retrieveKeyFile" $ \r k -> do 		lockContentForRemoval k removeAnnex-		get-	, Just $ check "fsck downloaded object" fsck-	, Just $ check "retrieveKeyFile resume from 33%" $ do+		get r k+	, check "fsck downloaded object" fsck+	, check "retrieveKeyFile resume from 33%" $ \r k -> do 		loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) 		tmp <- prepTmp k 		partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do@@ -182,106 +235,133 @@ 			L.hGet h $ fromInteger $ sz `div` 3 		liftIO $ L.writeFile tmp partial 		lockContentForRemoval k removeAnnex-		get-	, Just $ check "fsck downloaded object" fsck-	, Just $ check "retrieveKeyFile resume from 0" $ do+		get r k+	, check "fsck downloaded object" fsck+	, check "retrieveKeyFile resume from 0" $ \r k -> do 		tmp <- prepTmp k 		liftIO $ writeFile tmp "" 		lockContentForRemoval k removeAnnex-		get-	, Just $ check "fsck downloaded object" fsck-	, Just $ check "retrieveKeyFile resume from end" $ do+		get r k+	, check "fsck downloaded object" fsck+	, check "retrieveKeyFile resume from end" $ \r k -> do 		loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) 		tmp <- prepTmp k 		void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp 		lockContentForRemoval k removeAnnex-		get-	, Just $ check "fsck downloaded object" fsck-	, whenwritable $ check "removeKey when present" remove-	, whenwritable $ present False+		get r k+	, check "fsck downloaded object" fsck+	, check "removeKey when present" $ \r k -> +		whenwritable r $ remove r k+	, check ("present " ++ show False) $ \r k -> +		whenwritable r $ present r k False 	]   where-	whenwritable a = if Remote.readonly r then Nothing else Just a-	check desc a = testCase desc $-		Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed"-	present b = check ("present " ++ show b) $-		(== Right b) <$> Remote.hasKey r k-	fsck = case maybeLookupBackendVariety (fromKey keyVariety k) of+	whenwritable r a+		| Remote.readonly r = return True+		| otherwise = a+	check desc a = testCase desc $ do+		let a' = mkr >>= \case+			Just r -> do+				k <- mkk+				a r k+			Nothing -> return True+		runannex a' @? "failed"+	present r k b = (== Right b) <$> Remote.hasKey r k+	fsck _ k = case maybeLookupBackendVariety (fromKey keyVariety k) of 		Nothing -> return True 		Just b -> case Backend.verifyKeyContent b of 			Nothing -> return True 			Just verifier -> verifier k (serializeKey k)-	get = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest ->+	get r k = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> 		Remote.retrieveKeyFile r k (AssociatedFile Nothing) 			dest nullMeterUpdate-	store = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate-	remove = Remote.removeKey r k+	store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate+	remove r k = Remote.removeKey r k -testExportTree :: Annex.AnnexState -> Maybe Remote -> Remote.ExportActions Annex -> Key -> Key -> [TestTree]-testExportTree _ Nothing _ _ _ = []-testExportTree st (Just _) ea k1 k2 =-	[ check "check present export when not present" $-		not <$> checkpresentexport k1-	, check "remove export when not present" (removeexport k1)-	, check "store export" (storeexport k1)-	, check "check present export after store" $-		checkpresentexport k1-	, check "store export when already present" (storeexport k1)-	, check "retrieve export" (retrieveexport k1)-	, check "store new content to export" (storeexport k2)-	, check "check present export after store of new content" $-		checkpresentexport k2-	, check "retrieve export new content" (retrieveexport k2)-	, check "remove export" (removeexport k2)-	, check "check present export after remove" $-		not <$> checkpresentexport k2-	, check "retrieve export fails after removal" $-		not <$> retrieveexport k2-	, check "remove export directory" removeexportdirectory-	, check "remove export directory that is already removed" removeexportdirectory+testExportTree :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> Annex Key -> [TestTree]+testExportTree runannex mkr mkk1 mkk2 =+	[ check "check present export when not present" $ \ea k1 _k2 ->+		not <$> checkpresentexport ea k1+	, check "remove export when not present" $ \ea k1 _k2 -> +		removeexport ea k1+	, check "store export" $ \ea k1 _k2 ->+		storeexport ea k1+	, check "check present export after store" $ \ea k1 _k2 ->+		checkpresentexport ea k1+	, check "store export when already present" $ \ea k1 _k2 ->+		storeexport ea k1+	, check "retrieve export" $ \ea k1 _k2 -> +		retrieveexport ea k1+	, check "store new content to export" $ \ea _k1 k2 ->+		storeexport ea k2+	, check "check present export after store of new content" $ \ea _k1 k2 ->+		checkpresentexport ea k2+	, check "retrieve export new content" $ \ea _k1 k2 ->+		retrieveexport ea k2+	, check "remove export" $ \ea _k1 k2 -> +		removeexport ea k2+	, check "check present export after remove" $ \ea _k1 k2 ->+		not <$> checkpresentexport ea k2+	, check "retrieve export fails after removal" $ \ea _k1 k2 ->+		not <$> retrieveexport ea k2+	, check "remove export directory" $ \ea _k1 _k2 ->+		removeexportdirectory ea+	, check "remove export directory that is already removed" $ \ea _k1 _k2 ->+		removeexportdirectory ea 	-- renames are not tested because remotes do not need to support them 	]   where 	testexportdirectory = "testremote-export" 	testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory </> "location"))-	check desc a = testCase desc $-		Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed"-	storeexport k = do+	check desc a = testCase desc $ do+		let a' = mkr >>= \case+			Just r -> do+				let ea = Remote.exportActions r+				k1 <- mkk1+				k2 <- mkk2+				a ea k1 k2+			Nothing -> return True+		runannex a' @? "failed"+	storeexport ea k = do 		loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) 		Remote.storeExport ea loc k testexportlocation nullMeterUpdate-	retrieveexport k = withTmpFile "exported" $ \tmp h -> do+	retrieveexport ea k = withTmpFile "exported" $ \tmp h -> do 		liftIO $ hClose h 		ifM (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) 			( verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified k tmp 			, return False 			)-	checkpresentexport k = Remote.checkPresentExport ea k testexportlocation-	removeexport k = Remote.removeExport ea k testexportlocation-	removeexportdirectory = case Remote.removeExportDirectory ea of+	checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation+	removeexport ea k = Remote.removeExport ea k testexportlocation+	removeexportdirectory ea = case Remote.removeExportDirectory ea of 		Nothing -> return True 		Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory)) -testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree]-testUnavailable st r k =-	[ check (== Right False) "removeKey" $+testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree]+testUnavailable runannex mkr mkk =+	[ check (== Right False) "removeKey" $ \r k -> 		Remote.removeKey r k-	, check (== Right False) "storeKey" $+	, check (== Right False) "storeKey" $ \r k ->  		Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate-	, check (`notElem` [Right True, Right False]) "checkPresent" $+	, check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> 		Remote.checkPresent r k-	, check (== Right False) "retrieveKeyFile" $+	, check (== Right False) "retrieveKeyFile" $ \r k -> 		getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> 			Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate-	, check (== Right False) "retrieveKeyFileCheap" $+	, check (== Right False) "retrieveKeyFileCheap" $ \r k -> 		getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> unVerified $ 			Remote.retrieveKeyFileCheap r k (AssociatedFile Nothing) dest 	]   where-	check checkval desc a = testCase desc $ do-		v <- Annex.eval st $ do-			Annex.setOutput QuietOutput-			either (Left  . show) Right <$> tryNonAsync a-		checkval v  @? ("(got: " ++ show v ++ ")")+	check checkval desc a = testCase desc $ +		join $ runannex $ mkr >>= \case+			Just r -> do+				k <- mkk+				v <- either (Left  . show) Right+					<$> tryNonAsync (a r k)+				return $ checkval v+					@? ("(got: " ++ show v ++ ")")+			Nothing -> return noop  cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup cleanup rs ks ok
Command/TransferKeys.hs view
@@ -17,6 +17,7 @@ import Utility.SimpleProtocol (dupIoHandles) import Git.Types (RemoteName) import qualified Database.Keys+import Annex.BranchState  data TransferRequest = TransferRequest Direction Remote Key AssociatedFile @@ -29,6 +30,7 @@  start :: CommandStart start = do+	enableInteractiveJournalAccess 	(readh, writeh) <- liftIO dupIoHandles 	runRequests readh writeh runner 	stop
Command/Uninit.hs view
@@ -35,7 +35,7 @@ 	whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ 		giveup "can only run uninit from the top of the git repository"   where-	current_branch = Git.Ref . Prelude.head . lines . decodeBS' <$> revhead+	current_branch = Git.Ref . encodeBS' . Prelude.head . lines . decodeBS' <$> revhead 	revhead = inRepo $ Git.Command.pipeReadStrict 		[Param "rev-parse", Param "--abbrev-ref", Param "HEAD"]
Command/Unused.hs view
@@ -5,12 +5,10 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, OverloadedStrings #-}  module Command.Unused where -import qualified Data.Map as M- import Command import Logs.Unused import Annex.Content@@ -37,6 +35,11 @@ import qualified Database.Keys import Annex.InodeSentinal +import qualified Data.Map as M+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.Char+ cmd :: Command cmd = command "unused" SectionMaintenance "look for unused file content" 	paramNothing (seek <$$> optParser)@@ -221,8 +224,7 @@  withKeysReferencedDiffGitRefs :: RefSpec -> (Key -> Annex ()) -> Annex () withKeysReferencedDiffGitRefs refspec a = do-	rs <- relevantrefs . decodeBS'-		<$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"])+	rs <- relevantrefs <$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"]) 	shaHead <- maybe (return Nothing) (inRepo . Git.Ref.sha) 		=<< inRepo Git.Branch.currentUnsafe 	let haveHead = any (\(shaRef, _) -> Just shaRef == shaHead) rs@@ -233,12 +235,12 @@   where 	relevantrefs = map (\(r, h) -> (Git.Ref r, Git.Ref h)) . 		filter ourbranches .-		map (separate (== ' ')) .-		lines+		map (separate' (== (fromIntegral (ord ' ')))) .+		S8.lines 	nubRefs = nubBy (\(x, _) (y, _) -> x == y)-	ourbranchend = '/' : Git.fromRef Annex.Branch.name-	ourbranches (_, b) = not (ourbranchend `isSuffixOf` b)-		&& not ("refs/synced/" `isPrefixOf` b)+	ourbranchend = S.cons (fromIntegral (ord '/')) (Git.fromRef' Annex.Branch.name)+	ourbranches (_, b) = not (ourbranchend `S.isSuffixOf` b)+		&& not ("refs/synced/" `S.isPrefixOf` b) 		&& not (is_branchView (Git.Ref b)) 	getreflog rs = inRepo $ Git.RefLog.getMulti rs
Config/Cost.hs view
@@ -46,9 +46,9 @@ insertCostAfter l pos 	| pos < 0 = costBetween 0 (l !! 0) : l 	| nextpos > maxpos = l ++ [1 + l !! maxpos]-	| item == nextitem =-		let (_dup:new:l') = insertCostAfter lastsegment 0-		in firstsegment ++ [costBetween item new, new] ++ l'+	| item == nextitem = case insertCostAfter lastsegment 0 of+		(_dup:new:l') -> firstsegment ++ [costBetween item new, new] ++ l'+		_ -> error "insertCostAfter internal error" 	| otherwise = 		firstsegment ++ [costBetween item nextitem ] ++ lastsegment   where
Config/Files.hs view
@@ -61,27 +61,6 @@ programFile :: IO FilePath programFile = userConfigFile "program" -{- Returns a command to run for git-annex. -}-readProgramFile :: IO FilePath-readProgramFile = do-	programfile <- programFile-	p <- catchDefaultIO cmd $ -		fromMaybe cmd . headMaybe . lines <$> readFile programfile-	ifM (inPath p)-		( return p-		, ifM (inPath cmd)-			( return cmd-			, cannotFindProgram-			)-		)-  where-	cmd = "git-annex"--cannotFindProgram :: IO a-cannotFindProgram = do-	f <- programFile-	giveup $ "cannot find git-annex program in PATH or in the location listed in " ++ f- {- A .noannex file in a git repository prevents git-annex from  - initializing that repository.. The content of the file is returned. -} noAnnexFileContent :: Maybe FilePath -> IO (Maybe String)
Database/Keys.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}  module Database.Keys ( 	DbHandle,@@ -44,6 +45,7 @@ import Git.Index  import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import qualified System.FilePath.ByteString as P  {- Runs an action that reads from the database.@@ -59,7 +61,7 @@  -} runReader :: Monoid v => (SQL.ReadHandle -> Annex v) -> Annex v runReader a = do-	h <- getDbHandle+	h <- Annex.getState Annex.keysdbhandle 	withDbState h go   where 	go DbUnavailable = return (mempty, DbUnavailable)@@ -83,7 +85,7 @@  - The database is created if it doesn't exist yet. -} runWriter :: (SQL.WriteHandle -> Annex ()) -> Annex () runWriter a = do-	h <- getDbHandle+	h <- Annex.getState Annex.keysdbhandle 	withDbState h go   where 	go st@(DbOpen qh) = do@@ -99,17 +101,6 @@ runWriterIO :: (SQL.WriteHandle -> IO ()) -> Annex () runWriterIO a = runWriter (liftIO . a) -{- Gets the handle cached in Annex state; creates a new one if it's not yet- - available, but doesn't open the database. -}-getDbHandle :: Annex DbHandle-getDbHandle = go =<< Annex.getState Annex.keysdbhandle-  where-	go (Just h) = pure h-	go Nothing = do-		h <- liftIO newDbHandle-		Annex.changeState $ \s -> s { Annex.keysdbhandle = Just h }-		return h- {- Opens the database, perhaps creating it if it doesn't exist yet.  -  - Multiple readers and writers can have the database open at the same@@ -151,9 +142,7 @@  - data to it.  -} closeDb :: Annex ()-closeDb = Annex.getState Annex.keysdbhandle >>= \case-	Nothing -> return ()-	Just h -> liftIO (closeDbHandle h)+closeDb = liftIO . closeDbHandle =<< Annex.getState Annex.keysdbhandle  addAssociatedFile :: Key -> TopFilePath -> Annex () addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile k f@@ -237,8 +226,8 @@ 		Nothing -> noop   where 	go cur indexcache = do-		(l, cleanup) <- inRepo $ pipeNullSplit diff-		changed <- procdiff (map decodeBL' l) False+		(l, cleanup) <- inRepo $ pipeNullSplit' diff+		changed <- procdiff l False 		void $ liftIO cleanup 		-- Flush database changes immediately 		-- so other processes can see them.@@ -278,15 +267,16 @@ 		, Param "--no-ext-diff" 		] 	-	procdiff (info:file:rest) changed = case words info of-		((':':_srcmode):dstmode:_srcsha:dstsha:_change:[])-			-- Only want files, not symlinks-			| dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do-				maybe noop (reconcile (asTopFilePath (toRawFilePath file)))-					=<< catKey (Ref dstsha)-				procdiff rest True-			| otherwise -> procdiff rest changed-		_ -> return changed -- parse failed+	procdiff (info:file:rest) changed+		| ":" `S.isPrefixOf` info = case S8.words info of+			(_colonsrcmode:dstmode:_srcsha:dstsha:_change:[])+				-- Only want files, not symlinks+				| dstmode /= fmtTreeItemType TreeSymlink -> do+					maybe noop (reconcile (asTopFilePath file))+						=<< catKey (Ref dstsha)+					procdiff rest True+				| otherwise -> procdiff rest changed+			_ -> return changed -- parse failed 	procdiff _ changed = return changed  	-- Note that database writes done in here will not necessarily
Database/Types.hs view
@@ -28,6 +28,7 @@ import Key import Utility.InodeCache import Utility.FileSize+import Utility.FileSystemEncoding import Git.Types import Types.UUID import Types.Import@@ -94,10 +95,10 @@ 	deriving (Eq, Show)  toSSha :: Sha -> SSha-toSSha (Ref s) = SSha s+toSSha (Ref s) = SSha (decodeBS' s)  fromSSha :: SSha -> Ref-fromSSha (SSha s) = Ref s+fromSSha (SSha s) = Ref (encodeBS' s)  instance PersistField SSha where 	toPersistValue (SSha b) = toPersistValue b
Git.hs view
@@ -14,6 +14,7 @@ 	Repo(..), 	Ref(..), 	fromRef,+	fromRef', 	Branch, 	Sha, 	Tag,
Git/Branch.hs view
@@ -18,6 +18,7 @@ import qualified Git.Ref  import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8  {- The currently checked out branch.  -@@ -39,25 +40,27 @@  {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch)-currentUnsafe r = parse . firstLine'-	<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r+currentUnsafe r = parse . firstLine' <$> pipeReadStrict+	[ Param "symbolic-ref"+	, Param "-q"+	, Param $ fromRef Git.Ref.headRef+	] r   where 	parse b 		| B.null b = Nothing-		| otherwise = Just $ Git.Ref $ decodeBS b+		| otherwise = Just $ Git.Ref b  {- Checks if the second branch has any commits not present on the first  - branch. -} changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo 	| origbranch == newbranch = return False-	| otherwise = not . null+	| otherwise = not . B.null 		<$> changed' origbranch newbranch [Param "-n1"] repo   where -changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String-changed' origbranch newbranch extraps repo =-	decodeBS <$> pipeReadStrict ps repo+changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO B.ByteString+changed' origbranch newbranch extraps repo = pipeReadStrict ps repo   where 	ps = 		[ Param "log"@@ -68,7 +71,7 @@ {- Lists commits that are in the second branch and not in the first branch. -} changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha] changedCommits origbranch newbranch extraps repo = -	catMaybes . map extractSha . lines+	catMaybes . map extractSha . B8.lines 		<$> changed' origbranch newbranch extraps repo 	 {- Check if it's possible to fast-forward from the old@@ -163,8 +166,7 @@  -} commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do-	tree <- getSha "write-tree" $-		decodeBS' <$> pipeReadStrict [Param "write-tree"] repo+	tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo 	ifM (cancommit tree) 		( do 			sha <- commitTree commitmode message parentrefs tree repo
Git/CatFile.hs view
@@ -1,10 +1,12 @@ {- git cat-file interface  -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Git.CatFile ( 	CatFileHandle, 	catFileStart,@@ -22,7 +24,9 @@ import System.IO import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Char8 as S8+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Map as M import Data.String import Data.Char@@ -69,11 +73,11 @@ {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $-	fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)+	fromRef' branch <> ":" <> toInternalGitPath file  catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Ref $-	fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)+	fromRef' branch <> ":" <> toInternalGitPath file  {- Uses a running git cat-file read the content of an object.  - Objects that do not exist will have "" returned. -}@@ -82,9 +86,9 @@  catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do-	header <- hGetLine from+	header <- S8.hGetLine from 	case parseResp object header of-		Just (ParsedResp sha size objtype) -> do+		Just (ParsedResp sha objtype size) -> do 			content <- S.hGet from (fromIntegral size) 			eatchar '\n' from 			return $ Just (L.fromChunks [content], sha, objtype)@@ -112,9 +116,9 @@ {- Gets the size and type of an object, without reading its content. -} catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do-	resp <- hGetLine from+	resp <- S8.hGetLine from 	case parseResp object resp of-		Just (ParsedResp sha size objtype) ->+		Just (ParsedResp sha objtype size) -> 			return $ Just (sha, size, objtype) 		Just DNE -> return Nothing 		Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object)@@ -126,36 +130,40 @@ 		objtype <- queryObjectType object (gitRepo h) 		return $ (,,) <$> sha <*> sz <*> objtype -data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE+data ParsedResp = ParsedResp Sha ObjectType FileSize | DNE+	deriving (Show)  query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a query hdl object newlinefallback receive 	-- git cat-file --batch uses a line based protocol, so when the 	-- filename itself contains a newline, have to fall back to another 	-- method of getting the information.-	| '\n' `elem` s = newlinefallback+	| '\n' `S8.elem` s = newlinefallback 	-- git strips carriage return from the end of a line, out of some 	-- misplaced desire to support windows, so also use the newline 	-- fallback for those.-	| "\r" `isSuffixOf` s = newlinefallback+	| "\r" `S8.isSuffixOf` s = newlinefallback 	| otherwise = CoProcess.query hdl send receive   where-	send to = hPutStrLn to s-	s = fromRef object+	send to = S8.hPutStrLn to s+	s = fromRef' object -parseResp :: Ref -> String -> Maybe ParsedResp-parseResp object l -	| " missing" `isSuffixOf` l -- less expensive than full check-		&& l == fromRef object ++ " missing" = Just DNE-	| otherwise = case words l of-		[sha, objtype, size] -> case extractSha sha of-			Just sha' -> case (readObjectType (encodeBS objtype), reads size) of-				(Just t, [(bytes, "")]) -> -					Just $ ParsedResp sha' bytes t-				_ -> Nothing-			Nothing -> Nothing-		_ -> Nothing+parseResp :: Ref -> S.ByteString -> Maybe ParsedResp+parseResp object s+	| " missing" `S.isSuffixOf` s -- less expensive than full check+		&& s == fromRef' object <> " missing" = Just DNE+	| otherwise = eitherToMaybe $ A.parseOnly respParser s +respParser :: A.Parser ParsedResp+respParser = ParsedResp+	<$> (maybe (fail "bad sha") return . extractSha =<< nextword)+	<* A8.char ' '+	<*> (maybe (fail "bad object type") return . readObjectType =<< nextword)+	<* A8.char ' '+	<*> A8.decimal+  where+	nextword = A8.takeTill (== ' ')+ querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a) querySingle o r repo reader = assertLocal repo $ 	-- In non-batch mode, git cat-file warns on stderr when@@ -218,39 +226,39 @@ catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit) catCommit h commitref = go <$> catObjectDetails h commitref   where-	go (Just (b, _, CommitObject)) = parseCommit b+	go (Just (b, _, CommitObject)) = parseCommit (L.toStrict b) 	go _ = Nothing -parseCommit :: L.ByteString -> Maybe Commit+parseCommit :: S.ByteString -> Maybe Commit parseCommit b = Commit-	<$> (extractSha . L8.unpack =<< field "tree")-	<*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent"))+	<$> (extractSha =<< field "tree")+	<*> Just (maybe [] (mapMaybe extractSha) (fields "parent")) 	<*> (parsemetadata <$> field "author") 	<*> (parsemetadata <$> field "committer")-	<*> Just (L8.unpack $ L.intercalate (L.singleton nl) message)+	<*> Just (decodeBS $ S.intercalate (S.singleton nl) message)   where 	field n = headMaybe =<< fields n 	fields n = M.lookup (fromString n) fieldmap 	fieldmap = M.fromListWith (++) ((map breakfield) header) 	breakfield l =-		let (k, sp_v) = L.break (== sp) l-		in (k, [L.drop 1 sp_v])-	(header, message) = separate L.null ls-	ls = L.split nl b+		let (k, sp_v) = S.break (== sp) l+		in (k, [S.drop 1 sp_v])+	(header, message) = separate S.null ls+	ls = S.split nl b  	-- author and committer lines have the form: "name <email> date" 	-- The email is always present, even if empty "<>" 	parsemetadata l = CommitMetaData-		{ commitName = whenset $ L.init name_sp+		{ commitName = whenset $ S.init name_sp 		, commitEmail = whenset email-		, commitDate = whenset $ L.drop 2 gt_sp_date+		, commitDate = whenset $ S.drop 2 gt_sp_date 		} 	  where-		(name_sp, rest) = L.break (== lt) l-		(email, gt_sp_date) = L.break (== gt) (L.drop 1 rest)+		(name_sp, rest) = S.break (== lt) l+		(email, gt_sp_date) = S.break (== gt) (S.drop 1 rest) 		whenset v-			| L.null v = Nothing-			| otherwise = Just (L8.unpack v)+			| S.null v = Nothing+			| otherwise = Just (decodeBS v)  	nl = fromIntegral (ord '\n') 	sp = fromIntegral (ord ' ')
Git/Command.hs view
@@ -81,11 +81,16 @@ {- Runs a git command, feeding it an input, and returning its output,  - which is expected to be fairly small, since it's all read into memory  - strictly. -}-pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String+pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO S.ByteString pipeWriteRead params writer repo = assertLocal repo $ 	writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) -		(gitEnv repo) writer (Just adjusthandle)+		(gitEnv repo) writer'   where+	writer' = case writer of+		Nothing -> Nothing+		Just a -> Just $ \h -> do+			adjusthandle h+			a h 	adjusthandle h = hSetNewlineMode h noNewlineTranslation  {- Runs a git command, feeding it input on a handle with an action. -}
Git/Config.hs view
@@ -59,7 +59,7 @@ 	go Repo { location = LocalUnknown d } = git_config d 	go _ = assertLocal repo $ error "internal" 	git_config d = withHandle StdoutHandle createProcessSuccess p $-		hRead repo+		hRead repo ConfigNullList 	  where 		params = ["config", "--null", "--list"] 		p = (proc "git" params)@@ -74,7 +74,7 @@ 	ifM (doesFileExist $ home </> ".gitconfig") 		( do 			repo <- withHandle StdoutHandle createProcessSuccess p $-				hRead (Git.Construct.fromUnknown)+				hRead (Git.Construct.fromUnknown) ConfigNullList 			return $ Just repo 		, return Nothing 		)@@ -83,18 +83,18 @@ 	p = (proc "git" params)  {- Reads git config from a handle and populates a repo with it. -}-hRead :: Repo -> Handle -> IO Repo-hRead repo h = do+hRead :: Repo -> ConfigStyle -> Handle -> IO Repo+hRead repo st h = do 	val <- S.hGetContents h-	store val repo+	store val st repo  {- Stores a git config into a Repo, returning the new version of the Repo.  - The git config may be multiple lines, or a single line.  - Config settings can be updated incrementally.  -}-store :: S.ByteString -> Repo -> IO Repo-store s repo = do-	let c = parse s+store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo+store s st repo = do+	let c = parse s st 	updateLocation $ repo 		{ config = (M.map Prelude.head c) `M.union` config repo 		, fullconfig = M.unionWith (++) c (fullconfig repo)@@ -135,27 +135,30 @@ 			top <- absPath $ fromRawFilePath (gitdir l) 			let p = absPathFrom top (fromRawFilePath d) 			return $ l { worktree = Just (toRawFilePath p) }+		Just NoConfigValue -> return l 	return $ r { location = l' } +data ConfigStyle = ConfigList | ConfigNullList+ {- Parses git config --list or git config --null --list output into a  - config map. -}-parse :: S.ByteString -> M.Map ConfigKey [ConfigValue]-parse s+parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue]+parse s st 	| S.null s = M.empty-	-- --list output will have a '=' in the first line-	-- (The first line of --null --list output is the name of a key,-	-- which is assumed to never contain '='.)-	| S.elem eq firstline = sep eq $ S.split nl s-	-- --null --list output separates keys from values with newlines-	| otherwise = sep nl $ S.split 0 s+	| otherwise = case st of+		ConfigList -> sep eq $ S.split nl s+		ConfigNullList -> sep nl $ S.split 0 s   where 	nl = fromIntegral (ord '\n') 	eq = fromIntegral (ord '=')-	firstline = S.takeWhile (/= nl) s  	sep c = M.fromListWith (++)-		. map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)])) +		. map (\(k,v) -> (ConfigKey k, [mkval v]))  		. map (S.break (== c))+	+	mkval v +		| S.null v = NoConfigValue+		| otherwise = ConfigValue (S.drop 1 v)  {- Checks if a string from git config is a true/false value. -} isTrueFalse :: String -> Maybe Bool@@ -163,11 +166,21 @@  isTrueFalse' :: ConfigValue -> Maybe Bool isTrueFalse' (ConfigValue s)+	| s' == "yes" = Just True+	| s' == "on" = Just True 	| s' == "true" = Just True+	| s' == "1" = Just True++	| s' == "no" = Just False+	| s' == "off" = Just False 	| s' == "false" = Just False+	| s' == "0" = Just False+	| s' == "" = Just False+ 	| otherwise = Nothing   where 	s' = S8.map toLower s+isTrueFalse' NoConfigValue = Just True  boolConfig :: Bool -> String boolConfig True = "true"@@ -186,14 +199,14 @@ {- Runs a command to get the configuration of a repo,  - and returns a repo populated with the configuration, as well as the raw  - output and any standard output of the command. -}-fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString, S.ByteString))-fromPipe r cmd params = try $+fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString))+fromPipe r cmd params st = try $ 	withOEHandles createProcessSuccess p $ \(hout, herr) -> do 		geterr <- async $ S.hGetContents herr 		getval <- async $ S.hGetContents hout 		val <- wait getval 		err <- wait geterr-		r' <- store val r+		r' <- store val st r 		return (r', val, err)   where 	p = proc cmd $ toCommand params@@ -206,7 +219,7 @@ 	, Param "--file" 	, File f 	, Param "--list"-	]+	] ConfigList  {- Changes a git config setting in the specified config file.  - (Creates the file if it does not already exist.) -}
Git/ConfigTypes.hs view
@@ -23,7 +23,6 @@ getSharedRepository :: Repo -> SharedRepository getSharedRepository r = 	case Git.Config.getMaybe "core.sharedrepository" r of-		Nothing -> UnShared 		Just (ConfigValue v) -> case S8.map toLower v of 			"1" -> GroupShared 			"2" -> AllShared@@ -33,6 +32,8 @@ 			"world" -> AllShared 			"everybody" -> AllShared 			_ -> maybe UnShared UmaskShared (readish (decodeBS' v))+		Just NoConfigValue -> UnShared+		Nothing -> UnShared  data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush 	deriving (Eq)@@ -45,4 +46,5 @@ 			"warn" -> WarnPush 			"ignore" -> IgnorePush 			_ -> RefusePush+		Just NoConfigValue -> RefusePush 		Nothing -> RefusePush
Git/Credential.hs view
@@ -58,7 +58,7 @@  runCredential :: String -> Credential -> Repo -> IO Credential runCredential action input r =-	parseCredential <$> pipeWriteRead +	parseCredential . decodeBS <$> pipeWriteRead  		[ Param "credential" 		, Param action 		]
Git/DiffTree.hs view
@@ -1,6 +1,6 @@ {- git diff-tree interface  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -17,7 +17,9 @@ 	commitDiff, ) where -import Numeric+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import qualified Data.Attoparsec.ByteString.Char8 as A8  import Common import Git@@ -27,6 +29,7 @@ import Git.DiffTreeItem import qualified Git.Filename import qualified Git.Ref+import Utility.Attoparsec  {- Checks if the DiffTreeItem modifies a file with a given name  - or under a directory by that name. -}@@ -89,7 +92,7 @@ getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool) getdiff command params repo = do 	(diff, cleanup) <- pipeNullSplit ps repo-	return (parseDiffRaw (map decodeBL diff), cleanup)+	return (parseDiffRaw diff, cleanup)   where 	ps =  		command :@@ -100,26 +103,28 @@ 		params  {- Parses --raw output used by diff-tree and git-log. -}-parseDiffRaw :: [String] -> [DiffTreeItem]+parseDiffRaw :: [L.ByteString] -> [DiffTreeItem] parseDiffRaw l = go l   where 	go [] = []-	go (info:f:rest) = mk info f : go rest-	go (s:[]) = error $ "diff-tree parse error near \"" ++ s ++ "\""--	mk info f = DiffTreeItem-		{ srcmode = readmode srcm-		, dstmode = readmode dstm-		, srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha-		, dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha-		, status = s-		, file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f-		}-	  where-		readmode = fst . Prelude.head . readOct+	go (info:f:rest) = case A.parse (parserDiffRaw (L.toStrict f)) info of+		A.Done _ r -> r : go rest+		A.Fail _ _ err -> error $ "diff-tree parse error: " ++ err+	go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL' s ++ "\"" -		-- info = :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>-		(srcm, past_srcm) = splitAt 7 $ drop 1 info-		(dstm, past_dstm) = splitAt 7 past_srcm-		(ssha, past_ssha) = separate (== ' ') past_dstm-		(dsha, s) = separate (== ' ') past_ssha+-- :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>+parserDiffRaw :: RawFilePath -> A.Parser DiffTreeItem+parserDiffRaw f = DiffTreeItem+	<$ A8.char ':'+	<*> octal+	<* A8.char ' '+	<*> octal+	<* A8.char ' '+	<*> (maybe (fail "bad srcsha") return . extractSha =<< nextword)+	<* A8.char ' '+	<*> (maybe (fail "bad dstsha") return . extractSha =<< nextword)+	<* A8.char ' '+	<*> A.takeByteString+	<*> pure (asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f)+  where+	nextword = A8.takeTill (== ' ')
Git/DiffTreeItem.hs view
@@ -10,6 +10,7 @@ ) where  import System.Posix.Types+import qualified Data.ByteString as S  import Git.FilePath import Git.Types@@ -19,6 +20,6 @@ 	, dstmode :: FileMode 	, srcsha :: Sha -- null sha if file was added 	, dstsha :: Sha -- null sha if file was deleted-	, status :: String+	, status :: S.ByteString 	, file :: TopFilePath 	} deriving Show
Git/FilePath.hs view
@@ -50,7 +50,7 @@ {- Git uses the branch:file form to refer to a BranchFilePath -} descBranchFilePath :: BranchFilePath -> S.ByteString descBranchFilePath (BranchFilePath b f) =-	encodeBS' (fromRef b) <> ":" <> getTopFilePath f+	fromRef' b <> ":" <> getTopFilePath f  {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath
Git/Fsck.hs view
@@ -139,7 +139,8 @@ 		] r  findShas :: [String] -> [Sha]-findShas = catMaybes . map extractSha . concat . map words . filter wanted+findShas = catMaybes . map (extractSha . encodeBS') +	. concat . map words . filter wanted   where 	wanted l = not ("dangling " `isPrefixOf` l)
Git/GCrypt.hs view
@@ -98,6 +98,7 @@ 	defaultkey = "gcrypt.participants" 	parse (Just (ConfigValue "simple")) = [] 	parse (Just (ConfigValue b)) = words (decodeBS' b)+	parse (Just NoConfigValue) = [] 	parse Nothing = []  remoteParticipantConfigKey :: RemoteName -> ConfigKey
Git/HashObject.hs view
@@ -18,6 +18,7 @@ import Utility.Tmp  import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder @@ -39,7 +40,7 @@ hashFile h file = CoProcess.query h send receive   where 	send to = hPutStrLn to =<< absPath file-	receive from = getSha "hash-object" $ hGetLine from+	receive from = getSha "hash-object" $ S8.hGetLine from  class HashableBlob t where 	hashableBlobToHandle :: Handle -> t -> IO ()
Git/History.hs view
@@ -15,6 +15,9 @@ import Git.Sha  import qualified Data.Set as S+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8  data History t = History t (S.Set (History t)) 	deriving (Show, Eq, Ord)@@ -53,8 +56,9 @@ 	!h <- fmap (truncateHistoryToDepth n)  		. build Nothing  		. map parsehistorycommit-		. lines-		<$> hGetContents inh+		. map L.toStrict+		. L8.lines+		<$> L.hGetContents inh 	hClose inh 	void $ waitForProcess pid 	return h@@ -93,7 +97,7 @@ 		, Param "--format=%T %H %P" 		] 	-	parsehistorycommit l = case map extractSha (splitc ' ' l) of+	parsehistorycommit l = case map extractSha (B8.split ' ' l) of 		(Just t:Just c:ps) -> Just $  			( HistoryCommit 				{ historyCommit = c
Git/LsFiles.hs view
@@ -36,9 +36,10 @@ import Utility.TimeStamp  import Numeric+import Data.Char import System.Posix.Types import qualified Data.Map as M-import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S  {- It's only safe to use git ls-files on the current repo, not on a remote.  -@@ -81,7 +82,7 @@ {- Files that are checked into the index or have been committed to a  - branch. -} inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b]+inRepoOrBranch b = inRepo' [Param $ "--with-tree=" ++ fromRef b]  {- Scans for files at the specified locations that are not checked into git. -} notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)@@ -189,21 +190,21 @@  - contents. -} stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' ps l repo = guardSafeForLsFiles repo $ do-	(ls, cleanup) <- pipeNullSplit params repo+	(ls, cleanup) <- pipeNullSplit' params repo 	return (map parseStagedDetails ls, cleanup)   where 	params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++  		Param "--" : map (File . fromRawFilePath) l -parseStagedDetails :: L.ByteString -> StagedDetails+parseStagedDetails :: S.ByteString -> StagedDetails parseStagedDetails s-	| null file = (L.toStrict s, Nothing, Nothing)-	| otherwise = (toRawFilePath file, extractSha sha, readmode mode)+	| S.null file = (s, Nothing, Nothing)+	| otherwise = (file, extractSha sha, readmode mode)   where-	(metadata, file) = separate (== '\t') (decodeBL' s)-	(mode, metadata') = separate (== ' ') metadata-	(sha, _) = separate (== ' ') metadata'-	readmode = fst <$$> headMaybe . readOct+	(metadata, file) = separate' (== fromIntegral (ord '\t')) s+	(mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata+	(sha, _) = separate' (== fromIntegral (ord ' ')) metadata'+	readmode = fst <$$> headMaybe . readOct . decodeBS'  {- Returns a list of the files in the specified locations that are staged  - for commit, and whose type has changed. -}@@ -284,7 +285,7 @@ 				then Nothing 				else do 					treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)-					sha <- extractSha rawsha+					sha <- extractSha (encodeBS' rawsha) 					return $ InternalUnmerged (stage == 2) (toRawFilePath file) 						(Just treeitemtype) (Just sha) 		_ -> Nothing
Git/LsTree.hs view
@@ -96,7 +96,7 @@ 	<*> A8.takeTill (== ' ') 	<* A8.char ' ' 	-- sha-	<*> (Ref . decodeBS' <$> A8.takeTill (== '\t'))+	<*> (Ref <$> A8.takeTill (== '\t')) 	<* A8.char '\t' 	-- file 	<*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)
Git/Objects.hs view
@@ -26,7 +26,7 @@  listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas r = catchDefaultIO [] $-	mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories)+	mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories) 		<$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r)  looseObjectFile :: Repo -> Sha -> FilePath
Git/Ref.hs view
@@ -17,6 +17,7 @@  import Data.Char (chr, ord) import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8  headRef :: Ref headRef = Ref "HEAD"@@ -25,7 +26,7 @@ headFile r = fromRawFilePath (localGitDir r) </> "HEAD"  setHeadRef :: Ref -> Repo -> IO ()-setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref)+setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref)  {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String@@ -41,10 +42,11 @@ {- Removes a directory such as "refs/heads/master" from a  - fully qualified ref. Any ref not starting with it is left as-is. -} removeBase :: String -> Ref -> Ref-removeBase dir (Ref r)-	| prefix `isPrefixOf` r = Ref (drop (length prefix) r)-	| otherwise = Ref r+removeBase dir r+	| prefix `isPrefixOf` rs = Ref $ encodeBS $ drop (length prefix) rs+	| otherwise = r   where+	rs = fromRef r 	prefix = case end dir of 		['/'] -> dir 		_ -> dir ++ "/"@@ -53,7 +55,7 @@  - refs/heads/master, yields a version of that ref under the directory,  - such as refs/remotes/origin/master. -} underBase :: String -> Ref -> Ref-underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)+underBase dir r = Ref $ encodeBS dir <> "/" <> fromRef' (base r)  {- Convert a branch such as "master" into a fully qualified ref. -} branchRef :: Branch -> Ref@@ -66,21 +68,25 @@  - of a repo.  -} fileRef :: RawFilePath -> Ref-fileRef f = Ref $ ":./" ++ fromRawFilePath f+fileRef f = Ref $ ":./" <> f  {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref-dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d+dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d  {- A Ref that can be used to refer to a file in the repository as it  - appears in a given Ref. -} fileFromRef :: Ref -> RawFilePath -> Ref-fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)+fileFromRef r f = let (Ref fr) = fileRef f in Ref (fromRef' r <> fr)  {- Checks if a ref exists. -} exists :: Ref -> Repo -> IO Bool exists ref = runBool-	[Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]+	[ Param "show-ref"+	, Param "--verify"+	, Param "-q"+	, Param $ fromRef ref+	]  {- The file used to record a ref. (Git also stores some refs in a  - packed-refs file.) -}@@ -107,26 +113,26 @@ 		] 	process s 		| S.null s = Nothing-		| otherwise = Just $ Ref $ decodeBS' $ firstLine' s+		| otherwise = Just $ Ref $ firstLine' s  headSha :: Repo -> IO (Maybe Sha) headSha = sha headRef  {- List of (shas, branches) matching a given ref or refs. -} matching :: [Ref] -> Repo -> IO [(Sha, Branch)]-matching refs repo =  matching' (map fromRef refs) repo+matching = matching' []  {- Includes HEAD in the output, if asked for it. -} matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]-matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo+matchingWithHEAD = matching' [Param "--head"] -{- List of (shas, branches) matching a given ref spec. -}-matching' :: [String] -> Repo -> IO [(Sha, Branch)]-matching' ps repo = map gen . lines . decodeBS' <$> -	pipeReadStrict (Param "show-ref" : map Param ps) repo+matching' :: [CommandParam] -> [Ref] -> Repo -> IO [(Sha, Branch)]+matching' ps rs repo = map gen . S8.lines <$> +	pipeReadStrict (Param "show-ref" : ps ++ rps) repo   where-	gen l = let (r, b) = separate (== ' ') l+	gen l = let (r, b) = separate' (== fromIntegral (ord ' ')) l 		in (Ref r, Ref b)+	rps = map (Param . fromRef) rs  {- List of (shas, branches) matching a given ref.  - Duplicate shas are filtered out. -}@@ -137,7 +143,7 @@  {- List of all refs. -} list :: Repo -> IO [(Sha, Ref)]-list = matching' []+list = matching' [] []  {- Deletes a ref. This can delete refs that are not branches,   - which git branch --delete refuses to delete. -}@@ -154,13 +160,17 @@  - The ref may be something like a branch name, and it could contain  - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha)-tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict-	[ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ]+tree (Ref ref) = extractSha <$$> pipeReadStrict+	[ Param "rev-parse"+	, Param "--verify"+	, Param "--quiet"+	, Param (decodeBS' ref')+	]   where-	ref' = if ":" `isInfixOf` ref+	ref' = if ":" `S.isInfixOf` ref 		then ref 		-- de-reference commit objects to the tree-		else ref ++ ":"+		else ref <> ":"  {- Checks if a String is a legal git ref name.  -
Git/RefLog.hs view
@@ -12,6 +12,9 @@ import Git.Command import Git.Sha +import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+ {- Gets the reflog for a given branch. -} get :: Branch -> Repo -> IO [Sha] get b = getMulti [b]@@ -21,7 +24,7 @@ getMulti bs = get' (map (Param . fromRef) bs)  get' :: [CommandParam] -> Repo -> IO [Sha]-get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps'+get' ps = mapMaybe (extractSha . S.copy) . S8.lines <$$> pipeReadStrict ps'   where 	ps' = catMaybes 		[ Just $ Param "log"
Git/Remote.hs view
@@ -84,12 +84,17 @@ 	  where 		replacement = decodeBS' $ S.drop (S.length prefix) $ 			S.take (S.length bestkey - S.length suffix) bestkey-		(ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs+		(bestkey, bestvalue) = +			case maximumBy longestvalue insteadofs of+				(ConfigKey k, ConfigValue v) -> (k, v)+				(ConfigKey k, NoConfigValue) -> (k, mempty) 		longestvalue (_, a) (_, b) = compare b a-		insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) -> -			prefix `S.isPrefixOf` k &&-			suffix `S.isSuffixOf` k &&-			v `S.isPrefixOf` encodeBS l+		insteadofs = filterconfig $ \case+			(ConfigKey k, ConfigValue v) -> +				prefix `S.isPrefixOf` k &&+				suffix `S.isSuffixOf` k &&+				v `S.isPrefixOf` encodeBS l+			(_, NoConfigValue) -> False 		filterconfig f = filter f $ 			concatMap splitconfigs $ M.toList $ fullconfig repo 		splitconfigs (k, vs) = map (\v -> (k, v)) vs
Git/Repair.hs view
@@ -232,7 +232,7 @@ getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do 	let topsegs = length (splitPath refdir) - 1-	let toref = Ref . joinPath . drop topsegs . splitPath+	let toref = Ref . encodeBS' . joinPath . drop topsegs . splitPath 	map toref <$> dirContentsRecursive refdir  explodePackedRefsFile :: Repo -> IO ()@@ -257,8 +257,8 @@ parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of 	(sha:ref:[])-		| isJust (extractSha sha) && Ref.legal True ref ->-			Just (Ref sha, Ref ref)+		| isJust (extractSha (encodeBS' sha)) && Ref.legal True ref ->+			Just (Ref (encodeBS' sha), Ref (encodeBS' ref)) 	_ -> Nothing  {- git-branch -d cannot be used to remove a branch that is directly@@ -279,13 +279,13 @@ 	if ok 		then return (Just branch, goodcommits') 		else do-			(ls, cleanup) <- pipeNullSplit+			(ls, cleanup) <- pipeNullSplit' 				[ Param "log" 				, Param "-z" 				, Param "--format=%H" 				, Param (fromRef branch) 				] r-			let branchshas = catMaybes $ map (extractSha . decodeBL) ls+			let branchshas = catMaybes $ map extractSha ls 			reflogshas <- RefLog.get branch r 			-- XXX Could try a bit harder here, and look 			-- for uncorrupted old commits in branches in the@@ -328,8 +328,8 @@   where 	parse l = case words l of 		(commitsha:treesha:[]) -> (,)-			<$> extractSha commitsha-			<*> extractSha treesha+			<$> extractSha (encodeBS' commitsha)+			<*> extractSha (encodeBS' treesha) 		_ -> Nothing 	check [] = return True 	check ((c, t):rest)@@ -448,7 +448,8 @@ 		void $ tryIO $ allowWrite f   where 	headfile = fromRawFilePath (localGitDir g) </> "HEAD"-	validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)+	validhead s = "ref: refs/" `isPrefixOf` s+		|| isJust (extractSha (encodeBS' s))  {- Put it all together. -} runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch])
Git/Sha.hs view
@@ -5,31 +5,43 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Git.Sha where  import Common import Git.Types +import qualified Data.ByteString as S+import Data.Char+ {- Runs an action that causes a git subcommand to emit a Sha, and strips  - any trailing newline, returning the sha. -}-getSha :: String -> IO String -> IO Sha+getSha :: String -> IO S.ByteString -> IO Sha getSha subcommand a = maybe bad return =<< extractSha <$> a   where 	bad = error $ "failed to read sha from git " ++ subcommand -{- Extracts the Sha from a string. There can be a trailing newline after- - it, but nothing else. -}-extractSha :: String -> Maybe Sha+{- Extracts the Sha from a ByteString. + -+ - There can be a trailing newline after it, but nothing else.+ -}+extractSha :: S.ByteString -> Maybe Sha extractSha s 	| len `elem` shaSizes = val s-	| len - 1 `elem` shaSizes && length s' == len - 1 = val s'+	| len - 1 `elem` shaSizes && S.length s' == len - 1 = val s' 	| otherwise = Nothing   where-	len = length s-	s' = firstLine s+	len = S.length s+	s' = firstLine' s 	val v-		| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v+		| S.all validinsha v = Just $ Ref v 		| otherwise = Nothing+	validinsha w = or+		[ w >= 48 && w <= 57 -- 0-9+		, w >= 97 && w <= 102 -- a-f+		, w >= 65 && w <= 70 -- A-F+		]  {- Sizes of git shas. -} shaSizes :: [Int]@@ -41,7 +53,9 @@ {- Git plumbing often uses a all 0 sha to represent things like a  - deleted file. -} nullShas :: [Sha]-nullShas = map (\n -> Ref (replicate n '0')) shaSizes+nullShas = map (\n -> Ref (S.replicate n zero)) shaSizes+  where+	zero = fromIntegral (ord '0')  {- Sha to provide to git plumbing when deleting a file.  -
Git/Tree.hs view
@@ -38,6 +38,7 @@ import Control.Monad.IO.Class import qualified Data.Set as S import qualified Data.Map as M+import qualified Data.ByteString.Char8 as S8  newtype Tree = Tree [TreeContent] 	deriving (Show)@@ -106,7 +107,7 @@ 			NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree" 			TreeCommit f fm s -> mkTreeOutput fm CommitObject s f 		hPutStr h "\NUL" -- signal end of tree to --batch-	receive h = getSha "mktree" (hGetLine h)+	receive h = getSha "mktree" (S8.hGetLine h)  treeMode :: FileMode treeMode = 0o040000
Git/Types.hs view
@@ -1,12 +1,11 @@ {- git data types  -- - Copyright 2010-2019 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Git.Types where @@ -18,6 +17,8 @@ import System.Posix.Types import Utility.SafeCommand import Utility.FileSystemEncoding+import qualified Data.Semigroup as Sem+import Prelude  {- Support repositories on local disk, and repositories accessed via an URL.  -@@ -54,9 +55,21 @@ newtype ConfigKey = ConfigKey S.ByteString 	deriving (Ord, Eq) -newtype ConfigValue = ConfigValue S.ByteString-	deriving (Ord, Eq, Semigroup, Monoid)+data ConfigValue+	= ConfigValue S.ByteString+	| NoConfigValue+	-- ^ git treats a setting with no value as different than a setting+	-- with an empty value+	deriving (Ord, Eq) +instance Sem.Semigroup ConfigValue where+	ConfigValue a <> ConfigValue b = ConfigValue (a <> b)+	a <> NoConfigValue = a+	NoConfigValue <> b = b++instance Monoid ConfigValue where+	mempty = ConfigValue mempty+ instance Default ConfigValue where 	def = ConfigValue mempty @@ -68,6 +81,7 @@  fromConfigValue :: ConfigValue -> String fromConfigValue (ConfigValue s) = decodeBS' s+fromConfigValue NoConfigValue = mempty  instance Show ConfigValue where 	show = fromConfigValue@@ -81,12 +95,15 @@ type RemoteName = String  {- A git ref. Can be a sha1, or a branch or tag name. -}-newtype Ref = Ref String+newtype Ref = Ref S.ByteString 	deriving (Eq, Ord, Read, Show)  fromRef :: Ref -> String-fromRef (Ref s) = s+fromRef = decodeBS' . fromRef' +fromRef' :: Ref -> S.ByteString+fromRef' (Ref s) = s+ {- Aliases for Ref. -} type Branch = Ref type Sha = Ref@@ -98,6 +115,7 @@  {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject+	deriving (Show)  readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject
Git/UnionMerge.hs view
@@ -10,8 +10,10 @@ 	mergeIndex ) where +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Char8 as S8 import qualified Data.Set as S  import Common@@ -54,13 +56,13 @@  {- For merging two trees. -} mergeTrees :: Ref -> Ref -> HashObjectHandle -> CatFileHandle -> Repo -> Streamer-mergeTrees (Ref x) (Ref y) hashhandle ch = doMerge hashhandle ch-	("diff-tree":diffOpts ++ [x, y, "--"])+mergeTrees x y hashhandle ch = doMerge hashhandle ch+	("diff-tree":diffOpts ++ [fromRef x, fromRef y, "--"])  {- For merging a single tree into the index. -} mergeTreeIndex :: Ref -> HashObjectHandle -> CatFileHandle -> Repo -> Streamer-mergeTreeIndex (Ref r) hashhandle ch = doMerge hashhandle ch $-	"diff-index" : diffOpts ++ ["--cached", r, "--"]+mergeTreeIndex r hashhandle ch = doMerge hashhandle ch $+	"diff-index" : diffOpts ++ ["--cached", fromRef r, "--"]  diffOpts :: [String] diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"]@@ -69,27 +71,29 @@  - using git to get a raw diff. -} doMerge :: HashObjectHandle -> CatFileHandle -> [String] -> Repo -> Streamer doMerge hashhandle ch differ repo streamer = do-	(diff, cleanup) <- pipeNullSplit (map Param differ) repo+	(diff, cleanup) <- pipeNullSplit' (map Param differ) repo 	go diff 	void $ cleanup   where 	go [] = noop-	go (info:file:rest) = mergeFile (decodeBL' info) (L.toStrict file) hashhandle ch >>=+	go (info:file:rest) = mergeFile info file hashhandle ch >>= 		maybe (go rest) (\l -> streamer l >> go rest) 	go (_:[]) = error $ "parse error " ++ show differ  {- Given an info line from a git raw diff, and the filename, generates  - a line suitable for update-index that union merges the two sides of the  - diff. -}-mergeFile :: String -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString)-mergeFile info file hashhandle h = case filter (`notElem` nullShas) [Ref asha, Ref bsha] of-	[] -> return Nothing-	(sha:[]) -> use sha-	shas -> use-		=<< either return (hashBlob hashhandle . L8.unlines)-		=<< calcMerge . zip shas <$> mapM getcontents shas+mergeFile :: S.ByteString -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString)+mergeFile info file hashhandle h = case S8.words info of+	[_colonmode, _bmode, asha, bsha, _status] -> +		case filter (`notElem` nullShas) [Ref asha, Ref bsha] of+		[] -> return Nothing+		(sha:[]) -> use sha+		shas -> use+			=<< either return (hashBlob hashhandle . L8.unlines)+			=<< calcMerge . zip shas <$> mapM getcontents shas+	_ -> return Nothing   where-	[_colonmode, _bmode, asha, bsha, _status] = words info 	use sha = return $ Just $ 		updateIndexLine sha TreeFile $ asTopFilePath file 	-- Get file and split into lines to union merge.
Git/UpdateIndex.hs view
@@ -75,14 +75,14 @@ 	mapM_ streamer s 	void $ cleanup   where-	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]+	params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x] lsSubTree :: Ref -> FilePath -> Repo -> Streamer lsSubTree (Ref x) p repo streamer = do 	(s, cleanup) <- pipeNullSplit params repo 	mapM_ streamer s 	void $ cleanup   where-	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p]+	params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x, p]  {- Generates a line suitable to be fed into update-index, to add  - a given file with a given sha. -}@@ -90,7 +90,7 @@ updateIndexLine sha treeitemtype file = L.fromStrict $ 	fmtTreeItemType treeitemtype 	<> " blob "-	<> encodeBS (fromRef sha)+	<> fromRef' sha 	<> "\t" 	<> indexPath file @@ -108,7 +108,7 @@ unstageFile' :: TopFilePath -> Streamer unstageFile' p = pureStreamer $ L.fromStrict $ 	"0 "-	<> encodeBS' (fromRef deleteSha)+	<> fromRef' deleteSha 	<> "\t" 	<> indexPath p
Logs/Config.hs view
@@ -55,6 +55,7 @@   where 	configkeybuilder (ConfigKey k) = byteString k 	valuebuilder (ConfigValue v) = byteString v+	valuebuilder NoConfigValue = mempty  parseGlobalConfig :: L.ByteString -> MapLog ConfigKey ConfigValue parseGlobalConfig = parseMapLog configkeyparser valueparser@@ -63,7 +64,10 @@ 	valueparser = ConfigValue <$> A.takeByteString  loadGlobalConfig :: Annex (M.Map ConfigKey ConfigValue)-loadGlobalConfig = M.filter (\(ConfigValue v) -> not (S.null v)) +loadGlobalConfig = M.filter nonempty  	. simpleMap 	. parseGlobalConfig 	<$> Annex.Branch.get configLog+  where+	nonempty (ConfigValue v) = not (S.null v)+	nonempty NoConfigValue = True
Logs/Export.hs view
@@ -158,12 +158,12 @@   where 	go [] = mempty 	go (r:rs) = rref r <> mconcat [ charUtf8 ' ' <> rref r' | r' <- rs ]-	rref r = byteString (encodeBS' (Git.fromRef r))+	rref = byteString . Git.fromRef'  exportedParser :: A.Parser Exported exportedParser = Exported <$> refparser <*> many refparser   where-	refparser = (Git.Ref . decodeBS <$> A8.takeWhile1 (/= ' ') )+	refparser = (Git.Ref <$> A8.takeWhile1 (/= ' ') ) 		<* ((const () <$> A8.char ' ') <|> A.endOfInput)  logExportExcluded :: UUID -> ((Git.Tree.TreeItem -> IO ()) -> Annex a) -> Annex a
Logs/FsckResults.hs view
@@ -43,7 +43,7 @@ 	deserialize ("truncated":ls) = deserialize' ls True 	deserialize ls = deserialize' ls False 	deserialize' ls t =-		let s = S.fromList $ map Ref ls+		let s = S.fromList $ map (Ref . encodeBS') ls 		in if S.null s then FsckFailed else FsckFoundMissing s t  clearFsckResults :: UUID -> Annex ()
Logs/PreferredContent.hs view
@@ -92,8 +92,9 @@ 		in simpleMap 			. parseLogOldWithUUID (\u -> mk u . decodeBS <$> A.takeByteString) 			<$> Annex.Branch.get l-	pc <- genmap preferredContentLog =<< groupPreferredContentMapRaw-	rc <- genmap requiredContentLog M.empty+	gm <- groupPreferredContentMapRaw+	pc <- genmap preferredContentLog gm+	rc <- genmap requiredContentLog gm 	-- Required content is implicitly also preferred content, so combine. 	let pc' = M.unionWith combiner pc rc 	return (pc', rc)
Logs/Transfer.hs view
@@ -143,12 +143,12 @@ 	transfers <- filter (wanted . transferKey) 		<$> mapMaybe parseTransferFile . concat <$> findfiles 	infos <- mapM checkTransfer transfers-	return $ map (\(t, Just i) -> (t, i)) $-		filter running $ zip transfers infos+	return $ mapMaybe running $ zip transfers infos   where 	findfiles = liftIO . mapM dirContentsRecursive 		=<< mapM (fromRepo . transferDir) dirs-	running (_, i) = isJust i+	running (t, Just i) = Just (t, i)+	running (_, Nothing) = Nothing  {- Number of bytes remaining to download from matching downloads that are in  - progress. -}
Logs/View.hs view
@@ -9,6 +9,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Logs.View ( 	currentView, 	setView,@@ -31,6 +33,7 @@ import qualified Data.Text as T import qualified Data.Set as S import Data.Char+import qualified Data.ByteString as B  setView :: View -> Annex () setView v = do@@ -54,11 +57,11 @@ currentView :: Annex (Maybe View) currentView = go =<< inRepo Git.Branch.current   where-	go (Just b) | branchViewPrefix `isPrefixOf` fromRef b =+	go (Just b) | branchViewPrefix `B.isPrefixOf` fromRef' b = 		headMaybe . filter (\v -> branchView v == b) <$> recentViews 	go _ = return Nothing -branchViewPrefix :: String+branchViewPrefix :: B.ByteString branchViewPrefix = "refs/heads/views"  {- Generates a git branch name for a View.@@ -68,10 +71,11 @@  -} branchView :: View -> Git.Branch branchView view-	| null name = Git.Ref branchViewPrefix-	| otherwise = Git.Ref $ branchViewPrefix ++ "/" ++ name+	| B.null name = Git.Ref branchViewPrefix+	| otherwise = Git.Ref $ branchViewPrefix <> "/" <> name   where-	name = intercalate ";" $ map branchcomp (viewComponents view)+	name = encodeBS' $+		intercalate ";" $ map branchcomp (viewComponents view) 	branchcomp c 		| viewVisible c = branchcomp' c 		| otherwise = "(" ++ branchcomp' c ++ ")"@@ -92,7 +96,7 @@ is_branchView :: Git.Branch -> Bool is_branchView (Ref b) 	| b == branchViewPrefix = True-	| otherwise = (branchViewPrefix ++ "/") `isPrefixOf` b+	| otherwise = (branchViewPrefix <> "/") `B.isPrefixOf` b  prop_branchView_legal :: View -> Bool prop_branchView_legal = Git.Ref.legal False . fromRef . branchView
Logs/Web.hs view
@@ -90,7 +90,7 @@ 	{- Ensure the git-annex branch's index file is up-to-date and 	 - any journaled changes are reflected in it, since we're going 	 - to query its index directly. -}-	Annex.Branch.update+	_ <- Annex.Branch.update 	Annex.Branch.commit =<< Annex.Branch.commitMessage 	Annex.Branch.withIndex $ do 		top <- fromRepo Git.repoPath
Messages/JSON.hs view
@@ -65,9 +65,11 @@ none = id  start :: String -> Maybe RawFilePath -> Maybe Key -> JSONBuilder-start command file key _ = Just (o, False)+start command file key _ = case j of+	Object o -> Just (o, False)+	_ -> Nothing   where-	Object o = toJSON' $ JSONActionItem+	j = toJSON' $ JSONActionItem 		{ itemCommand = Just command 		, itemKey = key 		, itemFile = fromRawFilePath <$> file@@ -102,18 +104,22 @@ 	combinelines new _old = new  info :: String -> JSONBuilder-info s _ = Just (o, True)+info s _ = case j of+	Object o -> Just (o, True)+	_ -> Nothing   where-	Object o = object ["info" .= toJSON' s]+	j = object ["info" .= toJSON' s]  data JSONChunk v where 	AesonObject :: Object -> JSONChunk Object 	JSONChunk :: ToJSON' v => [(String, v)] -> JSONChunk [(String, v)]  add :: JSONChunk v -> JSONBuilder-add v (Just (o, e)) = Just (HM.union o' o, e)+add v (Just (o, e)) = case j of+	Object o' -> Just (HM.union o' o, e)+	_ -> Nothing   where-	Object o' = case v of+	j = case v of 		AesonObject ao -> Object ao 		JSONChunk l -> object $ map mkPair l 	mkPair (s, d) = (packString s, toJSON' d)@@ -125,12 +131,15 @@ -- Show JSON formatted progress, including the current state of the JSON  -- object for the action being performed. 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+progress maction msize bytesprocessed = +	case j of+		Object o -> emit $ case maction of+			Just action -> HM.insert "action" (Object action) o+			Nothing -> o+		_ -> return ()   where 	n = fromBytesProcessed bytesprocessed :: Integer-	Object o = case msize of+	j = case msize of 		Just size -> object 			[ "byte-progress" .= n 			, "percent-progress" .= showPercentage 2 (percentage size n)
Remote/Adb.hs view
@@ -128,12 +128,12 @@ 		(giveup "Specify androiddirectory=") 		(pure . AndroidPath . fromProposedAccepted) 		(M.lookup androiddirectoryField c)-	serial <- getserial =<< liftIO enumerateAdbConnected+	serial <- getserial =<< enumerateAdbConnected 	let c' = M.insert androidserialField (Proposed (fromAndroidSerial serial)) c  	(c'', _encsetup) <- encryptionSetup c' gc -	ok <- liftIO $ adbShellBool serial+	ok <- adbShellBool serial 		[Param "mkdir", Param "-p", File (fromAndroidPath adir)] 	unless ok $ 		giveup "Creating directory on Android device failed."@@ -166,15 +166,15 @@ store' serial dest src = store'' serial dest src (return True)  store'' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool -> Annex Bool-store'' serial dest src canoverwrite = do+store'' serial dest src canoverwrite = checkAdbInPath False $ do 	let destdir = takeDirectory $ fromAndroidPath dest-	liftIO $ void $ adbShell serial [Param "mkdir", Param "-p", File destdir]+	void $ adbShell serial [Param "mkdir", Param "-p", File destdir] 	showOutput -- make way for adb push output 	let tmpdest = fromAndroidPath dest ++ ".annextmp" 	ifM (liftIO $ boolSystem "adb" (mkAdbCommand serial [Param "push", File src, File tmpdest])) 		( ifM canoverwrite 			-- move into place atomically-			( liftIO $ adbShellBool serial [Param "mv", File tmpdest, File (fromAndroidPath dest)]+			( adbShellBool serial [Param "mv", File tmpdest, File (fromAndroidPath dest)] 			, do 				void $ remove' serial (AndroidPath tmpdest) 				return False@@ -189,7 +189,7 @@ 		giveup "adb pull failed"  retrieve' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool-retrieve' serial src dest = do+retrieve' serial src dest = checkAdbInPath False $ do 	showOutput -- make way for adb pull output 	liftIO $ boolSystem "adb" $ mkAdbCommand serial 		[ Param "pull"@@ -201,7 +201,7 @@ remove serial adir k = remove' serial (androidLocation adir k)  remove' :: AndroidSerial -> AndroidPath -> Annex Bool-remove' serial aloc = liftIO $ adbShellBool serial+remove' serial aloc = adbShellBool serial 	[Param "rm", Param "-f", File (fromAndroidPath aloc)]  checkKey :: Remote -> AndroidSerial -> AndroidPath -> CheckPresent@@ -210,7 +210,7 @@ checkKey' :: Remote -> AndroidSerial -> AndroidPath -> Annex Bool checkKey' r serial aloc = do 	showChecking r-	out <- liftIO $ adbShellRaw serial $ unwords+	out <- adbShellRaw serial $ unwords 		[ "if test -e ", shellEscape (fromAndroidPath aloc) 		, "; then echo y" 		, "; else echo n"@@ -247,7 +247,7 @@ 	aloc = androidExportLocation adir loc  removeExportDirectoryM :: AndroidSerial -> AndroidPath -> ExportDirectory -> Annex Bool-removeExportDirectoryM serial abase dir = liftIO $ adbShellBool serial+removeExportDirectoryM serial abase dir = adbShellBool serial 	[Param "rm", Param "-rf", File (fromAndroidPath adir)]   where 	adir = androidExportLocation abase (mkExportLocation (fromExportDirectory dir))@@ -258,14 +258,19 @@ 	aloc = androidExportLocation adir loc  renameExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)-renameExportM serial adir _k old new = liftIO $ Just <$> -	adbShellBool serial [Param "mv", Param "-f", File oldloc, File newloc]+renameExportM serial adir _k old new = Just <$> adbShellBool serial ps   where 	oldloc = fromAndroidPath $ androidExportLocation adir old 	newloc = fromAndroidPath $ androidExportLocation adir new+	ps =+		[ Param "mv"+		, Param "-f"+		, File oldloc+		, File newloc+		]  listImportableContentsM :: AndroidSerial -> AndroidPath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))-listImportableContentsM serial adir = liftIO $+listImportableContentsM serial adir = 	process <$> adbShell serial 		[ Param "find" 		-- trailing slash is needed, or android's find command@@ -300,7 +305,7 @@ 	ifM (retrieve' serial src dest) 		( do 			k <- mkkey-			currcid <- liftIO $ getExportContentIdentifier serial adir loc+			currcid <- getExportContentIdentifier serial adir loc 			return $ if currcid == Right (Just cid) 				then k 				else Nothing@@ -315,7 +320,7 @@ 	-- file is expensive and don't want to do it unncessarily. 	ifM checkcanoverwrite 		( ifM (store'' serial dest src checkcanoverwrite)-			( liftIO $ getExportContentIdentifier serial adir loc >>= return . \case+			( getExportContentIdentifier serial adir loc >>= return . \case 				Right (Just cid) -> Right cid 				Right Nothing -> Left "adb failed to store file" 				Left _ -> Left "unable to get content identifier for file stored on adtb"@@ -325,7 +330,7 @@ 		)   where 	dest = androidExportLocation adir loc-	checkcanoverwrite = liftIO $+	checkcanoverwrite = 		getExportContentIdentifier serial adir loc >>= return . \case 			Right (Just cid) | cid `elem` overwritablecids -> True 			Right Nothing -> True@@ -333,7 +338,7 @@  removeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool removeExportWithContentIdentifierM serial adir k loc removeablecids = catchBoolIO $-	liftIO (getExportContentIdentifier serial adir loc) >>= \case+	getExportContentIdentifier serial adir loc >>= \case 		Right Nothing -> return True 		Right (Just cid) | cid `elem` removeablecids -> 			removeExportM serial adir k loc@@ -341,7 +346,7 @@  checkPresentExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierM serial adir _k loc knowncids = -	liftIO $ getExportContentIdentifier serial adir loc >>= \case+	getExportContentIdentifier serial adir loc >>= \case 		Right (Just cid) | cid `elem` knowncids -> return True 		Right _ -> return False 		Left _ -> giveup "unable to access Android device"@@ -351,8 +356,8 @@ 	fromAndroidPath adir ++ "/" ++ fromRawFilePath (fromExportLocation loc)  -- | List all connected Android devices.-enumerateAdbConnected :: IO [AndroidSerial]-enumerateAdbConnected = +enumerateAdbConnected :: Annex [AndroidSerial]+enumerateAdbConnected = checkAdbInPath [] $ liftIO $ 	mapMaybe parse . lines <$> readProcess "adb" ["devices"]   where 	parse l = @@ -364,11 +369,11 @@ -- | Runs a command on the android device with the given serial number. -- -- Any stdout from the command is returned, separated into lines.-adbShell :: AndroidSerial -> [CommandParam] -> IO (Maybe [String])+adbShell :: AndroidSerial -> [CommandParam] -> Annex (Maybe [String]) adbShell serial cmd = adbShellRaw serial $ 	unwords $ map shellEscape (toCommand cmd) -adbShellBool :: AndroidSerial -> [CommandParam] -> IO Bool+adbShellBool :: AndroidSerial -> [CommandParam] -> Annex Bool adbShellBool serial cmd = 	adbShellRaw serial cmd' >>= return . \case 		Just l -> end l == ["y"]@@ -379,8 +384,8 @@  -- | Runs a raw shell command on the android device. -- Any necessary shellEscaping must be done by caller.-adbShellRaw :: AndroidSerial -> String -> IO (Maybe [String])-adbShellRaw serial cmd = catchMaybeIO $ +adbShellRaw :: AndroidSerial -> String -> Annex (Maybe [String])+adbShellRaw serial cmd = checkAdbInPath Nothing $ liftIO $ catchMaybeIO $  	processoutput <$> readProcess "adb" 		[ "-s" 		, fromAndroidSerial serial@@ -393,13 +398,21 @@ 	-- despite both linux and android being unix systems. 	trimcr = takeWhile (/= '\r') +checkAdbInPath :: a -> Annex a -> Annex a+checkAdbInPath d a = ifM (isJust <$> liftIO (searchPath "adb"))+	( a+	, do+		warning "adb command not found in PATH. Install it to use this remote."+		return d+	)+ mkAdbCommand :: AndroidSerial -> [CommandParam] -> [CommandParam] mkAdbCommand serial cmd = [Param "-s", Param (fromAndroidSerial serial)] ++ cmd  -- Gets the current content identifier for a file on the android device. -- If the file is not present, returns Right Nothing-getExportContentIdentifier :: AndroidSerial -> AndroidPath -> ExportLocation -> IO (Either ExitCode (Maybe ContentIdentifier))-getExportContentIdentifier serial adir loc = liftIO $ do+getExportContentIdentifier :: AndroidSerial -> AndroidPath -> ExportLocation -> Annex (Either ExitCode (Maybe ContentIdentifier))+getExportContentIdentifier serial adir loc = do 	ls <- adbShellRaw serial $ unwords 		[ "if test -e ", shellEscape aloc 		, "; then stat -c"
Remote/Bup.hs view
@@ -223,8 +223,10 @@ 					giveup "ssh failed" 		else liftIO $ do 			r' <- Git.Config.read r-			let ConfigValue olduuid = Git.Config.get configkeyUUID mempty r'-			when (S.null olduuid) $+			let noolduuid = case Git.Config.get configkeyUUID mempty r' of+				ConfigValue olduuid -> S.null olduuid+				NoConfigValue -> True+			when noolduuid $ 				Git.Command.run 					[ Param "config" 					, Param "annex.uuid"
Remote/External.hs view
@@ -65,7 +65,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs 	-- readonly mode only downloads urls; does not use external program-	| remoteAnnexReadOnly gc = do+	| externaltype == "readonly" = do 		c <- parsedRemoteConfig remote rc 		cst <- remoteCost gc expensiveRemoteCost 		mk c cst GloballyAvailable@@ -165,15 +165,22 @@ externalSetup _ mu _ c gc = do 	u <- maybe (liftIO genUUID) return mu 	pc <- either giveup return $ parseRemoteConfig c lenientRemoteConfigParser-	let externaltype = fromMaybe (giveup "Specify externaltype=") $-		getRemoteConfigValue externaltypeField pc+	let readonlyconfig = getRemoteConfigValue readonlyField pc == Just True+	let externaltype = if readonlyconfig+		then "readonly"+		else fromMaybe (giveup "Specify externaltype=") $+			getRemoteConfigValue externaltypeField pc 	(c', _encsetup) <- encryptionSetup c gc -	c'' <- case getRemoteConfigValue readonlyField pc of-		Just True -> do+	c'' <- if readonlyconfig+		then do+			-- Setting annex-readonly is not really necessary+			-- anymore, but older versions of git-annex used+			-- this, not externaltype=readonly, so still set+			-- it. 			setConfig (remoteAnnexConfig (fromJust (lookupName c)) "readonly") (boolConfig True) 			return c'-		_ -> do+		else do 			pc' <- either giveup return $ parseRemoteConfig c' lenientRemoteConfigParser 			external <- newExternal externaltype (Just u) pc' (Just gc) Nothing 			-- Now that we have an external, ask it to LISTCONFIGS, @@ -194,14 +201,16 @@ 			return (changes c')  	gitConfigSpecialRemote u c'' [("externaltype", externaltype)]-	return (c'', u)+	return (M.delete readonlyField c'', u)  checkExportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool checkExportSupported c gc = do 	let externaltype = fromMaybe (giveup "Specify externaltype=") $ 		remoteAnnexExternalType gc <|> getRemoteConfigValue externaltypeField c-	checkExportSupported' -		=<< newExternal externaltype Nothing c (Just gc) Nothing+	if externaltype == "readonly"+		then return False+		else checkExportSupported' +			=<< newExternal externaltype Nothing c (Just gc) Nothing  checkExportSupported' :: External -> Annex Bool checkExportSupported' external = go `catchNonAsync` (const (return False))@@ -649,7 +658,16 @@ 		giveup $ "Cannot run " ++ cmd ++ " -- Make sure it's executable and that its dependencies are installed." 	runerr Nothing _ = do 		path <- intercalate ":" <$> getSearchPath-		giveup $ "Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"+		let err = "Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"+		case (lookupName (unparsedRemoteConfig (externalDefaultConfig external)), remoteAnnexReadOnly <$> externalGitConfig external) of+			(Just rname, Just True) -> giveup $ unlines+				[ err+				, "This remote has annex-readonly=true, and previous versions of"+				, "git-annex would tried to download from it without"+				, "installing " ++ basecmd ++ ". If you want that, you need to set:"+				, "git config remote." ++ rname ++ ".annex-externaltype readonly"+				]+			_ -> giveup err  stopExternal :: External -> Annex () stopExternal external = liftIO $ do
Remote/GCrypt.hs view
@@ -474,7 +474,7 @@ 	| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> 		liftIO (catchMaybeIO $ Git.Config.read r) 	| not fast = extract . liftM fst3 <$> getM (eitherToMaybe <$>)-		[ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p), return (Left $ error "configlist failed")) "configlist" [] []+		[ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p Git.Config.ConfigList), return (Left $ error "configlist failed")) "configlist" [] [] 		, getConfigViaRsync r gc 		] 	| otherwise = return (Nothing, r)
Remote/Git.hs view
@@ -1,6 +1,6 @@ {- Standard git remotes.  -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -12,7 +12,7 @@ 	remote, 	configRead, 	repoAvail,-	onLocal,+	onLocalRepo, ) where  import Annex.Common@@ -249,7 +249,7 @@ 	| haveconfig r = return r -- already read 	| Git.repoIsSsh r = storeUpdatedRemote $ do 		v <- Ssh.onRemote NoConsumeStdin r-			(pipedconfig autoinit (Git.repoDescribe r), return (Left $ giveup "configlist failed"))+			(pipedconfig Git.Config.ConfigList autoinit (Git.repoDescribe r), return (Left $ giveup "configlist failed")) 			"configlist" [] configlistfields 		case v of 			Right r'@@ -264,8 +264,8 @@   where 	haveconfig = not . M.null . Git.config -	pipedconfig mustincludeuuuid configloc cmd params = do-		v <- liftIO $ Git.Config.fromPipe r cmd params+	pipedconfig st mustincludeuuuid configloc cmd params = do+		v <- liftIO $ Git.Config.fromPipe r cmd params st 		case v of 			Right (r', val, _err) -> do 				unless (isUUIDConfigured r' || S.null val || not mustincludeuuuid) $ do@@ -282,7 +282,7 @@ 			liftIO $ hClose h 			let url = Git.repoLocation r ++ "/config" 			ifM (liftIO $ Url.downloadQuiet nullMeterUpdate url tmpfile uo)-				( Just <$> pipedconfig False url "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]+				( Just <$> pipedconfig Git.Config.ConfigNullList False url "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] 				, return Nothing 				) 		case v of@@ -375,7 +375,7 @@ 	inAnnex' repo rmt st key  inAnnex' :: Git.Repo -> Remote -> State -> Key -> Annex Bool-inAnnex' repo rmt (State connpool duc _ _) key+inAnnex' repo rmt st@(State connpool duc _ _ _) key 	| Git.repoIsHttp repo = checkhttp 	| Git.repoIsUrl repo = checkremote 	| otherwise = checklocal@@ -393,7 +393,7 @@ 	checklocal = ifM duc 		( guardUsable repo (cantCheck repo) $ 			maybe (cantCheck repo) return-				=<< onLocalFast repo rmt (Annex.Content.inAnnexSafe key)+				=<< onLocalFast st (Annex.Content.inAnnexSafe key) 		, cantCheck repo 		) @@ -421,10 +421,10 @@ 		(\e -> warning (show e) >> return False)  dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex Bool-dropKey' repo r (State connpool duc _ _) key+dropKey' repo r st@(State connpool duc _ _ _) key 	| not $ Git.repoIsUrl repo = ifM duc 		( guardUsable repo (return False) $-			commitOnCleanup repo r $ onLocalFast repo r $ do+			commitOnCleanup repo r st $ onLocalFast st $ do 				whenM (Annex.Content.inAnnex key) $ do 					Annex.Content.lockContentForRemoval key $ \lock -> do 						Annex.Content.removeAnnex lock@@ -436,7 +436,7 @@ 	| Git.repoIsHttp repo = do 		warning "dropping from http remote not supported" 		return False-	| otherwise = commitOnCleanup repo r $ do+	| otherwise = commitOnCleanup repo r st $ do 		let fallback = Ssh.dropKey repo key 		P2PHelper.remove (Ssh.runProto r connpool (return False) fallback) key @@ -446,14 +446,14 @@ 	lockKey' repo r st key callback  lockKey' :: Git.Repo -> Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r-lockKey' repo r (State connpool duc _ _) key callback+lockKey' repo r st@(State connpool duc _ _ _) key callback 	| not $ Git.repoIsUrl repo = ifM duc 		( guardUsable repo failedlock $ do 			inorigrepo <- Annex.makeRunner 			-- Lock content from perspective of remote, 			-- and then run the callback in the original 			-- annex monad, not the remote's.-			onLocalFast repo r $ +			onLocalFast st $  				Annex.Content.lockContentShared key $ 					liftIO . inorigrepo . callback 		, failedlock@@ -514,7 +514,7 @@ 	copyFromRemote'' repo forcersync r st key file dest meterupdate  copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)-copyFromRemote'' repo forcersync r st@(State connpool _ _ _) key file dest meterupdate+copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest meterupdate 	| Git.repoIsHttp repo = unVerified $ do 		gc <- Annex.getGitConfig 		Url.withUrlOptionsPromptingCreds $@@ -524,10 +524,12 @@ 		u <- getUUID 		hardlink <- wantHardLink 		-- run copy from perspective of remote-		onLocalFast repo r $ do+		onLocalFast st $ do 			v <- Annex.Content.prepSendAnnex key 			case v of-				Nothing -> return (False, UnVerified)+				Nothing -> do+					warning "content is not present in remote"+					return (False, UnVerified) 				Just (object, checksuccess) -> do 					copier <- mkCopier hardlink st params 					runTransfer (Transfer Download u (fromKey id key))@@ -643,13 +645,13 @@ 	copyToRemote' repo r st key file meterupdate  copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool-copyToRemote' repo r st@(State connpool duc _ _) key file meterupdate+copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate 	| not $ Git.repoIsUrl repo = ifM duc-		( guardUsable repo (return False) $ commitOnCleanup repo r $+		( guardUsable repo (return False) $ commitOnCleanup repo r st $ 			copylocal =<< Annex.Content.prepSendAnnex key 		, return False 		)-	| Git.repoIsSsh repo = commitOnCleanup repo r $+	| Git.repoIsSsh repo = commitOnCleanup repo r st $ 		P2PHelper.store 			(\p -> Ssh.runProto r connpool (return False) (copyremotefallback p)) 			key file meterupdate@@ -668,7 +670,7 @@ 		u <- getUUID 		hardlink <- wantHardLink 		-- run copy from perspective of remote-		onLocalFast repo r $ ifM (Annex.Content.inAnnex key)+		onLocalFast st $ ifM (Annex.Content.inAnnex key) 			( return True 			, runTransfer (Transfer Download u (fromKey id key)) file stdRetry $ \p -> do 				copier <- mkCopier hardlink st params@@ -715,6 +717,13 @@ 		ensureInitialized 		a `finally` stopCoProcesses +data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar (Maybe Annex.AnnexState))++{- This can safely be called on a Repo that is not local, but of course+ - onLocal will not work if used with the result. -}+mkLocalRemoteAnnex :: Git.Repo -> Annex (LocalRemoteAnnex)+mkLocalRemoteAnnex repo = LocalRemoteAnnex repo <$> liftIO (newMVar Nothing)+ {- Runs an action from the perspective of a local remote.  -  - The AnnexState is cached for speed and to avoid resource leaks.@@ -724,23 +733,29 @@  - The remote will be automatically initialized/upgraded first,  - when possible.  -}-onLocal :: Git.Repo -> Remote -> Annex a -> Annex a-onLocal repo r a = do-	m <- Annex.getState Annex.remoteannexstate-	case M.lookup (uuid r) m of-		Nothing -> do-			st <- liftIO $ Annex.new repo-			go (st, ensureInitialized >> a)-		Just st -> go (st, a)+onLocal :: State -> Annex a -> Annex a+onLocal (State _ _ _ _ lra) = onLocal' lra++onLocalRepo :: Git.Repo -> Annex a -> Annex a+onLocalRepo repo a = do+	lra <- mkLocalRemoteAnnex repo+	onLocal' lra a++onLocal' :: LocalRemoteAnnex -> Annex a -> Annex a+onLocal' (LocalRemoteAnnex repo v) a = liftIO (takeMVar v) >>= \case+	Nothing -> do+		st <- liftIO $ Annex.new repo+		go (st, ensureInitialized >> a)+	Just st -> go (st, a)   where-	cache st = Annex.changeState $ \s -> s-		{ Annex.remoteannexstate = M.insert (uuid r) st (Annex.remoteannexstate s) } 	go (st, a') = do 		curro <- Annex.getState Annex.output-		(ret, st') <- liftIO $ Annex.run (st { Annex.output = curro }) $+		let act = Annex.run (st { Annex.output = curro }) $ 			a' `finally` stopCoProcesses-		cache st'+		(ret, st') <- liftIO $ act `onException` cache st+		liftIO $ cache st' 		return ret+	cache st = putMVar v (Just st)  {- Faster variant of onLocal.  -@@ -749,8 +764,8 @@  - it gets the most current value. Caller of onLocalFast can make changes  - to the branch, however.  -}-onLocalFast :: Git.Repo -> Remote -> Annex a -> Annex a-onLocalFast repo r a = onLocal repo r $ Annex.BranchState.disableUpdate >> a+onLocalFast :: State -> Annex a -> Annex a+onLocalFast st a = onLocal st $ Annex.BranchState.disableUpdate >> a  -- To avoid the overhead of trying copy-on-write every time, it's tried -- once and if it fails, is not tried again.@@ -784,7 +799,7 @@ 		)   where 	copycowtried = case st of-		State _ _ (CopyCoWTried v) _ -> v+		State _ _ (CopyCoWTried v) _ _ -> v 	dorsync = do 		-- dest may already exist, so make sure rsync can write to it 		void $ liftIO $ tryIO $ allowWrite dest@@ -796,12 +811,12 @@ 	docopywith a = liftIO $ watchFileSize dest p $ 		a CopyTimeStamps src dest -commitOnCleanup :: Git.Repo -> Remote -> Annex a -> Annex a-commitOnCleanup repo r a = go `after` a+commitOnCleanup :: Git.Repo -> Remote -> State -> Annex a -> Annex a+commitOnCleanup repo r st a = go `after` a   where 	go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup 	cleanup-		| not $ Git.repoIsUrl repo = onLocalFast repo r $+		| not $ Git.repoIsUrl repo = onLocalFast st $ 			doQuietSideAction $ 				Annex.Branch.commit =<< Annex.Branch.commitMessage 		| otherwise = void $ do@@ -857,23 +872,24 @@  - This returns False when the repository UUID is not as expected. -} type DeferredUUIDCheck = Annex Bool -data State = State Ssh.P2PSshConnectionPool DeferredUUIDCheck CopyCoWTried (Annex (Git.Repo, GitConfig))+data State = State Ssh.P2PSshConnectionPool DeferredUUIDCheck CopyCoWTried (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex  getRepoFromState :: State -> Annex Git.Repo-getRepoFromState (State _ _ _ a) = fst <$> a+getRepoFromState (State _ _ _ a _) = fst <$> a  #ifndef mingw32_HOST_OS {- The config of the remote git repository, cached for speed. -} getGitConfigFromState :: State -> Annex GitConfig-getGitConfigFromState (State _ _ _ a) = snd <$> a+getGitConfigFromState (State _ _ _ a _) = snd <$> a #endif  mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State mkState r u gc = do 	pool <- Ssh.mkP2PSshConnectionPool 	copycowtried <- liftIO newCopyCoWTried+	lra <- mkLocalRemoteAnnex r 	(duc, getrepo) <- go-	return $ State pool duc copycowtried getrepo+	return $ State pool duc copycowtried getrepo lra   where 	go 		| remoteAnnexCheckUUID gc = return
RemoteDaemon/Core.hs view
@@ -22,6 +22,7 @@ import Utility.ThreadScheduler import Config import Annex.Ssh+import Annex.BranchState import Types.Messages  import Control.Concurrent@@ -163,7 +164,9 @@ 	annexstate <- newMVar =<< Annex.new =<< Git.CurrentRepo.get 	g <- Annex.repo <$> readMVar annexstate 	let h = TransportHandle (LocalRepo g) annexstate-	liftAnnex h $ Annex.setOutput QuietOutput+	liftAnnex h $ do+		Annex.setOutput QuietOutput+		enableInteractiveJournalAccess 	return h  updateTransportHandle :: TransportHandle -> IO TransportHandle
Test.hs view
@@ -24,6 +24,7 @@ import qualified Data.Map as M import qualified Data.ByteString.Lazy.UTF8 as BU8 import System.Environment+import Control.Concurrent.STM hiding (check)  import Common import CmdLine.GitAnnex.Options@@ -65,6 +66,7 @@ import qualified Annex.View import qualified Annex.View.ViewedFile import qualified Logs.View+import qualified Command.TestRemote import qualified Utility.Path import qualified Utility.FileMode import qualified BuildInfo@@ -145,14 +147,16 @@  tests :: Bool -> Bool -> TestOptions -> TestTree tests crippledfilesystem adjustedbranchok opts = -	testGroup "Tests" $ properties :-		map (\(d, te) -> withTestMode te initTests (unitTests d)) testmodes+	testGroup "Tests" $ properties +		: withTestMode remotetestmode Nothing testRemotes+		: map (\(d, te) -> withTestMode te (Just initTests) (unitTests d)) testmodes   where 	testmodes = catMaybes 		[ canadjust ("v8 adjusted unlocked branch", (testMode opts (RepoVersion 8)) { adjustedUnlockedBranch = True }) 		, unlesscrippled ("v8 unlocked", (testMode opts (RepoVersion 8)) { unlockedFiles = True }) 		, unlesscrippled ("v8 locked", testMode opts (RepoVersion 8)) 		]+	remotetestmode = testMode opts (RepoVersion 8) 	unlesscrippled v 		| crippledfilesystem = Nothing 		| otherwise = Just v@@ -203,6 +207,62 @@ 		, Utility.Hash.props_macs_stable 		] +testRemotes :: TestTree+testRemotes = testGroup "Remote Tests"+	[ testRemote "directory"+		[ "directory=remotedir"+		, "encryption=none"+		]+		(createDirectory "remotedir")+	]++testRemote :: String -> [String] -> IO () -> TestTree+testRemote remotetype config preinitremote = +	withResource newEmptyTMVarIO (const noop) $ \getv -> +		testGroup ("remote type " ++ remotetype) $ concat+			[ [testCase "init" (prep getv)]+			, go getv+			]+  where+	reponame = "test repo"+	remotename = "testremote"+	basesz = 1024 * 1024+	keysizes = Command.TestRemote.keySizes basesz False+	prep getv = do+		d <- newmainrepodir+		setmainrepodir d+		innewrepo $ do+			git_annex "init" [reponame, "--quiet"]+				@? "init failed"+			preinitremote+			git_annex "initremote"+				([ remotename+				, "type=" ++ remotetype+				, "--quiet"+				] ++ config)+				@? "init failed"+			r <- annexeval $ either error return +				=<< Remote.byName' remotename+			unavailr <- annexeval $ Types.Remote.mkUnavailable r+			exportr <- annexeval $ Command.TestRemote.exportTreeVariant r+			ks <- annexeval $ mapM Command.TestRemote.randKey keysizes+			v <- getv+			liftIO $ atomically $ putTMVar v+				(r, (unavailr, (exportr, ks)))+	go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks+	  where+		runannex = inmainrepo . annexeval+		mkrs = Command.TestRemote.remoteVariants mkr basesz False+		mkr = descas (remotetype ++ " remote") (fst <$> v)+		mkunavailr = fst . snd <$> v+		mkexportr = fst . snd . snd <$> v+		mkks = map (\(sz, n) -> desckeysize sz (getk n))+			(zip keysizes [0..])+		getk n = fmap (!! n) (snd . snd . snd <$> v)+		v = liftIO $ atomically . readTMVar =<< getv+		descas = Command.TestRemote.Described+		desckeysize sz = descas ("key size " ++ show sz)+ {- These tests set up the test environment, but also test some basic parts  - of git-annex. They are always run before the unitTests. -} initTests :: TestTree@@ -281,7 +341,7 @@ 	, testCase "addurl" test_addurl 	] --- this test case create the main repo+-- this test case creates the main repo test_init :: Assertion test_init = innewrepo $ do 	ver <- annexVersion <$> getTestMode@@ -1576,14 +1636,12 @@ 	testscheme scheme = do 		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.+	testscheme' scheme abstmp = intmpclonerepo $ do 		gpgtmp <- (</> "gpgtmp") <$> relPathCwdToFile abstmp 		createDirectoryIfMissing False gpgtmp-		Utility.Gpg.testTestHarness gpgtmp gpgcmd +		Utility.Gpg.testTestHarness gpgtmp gpgcmd 			@? "test harness self-test failed"-		Utility.Gpg.testHarness gpgtmp gpgcmd $ do+		void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ do 			createDirectory "dir" 			let a cmd = git_annex cmd $ 				[ "foo"@@ -1664,7 +1722,7 @@ 	unlessM (hasUnlockedFiles <$> getTestMode) $ do 		git_annex "sync" [] @? "sync failed" 		l <- annexeval $ Utility.FileSystemEncoding.decodeBL-			<$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo")+			<$> Annex.CatFile.catObject (Git.Types.Ref (encodeBS "HEAD:dir/foo")) 		"../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l)  	createDirectory "dir2"
Test/Framework.hs view
@@ -79,10 +79,10 @@ 		Annex.setOutput Types.Messages.QuietOutput 		a `finally` Annex.Action.stopCoProcesses -innewrepo :: Assertion -> Assertion+innewrepo :: IO () -> IO () innewrepo a = withgitrepo $ \r -> indir r a -inmainrepo :: Assertion -> Assertion+inmainrepo :: IO a -> IO a inmainrepo a = do 	d <- mainrepodir 	indir d a@@ -417,17 +417,19 @@ hasUnlockedFiles :: TestMode -> Bool hasUnlockedFiles m = unlockedFiles m || adjustedUnlockedBranch m -withTestMode :: TestMode -> TestTree -> TestTree -> TestTree-withTestMode testmode inittests = withResource prepare release . const+withTestMode :: TestMode -> Maybe TestTree -> TestTree -> TestTree+withTestMode testmode minittests = withResource prepare release . const   where 	prepare = do 		setTestMode testmode 		setmainrepodir =<< newmainrepodir-		case tryIngredients [consoleTestReporter] mempty inittests of-			Nothing -> error "No tests found!?"-			Just act -> unlessM act $-				error "init tests failed! cannot continue"-		return ()+		case minittests of+			Just inittests ->+				case tryIngredients [consoleTestReporter] mempty inittests of+					Nothing -> error "No tests found!?"+					Just act -> unlessM act $+						error "init tests failed! cannot continue"+			Nothing -> return () 	release _ = noop  setTestMode :: TestMode -> IO ()
Types/BranchState.hs view
@@ -8,9 +8,17 @@ module Types.BranchState where  data BranchState = BranchState-	{ branchUpdated :: Bool -- has the branch been updated this run?-	, indexChecked :: Bool -- has the index file been checked to exist?+	{ branchUpdated :: Bool+	-- ^ has the branch been updated this run?+	, indexChecked :: Bool+	-- ^ has the index file been checked to exist?+	, journalIgnorable :: Bool+	-- ^ can reading the journal be skipped, while still getting+	-- sufficiently up-to-date information from the branch?+	, journalNeverIgnorable :: Bool+	-- ^ should the journal always be read even if it would normally+	-- be safe to skip it? 	}  startBranchState :: BranchState-startBranchState = BranchState False False+startBranchState = BranchState False False False False
+ Types/CatFileHandles.hs view
@@ -0,0 +1,30 @@+{- git-cat file handles pools+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.CatFileHandles (+	CatFileHandles(..),+	catFileHandlesNonConcurrent,+	catFileHandlesPool,+) where++import Control.Concurrent.STM+import qualified Data.Map as M++import Utility.ResourcePool+import Git.CatFile (CatFileHandle)++data CatFileHandles+	= CatFileHandlesNonConcurrent CatMap+	| CatFileHandlesPool (TMVar CatMap)++type CatMap = M.Map FilePath (ResourcePool CatFileHandle)++catFileHandlesNonConcurrent :: CatFileHandles+catFileHandlesNonConcurrent = CatFileHandlesNonConcurrent M.empty++catFileHandlesPool :: IO CatFileHandles+catFileHandlesPool = CatFileHandlesPool <$> newTMVarIO M.empty
Types/Concurrency.hs view
@@ -11,6 +11,7 @@ -- the former specifies 1 job of each particular kind, but there can be -- more than one kind of job running concurrently. data Concurrency = NonConcurrent | Concurrent Int | ConcurrentPerCpu+	deriving (Eq)  parseConcurrency :: String -> Maybe Concurrency parseConcurrency "cpus" = Just ConcurrentPerCpu
Types/GitConfig.hs view
@@ -343,7 +343,7 @@ 		, remoteAnnexReadOnly = getbool "readonly" False 		, remoteAnnexCheckUUID = getbool "checkuuid" True 		, remoteAnnexVerify = getbool "verify" True-		, remoteAnnexTrackingBranch = Git.Ref <$>+		, remoteAnnexTrackingBranch = Git.Ref . encodeBS <$> 			( notempty (getmaybe "tracking-branch") 			<|> notempty (getmaybe "export-tracking") -- old name 			)
+ Types/IndexFiles.hs view
@@ -0,0 +1,11 @@+{- Alternative git index files+ - + - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.IndexFiles where++data AltIndexFile = AnnexIndexFile | ViewIndexFile+	deriving (Eq, Show)
Types/RefSpec.hs view
@@ -32,7 +32,7 @@ 	mk ('+':s) 		| any (`elem` s) "*?" = 			Right $ AddMatching $ compileGlob s CaseSensative-		| otherwise = Right $ AddRef $ Ref s+		| otherwise = Right $ AddRef $ Ref $ encodeBS s 	mk ('-':s) = Right $ RemoveMatching $ compileGlob s CaseSensative 	mk "reflog" = Right AddRefLog 	mk s = Left $ "bad refspec item \"" ++ s ++ "\" (expected + or - prefix)"
Types/UUID.hs view
@@ -58,6 +58,7 @@  instance ToUUID ConfigValue where 	toUUID (ConfigValue v) = toUUID v+	toUUID NoConfigValue = NoUUID  -- There is no matching FromUUID U.UUID because a git-annex UUID may -- be NoUUID or perhaps contain something not allowed in a canonical UUID.
Types/View.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Types.View where  import Annex.Common
Upgrade.hs view
@@ -13,7 +13,7 @@ import qualified Annex import qualified Git import Config-import Config.Files+import Annex.Path import Annex.Version import Types.RepoVersion #ifndef mingw32_HOST_OS@@ -103,7 +103,7 @@ 	-- upgrading a git repo other than the current repo. 	upgraderemote = do 		rp <- fromRawFilePath <$> fromRepo Git.repoPath-		cmd <- liftIO readProgramFile+		cmd <- liftIO programPath 		liftIO $ boolSystem' cmd 			[ Param "upgrade" 			, Param "--quiet"
Upgrade/V2.hs view
@@ -92,7 +92,8 @@  push :: Annex () push = do-	origin_master <- inRepo $ Git.Ref.exists $ Git.Ref "origin/master"+	origin_master <- inRepo $ Git.Ref.exists $ +		Git.Ref $ encodeBS' "origin/master" 	origin_gitannex <- Annex.Branch.hasOrigin 	case (origin_master, origin_gitannex) of 		(_, True) -> do@@ -101,12 +102,12 @@ 			-- will immediately work. Not pushed here, 			-- because it's less obnoxious to let the user 			-- push.-			Annex.Branch.update+			void Annex.Branch.update 		(True, False) -> do 			-- push git-annex to origin, so that 			-- "git push" will from then on 			-- automatically push it-			Annex.Branch.update -- just in case+			void Annex.Branch.update -- just in case 			showAction "pushing new git-annex branch to origin" 			showOutput 			inRepo $ Git.Command.run@@ -117,7 +118,7 @@ 		_ -> do 			-- no origin exists, so just let the user 			-- know about the new branch-			Annex.Branch.update+			void Annex.Branch.update 			showLongNote $ 				"git-annex branch created\n" ++ 				"Be sure to push this branch when pushing to remotes.\n"
Upgrade/V5/Direct.hs view
@@ -59,7 +59,7 @@ fromDirectBranch :: Ref -> Ref fromDirectBranch directhead = case splitc '/' $ fromRef directhead of 	("refs":"heads":"annex":"direct":rest) -> -		Ref $ "refs/heads/" ++ intercalate "/" rest+		Ref $ encodeBS' $ "refs/heads/" ++ intercalate "/" rest 	_ -> directhead  switchHEADBack :: Annex ()
Utility/CoProcess.hs view
@@ -9,7 +9,8 @@ {-# LANGUAGE CPP #-}  module Utility.CoProcess (-	CoProcessHandle,+	CoProcessHandle(..),+	CoProcessState(..), 	start, 	stop, 	query,
Utility/Gpg.hs view
@@ -376,9 +376,18 @@ #ifndef mingw32_HOST_OS {- Runs an action using gpg in a test harness, in which gpg does  - not use ~/.gpg/, but sets up the test key in a subdirectory of - - the passed directory and uses it. -}-testHarness :: FilePath -> GpgCmd -> IO a -> IO a-testHarness tmpdir cmd a = bracket setup cleanup (const a)+ - the passed directory and uses it.+ -+ - If the test harness is not able to be set up (eg, because gpg is not+ - installed or because there is some problem importing the test key,+ - perhaps related to the agent socket), the action is not run, and Nothing+ - is returned.+ -}+testHarness :: FilePath -> GpgCmd -> IO a -> IO (Maybe a)+testHarness tmpdir cmd a = ifM (inPath (unGpgCmd cmd))+	( bracket (eitherToMaybe <$> tryNonAsync setup) cleanup go+	, return Nothing+	)   where 	var = "GNUPGHOME"		 @@ -395,9 +404,13 @@ 			[testSecretKey, testKey] 		return orig 		-	cleanup (Just v) = setEnv var v True-	cleanup Nothing = unsetEnv var+	cleanup (Just (Just v)) = setEnv var v True+	cleanup (Just Nothing) = unsetEnv var+	cleanup Nothing = return () +	go (Just _) = Just <$> a+	go Nothing = return Nothing+         makenewdir n = do 		let subdir = tmpdir </> show n 		catchIOErrorType AlreadyExists (const $ makenewdir $ n + 1) $ do@@ -406,9 +419,12 @@  {- Tests the test harness. -} testTestHarness :: FilePath -> GpgCmd -> IO Bool-testTestHarness tmpdir cmd = do-	keys <- testHarness tmpdir cmd $ findPubKeys cmd testKeyId-	return $ KeyIds [testKeyId] == keys+testTestHarness tmpdir cmd =+	testHarness tmpdir cmd (findPubKeys cmd testKeyId) >>= \case+		Nothing -> do+			hPutStrLn stderr "unable to test gpg, setting up the test harness did not succeed"+			return True+		Just keys -> return $ KeyIds [testKeyId] == keys  checkEncryptionFile :: GpgCmd -> FilePath -> Maybe KeyIds -> IO Bool checkEncryptionFile cmd filename keys =
Utility/Misc.hs view
@@ -11,6 +11,7 @@ 	hGetContentsStrict, 	readFileStrict, 	separate,+	separate', 	firstLine, 	firstLine', 	segment,@@ -53,6 +54,13 @@ 	unbreak r@(a, b) 		| null b = r 		| otherwise = (a, tail b)++separate' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString)+separate' c l = unbreak $ S.break c l+  where+	unbreak r@(a, b)+		| S.null b = r+		| otherwise = (a, S.tail b)  {- Breaks out the first line. -} firstLine :: String -> String
Utility/Process.hs view
@@ -1,7 +1,7 @@ {- System.Process enhancements, including additional ways of running  - processes, and logging.  -- - Copyright 2012-2015 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -53,6 +53,7 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad+import qualified Data.ByteString as S  type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -85,25 +86,20 @@ 	-> [String] 	-> Maybe [(String, String)] 	-> (Maybe (Handle -> IO ()))-	-> (Maybe (Handle -> IO ()))-	-> IO String-writeReadProcessEnv cmd args environ writestdin adjusthandle = do+	-> IO S.ByteString+writeReadProcessEnv cmd args environ writestdin = do 	(Just inh, Just outh, _, pid) <- createProcess p -	maybe (return ()) (\a -> a inh) adjusthandle-	maybe (return ()) (\a -> a outh) adjusthandle- 	-- fork off a thread to start consuming the output-	output  <- hGetContents outh 	outMVar <- newEmptyMVar-	_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()+	_ <- forkIO $ putMVar outMVar =<< S.hGetContents outh  	-- now write and flush any input 	maybe (return ()) (\a -> a inh >> hFlush inh) writestdin 	hClose inh -- done with stdin  	-- wait on the output-	takeMVar outMVar+	output <- takeMVar outMVar 	hClose outh  	-- wait on the process
+ Utility/ResourcePool.hs view
@@ -0,0 +1,94 @@+{- Resource pools.+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE BangPatterns #-}++module Utility.ResourcePool (+	ResourcePool(..),+	mkResourcePool,+	mkResourcePoolNonConcurrent,+	withResourcePool,+	freeResourcePool,+) where++import Common++import Control.Concurrent.STM+import Control.Monad.IO.Class+import Data.Either++data ResourcePool r+	= ResourcePool Int (TVar Int) (TVar [r])+	| ResourcePoolNonConcurrent r++{- Make a new resource pool, that can grow to contain the specified number+ - of resources. -}+mkResourcePool :: MonadIO m => Int -> m (ResourcePool r)+mkResourcePool maxsz = liftIO $+	ResourcePool maxsz+		<$> newTVarIO 0+		<*> newTVarIO []++{- When there will not be multiple threads that may + - may concurrently try to use it, using this is more+ - efficient than mkResourcePool.+ -}+mkResourcePoolNonConcurrent :: (MonadMask m, MonadIO m) => m r -> m (ResourcePool r)+mkResourcePoolNonConcurrent allocresource =+	ResourcePoolNonConcurrent <$> allocresource++{- Runs an action with a resource.+ -+ - If no free resource is available in the pool,+ - will run the action the allocate a new resource if the pool's size+ - allows. Or will block a resource becomes available to use.+ -+ - The resource is returned to the pool at the end.+ -}+withResourcePool :: (MonadMask m, MonadIO m) => ResourcePool r -> m r -> (r -> m a) -> m a+withResourcePool (ResourcePoolNonConcurrent r) _ a = a r+withResourcePool (ResourcePool maxsz currsz p) allocresource a =+	bracket setup cleanup a+  where+	setup = do+		mr <- liftIO $ atomically $ do+			l <- readTVar p+			case l of+				(r:rs) -> do+					writeTVar p rs+					return (Just r)+				[] -> do+					n <- readTVar currsz+					if n < maxsz+						then do+							let !n' = succ n+							writeTVar currsz n'+							return Nothing+						else retry+		case mr of+			Just r -> return r+			Nothing -> allocresource+	cleanup r = liftIO $ atomically $ modifyTVar' p (r:)++{- Frees all resources in use in the pool, running the supplied action on+ - each. (If any of the actions throw an exception, it will be rethrown+ - after all the actions have completed.)+ -+ - The pool should not have any resources in use when this is called,+ - and the pool should not be used again after calling this.+ -}+freeResourcePool :: (MonadMask m, MonadIO m) => ResourcePool r -> (r -> m ()) -> m ()+freeResourcePool (ResourcePoolNonConcurrent r) freeresource = freeresource r+freeResourcePool (ResourcePool _ currsz p) freeresource = do+	rs <- liftIO $ atomically $ do+		writeTVar currsz 0+		swapTVar p []+	res <- forM rs $ tryNonAsync . freeresource+	case lefts res of+		[] -> return ()+		(e:_) -> throwM e+
Utility/Url.hs view
@@ -162,8 +162,8 @@ {- Checks that an url exists and could be successfully downloaded,  - also checking that its size, if available, matches a specified size.  -- - The Left error is returned if policy does not allow accessing the url- - or the url scheme is not supported.+ - The Left error is returned if policy or the restricted http manager+ - does not allow accessing the url or the url scheme is not supported.  -} checkBoth :: URLString -> Maybe Integer -> UrlOptions -> IO (Either String Bool) checkBoth url expected_size uo = fmap go <$> check url expected_size uo@@ -195,8 +195,8 @@ {- Checks that an url exists and could be successfully downloaded,  - also returning its size and suggested filename if available.  -- - The Left error is returned if policy does not allow accessing the url- - or the url scheme is not supported.+ - The Left error is returned if policy or the restricted http manages+ - does not allow accessing the url or the url scheme is not supported.  -} getUrlInfo :: URLString -> UrlOptions -> IO (Either String UrlInfo) getUrlInfo url uo = case parseURIRelaxed url of@@ -205,15 +205,8 @@    where 	go :: URI -> IO (Either String UrlInfo) 	go u = case (urlDownloader uo, parseRequest (show u)) of-		(DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust-			-- When http redirects to a protocol which -			-- conduit does not support, it will throw-			-- a StatusCodeException with found302-			-- and a Response with the redir Location.-			(matchStatusCodeException (== found302))-			(Right <$> existsconduit req uo)-			(followredir r)-				`catchNonAsync` (const $ return $ Right dne)+		(DownloadWithConduit (DownloadWithCurlRestricted r), Just req) ->+			existsconduit r req 		(DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) 			| isfileurl u -> Right <$> existsfile u 			| isftpurl u -> (Right <$> existscurlrestricted r u url ftpport)@@ -250,7 +243,23 @@ 	extractfilename = contentDispositionFilename . B8.toString 		<=< lookup hContentDisposition . responseHeaders -	existsconduit req uo' = do+	existsconduit r req =+		let go = catchcrossprotoredir r (existsconduit' req uo)+		in catchJust matchconnectionrestricted go retconnectionrestricted+	+	matchconnectionrestricted he@(HttpExceptionRequest _ (InternalException ie)) =+		case fromException ie of+			Just (ConnectionRestricted why) -> Just he+			_ -> Nothing+	matchconnectionrestricted _ = Nothing++	retconnectionrestricted he@(HttpExceptionRequest _ (InternalException ie)) =+		case fromException ie of+			Just (ConnectionRestricted why) -> return (Left why)+			_ -> throwM he+	retconnectionrestricted he = throwM he++	existsconduit' req uo' = do 		let req' = headRequest (applyRequest uo req) 		debugM "url" (show req') 		join $ runResourceT $ do@@ -266,7 +275,7 @@ 					then return $ getBasicAuth uo' (show (getUri req)) >>= \case 						Nothing -> return dne 						Just (ba, signalsuccess) -> do-							ui <- existsconduit+							ui <- existsconduit' 								(applyBasicAuth' ba req)							 								(uo' { getBasicAuth = noBasicAuth }) 							signalsuccess (urlExists ui)@@ -301,6 +310,14 @@ 				sz <- getFileSize' f stat 				found (Just sz) Nothing 			Nothing -> return dne++	-- When http server redirects to a protocol which conduit does not+	-- support, it will throw a StatusCodeException with found302+	-- and a Response with the redir Location.+	catchcrossprotoredir r a = +		catchJust (matchStatusCodeException (== found302))+			(Right <$> a)+			(followredir r) 	 	followredir r (HttpExceptionRequest _ (StatusCodeException resp _)) =  		case headMaybe $ map decodeBS $ getResponseHeader hLocation resp of
doc/git-annex-copy.mdwn view
@@ -10,6 +10,9 @@  Copies the content of files from or to another remote. +With no parameters, operates on all annexed files in the current directory.+Paths of files or directories to operate on can be specified.+ # OPTIONS  * `--from=remote`@@ -38,7 +41,7 @@  * `--auto` -  Rather than copying all files, only copy files that don't yet have+  Rather than copying all specified files, only copy those that don't yet have   the desired number of copies, or that are preferred content of the   destination repository. See [[git-annex-preferred-content]](1)
doc/git-annex-drop.mdwn view
@@ -18,6 +18,9 @@ Content that is required to be stored in the repository will not be dropped even if enough copies exist elsewhere. See [[git-annex-required]](1). +With no parameters, tries to drop all annexed files in the current directory.+Paths of files or directories to drop can be specified.+ # OPTIONS  * `--from=remote`@@ -28,7 +31,7 @@  * `--auto` -  Rather than trying to drop all specified files, drop only files that+  Rather than trying to drop all specified files, drop only those that   are not preferred content of the repository.   See [[git-annex-preferred-content]](1) @@ -44,7 +47,8 @@   Rather than specifying a filename or path to drop, this option can be   used to drop all available versions of all files. -  This is the default behavior when running git-annex drop in a bare repository.+  This is the default behavior when running git-annex drop in a bare+  repository.    Note that this bypasses checking the .gitattributes annex.numcopies   setting and required content settings.
doc/git-annex-fsck.mdwn view
@@ -8,11 +8,16 @@  # DESCRIPTION -With no parameters, this command checks the whole annex for consistency,-and warns about or fixes any problems found. This is a good complement to-`git fsck`.+This command checks annexed files for consistency, and warns about or+fixes any problems found. This is a good complement to `git fsck`. -With parameters, only the specified files are checked.+The default is to check all annexed files in the current directory and+subdirectories. With parameters, only the specified files are checked.++The problems fsck finds include files that have gotten corrupted,+files whose content has somehow become lost, files that do not have the+configured number of copies yet made, and keys that can be upgraded to a+better format.  # OPTIONS
doc/git-annex-get.mdwn view
@@ -12,12 +12,16 @@ will involve copying them from a remote repository, or downloading them, or transferring them from some kind of key-value store. +With no parameters, gets all annexed files in the current directory whose+content was not already present. Paths of files or directories to get can+be specified.+ # OPTIONS  * `--auto` -  Rather than getting all files, get only files that don't yet have-  the desired number of copies, or that are preferred content of the+  Rather than getting all the specified files, get only those that don't yet+  have the desired number of copies, or that are preferred content of the   repository. See [[git-annex-preferred-content]](1)  * `--from=remote`
doc/git-annex-move.mdwn view
@@ -10,6 +10,9 @@  Moves the content of files from or to another remote. +With no parameters, operates on all annexed files in the current directory.+Paths of files or directories to operate on can be specified.+ # OPTIONS  * `--from=remote`
doc/git-annex-preferred-content.mdwn view
@@ -48,6 +48,10 @@   [[git-annex-export]](1)) and [[git-annex-import]](1), these match relative   to the top of the subdirectory. +  Note that, when a command is run with the `--all` option, or in a bare+  repository, there is no filename associated with an annexed object,+  and so "include=" and "exclude=" will not match.+ * `copies=number`    Matches only files that git-annex believes to have the specified number@@ -159,6 +163,10 @@   `git annex enableremote $remote preferreddir=$dirname`    (If no directory name is configured, it uses "public" by default.)++  Note that, when a command is run with the `--all` option, or in a bare+  repository, there is no filename associated with an annexed object,+  and so "inpreferreddir" will not match.  * `standard`
doc/git-annex-sync.mdwn view
@@ -46,6 +46,9 @@    Only sync with the remotes with the lowest annex-cost value configured. +  When a list of remotes (or remote groups) is provided, it picks from+  amoung those, otherwise it picks from amoung all remotes.+ * `--only-annex` `-a`, `--not-only-annex`    Only sync the git-annex branch and annexed content with remotes,@@ -99,9 +102,9 @@   The `annex.synccontent` configuration can be set to true to make content   be synced by default. -  Normally this tries to get each annexed file that the local repository-  does not yet have, and then copies each file to every remote that it-  is syncing with.+  Normally this tries to get each annexed file that is in the working tree+  and whose content the local repository does not yet have, and then copies+  each file to every remote that it is syncing with.   This behavior can be overridden by configuring the preferred content   of a repository. See [[git-annex-preferred-content]](1).
doc/git-annex.mdwn view
@@ -1039,10 +1039,6 @@   commit the data by running `git annex merge` (or by automatic merges)   or `git annex sync`. -  You should beware running `git gc` when using this configuration,-  since it could garbage collect objects that are staged in git-annex's-  index but not yet committed.- * `annex.commitmessage`    When git-annex updates the git-annex branch, it usually makes up@@ -1531,10 +1527,21 @@    It is set to "true" if this is a git-lfs remote. -* `remote.<name>.annex-hooktype`, `remote.<name>.annex-externaltype`+* `remote.<name>.annex-externaltype` -  Used by hook special remotes and external special remotes to record-  the type of the remote.+  Used external special remotes to record the type of the remote.++  Eg, if this is set to "foo", git-annex will run a "git-annex-remote-foo"+  program to communicate with the external special remote.++  If this is set to "readonly", then git-annex will not run any external+  special remote program, but will try to access things stored in the+  remote using http. That only works for some external special remotes,+  so consult the documentation of the one you are using.++* `remote.<name>.annex-hooktype`++  Used by hook special remotes to record the type of the remote.  * `annex.web-options`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20200330+Version: 8.20200501 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -371,7 +371,7 @@    tasty-quickcheck,    tasty-rerun   CC-Options: -Wall-  GHC-Options: -Wall -fno-warn-tabs+  GHC-Options: -Wall -fno-warn-tabs  -Wincomplete-uni-patterns   Extensions: PackageImports, LambdaCase   -- Some things don't work with the non-threaded RTS.   GHC-Options: -threaded@@ -619,6 +619,7 @@     Annex.CheckIgnore     Annex.Common     Annex.Concurrent+    Annex.Concurrent.Utility     Annex.Content     Annex.Content.LowLevel     Annex.Content.PointerFile@@ -668,6 +669,7 @@     Annex.View     Annex.View.ViewedFile     Annex.Wanted+    Annex.WorkerPool     Annex.WorkTree     Annex.YoutubeDl     Backend@@ -974,6 +976,7 @@     Types.Backend     Types.Benchmark     Types.BranchState+    Types.CatFileHandles     Types.CleanupActions     Types.Command     Types.Concurrency@@ -988,6 +991,7 @@     Types.GitConfig     Types.Group     Types.Import+    Types.IndexFiles     Types.Key     Types.KeySource     Types.LockCache@@ -1087,6 +1091,7 @@     Utility.Process.Transcript     Utility.QuickCheck     Utility.RawFilePath+    Utility.ResourcePool     Utility.Rsync     Utility.SafeCommand     Utility.Scheduled