packages feed

git-annex 8.20210330 → 8.20210428

raw patch · 119 files changed

+1815/−1006 lines, 119 filesdep −hsloggerdep ~monad-logger

Dependencies removed: hslogger

Dependency ranges changed: monad-logger

Files

Annex.hs view
@@ -10,10 +10,12 @@ module Annex ( 	Annex, 	AnnexState(..),+	AnnexRead(..), 	new, 	run, 	eval, 	makeRunner,+	getRead, 	getState, 	changeState, 	withState,@@ -74,6 +76,7 @@ import Types.TransferrerPool import Types.VectorClock import Annex.VectorClock.Utility+import Annex.Debug.Utility import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url@@ -88,18 +91,18 @@ import qualified Data.Set as S import Data.Time.Clock.POSIX -{- git-annex's monad is a ReaderT around an AnnexState stored in a MVar.- - The MVar is not exposed outside this module.+{- git-annex's monad is a ReaderT around an AnnexState stored in a MVar,+ - and an AnnexRead. The MVar is not exposed outside this module.  -  - Note that when an Annex action fails and the exception is caught,  - any changes the action has made to the AnnexState are retained,  - due to the use of the MVar to store the state.  -}-newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a }+newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState, AnnexRead) IO a } 	deriving ( 		Monad, 		MonadIO,-		MonadReader (MVar AnnexState),+		MonadReader (MVar AnnexState, AnnexRead), 		MonadCatch, 		MonadThrow, 		MonadMask,@@ -109,7 +112,41 @@ 		Alternative 	) --- internal state storage+-- Values that can be read, but not modified by an Annex action.+data AnnexRead = AnnexRead+	{ activekeys :: TVar (M.Map Key ThreadId)+	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)+	, keysdbhandle :: Keys.DbHandle+	, sshstalecleaned :: TMVar Bool+	, signalactions :: TVar (M.Map SignalAction (Int -> IO ()))+	, transferrerpool :: TransferrerPool+	, debugenabled :: Bool+	, debugselector :: DebugSelector+	, ciphers :: TMVar (M.Map StorableCipher Cipher)+	}++newAnnexRead :: GitConfig -> IO AnnexRead+newAnnexRead c = do+	emptyactivekeys <- newTVarIO M.empty+	emptyactiveremotes <- newMVar M.empty+	kh <- Keys.newDbHandle+	sc <- newTMVarIO False+	si <- newTVarIO M.empty+	tp <- newTransferrerPool+	cm <- newTMVarIO M.empty+	return $ AnnexRead+		{ activekeys = emptyactivekeys+		, activeremotes = emptyactiveremotes+		, keysdbhandle = kh+		, sshstalecleaned = sc+		, signalactions = si+		, transferrerpool = tp+		, debugenabled = annexDebug c+		, debugselector = debugSelectorFromGitConfig c+		, ciphers = cm+		}++-- Values that can change while running an Annex action. data AnnexState = AnnexState 	{ repo :: Git.Repo 	, repoadjustment :: (Git.Repo -> IO Git.Repo)@@ -125,7 +162,6 @@ 	, fast :: Bool 	, daemon :: Bool 	, branchstate :: BranchState-	, getvectorclock :: IO VectorClock 	, repoqueue :: Maybe (Git.Queue.Queue Annex) 	, catfilehandles :: CatFileHandles 	, hashobjecthandle :: Maybe HashObjectHandle@@ -145,13 +181,10 @@ 	, forcetrust :: TrustMap 	, trustmap :: Maybe TrustMap 	, groupmap :: Maybe GroupMap-	, ciphers :: M.Map StorableCipher Cipher 	, lockcache :: LockCache-	, sshstalecleaned :: TMVar Bool 	, flags :: M.Map String Bool 	, fields :: M.Map String String 	, cleanupactions :: M.Map CleanupAction (Annex ())-	, signalactions :: TVar (M.Map SignalAction (Int -> IO ())) 	, sentinalstatus :: Maybe SentinalStatus 	, useragent :: Maybe String 	, errcounter :: Integer@@ -160,26 +193,17 @@ 	, tempurls :: M.Map Key URLString 	, existinghooks :: M.Map Git.Hook.Hook Bool 	, desktopnotify :: DesktopNotify-	, workers :: Maybe (TMVar (WorkerPool AnnexState))-	, activekeys :: TVar (M.Map Key ThreadId)-	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)-	, keysdbhandle :: Keys.DbHandle+	, workers :: Maybe (TMVar (WorkerPool (AnnexState, AnnexRead))) 	, cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment)) 	, cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)]) 	, urloptions :: Maybe UrlOptions 	, insmudgecleanfilter :: Bool-	, transferrerpool :: TransferrerPool+	, getvectorclock :: IO VectorClock 	} -newState :: GitConfig -> Git.Repo -> IO AnnexState-newState c r = do-	emptyactiveremotes <- newMVar M.empty-	emptyactivekeys <- newTVarIO M.empty-	si <- newTVarIO M.empty+newAnnexState :: GitConfig -> Git.Repo -> IO AnnexState+newAnnexState c r = do 	o <- newMessageState-	sc <- newTMVarIO False-	kh <- Keys.newDbHandle-	tp <- newTransferrerPool 	vc <- startVectorClock 	return $ AnnexState 		{ repo = r@@ -196,7 +220,6 @@ 		, fast = False 		, daemon = False 		, branchstate = startBranchState-		, getvectorclock = vc 		, repoqueue = Nothing 		, catfilehandles = catFileHandlesNonConcurrent 		, hashobjecthandle = Nothing@@ -216,13 +239,10 @@ 		, forcetrust = M.empty 		, trustmap = Nothing 		, groupmap = Nothing-		, ciphers = M.empty 		, lockcache = M.empty-		, sshstalecleaned = sc 		, flags = M.empty 		, fields = M.empty 		, cleanupactions = M.empty-		, signalactions = si 		, sentinalstatus = Nothing 		, useragent = Nothing 		, errcounter = 0@@ -232,91 +252,95 @@ 		, existinghooks = M.empty 		, desktopnotify = mempty 		, workers = Nothing-		, activekeys = emptyactivekeys-		, activeremotes = emptyactiveremotes-		, keysdbhandle = kh 		, cachedcurrentbranch = Nothing 		, cachedgitenv = Nothing 		, urloptions = Nothing 		, insmudgecleanfilter = False-		, transferrerpool = tp+		, getvectorclock = vc 		}  {- Makes an Annex state object for the specified git repo.  - Ensures the config is read, if it was not already, and performs  - any necessary git repo fixups. -}-new :: Git.Repo -> IO AnnexState+new :: Git.Repo -> IO (AnnexState, AnnexRead) new r = do 	r' <- Git.Config.read r 	let c = extractGitConfig FromGitConfig r'-	newState c =<< fixupRepo r' c+	st <- newAnnexState c =<< fixupRepo r' c+	rd <- newAnnexRead c+	return (st, rd)  {- Performs an action in the Annex monad from a starting state,  - returning a new state. -}-run :: AnnexState -> Annex a -> IO (a, AnnexState)-run s a = flip run' a =<< newMVar s+run :: (AnnexState, AnnexRead) -> Annex a -> IO (a, (AnnexState, AnnexRead))+run (st, rd) a = do+	mv <- newMVar st+	run' mv rd a  -run' :: MVar AnnexState -> Annex a -> IO (a, AnnexState)-run' mvar a = do-	r <- runReaderT (runAnnex a) mvar-		`onException` (flush =<< readMVar mvar)-	s' <- takeMVar mvar-	flush s'-	return (r, s')+run' :: MVar AnnexState -> AnnexRead -> Annex a -> IO (a, (AnnexState, AnnexRead))+run' mvar rd a = do+	r <- runReaderT (runAnnex a) (mvar, rd)+		`onException` (flush rd)+	flush rd+	st <- takeMVar mvar+	return (r, (st, rd))   where 	flush = Keys.flushDbQueue . keysdbhandle  {- Performs an action in the Annex monad from a starting state, - - and throws away the new state. -}-eval :: AnnexState -> Annex a -> IO a-eval s a = fst <$> run s a+ - and throws away the changed state. -}+eval :: (AnnexState, AnnexRead) -> Annex a -> IO a+eval v a = fst <$> run v a  {- Makes a runner action, that allows diving into IO and from inside  - the IO action, running an Annex action. -} makeRunner :: Annex (Annex a -> IO a) makeRunner = do-	mvar <- ask+	(mvar, rd) <- ask 	return $ \a -> do-		(r, s) <- run' mvar a+		(r, (s, _rd)) <- run' mvar rd a 		putMVar mvar s 		return r +getRead :: (AnnexRead -> v) -> Annex v+getRead selector = selector . snd <$> ask+ getState :: (AnnexState -> v) -> Annex v getState selector = do-	mvar <- ask-	s <- liftIO $ readMVar mvar-	return $ selector s+	mvar <- fst <$> ask+	st <- liftIO $ readMVar mvar+	return $ selector st  changeState :: (AnnexState -> AnnexState) -> Annex () changeState modifier = do-	mvar <- ask+	mvar <- fst <$> ask 	liftIO $ modifyMVar_ mvar $ return . modifier  withState :: (AnnexState -> IO (AnnexState, b)) -> Annex b withState modifier = do-	mvar <- ask+	mvar <- fst <$> ask 	liftIO $ modifyMVar mvar modifier  {- Sets a flag to True -} setFlag :: String -> Annex ()-setFlag flag = changeState $ \s ->-	s { flags = M.insert flag True $ flags s }+setFlag flag = changeState $ \st ->+	st { flags = M.insert flag True $ flags st }  {- Sets a field to a value -} setField :: String -> String -> Annex ()-setField field value = changeState $ \s ->-	s { fields = M.insert field value $ fields s }+setField field value = changeState $ \st ->+	st { fields = M.insert field value $ fields st }  {- Adds a cleanup action to perform. -} addCleanupAction :: CleanupAction -> Annex () -> Annex ()-addCleanupAction k a = changeState $ \s ->-	s { cleanupactions = M.insert k a $ cleanupactions s }+addCleanupAction k a = changeState $ \st ->+	st { cleanupactions = M.insert k a $ cleanupactions st }  {- Sets the type of output to emit. -} setOutput :: OutputType -> Annex ()-setOutput o = changeState $ \s ->-	let m = output s-	in s { output = m { outputType = adjustOutputType (outputType m) o } }+setOutput o = changeState $ \st ->+	let m = output st+	in st { output = m { outputType = adjustOutputType (outputType m) o } }  {- Checks if a flag was set. -} getFlag :: String -> Annex Bool@@ -351,9 +375,9 @@ {- Overrides a GitConfig setting. The modification persists across  - reloads of the repo's config. -} overrideGitConfig :: (GitConfig -> GitConfig) -> Annex ()-overrideGitConfig f = changeState $ \s -> s-	{ gitconfigadjustment = gitconfigadjustment s . f-	, gitconfig = f (gitconfig s)+overrideGitConfig f = changeState $ \st -> st+	{ gitconfigadjustment = gitconfigadjustment st . f+	, gitconfig = f (gitconfig st) 	}  {- Adds an adjustment to the Repo data. Adjustments persist across reloads@@ -364,7 +388,7 @@  -} adjustGitRepo :: (Git.Repo -> IO Git.Repo) -> Annex () adjustGitRepo a = do-	changeState $ \s -> s { repoadjustment = \r -> repoadjustment s r >>= a }+	changeState $ \st -> st { repoadjustment = \r -> repoadjustment st r >>= a } 	changeGitRepo =<< gitRepo  {- Adds git config setting, like "foo=bar". It will be passed with -c@@ -375,7 +399,7 @@ 	adjustGitRepo $ \r -> 		Git.Config.store (encodeBS' v) Git.Config.ConfigList $ 			r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) }-	changeState $ \s -> s { gitconfigoverride = v : gitconfigoverride s }+	changeState $ \st -> st { gitconfigoverride = v : gitconfigoverride st }   where 	-- Remove any prior occurrance of the setting to avoid 	-- building up many of them when the adjustment is run repeatedly,@@ -394,7 +418,7 @@ 	repoadjuster <- getState repoadjustment 	gitconfigadjuster <- getState gitconfigadjustment 	r' <- liftIO $ repoadjuster r-	changeState $ \s -> s+	changeState $ \st -> st 		{ repo = r' 		, gitconfig = gitconfigadjuster $ 			extractGitConfig FromGitConfig r'@@ -414,8 +438,9 @@  - state, as it will be thrown away. -} withCurrentState :: Annex a -> Annex (IO a) withCurrentState a = do-	s <- getState id-	return $ eval s a+	(mvar, rd) <- ask+	st <- liftIO $ readMVar mvar+	return $ eval (st, rd) a  {- It's not safe to use setCurrentDirectory in the Annex monad,  - because the git repo paths are stored relative.@@ -426,20 +451,20 @@ 	r <- liftIO . Git.adjustPath absPath =<< gitRepo 	liftIO $ setCurrentDirectory d 	r' <- liftIO $ Git.relPath r-	changeState $ \s -> s { repo = r' }+	changeState $ \st -> st { repo = r' }  incError :: Annex ()-incError = changeState $ \s -> -	let !c = errcounter s + 1 -	    !s' = s { errcounter = c }-	in s'+incError = changeState $ \st -> +	let !c = errcounter st + 1 +	    !st' = st { errcounter = c }+	in st'  getGitRemotes :: Annex [Git.Repo] getGitRemotes = do-	s <- getState id-	case gitremotes s of+	st <- getState id+	case gitremotes st of 		Just rs -> return rs 		Nothing -> do-			rs <- liftIO $ Git.Construct.fromRemotes (repo s)-			changeState $ \s' -> s' { gitremotes = Just rs }+			rs <- liftIO $ Git.Construct.fromRemotes (repo st)+			changeState $ \st' -> st' { gitremotes = Just rs } 			return rs
Annex/Action.hs view
@@ -52,7 +52,7 @@ startup :: Annex () startup = do #ifndef mingw32_HOST_OS-	av <- Annex.getState Annex.signalactions+	av <- Annex.getRead Annex.signalactions 	let propagate sig = liftIO $ installhandleronce sig av 	propagate sigINT 	propagate sigQUIT
Annex/AdjustedBranch.hs view
@@ -600,9 +600,7 @@  - So, find the adjusting commit on the currently checked out adjusted  - branch, and use the parent of that commit as the basis, and set the  - origbranch to it.- -- - The repository may also need to be upgraded to a new version, if the- - current version is too old to support adjusted branches. -}+ -} checkAdjustedClone :: Annex AdjustedClone checkAdjustedClone = ifM isBareRepo 	( return NotInAdjustedClone@@ -615,12 +613,12 @@ 		Just (adj, origbranch) -> do 			let basis@(BasisBranch bb) = basisBranch (originalToAdjusted origbranch adj) 			unlessM (inRepo $ Git.Ref.exists bb) $ do-				unlessM (inRepo $ Git.Ref.exists origbranch) $ do-					let remotebranch = Git.Ref.underBase "refs/remotes/origin" origbranch-					inRepo $ Git.Branch.update' origbranch remotebranch 				aps <- fmap commitParent <$> findAdjustingCommit (AdjBranch currbranch) 				case aps of-					Just [p] -> setBasisBranch basis p+					Just [p] -> do+						unlessM (inRepo $ Git.Ref.exists origbranch) $+							inRepo $ Git.Branch.update' origbranch p+						setBasisBranch basis p 					_ -> giveup $ "Unable to clean up from clone of adjusted branch; perhaps you should check out " ++ Git.Ref.describe origbranch 			return InAdjustedClone
Annex/Branch.hs view
@@ -1,6 +1,6 @@ {- management of the git-annex branch  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -20,6 +20,7 @@ 	updateTo, 	get, 	getHistorical,+	RegardingUUID(..), 	change, 	maybeChange, 	commitMessage,@@ -30,6 +31,8 @@ 	rememberTreeish, 	performTransitions, 	withIndex,+	precache,+	overBranchFileContents, ) where  import qualified Data.ByteString as B@@ -41,6 +44,7 @@ import Data.Char import Data.ByteString.Builder import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar import qualified System.FilePath.ByteString as P  import Annex.Common@@ -65,12 +69,14 @@ import Git.Types (Ref(..), fromRef, fromRef', RefDate, TreeItemType(..)) import Git.FilePath import Annex.CatFile+import Git.CatFile (catObjectStreamLsTree) import Annex.Perms import Logs import Logs.Transitions import Logs.File import Logs.Trust.Pure import Logs.Remote.Pure+import Logs.Export.Pure import Logs.Difference.Pure import qualified Annex.Queue import Annex.Branch.Transitions@@ -171,7 +177,7 @@ updateTo' pairs = do 	-- ensure branch exists, and get its current ref 	branchref <- getBranch-	dirty <- journalDirty+	dirty <- journalDirty gitAnnexJournalDir 	ignoredrefs <- getIgnoredRefs 	let unignoredrefs = excludeset ignoredrefs pairs 	tomerge <- if null unignoredrefs@@ -179,7 +185,7 @@ 		else do 			mergedrefs <- getMergedRefs 			filterM isnewer (excludeset mergedrefs unignoredrefs)-	journalclean <- if null tomerge+	journalcleaned <- 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, or just if the journal is dirty. -}@@ -204,9 +210,12 @@ 		else do 			lockJournal $ go branchref dirty tomerge 			return True+	journalclean <- if journalcleaned+		then not <$> privateUUIDsKnown+		else pure False 	return $ UpdateMade 		{ refsWereMerged = not (null tomerge)-		, journalClean = journalclean+		, journalClean = journalclean  		}   where 	excludeset s = filter (\(r, _) -> S.notMember r s)@@ -259,12 +268,30 @@ 		setCache file content 		return content +{- Used to cache the value of a file, which has been read from the branch+ - using some optimised method. The journal has to be checked, in case+ - it has a newer version of the file that has not reached the branch yet.+ -}+precache :: RawFilePath -> L.ByteString -> Annex ()+precache file branchcontent = do+	st <- getState+	content <- if journalIgnorable st+		then pure branchcontent+		else fromMaybe branchcontent+			<$> getJournalFileStale (GetPrivate True) file+	Annex.BranchState.setCache file content+ {- Like get, but does not merge the branch, so the info returned may not  - reflect changes in remotes.  - (Changing the value this returns, and then merging is always the  - same as using get, and then changing its value.) -} getLocal :: RawFilePath -> Annex L.ByteString-getLocal file = go =<< getJournalFileStale file+getLocal = getLocal' (GetPrivate True)++getLocal' :: GetPrivate -> RawFilePath -> Annex L.ByteString+getLocal' getprivate file = do+	fastDebug "Annex.Branch" ("read " ++ fromRawFilePath file)+	go =<< getJournalFileStale getprivate file   where 	go (Just journalcontent) = return journalcontent 	go Nothing = getRef fullname file@@ -294,24 +321,37 @@  - Note that this does not cause the branch to be merged, it only  - modifes the current content of the file on the branch.  -}-change :: Journalable content => RawFilePath -> (L.ByteString -> content) -> Annex ()-change file f = lockJournal $ \jl -> f <$> getLocal file >>= set jl file+change :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> content) -> Annex ()+change ru file f = lockJournal $ \jl -> f <$> getToChange ru file >>= set jl ru file  {- Applies a function which can modify the content of a file, or not. -}-maybeChange :: Journalable content => RawFilePath -> (L.ByteString -> Maybe content) -> Annex ()-maybeChange file f = lockJournal $ \jl -> do-	v <- getLocal file+maybeChange :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> Maybe content) -> Annex ()+maybeChange ru file f = lockJournal $ \jl -> do+	v <- getToChange ru file 	case f v of 		Just jv -> 			let b = journalableByteString jv-			in when (v /= b) $ set jl file b+			in when (v /= b) $ set jl ru file b 		_ -> noop -{- Records new content of a file into the journal -}-set :: Journalable content => JournalLocked -> RawFilePath -> content -> Annex ()-set jl f c = do+{- Only get private information when the RegardingUUID is itself private. -}+getToChange :: RegardingUUID -> RawFilePath -> Annex L.ByteString+getToChange ru f = flip getLocal' f . GetPrivate =<< regardingPrivateUUID ru++{- Records new content of a file into the journal.+ -+ - This is not exported; all changes have to be made via change. This+ - ensures that information that was written to the branch is not+ - overwritten. Also, it avoids a get followed by a set without taking into+ - account whether private information was gotten from the private+ - git-annex index, and should not be written to the public git-annex+ - branch.+ -}+set :: Journalable content => JournalLocked -> RegardingUUID -> RawFilePath -> content -> Annex ()+set jl ru f c = do 	journalChanged-	setJournalFile jl f c+	setJournalFile jl ru f c+	fastDebug "Annex.Branch" ("set " ++ fromRawFilePath f) 	-- Could cache the new content, but it would involve 	-- evaluating a Journalable Builder twice, which is not very 	-- efficient. Instead, assume that it's not common to need to read@@ -325,7 +365,7 @@  {- Stages the journal, and commits staged changes to the branch. -} commit :: String -> Annex ()-commit = whenM journalDirty . forceCommit+commit = whenM (journalDirty gitAnnexJournalDir) . forceCommit  {- Commits the current index to the branch even without any journalled  - changes. -}@@ -403,14 +443,22 @@ files = do 	_  <- update 	(bfs, cleanup) <- branchFiles-	-- ++ 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.-	l <- (++)-		<$> (map toRawFilePath <$> getJournalledFilesStale)-		<*> pure bfs+	-- ++ forces the content of the first list to be buffered in+	-- memory, so use journalledFiles, which should be much smaller+	-- most of the time. branchFiles will stream as the list is consumed.+	l <- (++) <$> journalledFiles <*> pure bfs 	return (l, cleanup) +{- Lists all files currently in the journal. There may be duplicates in+ - the list when using a private journal. -}+journalledFiles :: Annex [RawFilePath]+journalledFiles = ifM privateUUIDsKnown+	( (++)+		<$> getJournalledFilesStale gitAnnexPrivateJournalDir+		<*> getJournalledFilesStale gitAnnexJournalDir+	, getJournalledFilesStale gitAnnexJournalDir+	)+ {- Files in the branch, not including any from journalled changes,  - and without updating the branch. -} branchFiles :: Annex ([RawFilePath], IO Bool)@@ -516,7 +564,7 @@ 	let dir = gitAnnexJournalDir g 	(jlogf, jlogh) <- openjlog (fromRawFilePath tmpdir) 	h <- hashObjectHandle-	withJournalHandle $ \jh ->+	withJournalHandle gitAnnexJournalDir $ \jh -> 		Git.UpdateIndex.streamUpdateIndex g 			[genstream dir h jh jlogh] 	commitindex@@ -607,6 +655,7 @@ 			else do 				ref <- getBranch 				commitIndex jl ref message (nub $ fullname:transitionedrefs)+	regraftexports   where 	message 		| neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc@@ -635,6 +684,7 @@ 			content <- getStaged f 			apply changers' f content 		liftIO $ void cleanup+	 	apply [] _ _ = return () 	apply (changer:rest) file content = case changer file content of 		PreserveFile -> apply rest file content@@ -653,6 +703,15 @@ 						Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file) 					apply rest file content' +	-- Trees mentioned in export.log were grafted into the old+	-- git-annex branch to make sure they remain available. Re-graft+	-- the trees into the new branch.+	regraftexports = do+		l <- exportedTreeishes . M.elems . parseExportLogMap+			<$> getStaged exportLog+		forM_ l $ \t ->+			rememberTreeishLocked t (asTopFilePath exportTreeGraftPoint) jl+ checkBranchDifferences :: Git.Ref -> Annex () checkBranchDifferences ref = do 	theirdiffs <- allDifferences . parseDifferencesLog@@ -705,7 +764,9 @@  - collected, and will always be available as long as the git-annex branch  - is available. -} rememberTreeish :: Git.Ref -> TopFilePath -> Annex ()-rememberTreeish treeish graftpoint = lockJournal $ \jl -> do+rememberTreeish treeish graftpoint = lockJournal $ rememberTreeishLocked treeish graftpoint+rememberTreeishLocked :: Git.Ref -> TopFilePath -> JournalLocked -> Annex ()+rememberTreeishLocked treeish graftpoint jl = do 	branchref <- getBranch 	updateIndex jl branchref 	origtree <- fromMaybe (giveup "unable to determine git-annex branch tree") <$>@@ -722,3 +783,60 @@ 	-- say that the index contains c'. 	setIndexSha c' +{- Runs an action on the content of selected files from the branch.+ - This is much faster than reading the content of each file in turn,+ - because it lets git cat-file stream content without blocking.+ -+ - The action is passed a callback that it can repeatedly call to read+ - the next file and its contents. When there are no more files, the+ - callback will return Nothing.+ -}+overBranchFileContents+	:: (RawFilePath -> Maybe v)+	-> (Annex (Maybe (v, RawFilePath, Maybe L.ByteString)) -> Annex a)+	-> Annex a+overBranchFileContents select go = do+	st <- update+	g <- Annex.gitRepo+	(l, cleanup) <- inRepo $ Git.LsTree.lsTree+		Git.LsTree.LsTreeRecursive+		(Git.LsTree.LsTreeLong False)+		fullname+	let select' f = fmap (\v -> (v, f)) (select f)+	buf <- liftIO newEmptyMVar+	let go' reader = go $ liftIO reader >>= \case+		Just ((v, f), content) -> do+			-- Check the journal if it did not get+			-- committed to the branch+			content' <- if journalIgnorable st+				then pure content+				else maybe content Just +					<$> getJournalFileStale (GetPrivate True) f+			return (Just (v, f, content'))+		Nothing+			| journalIgnorable st -> return Nothing+			-- The journal did not get committed to the+			-- branch, and may contain files that+			-- are not present in the branch, which +			-- need to be provided to the action still.+			-- This can cause the action to be run a+			-- second time with a file it already ran on.+			| otherwise -> liftIO (tryTakeMVar buf) >>= \case+				Nothing -> drain buf =<< journalledFiles+				Just fs -> drain buf fs+	catObjectStreamLsTree l (select' . getTopFilePath . Git.LsTree.file) g go'+		`finally` liftIO (void cleanup)+  where+	getnext [] = Nothing+	getnext (f:fs) = case select f of+		Nothing -> getnext fs+		Just v -> Just (v, f, fs)+					+	drain buf fs = case getnext fs of+		Just (v, f, fs') -> do+			liftIO $ putMVar buf fs'+			content <- getJournalFileStale (GetPrivate True) f+			return (Just (v, f, content))+		Nothing -> do+			liftIO $ putMVar buf []+			return Nothing
Annex/Branch/Transitions.hs view
@@ -45,7 +45,7 @@ -- Removes data about all dead repos. -- -- The trust log is not changed, because other, unmerged clones--- may contain other data about the dead repos. So we need to rememebr+-- may contain other data about the dead repos. So we need to remember -- which are dead to later remove that. -- -- When the remote log contains a sameas-uuid pointing to a dead uuid,
Annex/BranchState.hs view
@@ -37,25 +37,28 @@  - 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.+ -+ - When interactive access is enabled, the journal is always checked when+ - reading values from the branch, and so this does not need to update+ - the branch.  -} runUpdateOnce :: Annex Bool -> Annex BranchState runUpdateOnce a = do 	st <- getState-	if branchUpdated st+	if branchUpdated st || needInteractiveAccess st 		then return st 		else do 			journalstaged <- a 			let stf = \st' -> st' 				{ branchUpdated = True 				, journalIgnorable = journalstaged -					&& not (needInteractiveAccess 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. -}+ - queried from it being as up-to-date as possible. -} disableUpdate :: Annex () disableUpdate = changeState $ \s -> s { branchUpdated = True }
Annex/Common.hs view
@@ -8,6 +8,7 @@ import Types.UUID as X import Annex as X (gitRepo, inRepo, fromRepo, calcRepo) import Annex.Locations as X+import Annex.Debug as X (fastDebug, debug) import Messages as X #ifndef mingw32_HOST_OS import System.Posix.IO as X hiding (createPipe)
Annex/Concurrent.hs view
@@ -55,9 +55,10 @@  -} forkState :: Annex a -> Annex (IO (Annex a)) forkState a = do+	rd <- Annex.getRead id 	st <- dupState 	return $ do-		(ret, newst) <- run st a+		(ret, (newst, _rd)) <- run (st, rd) a 		return $ do 			mergeState newst 			return ret@@ -90,7 +91,9 @@  - Also closes various handles in it. -} mergeState :: AnnexState -> Annex () mergeState st = do-	st' <- liftIO $ snd <$> run st stopNonConcurrentSafeCoProcesses+	rd <- Annex.getRead id+	st' <- liftIO $ (fst . snd)+		<$> run (st, rd) stopNonConcurrentSafeCoProcesses 	forM_ (M.toList $ Annex.cleanupactions st') $ 		uncurry addCleanupAction 	Annex.Queue.mergeFrom st'
+ Annex/CopyFile.hs view
@@ -0,0 +1,163 @@+{- Copying files.+ -+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Annex.CopyFile where++import Annex.Common+import Types.Remote+import Utility.Metered+import Utility.CopyFile+import Utility.FileMode+import Utility.Touch+import Types.Backend+import Backend+import Annex.Verify++import Control.Concurrent+import qualified Data.ByteString as S+import Data.Time.Clock.POSIX++-- Copies from src to dest, updating a meter. If the copy finishes+-- successfully, calls a final check action, which must also succeed, or+-- returns false.+--+-- If either the remote or local repository wants to use hard links,+-- the copier will do so (falling back to copying if a hard link cannot be+-- made).+--+-- When a hard link is created, returns Verified; the repo being linked+-- from is implicitly trusted, so no expensive verification needs to be+-- done. Also returns Verified if the key's content is verified while+-- copying it.+type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)++-- To avoid the overhead of trying copy-on-write every time, it's tried+-- once and if it fails, is not tried again.+newtype CopyCoWTried = CopyCoWTried (MVar Bool)++newCopyCoWTried :: IO CopyCoWTried+newCopyCoWTried = CopyCoWTried <$> newEmptyMVar++{- Copies a file is copy-on-write is supported. Otherwise, returns False. -}+tryCopyCoW :: CopyCoWTried -> FilePath -> FilePath -> MeterUpdate -> IO Bool+tryCopyCoW (CopyCoWTried copycowtried) src dest meterupdate =+	-- If multiple threads reach this at the same time, they+	-- will both try CoW, which is acceptable.+	ifM (isEmptyMVar copycowtried)+		( do+			ok <- docopycow+			void $ tryPutMVar copycowtried ok+			return ok+		, ifM (readMVar copycowtried)+			( docopycow+			, return False+			)+		)+  where+	docopycow = watchFileSize dest meterupdate $+		copyCoW CopyTimeStamps src dest++{- Copys a file. Uses copy-on-write if it is supported. Otherwise,+ - copies the file itself. If the destination already exists,+ - an interruped copy will resume where it left off.+ -+ - When copy-on-write is used, returns UnVerified, because the content of+ - the file has not been verified to be correct. When the file has to be+ - read to copy it, a hash is calulated at the same time.+ -+ - Note that, when the destination file already exists, it's read both+ - to start calculating the hash, and also to verify that its content is+ - the same as the start of the source file. It's possible that the+ - destination file was created from some other source file,+ - (eg when isStableKey is false), and doing this avoids getting a+ - corrupted file in such cases.+ -}+fileCopier :: CopyCoWTried -> FileCopier+#ifdef mingw32_HOST_OS+fileCopier _ src dest k meterupdate check verifyconfig = docopy+#else+fileCopier copycowtried src dest k meterupdate check verifyconfig =+	ifM (liftIO $ tryCopyCoW copycowtried src dest meterupdate)+		( unVerified check+		, docopy+		)+#endif+  where+	dest' = toRawFilePath dest++	docopy = do+		iv <- startVerifyKeyContentIncrementally verifyconfig k++		-- The file might have had the write bit removed,+		-- so make sure we can write to it.+		void $ liftIO $ tryIO $ allowWrite dest'++		liftIO $ withBinaryFile dest ReadWriteMode $ \hdest ->+			withBinaryFile src ReadMode $ \hsrc -> do+				sofar <- compareexisting iv hdest hsrc zeroBytesProcessed+				docopy' iv hdest hsrc sofar++		-- Copy src mode and mtime.+		mode <- liftIO $ fileMode <$> getFileStatus src+		mtime <- liftIO $ utcTimeToPOSIXSeconds <$> getModificationTime src+		liftIO $ setFileMode dest mode+		liftIO $ touch dest' mtime False++		ifM check+			( case iv of+				Just x -> ifM (liftIO $ finalizeIncremental x)+					( return (True, Verified)+					, return (False, UnVerified)+					)+				Nothing -> return (True, UnVerified)+			, return (False, UnVerified)+			)+	+	docopy' iv hdest hsrc sofar = do+		s <- S.hGet hsrc defaultChunkSize+		if s == S.empty+			then return ()+			else do+				let sofar' = addBytesProcessed sofar (S.length s)+				S.hPut hdest s+				maybe noop (flip updateIncremental s) iv+				meterupdate sofar'+				docopy' iv hdest hsrc sofar'++	-- Leaves hdest and hsrc seeked to wherever the two diverge,+	-- so typically hdest will be seeked to end, and hsrc to the same+	-- position.+	compareexisting iv hdest hsrc sofar = do+		s <- S.hGet hdest defaultChunkSize+		if s == S.empty+			then return sofar+			else do+				s' <- getnoshort (S.length s) hsrc+				if s == s'+					then do+						maybe noop (flip updateIncremental s) iv+						let sofar' = addBytesProcessed sofar (S.length s)+						meterupdate sofar'+						compareexisting iv hdest hsrc sofar'+					else do+						seekbefore hdest s+						seekbefore hsrc s'+						return sofar+	+	seekbefore h s = hSeek h RelativeSeek (fromIntegral (-1*S.length s))+	+	-- Like hGet, but never returns less than the requested number of+	-- bytes, unless it reaches EOF.+	getnoshort n h = do+		s <- S.hGet h n+		if S.length s == n || S.empty == s+			then return s+			else do+				s' <- getnoshort (n - S.length s) h+				return (s <> s')
+ Annex/Debug.hs view
@@ -0,0 +1,31 @@+{- git-annex debugging+ -+ - Copyright 2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.Debug (+	DebugSelector(..),+	DebugSource(..),+	debug,+	fastDebug,+	configureDebug,+	debugSelectorFromGitConfig,+	parseDebugSelector,+) where++import Common+import qualified Annex+import Utility.Debug hiding (fastDebug)+import qualified Utility.Debug+import Annex.Debug.Utility++-- | This is faster than using debug, because the DebugSelector+-- is read from the Annex monad, which avoids any IORef access overhead+-- when debugging is not enabled.+fastDebug :: DebugSource -> String -> Annex.Annex ()+fastDebug src msg = do+	rd <- Annex.getRead id+	when (Annex.debugenabled rd) $+		liftIO $ Utility.Debug.fastDebug (Annex.debugselector rd) src msg
+ Annex/Debug/Utility.hs view
@@ -0,0 +1,32 @@+{- git-annex debugging, utility functions+ -+ - Copyright 2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.Debug.Utility (+	debugSelectorFromGitConfig,+	parseDebugSelector,+	DebugSelector,+) where++import Types.GitConfig+import Utility.Debug+import Utility.Split+import Utility.FileSystemEncoding++import qualified Data.ByteString as S++debugSelectorFromGitConfig :: GitConfig -> DebugSelector+debugSelectorFromGitConfig = +	maybe NoDebugSelector parseDebugSelector . annexDebugFilter++parseDebugSelector :: String -> DebugSelector+parseDebugSelector = DebugSelector . matchDebugSource . splitSelectorNames++splitSelectorNames :: String -> [S.ByteString]+splitSelectorNames = map encodeBS . splitc ','++matchDebugSource :: [S.ByteString] -> DebugSource -> Bool+matchDebugSource names (DebugSource s) = any (`S.isInfixOf` s) names
Annex/Drop.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.Drop where  import Annex.Common@@ -22,7 +24,6 @@ import Git.FilePath  import qualified Data.Set as S-import System.Log.Logger (debugM)  type Reason = String @@ -68,7 +69,7 @@ 			else do 				l <- mapM getFileNumMinCopies fs 				return (maximum $ map fst l, maximum $ map snd l)-		return (NumCopies (length have), numcopies, mincopies, S.fromList untrusted)+		return (length have, numcopies, mincopies, S.fromList untrusted)  	{- Check that we have enough copies still to drop the content. 	 - When the remote being dropped from is untrusted, it was not@@ -79,13 +80,14 @@ 	 - avoids doing extra work to do that check later in cases where it 	 - will surely fail. 	 -}-	checkcopies (have, numcopies, _mincopies, _untrusted) Nothing = have > numcopies-	checkcopies (have, numcopies, _mincopies, untrusted) (Just u)-		| S.member u untrusted = have >= numcopies-		| otherwise = have > numcopies+	checkcopies (have, numcopies, mincopies, _untrusted) Nothing =+		NumCopies have > numcopies && MinCopies have > mincopies+	checkcopies (have, numcopies, mincopies, untrusted) (Just u)+		| S.member u untrusted = NumCopies have >= numcopies && MinCopies have >= mincopies+		| otherwise = NumCopies have > numcopies && MinCopies have > mincopies 	 	decrcopies (have, numcopies, mincopies, untrusted) Nothing =-		(NumCopies (fromNumCopies have - 1), numcopies, mincopies, untrusted)+		(have - 1, numcopies, mincopies, untrusted) 	decrcopies v@(_have, _numcopies, _mincopies, untrusted) (Just u) 		| S.member u untrusted = v 		| otherwise = decrcopies v Nothing@@ -115,13 +117,13 @@ 	dodrop n@(have, numcopies, mincopies, _untrusted) u a =  		ifM (safely $ runner $ a numcopies mincopies) 			( do-				liftIO $ debugM "drop" $ unwords+				fastDebug "Annex.Drop" $ unwords 					[ "dropped" 					, case afile of 						AssociatedFile Nothing -> serializeKey key 						AssociatedFile (Just af) -> fromRawFilePath af 					, "(from " ++ maybe "here" show u ++ ")"-					, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"+					, "(copies now " ++ show (have - 1) ++ ")" 					, ": " ++ reason 					] 				return $ decrcopies n u
Annex/ExternalAddonProcess.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.ExternalAddonProcess where  import qualified Annex@@ -14,7 +16,6 @@ import Messages.Progress  import Control.Concurrent.Async-import System.Log.Logger (debugM)  data ExternalAddonProcess = ExternalAddonProcess 	{ externalSend :: Handle@@ -91,7 +92,7 @@ 			"Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"  protocolDebug :: ExternalAddonProcess -> Bool -> String -> IO ()-protocolDebug external sendto line = debugM "external" $ unwords+protocolDebug external sendto line = debug "Annex.ExternalAddonProcess" $ unwords 	[ externalProgram external ++  		"[" ++ show (externalPid external) ++ "]" 	, if sendto then "<--" else "-->"
Annex/Journal.hs view
@@ -4,22 +4,26 @@  - git-annex branch. Among other things, it ensures that if git-annex is  - interrupted, its recorded data is not lost.  -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.Journal where  import Annex.Common+import qualified Annex import qualified Git import Annex.Perms import Annex.Tmp import Annex.LockFile import Utility.Directory.Stream +import qualified Data.Set as S import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as S+import qualified Data.ByteString as B import qualified System.FilePath.ByteString as P import Data.ByteString.Builder import Data.Char@@ -37,6 +41,31 @@ 	writeJournalHandle = hPutBuilder 	journalableByteString = toLazyByteString +{- When a file in the git-annex branch is changed, this indicates what+ - repository UUID (or in some cases, UUIDs) a change is regarding.+ -+ - Using this lets changes regarding private UUIDs be stored separately+ - from the git-annex branch, so its information does not get exposed+ - outside the repo.+ -}+data RegardingUUID = RegardingUUID [UUID]++regardingPrivateUUID :: RegardingUUID -> Annex Bool+regardingPrivateUUID (RegardingUUID []) = pure False+regardingPrivateUUID (RegardingUUID us) = do+	s <- annexPrivateRepos <$> Annex.getGitConfig+	return (any (flip S.member s) us)++{- Are any private UUIDs known to exist? If so, extra work has to be done,+ - to check for information separately recorded for them, outside the usual+ - locations.+ -}+privateUUIDsKnown :: Annex Bool+privateUUIDsKnown = privateUUIDsKnown' <$> Annex.getState id++privateUUIDsKnown' :: Annex.AnnexState -> Bool+privateUUIDsKnown' = not . S.null . annexPrivateRepos . Annex.gitconfig+ {- Records content for a file in the branch to the journal.  -  - Using the journal, rather than immediatly staging content to the index@@ -46,20 +75,26 @@  - getJournalFileStale to always return a consistent journal file  - content, although possibly not the most current one.  -}-setJournalFile :: Journalable content => JournalLocked -> RawFilePath -> content -> Annex ()-setJournalFile _jl file content = withOtherTmp $ \tmp -> do-	createAnnexDirectory =<< fromRepo gitAnnexJournalDir+setJournalFile :: Journalable content => JournalLocked -> RegardingUUID -> RawFilePath -> content -> Annex ()+setJournalFile _jl ru file content = withOtherTmp $ \tmp -> do+	jd <- fromRepo =<< ifM (regardingPrivateUUID ru)+		( return gitAnnexPrivateJournalDir+		, return gitAnnexJournalDir+		)+	createAnnexDirectory jd 	-- journal file is written atomically-	jfile <- fromRepo (journalFile file)-	let tmpfile = fromRawFilePath (tmp P.</> P.takeFileName jfile)+	let jfile = journalFile file+	let tmpfile = fromRawFilePath (tmp P.</> jfile) 	liftIO $ do 		withFile tmpfile WriteMode $ \h -> writeJournalHandle h content-		moveFile tmpfile (fromRawFilePath jfile)+		moveFile tmpfile (fromRawFilePath (jd P.</> jfile))  {- Gets any journalled content for a file in the branch. -}-getJournalFile :: JournalLocked -> RawFilePath -> Annex (Maybe L.ByteString)+getJournalFile :: JournalLocked -> GetPrivate -> RawFilePath -> Annex (Maybe L.ByteString) getJournalFile _jl = getJournalFileStale +data GetPrivate = GetPrivate Bool+ {- Without locking, this is not guaranteed to be the most recent  - version of the file in the journal, so should not be used as a basis for  - changes.@@ -71,47 +106,64 @@  - concurrency or other issues with a lazy read, and the minor loss of  - laziness doesn't matter much, as the files are not very large.  -}-getJournalFileStale :: RawFilePath -> Annex (Maybe L.ByteString)-getJournalFileStale file = inRepo $ \g -> catchMaybeIO $-	L.fromStrict <$> S.readFile (fromRawFilePath $ journalFile file g)+getJournalFileStale :: GetPrivate -> RawFilePath -> Annex (Maybe L.ByteString)+getJournalFileStale (GetPrivate getprivate) file = do+	-- Optimisation to avoid a second MVar access.+	st <- Annex.getState id+	let g = Annex.repo st+	liftIO $+		if getprivate && privateUUIDsKnown' st+		then do+			x <- getfrom (gitAnnexJournalDir g)+			y <- getfrom (gitAnnexPrivateJournalDir g)+			-- This concacenation is the same as happens in a+			-- merge of two git-annex branches.+			return (x <> y)+		else getfrom (gitAnnexJournalDir g)+  where+	jfile = journalFile file+	getfrom d = catchMaybeIO $+		L.fromStrict <$> B.readFile (fromRawFilePath (d P.</> jfile)) -{- List of existing journal files, but without locking, may miss new ones- - just being added, or may have false positives if the journal is staged- - as it is run. -}-getJournalledFilesStale :: Annex [FilePath]-getJournalledFilesStale = do+{- List of existing journal files in a journal directory, but without locking,+ - may miss new ones just being added, or may have false positives if the+ - journal is staged as it is run. -}+getJournalledFilesStale :: (Git.Repo -> RawFilePath) -> Annex [RawFilePath]+getJournalledFilesStale getjournaldir = do 	g <- gitRepo 	fs <- liftIO $ catchDefaultIO [] $-		getDirectoryContents $ fromRawFilePath $ gitAnnexJournalDir g+		getDirectoryContents $ fromRawFilePath (getjournaldir g) 	return $ filter (`notElem` [".", ".."]) $-		map (fromRawFilePath . fileJournal . toRawFilePath) fs+		map (fileJournal . toRawFilePath) fs -withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a-withJournalHandle a = do-	d <- fromRawFilePath <$> fromRepo gitAnnexJournalDir+{- Directory handle open on a journal directory. -}+withJournalHandle :: (Git.Repo -> RawFilePath) -> (DirectoryHandle -> IO a) -> Annex a+withJournalHandle getjournaldir a = do+	d <- fromRawFilePath <$> fromRepo getjournaldir 	bracketIO (openDirectory d) closeDirectory (liftIO . a)  {- Checks if there are changes in the journal. -}-journalDirty :: Annex Bool-journalDirty = do-	d <- fromRawFilePath <$> fromRepo gitAnnexJournalDir+journalDirty :: (Git.Repo -> RawFilePath) -> Annex Bool+journalDirty getjournaldir = do+	d <- fromRawFilePath <$> fromRepo getjournaldir 	liftIO $  		(not <$> isDirectoryEmpty d) 			`catchIO` (const $ doesDirectoryExist d)  {- Produces a filename to use in the journal for a file on the branch.+ - The filename does not include the journal directory.  -  - The journal typically won't have a lot of files in it, so the hashing  - used in the branch is not necessary, and all the files are put directly  - in the journal directory.  -}-journalFile :: RawFilePath -> Git.Repo -> RawFilePath-journalFile file repo = gitAnnexJournalDir' repo P.</> S.concatMap mangle file+journalFile :: RawFilePath -> RawFilePath+journalFile file = B.concatMap mangle file   where 	mangle c-		| P.isPathSeparator c = S.singleton underscore-		| c == underscore = S.pack [underscore, underscore]-		| otherwise = S.singleton c+		| P.isPathSeparator c = B.singleton underscore+		| c == underscore = B.pack [underscore, underscore]+		| otherwise = B.singleton c 	underscore = fromIntegral (ord '_')  {- Converts a journal file (relative to the journal dir) back to the@@ -120,16 +172,16 @@ fileJournal = go   where 	go b = -		let (h, t) = S.break (== underscore) b-		in h <> case S.uncons t of+		let (h, t) = B.break (== underscore) b+		in h <> case B.uncons t of 			Nothing -> t-			Just (_u, t') -> case S.uncons t' of+			Just (_u, t') -> case B.uncons t' of 				Nothing -> t'			 				Just (w, t'') 					| w == underscore ->-						S.cons underscore (go t'')+						B.cons underscore (go t'') 					| otherwise -> -						S.cons P.pathSeparator (go t')+						B.cons P.pathSeparator (go t') 	 	underscore = fromIntegral (ord '_')
Annex/Link.hs view
@@ -204,7 +204,7 @@ 	runner :: Git.Queue.InternalActionRunner Annex 	runner = Git.Queue.InternalActionRunner "restagePointerFile" $ \r l -> do 		liftIO . Database.Keys.Handle.flushDbQueue-			=<< Annex.getState Annex.keysdbhandle+			=<< Annex.getRead Annex.keysdbhandle 		realindex <- liftIO $ Git.Index.currentIndexFile r 		let lock = fromRawFilePath (Git.Index.indexFileLock realindex) 		    lockindex = liftIO $ catchMaybeIO $ Git.LockFile.openLock' lock
Annex/Locations.hs view
@@ -63,10 +63,11 @@ 	gitAnnexFeedState, 	gitAnnexMergeDir, 	gitAnnexJournalDir,-	gitAnnexJournalDir',+	gitAnnexPrivateJournalDir, 	gitAnnexJournalLock, 	gitAnnexGitQueueLock, 	gitAnnexIndex,+	gitAnnexPrivateIndex, 	gitAnnexIndexStatus, 	gitAnnexViewIndex, 	gitAnnexViewLog,@@ -432,9 +433,11 @@ gitAnnexJournalDir r =  	P.addTrailingPathSeparator $ gitAnnexDir r P.</> "journal" -gitAnnexJournalDir' :: Git.Repo -> RawFilePath-gitAnnexJournalDir' r =-	P.addTrailingPathSeparator $ gitAnnexDir r P.</> "journal"+{- .git/annex/journal.private/ is used to journal changes regarding private+ - repositories. -}+gitAnnexPrivateJournalDir :: Git.Repo -> RawFilePath+gitAnnexPrivateJournalDir r = +	P.addTrailingPathSeparator $ gitAnnexDir r P.</> "journal-private"  {- Lock file for the journal. -} gitAnnexJournalLock :: Git.Repo -> RawFilePath@@ -448,6 +451,11 @@ {- .git/annex/index is used to stage changes to the git-annex branch -} gitAnnexIndex :: Git.Repo -> RawFilePath gitAnnexIndex r = gitAnnexDir r P.</> "index"++{- .git/annex/index-private is used to store information that is not to+ - be exposed to the git-annex branch. -}+gitAnnexPrivateIndex :: Git.Repo -> RawFilePath+gitAnnexPrivateIndex r = gitAnnexDir r P.</> "index-private"  {- Holds the ref of the git-annex branch that the index was last updated to.  -
Annex/NumCopies.hs view
@@ -241,9 +241,11 @@ 		then showLongNote $ 			"Could only verify the existence of " ++ 			show (length have) ++ " out of " ++ show (fromNumCopies neednum) ++ -			" necessary copies"+			" necessary " ++ pluralcopies (fromNumCopies neednum) 		else do-			showLongNote $ "Unable to lock down " ++ show (fromMinCopies needmin) ++ " copy of file that is required to safely drop it."+			showLongNote $ "Unable to lock down " ++ show (fromMinCopies needmin) ++ +				" " ++ pluralcopies (fromMinCopies needmin) ++ +				" of file necessary to safely drop it." 			if null lockunsupported 				then showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)" 				else showLongNote $ "These remotes do not support locking: "@@ -251,6 +253,9 @@  	Remote.showTriedRemotes bad 	Remote.showLocations True key (map toUUID have++skip) nolocmsg+  where+	pluralcopies 1 = "copy"+	pluralcopies _ = "copies"  {- Finds locations of a key that can be used to get VerifiedCopies,  - in order to allow dropping the key.
Annex/Ssh.hs view
@@ -219,7 +219,7 @@ 	-- from a previous git-annex run that was interrupted. 	-- This must run only once, before we have made any ssh connection, 	-- and any other prepSocket calls must block while it's run.-	tv <- Annex.getState Annex.sshstalecleaned+	tv <- Annex.getRead Annex.sshstalecleaned 	join $ liftIO $ atomically $ do 		cleaned <- takeTMVar tv 		if cleaned
Annex/Transfer.hs view
@@ -371,7 +371,7 @@ 			else gononconcurrent rs 	 	goconcurrent rs = do-		mv <- Annex.getState Annex.activeremotes+		mv <- Annex.getRead Annex.activeremotes 		active <- liftIO $ takeMVar mv 		let rs' = sortBy (lessActiveFirst active) rs 		goconcurrent' mv active rs'
Annex/TransferrerPool.hs view
@@ -5,6 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} @@ -29,7 +30,6 @@ import Control.Concurrent.Async import Control.Concurrent.STM hiding (check) import Control.Monad.IO.Class (MonadIO)-import System.Log.Logger (debugM) import qualified Data.Map as M #ifndef mingw32_HOST_OS import System.Posix.Signals@@ -50,9 +50,9 @@ withTransferrer :: (Transferrer -> Annex a) -> Annex a withTransferrer a = do 	rt <- mkRunTransferrer nonBatchCommandMaker-	pool <- Annex.getState Annex.transferrerpool+	pool <- Annex.getRead Annex.transferrerpool 	let nocheck = pure (pure True)-	signalactonsvar <- Annex.getState Annex.signalactions+	signalactonsvar <- Annex.getRead Annex.signalactions 	withTransferrer' False signalactonsvar nocheck rt pool a  withTransferrer'@@ -241,7 +241,7 @@ 		(AssistantLevel, Download) -> AssistantDownloadRequest 	let r = f tr (transferKey t) (TransferAssociatedFile afile) 	let l = unwords $ Proto.formatMessage r-	debugM "transfer" ("> " ++ l)+	debug "Annex.TransferrerPool" ("> " ++ l) 	hPutStrLn h l 	hFlush h @@ -249,7 +249,7 @@ sendSerializedOutputResponse h sor = do 	let l = unwords $ Proto.formatMessage $ 		TransferSerializedOutputResponse sor-	debugM "transfer" ("> " ++ show l)+	debug "Annex.TransferrerPool" ("> " ++ show l) 	hPutStrLn h l 	hFlush h @@ -260,7 +260,7 @@ readResponse :: Handle -> IO (Either SerializedOutput Bool) readResponse h = do 	l <- liftIO $ hGetLine h-	debugM "transfer" ("< " ++ l)+	debug "Annex.TransferrerPool" ("< " ++ l) 	case Proto.parseMessage l of 		Just (TransferOutput so) -> return (Left so) 		Just (TransferResult r) -> return (Right r)@@ -279,7 +279,7 @@ {- Stop all transferrers in the pool. -} emptyTransferrerPool :: Annex () emptyTransferrerPool = do-	poolvar <- Annex.getState Annex.transferrerpool+	poolvar <- Annex.getRead Annex.transferrerpool 	pool <- liftIO $ atomically $ swapTVar poolvar [] 	liftIO $ forM_ pool $ \case 		TransferrerPoolItem (Just t) _ -> transferrerShutdown t
Annex/WorkerPool.hs view
@@ -60,7 +60,7 @@  - 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 :: ThreadId -> TMVar (WorkerPool t) -> (UsedStages -> WorkerStage) -> Annex (Maybe WorkerStage) changeStageTo mytid tv getnewstage = liftIO $ 	replaceidle >>= maybe 		(return Nothing)@@ -99,11 +99,11 @@ -- 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 :: TMVar (WorkerPool t) -> STM (Maybe (t, WorkerStage)) waitStartWorkerSlot tv = do 	pool <- takeTMVar tv-	st <- go pool-	return $ Just (st, StartStage)+	v <- go pool+	return $ Just (v, StartStage)   where 	go pool = case spareVals pool of 		[] -> retry@@ -112,10 +112,10 @@ 			putTMVar tv =<< waitIdleWorkerSlot StartStage pool' 			return v -waitIdleWorkerSlot :: WorkerStage -> WorkerPool Annex.AnnexState -> STM (WorkerPool Annex.AnnexState)+waitIdleWorkerSlot :: WorkerStage -> WorkerPool t -> STM (WorkerPool t) waitIdleWorkerSlot wantstage = maybe retry return . getIdleWorkerSlot wantstage -getIdleWorkerSlot :: WorkerStage -> WorkerPool Annex.AnnexState -> Maybe (WorkerPool Annex.AnnexState)+getIdleWorkerSlot :: WorkerStage -> WorkerPool t -> Maybe (WorkerPool t) getIdleWorkerSlot wantstage pool = do 	l <- findidle [] (workerList pool) 	return $ pool { workerList = l }
Assistant.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Assistant where @@ -48,7 +49,6 @@ import qualified Utility.Daemon import Utility.ThreadScheduler import Utility.HumanTime-import qualified BuildInfo import Annex.Perms import Annex.BranchState import Utility.LogFile@@ -57,8 +57,8 @@ import Annex.Path import System.Environment (getArgs) #endif+import qualified Utility.Debug as Debug -import System.Log.Logger import Network.Socket (HostName)  stopDaemon :: Annex ()@@ -76,7 +76,7 @@ 	enableInteractiveBranchAccess 	pidfile <- fromRepo gitAnnexPidFile 	logfile <- fromRepo gitAnnexDaemonLogFile-	liftIO $ debugM desc $ "logging to " ++ fromRawFilePath logfile+	liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile 	createAnnexDirectory (parentDir pidfile) #ifndef mingw32_HOST_OS 	createAnnexDirectory (parentDir logfile)@@ -122,14 +122,11 @@ 			) #endif   where-	desc-		| assistant = "assistant"-		| otherwise = "watch" 	start daemonize webappwaiter = withThreadState $ \st -> do 		checkCanWatch 		dstatus <- startDaemonStatus 		logfile <- fromRepo gitAnnexDaemonLogFile-		liftIO $ debugM desc $ "logging to " ++ fromRawFilePath logfile+		liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile 		liftIO $ daemonize $ 			flip runAssistant (go webappwaiter)  				=<< newAssistantData st dstatus@@ -140,7 +137,6 @@ #else 	go _webappwaiter = do #endif-		notice ["starting", desc, "version", BuildInfo.packageversion] 		urlrenderer <- liftIO newUrlRenderer #ifdef WITH_WEBAPP 		let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun Nothing listenhost webappwaiter ]
Assistant/Common.hs view
@@ -7,7 +7,7 @@  module Assistant.Common (module X) where -import Annex.Common as X+import Annex.Common as X hiding (debug) import Assistant.Monad as X import Assistant.Types.DaemonStatus as X import Assistant.Types.NamedThread as X
Assistant/DaemonStatus.hs view
@@ -221,9 +221,7 @@  {- Returns the alert's identifier, which can be used to remove it. -} addAlert :: Alert -> Assistant AlertId-addAlert alert = do-	notice [showAlert alert]-	notifyAlert `after` modifyDaemonStatus add+addAlert alert = notifyAlert `after` modifyDaemonStatus add   where 	add s = (s { lastAlertId = i, alertMap = m }, i) 	  where
Assistant/Monad.hs view
@@ -22,14 +22,12 @@ 	asIO2, 	ThreadName, 	debug,-	notice ) where  import "mtl" Control.Monad.Reader-import System.Log.Logger import qualified Control.Monad.Fail as Fail -import Annex.Common+import Annex.Common hiding (debug) import Assistant.Types.ThreadedMonad import Assistant.Types.DaemonStatus import Assistant.Types.ScanRemotes@@ -43,6 +41,7 @@ import Assistant.Types.ThreadName import Assistant.Types.RemoteControl import Assistant.Types.CredPairCache+import qualified Utility.Debug as Debug  newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a } 	deriving (@@ -139,12 +138,6 @@ io <<~ v = reader v >>= liftIO . io  debug :: [String] -> Assistant ()-debug = logaction debugM--notice :: [String] -> Assistant ()-notice = logaction noticeM--logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()-logaction a ws = do+debug ws = do 	ThreadName name <- getAssistant threadName-	liftIO $ a name $ unwords $ (name ++ ":") : ws+	liftIO $ Debug.debug (Debug.DebugSource (encodeBS name)) (unwords ws)
Assistant/Pairing/Network.hs view
@@ -119,7 +119,7 @@  - Note that the repository's description is not shown to the user, because  - it could be something like "my repo", which is confusing when pairing  - with someone else's repo. However, this has the same format as the- - default decription of a repo. -}+ - default description of a repo. -} pairRepo :: PairMsg -> String pairRepo msg = concat 	[ remoteUserName d
Assistant/Repair.hs view
@@ -157,5 +157,5 @@ 			go =<< getsizes 		) 	waitforit why = do-		notice ["Waiting for 60 seconds", why]+		debug ["Waiting for 60 seconds", why] 		liftIO $ threadDelaySeconds $ Seconds 60
Assistant/Threads/SanityChecker.hs view
@@ -66,7 +66,7 @@ 	 - all, so detect and repair. -} 	ifM (not <$> liftAnnex (inRepo checkIndexFast)) 		( do-			notice ["corrupt index file found at startup; removing and restaging"]+			debug ["corrupt index file found at startup; removing and restaging"] 			liftAnnex $ inRepo $ removeWhenExistsWith R.removeLink . indexFile 			{- Normally the startup scan avoids re-staging files, 			 - but with the index deleted, everything needs to be@@ -80,7 +80,7 @@ 	 - the data from the git-annex branch will be used, and the index 	 - will be automatically regenerated. -} 	unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do-		notice ["corrupt annex/index file found at startup; removing"]+		debug ["corrupt annex/index file found at startup; removing"] 		liftAnnex $ liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexIndex  	{- Fix up ssh remotes set up by past versions of the assistant. -}@@ -226,7 +226,7 @@ 	logs <- liftIO $ listLogs f 	totalsize <- liftIO $ sum <$> mapM (getFileSize . toRawFilePath) logs 	when (totalsize > 2 * oneMegabyte) $ do-		notice ["Rotated logs due to size:", show totalsize]+		debug ["Rotated logs due to size:", show totalsize] 		liftIO $ openLog f >>= handleToFd >>= redirLog 		when (n < maxLogs + 1) $ do 			df <- liftIO $ getDiskFree $ takeDirectory f
Assistant/Threads/WebApp.hs view
@@ -80,7 +80,7 @@ 		<*> newWormholePairingState 	setUrlRenderer urlrenderer $ yesodRender webapp (pack "") 	app <- toWaiAppPlain webapp-	app' <- ifM debugEnabled+	app' <- ifM (fromMaybe False <$> (getAnnex $ Just . annexDebug <$> Annex.getGitConfig)) 		( return $ logStdout app 		, return app 		)
Assistant/TransferSlots.hs view
@@ -91,9 +91,9 @@   where 	go = catchPauseResume $ do 		p <- runAssistant d $ liftAnnex $ -			Annex.getState Annex.transferrerpool+			Annex.getRead Annex.transferrerpool 		signalactonsvar <- runAssistant d $ liftAnnex $-			Annex.getState Annex.signalactions+			Annex.getRead Annex.signalactions 		withTransferrer' True signalactonsvar mkcheck rt p run 	pause = catchPauseResume $ 		runEvery (Seconds 86400) noop
Assistant/Types/ThreadedMonad.hs view
@@ -15,7 +15,7 @@  {- The Annex state is stored in a MVar, so that threaded actions can access  - it. -}-type ThreadState = MVar Annex.AnnexState+type ThreadState = MVar (Annex.AnnexState, Annex.AnnexRead)  {- Stores the Annex state in a MVar.  -@@ -24,9 +24,10 @@ withThreadState :: (ThreadState -> Annex a) -> Annex a withThreadState a = do 	state <- Annex.getState id-	mvar <- liftIO $ newMVar state+	rd <- Annex.getRead id+	mvar <- liftIO $ newMVar (state, rd) 	r <- a mvar-	newstate <- liftIO $ takeMVar mvar+	newstate <- liftIO $ fst <$> takeMVar mvar 	Annex.changeState (const newstate) 	return r @@ -35,4 +36,5 @@  - This serializes calls by threads; only one thread can run in Annex at a  - time. -} runThreadState :: ThreadState -> Annex a -> IO a-runThreadState mvar a = modifyMVar mvar $ \state -> swap <$> Annex.run state a+runThreadState mvar a = modifyMVar mvar $ \v -> swap <$> Annex.run v a+
Assistant/WebApp/Configurators/Preferences.hs view
@@ -19,7 +19,6 @@ import Config.Files.AutoStart import Annex.NumCopies import Utility.DataUnits-import Git.Config import Types.Distribution import Assistant.Upgrade @@ -31,7 +30,6 @@ 	, numCopies :: Int 	, autoStart :: Bool 	, autoUpgrade :: AutoUpgrade-	, enableDebug :: Bool 	}  prefsAForm :: PrefsForm -> MkAForm PrefsForm@@ -44,12 +42,9 @@ 		"Auto start" (Just $ autoStart d) 	<*> areq (selectFieldList autoUpgradeChoices) 		(bfs autoUpgradeLabel) (Just $ autoUpgrade d)-	<*> areq (checkBoxField `withNote` debugnote)-		"Enable debug logging" (Just $ enableDebug d)   where 	diskreservenote = [whamlet|<br>Avoid downloading files from other repositories when there is too little free disk space.|] 	numcopiesnote = [whamlet|<br>Only drop a file after verifying that other repositories contain this many copies.|]-	debugnote = [whamlet|<a href="@{LogR}">View Log</a>|] 	autostartnote = [whamlet|Start the git-annex assistant at boot or on login.|]  	autoUpgradeChoices :: [(Text, AutoUpgrade)]@@ -86,7 +81,6 @@ 	<*> (fromNumCopies <$> getNumCopies) 	<*> inAutoStartFile 	<*> (annexAutoUpgrade <$> Annex.getGitConfig)-	<*> (annexDebug <$> Annex.getGitConfig)  storePrefs :: PrefsForm -> Annex () storePrefs p = do@@ -99,10 +93,6 @@ 		liftIO $ if autoStart p 			then addAutoStartFile here 			else removeAutoStartFile here-	setConfig (annexConfig "debug") (boolConfig $ enableDebug p)-	liftIO $ if enableDebug p-		then enableDebugOutput -		else disableDebugOutput  getPreferencesR :: Handler Html getPreferencesR = postPreferencesR
Backend/External.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE OverloadedStrings #-}  module Backend.External (makeBackend) where @@ -23,7 +24,6 @@ import Data.Char import Control.Concurrent import System.IO.Unsafe (unsafePerformIO)-import System.Log.Logger (debugM)  newtype ExternalBackendName = ExternalBackendName S.ByteString 	deriving (Show, Eq, Ord)@@ -141,7 +141,7 @@ 		warning ("external special remote error: " ++ err) 		whenunavail 	handleExceptionalMessage loop (DEBUG msg) = do-		liftIO $ debugM "external" msg+		fastDebug "Backend.External" msg 		loop  withExternalAddon :: ExternalState -> a -> (ExternalAddonProcess -> a) -> a
CHANGELOG view
@@ -1,3 +1,36 @@+git-annex (8.20210428) upstream; urgency=medium++  * New annex.private and remote.name.annex-private configs that can+    prevent storing information about a repository and remotes in the+    git-annex branch.+  * initremote: Added --private option to set up a private special remote.+  * importfeed: Made "checking known urls" phase run 12 times faster.+  * Added --debugfilter (and annex.debugfilter)+  * diffdriver: Support unlocked files.+  * forget: Preserve currently exported trees, avoiding problems with+    exporttree remotes in some unusual circumstances.+  * fsck: When downloading content from a remote, if the content is able+    to be verified during the transfer, skip checksumming it a second time.+  * directory: When cp supports reflinks, use it.+  * Avoid excess commits to the git-annex branch when stall detection is+    enabled.+  * git-annex-config: Allow setting annex.securehashesonly, which has+    otherwise been supported since 2019, but was missing from the list of+    allowed repo-global configs.+  * init: Fix a crash when the repo's was cloned from a repo that had an+    adjusted branch checked out, and the origin remote is not named "origin".    +  * Fix some bugs that made git-annex not see recently recorded status+    information when configured with annex.alwayscommit=false.+  * When mincopies is set to a larger value than numcopies, make sure that+    mincopies is satisfied. Before, it assumed a sane configuration would+    have numcopies larger or equal to mincopies. It's still a good idea+    not to configure git-annex this way.+  * Avoid more than 1 gpg password prompt at the same time, which+    could happen occasionally before when concurrency is enabled.+  * Fix build with persistent-2.12.0.1++ -- Joey Hess <id@joeyh.name>  Wed, 28 Apr 2021 12:13:24 -0400+ git-annex (8.20210330) upstream; urgency=medium    * Behavior change: When autoenabling special remotes of type S3, weddav,
CmdLine.hs view
@@ -52,14 +52,15 @@ 	go =<< tryNonAsync getgitrepo   where 	go (Right g) = do-		state <- Annex.new g+		g' <- Git.Config.read g+		(cmd, seek, globalsetter) <- parsewith False cmdparser+			(\a -> a (Just g'))+			O.handleParseResult+		state <- applyAnnexReadSetter globalsetter <$> Annex.new g' 		Annex.eval state $ do 			checkEnvironment 			forM_ fields $ uncurry Annex.setField-			(cmd, seek, globalconfig) <- parsewith False cmdparser-				(\a -> inRepo $ a . Just)-				(liftIO . O.handleParseResult)-			prepRunCommand cmd globalconfig+			prepRunCommand cmd globalsetter 			startup 			performCommandAction cmd seek $ 				shutdown $ cmdnocommit cmd@@ -140,13 +141,16 @@ 		| "-" `isPrefixOf` a = findname as (a:c) 		| otherwise = (Just a, reverse c ++ as) +-- | Note that the GlobalSetter must have already had its annexReadSetter+-- applied before entering the Annex monad to run this; that cannot be+-- changed while running in the Annex monad. prepRunCommand :: Command -> GlobalSetter -> Annex ()-prepRunCommand cmd globalconfig = do+prepRunCommand cmd globalsetter = do 	when (cmdnomessages cmd) $ 		Annex.setOutput QuietOutput-	getParsed globalconfig-	whenM (annexDebug <$> Annex.getGitConfig) $-		liftIO enableDebugOutput+	annexStateSetter globalsetter+	whenM (Annex.getRead Annex.debugenabled) $+		enableDebugOutput  findAddonCommand :: Maybe String -> IO (Maybe Command) findAddonCommand Nothing = return Nothing
CmdLine/Action.hs view
@@ -68,9 +68,10 @@ 		Just tv ->  			liftIO (atomically (waitStartWorkerSlot tv)) >>= 				maybe runnonconcurrent (runconcurrent' tv)-	runconcurrent' tv (workerst, workerstage) = do-		aid <- liftIO $ async $ snd <$> Annex.run workerst-			(concurrentjob workerst)+	runconcurrent' tv (workerstrd, workerstage) = do+		aid <- liftIO $ async $ snd +			<$> Annex.run workerstrd+				(concurrentjob (fst workerstrd)) 		liftIO $ atomically $ do 			pool <- takeTMVar tv 			let !pool' = addWorkerPool (ActiveWorker aid workerstage) pool@@ -78,12 +79,12 @@ 		void $ liftIO $ forkIO $ debugLocks $ do 			-- accountCommandAction will usually catch 			-- exceptions. Just in case, fall back to the-			-- original workerst.-			workerst' <- either (const workerst) id+			-- original workerstrd.+			workerstrd' <- either (const workerstrd) id 				<$> waitCatch aid 			atomically $ do 				pool <- takeTMVar tv-				let !pool' = deactivateWorker pool aid workerst'+				let !pool' = deactivateWorker pool aid workerstrd' 				putTMVar tv pool' 	 	concurrentjob workerst = start >>= \case@@ -133,12 +134,12 @@ 	Nothing -> noop 	Just tv -> do 		Annex.changeState $ \s -> s { Annex.workers = Nothing }-		sts <- liftIO $ atomically $ do+		vs <- liftIO $ atomically $ do 			pool <- readTMVar tv 			if allIdle pool 				then return (spareVals pool) 				else retry-		mapM_ mergeState sts+		mapM_ (mergeState . fst) vs  {- Waits for all worker threads that have been started so far to finish. -} waitForAllRunningCommandActions :: Annex ()@@ -254,8 +255,9 @@ 		Annex.changeState $ \s -> s { Annex.workers = Just tv } 		prepDupState 		st <- dupState+		rd <- Annex.getRead id 		liftIO $ atomically $ putTMVar tv $-			allocateWorkerPool st (max n 1) usedstages+			allocateWorkerPool (st, rd) (max n 1) usedstages  -- Make sure that some expensive actions have been done before -- starting threads. This way the state has them already run,@@ -277,7 +279,7 @@ 	go (Concurrent _) = goconcurrent 	go ConcurrentPerCpu = goconcurrent 	goconcurrent = do-		tv <- Annex.getState Annex.activekeys+		tv <- Annex.getRead Annex.activekeys 		bracket (setup tv) id (const a) 	setup tv = liftIO $ do 		mytid <- myThreadId
CmdLine/GitAnnex/Options.hs view
@@ -43,55 +43,55 @@ -- although not always used. gitAnnexGlobalOptions :: [GlobalOption] gitAnnexGlobalOptions = commonGlobalOptions ++-	[ globalSetter setnumcopies $ option auto+	[ globalOption (setAnnexState . setnumcopies) $ option auto 		( long "numcopies" <> short 'N' <> metavar paramNumber 		<> help "override desired number of copies" 		<> hidden 		)-	, globalSetter setmincopies $ option auto+	, globalOption (setAnnexState . setmincopies) $ option auto 		( long "mincopies" <> short 'N' <> metavar paramNumber 		<> help "override minimum number of copies" 		<> hidden 		)-	, globalSetter (Remote.forceTrust Trusted) $ strOption+	, globalOption (setAnnexState . Remote.forceTrust Trusted) $ strOption 		( long "trust" <> metavar paramRemote 		<> help "deprecated, does not override trust setting" 		<> hidden 		<> completeRemotes 		)-	, globalSetter (Remote.forceTrust SemiTrusted) $ strOption+	, globalOption (setAnnexState . Remote.forceTrust SemiTrusted) $ strOption 		( long "semitrust" <> metavar paramRemote 		<> help "override trust setting back to default" 		<> hidden 		<> completeRemotes 		)-	, globalSetter (Remote.forceTrust UnTrusted) $ strOption+	, globalOption (setAnnexState . Remote.forceTrust UnTrusted) $ strOption 		( long "untrust" <> metavar paramRemote 		<> help "override trust setting to untrusted" 		<> hidden 		<> completeRemotes 		)-	, globalSetter setgitconfig $ strOption+	, globalOption (setAnnexState . setgitconfig) $ strOption 		( long "config" <> short 'c' <> metavar "NAME=VALUE" 		<> help "override git configuration setting" 		<> hidden 		)-	, globalSetter setuseragent $ strOption+	, globalOption (setAnnexState . setuseragent) $ strOption 		( long "user-agent" <> metavar paramName 		<> help "override default User-Agent" 		<> hidden 		)-	, globalFlag (toplevelWarning False "--trust-glacier no longer has any effect")+	, globalFlag (setAnnexState $ toplevelWarning False "--trust-glacier no longer has any effect") 		( long "trust-glacier" 		<> help "deprecated, does not trust Amazon Glacier inventory" 		<> hidden 		)-	, globalFlag (setdesktopnotify mkNotifyFinish)+	, globalFlag (setAnnexState $ setdesktopnotify mkNotifyFinish) 		( long "notify-finish" 		<> help "show desktop notification after transfer finishes" 		<> hidden 		)-	, globalFlag (setdesktopnotify mkNotifyStart)+	, globalFlag (setAnnexState $ setdesktopnotify mkNotifyStart) 		( long "notify-start" 		<> help "show desktop notification after transfer starts" 		<> hidden@@ -241,80 +241,81 @@  keyMatchingOptions' :: [GlobalOption] keyMatchingOptions' = -	[ globalSetter Limit.addIn $ strOption+	[ globalOption (setAnnexState . Limit.addIn) $ strOption 		( long "in" <> short 'i' <> metavar paramRemote 		<> help "match files present in a remote" 		<> hidden 		<> completeRemotes 		)-	, globalSetter Limit.addCopies $ strOption+	, globalOption (setAnnexState . Limit.addCopies) $ strOption 		( long "copies" <> short 'C' <> metavar paramRemote 		<> help "skip files with fewer copies" 		<> hidden 		)-	, globalSetter (Limit.addLackingCopies False) $ strOption+	, globalOption (setAnnexState . Limit.addLackingCopies False) $ strOption 		( long "lackingcopies" <> metavar paramNumber 		<> help "match files that need more copies" 		<> hidden 		)-	, globalSetter (Limit.addLackingCopies True) $ strOption+	, globalOption (setAnnexState . Limit.addLackingCopies True) $ strOption 		( long "approxlackingcopies" <> metavar paramNumber 		<> help "match files that need more copies (faster)" 		<> hidden 		)-	, globalSetter Limit.addInBackend $ strOption+	, globalOption (setAnnexState . Limit.addInBackend) $ strOption 		( long "inbackend" <> short 'B' <> metavar paramName 		<> help "match files using a key-value backend" 		<> hidden 		<> completeBackends 		)-	, globalFlag Limit.addSecureHash+	, globalFlag (setAnnexState Limit.addSecureHash) 		( long "securehash" 		<> help "match files using a cryptographically secure hash" 		<> hidden 		)-	, globalSetter Limit.addInAllGroup $ strOption+	, globalOption (setAnnexState . Limit.addInAllGroup) $ strOption 		( long "inallgroup" <> metavar paramGroup 		<> help "match files present in all remotes in a group" 		<> hidden 		)-	, globalSetter Limit.addMetaData $ strOption+	, globalOption (setAnnexState . Limit.addMetaData) $ strOption 		( long "metadata" <> metavar "FIELD=VALUE" 		<> help "match files with attached metadata" 		<> hidden 		)-	, globalFlag Limit.Wanted.addWantGet+	, globalFlag (setAnnexState Limit.Wanted.addWantGet) 		( long "want-get" 		<> help "match files the repository wants to get" 		<> hidden 		)-	, globalFlag Limit.Wanted.addWantDrop+	, globalFlag (setAnnexState Limit.Wanted.addWantDrop) 		( long "want-drop" 		<> help "match files the repository wants to drop" 		<> hidden 		)-	, globalSetter Limit.addAccessedWithin $ option (eitherReader parseDuration)-		( long "accessedwithin"-		<> metavar paramTime-		<> help "match files accessed within a time interval"-		<> hidden-		)-	, globalSetter Limit.addMimeType $ strOption+	, globalOption (setAnnexState . Limit.addAccessedWithin) $+		option (eitherReader parseDuration)+			( long "accessedwithin"+			<> metavar paramTime+			<> help "match files accessed within a time interval"+			<> hidden+			)+	, globalOption (setAnnexState . Limit.addMimeType) $ strOption 		( long "mimetype" <> metavar paramGlob 		<> help "match files by mime type" 		<> hidden 		)-	, globalSetter Limit.addMimeEncoding $ strOption+	, globalOption (setAnnexState . Limit.addMimeEncoding) $ strOption 		( long "mimeencoding" <> metavar paramGlob 		<> help "match files by mime encoding" 		<> hidden 		)-	, globalFlag Limit.addUnlocked+	, globalFlag (setAnnexState Limit.addUnlocked) 		( long "unlocked" 		<> help "match files that are unlocked" 		<> hidden 		)-	, globalFlag Limit.addLocked+	, globalFlag (setAnnexState Limit.addLocked) 		( long "locked" 		<> help "match files that are locked" 		<> hidden@@ -327,22 +328,22 @@  fileMatchingOptions' :: Limit.LimitBy -> [GlobalOption] fileMatchingOptions' lb =-	[ globalSetter Limit.addExclude $ strOption+	[ globalOption (setAnnexState . Limit.addExclude) $ strOption 		( long "exclude" <> short 'x' <> metavar paramGlob 		<> help "skip files matching the glob pattern" 		<> hidden 		)-	, globalSetter Limit.addInclude $ strOption+	, globalOption (setAnnexState . Limit.addInclude) $ strOption 		( long "include" <> short 'I' <> metavar paramGlob 		<> help "limit to files matching the glob pattern" 		<> hidden 		)-	, globalSetter (Limit.addLargerThan lb) $ strOption+	, globalOption (setAnnexState . Limit.addLargerThan lb) $ strOption 		( long "largerthan" <> metavar paramSize 		<> help "match files larger than a size" 		<> hidden 		)-	, globalSetter (Limit.addSmallerThan lb) $ strOption+	, globalOption (setAnnexState . Limit.addSmallerThan lb) $ strOption 		( long "smallerthan" <> metavar paramSize 		<> help "match files smaller than a size" 		<> hidden@@ -358,17 +359,19 @@ 	, shortopt ')' "close group of options" 	]   where-	longopt o h = globalFlag (Limit.addSyntaxToken o) ( long o <> help h <> hidden )-	shortopt o h = globalFlag (Limit.addSyntaxToken [o]) ( short o <> help h <> hidden )+	longopt o h = globalFlag (setAnnexState $ Limit.addSyntaxToken o)+		( long o <> help h <> hidden )+	shortopt o h = globalFlag (setAnnexState $ Limit.addSyntaxToken [o])+		( short o <> help h <> hidden )  jsonOptions :: [GlobalOption] jsonOptions = -	[ globalFlag (Annex.setOutput (JSONOutput stdjsonoptions))+	[ globalFlag (setAnnexState $ Annex.setOutput (JSONOutput stdjsonoptions)) 		( long "json" <> short 'j' 		<> help "enable JSON output" 		<> hidden 		)-	, globalFlag (Annex.setOutput (JSONOutput jsonerrormessagesoptions))+	, globalFlag (setAnnexState $ Annex.setOutput (JSONOutput jsonerrormessagesoptions)) 		( long "json-error-messages" 		<> help "include error messages in JSON" 		<> hidden@@ -383,7 +386,7 @@  jsonProgressOption :: [GlobalOption] jsonProgressOption = -	[ globalFlag (Annex.setOutput (JSONOutput jsonoptions))+	[ globalFlag (setAnnexState $ Annex.setOutput (JSONOutput jsonoptions)) 		( long "json-progress" 		<> help "include progress in JSON output" 		<> hidden@@ -399,7 +402,7 @@ -- action in `allowConcurrentOutput`. jobsOption :: [GlobalOption] jobsOption = -	[ globalSetter (setConcurrency . ConcurrencyCmdLine) $ +	[ globalOption (setAnnexState . setConcurrency . ConcurrencyCmdLine) $  		option (maybeReader parseConcurrency) 			( long "jobs" <> short 'J'  			<> metavar (paramNumber `paramOr` "cpus")@@ -410,14 +413,14 @@  timeLimitOption :: [GlobalOption] timeLimitOption = -	[ globalSetter settimelimit $ option (eitherReader parseDuration)+	[ globalOption settimelimit $ option (eitherReader parseDuration) 		( long "time-limit" <> short 'T' <> metavar paramTime 		<> help "stop after the specified amount of time" 		<> hidden 		) 	]   where-	settimelimit duration = do+	settimelimit duration = setAnnexState $ do 		start <- liftIO getPOSIXTime 		let cutoff = start + durationToPOSIXTime duration 		Annex.changeState $ \s -> s { Annex.timelimit = Just (duration, cutoff) }@@ -446,8 +449,8 @@ 	r <- maybe (pure Nothing) (Just <$$> Git.Config.read) 		=<< Git.Construct.fromCwd 	return $ filter (input `isPrefixOf`) $-		map remoteKeyToRemoteName $-			filter isRemoteKey $+		mapMaybe remoteKeyToRemoteName $+			filter isRemoteUrlKey $ 				maybe [] (M.keys . config) r 		 completeBackends :: HasCompleter f => Mod f a
CmdLine/GitAnnexShell.hs view
@@ -74,7 +74,7 @@  globalOptions :: [GlobalOption] globalOptions = -	globalSetter checkUUID (strOption+	globalOption (setAnnexState . checkUUID) (strOption 		( long "uuid" <> metavar paramUUID 		<> help "local repository uuid" 		))
CmdLine/GlobalSetter.hs view
@@ -7,19 +7,30 @@    module CmdLine.GlobalSetter where -import Types.DeferredParse import Common import Annex+import Types.DeferredParse  import Options.Applicative -globalFlag :: Annex () -> Mod FlagFields GlobalSetter -> GlobalOption-globalFlag setter = flag' (DeferredParse setter) +setAnnexState :: Annex () -> GlobalSetter+setAnnexState a = GlobalSetter a id -globalSetter :: (v -> Annex ()) -> Parser v -> GlobalOption-globalSetter setter parser = DeferredParse . setter <$> parser+setAnnexRead :: (AnnexRead -> AnnexRead) -> GlobalSetter+setAnnexRead f = GlobalSetter (return ()) f +globalFlag :: GlobalSetter -> Mod FlagFields GlobalSetter -> GlobalOption+globalFlag = flag'++globalOption :: (v -> GlobalSetter) -> Parser v -> GlobalOption+globalOption mk parser = mk <$> parser++-- | Combines a bunch of GlobalOptions together into a Parser+-- that returns a GlobalSetter that can be used to set all the options that+-- are enabled. parserGlobalOptions :: [GlobalOption] -> Parser GlobalSetter-parserGlobalOptions [] = DeferredParse <$> pure noop-parserGlobalOptions l = DeferredParse . mapM_ getParsed-	<$> many (foldl1 (<|>) l)+parserGlobalOptions [] = pure mempty+parserGlobalOptions l = mconcat <$> many (foldl1 (<|>) l)++applyAnnexReadSetter :: GlobalSetter -> (AnnexState, AnnexRead) -> (AnnexState, AnnexRead)+applyAnnexReadSetter gs (st, rd) = (st, annexReadSetter gs rd)
CmdLine/Option.hs view
@@ -20,26 +20,27 @@ import Git.Types (ConfigKey(..)) import Git.Config import Utility.FileSystemEncoding+import Annex.Debug  -- Global options accepted by both git-annex and git-annex-shell sub-commands. commonGlobalOptions :: [GlobalOption] commonGlobalOptions =-	[ globalFlag (setforce True)+	[ globalFlag (setAnnexState $ setforce True) 		( long "force"  		<> help "allow actions that may lose annexed data" 		<> hidden 		)-	, globalFlag (setfast True)+	, globalFlag (setAnnexState $ setfast True) 		( long "fast" <> short 'F' 		<> help "avoid slow operations" 		<> hidden 		)-	, globalFlag (Annex.setOutput QuietOutput)+	, globalFlag (setAnnexState $ Annex.setOutput QuietOutput) 		( long "quiet" <> short 'q' 		<> help "avoid verbose output" 		<> hidden 		)-	, globalFlag (Annex.setOutput NormalOutput)+	, globalFlag (setAnnexState $ Annex.setOutput NormalOutput) 		( long "verbose" <> short 'v' 		<> help "allow verbose output (default)" 		<> hidden@@ -54,7 +55,12 @@ 		<> help "don't show debug messages" 		<> hidden 		)-	, globalSetter setforcebackend $ strOption+	, globalOption setdebugfilter $ strOption+		( long "debugfilter" <> metavar "NAME[,NAME..]"+		<> help "show debug messages coming from a module"+		<> hidden+		)+	, globalOption setforcebackend $ strOption 		( long "backend" <> short 'b' <> metavar paramName 		<> help "specify key-value backend to use" 		<> hidden@@ -62,10 +68,28 @@ 	]   where 	setforce v = Annex.changeState $ \s -> s { Annex.force = v }+ 	setfast v = Annex.changeState $ \s -> s { Annex.fast = v }-	setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }-	-- Overriding this way, rather than just setting annexDebug-	-- makes the config be passed on to any git-annex child processes.-	setdebug b = Annex.addGitConfigOverride $ decodeBS' $-		debugconfig <> "=" <> boolConfig' b++	setforcebackend v = setAnnexState $+		Annex.changeState $ \s -> s { Annex.forcebackend = Just v }+	+	setdebug v = mconcat+		[ setAnnexRead $ \rd -> rd { Annex.debugenabled = v }+		-- Also set in git config so it will be passed on to any+		-- git-annex child processes.+		, setAnnexState $ Annex.addGitConfigOverride $+			decodeBS' $ debugconfig <> "=" <> boolConfig' v+		]+	+	setdebugfilter v = mconcat+		[ setAnnexRead $ \rd -> rd+			{ Annex.debugselector = parseDebugSelector v }+		-- Also set in git config so it will be passed on to any+		-- git-annex child processes.+		, setAnnexState $ Annex.addGitConfigOverride $ +			decodeBS' (debugfilterconfig <> "=") ++ v+		]+	 	(ConfigKey debugconfig) = annexConfig "debug"+	(ConfigKey debugfilterconfig) = annexConfig "debugfilter"
CmdLine/Seek.hs view
@@ -9,8 +9,6 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE TupleSections #-}- module CmdLine.Seek where  import Annex.Common@@ -44,7 +42,6 @@ import Annex.CheckIgnore import Annex.Action import qualified Annex.Branch-import qualified Annex.BranchState import qualified Database.Keys import qualified Utility.RawFilePath as R import Utility.Tuple@@ -274,25 +271,18 @@ 		checktimelimit <- mkCheckTimeLimit 		keyaction <- mkkeyaction 		config <- Annex.getGitConfig-		g <- Annex.gitRepo 		-		void Annex.Branch.update-		(l, cleanup) <- inRepo $ LsTree.lsTree-			LsTree.LsTreeRecursive-			(LsTree.LsTreeLong False)-			Annex.Branch.fullname-		let getk f = fmap (,f) (locationLogFileKey config f)+		let getk = locationLogFileKey config 		let discard reader = reader >>= \case 			Nothing -> noop 			Just _ -> discard reader-		let go reader = liftIO reader >>= \case-			Nothing -> return ()-			Just ((k, f), content) -> checktimelimit (discard reader) $ do-				maybe noop (Annex.BranchState.setCache f) content+		let go reader = reader >>= \case+			Just (k, f, content) -> checktimelimit (discard reader) $ do+				maybe noop (Annex.Branch.precache f) content 				keyaction Nothing (SeekInput [], k, mkActionItem k) 				go reader-		catObjectStreamLsTree l (getk . getTopFilePath . LsTree.file) g go-		liftIO $ void cleanup+			Nothing -> return ()+		Annex.Branch.overBranchFileContents getk go  	runkeyaction getks = do 		keyaction <- mkkeyaction@@ -383,7 +373,7 @@ 	liftIO $ void cleanup   where 	finisher mi oreader checktimelimit = liftIO oreader >>= \case-		Just ((si, f), content) -> checktimelimit discard $ do+		Just ((si, f), content) -> checktimelimit (liftIO discard) $ do 			keyaction f mi content $  				commandAction . startAction seeker si f 			finisher mi oreader checktimelimit@@ -394,8 +384,8 @@ 			Just _ -> discard  	precachefinisher mi lreader checktimelimit = liftIO lreader >>= \case-		Just ((logf, (si, f), k), logcontent) -> checktimelimit discard $ do-			maybe noop (Annex.BranchState.setCache logf) logcontent+		Just ((logf, (si, f), k), logcontent) -> checktimelimit (liftIO discard) $ do+			maybe noop (Annex.Branch.precache logf) logcontent 			checkMatcherWhen mi 				(matcherNeedsLocationLog mi && not (matcherNeedsFileName mi)) 				(MatchingFile $ FileInfo f f (Just k))@@ -601,9 +591,9 @@ notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus f  {- Returns an action that, when there's a time limit, can be used- - to check it before processing a file. The IO action is run when over the- - time limit. -}-mkCheckTimeLimit :: Annex (IO () -> Annex () -> Annex ())+ - to check it before processing a file. The first action is run when over the+ - time limit, otherwise the second action is run. -}+mkCheckTimeLimit :: Annex (Annex () -> Annex () -> Annex ()) mkCheckTimeLimit = Annex.getState Annex.timelimit >>= \case 	Nothing -> return $ \_ a -> a 	Just (duration, cutoff) -> return $ \cleanup a -> do@@ -612,6 +602,6 @@ 			then do 				warning $ "Time limit (" ++ fromDuration duration ++ ") reached! Shutting down..." 				shutdown True-				liftIO cleanup+				cleanup 				liftIO $ exitWith $ ExitFailure 101 			else a
Command/DiffDriver.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -77,8 +77,12 @@  {- Check if either file is a symlink to a git-annex object,  - which git-diff will leave as a normal file containing the link text.- - Adjust the Req to instead point to the actual location of the annexed- - object (which may or may not exist). -}+ -+ - Also check if either file is a pointer file, as used for unlocked files.+ -+ - In either case, adjust the Req to instead point to the actual+ - location of the annexed object (which may or may not be present).+ -} fixupReq :: Req -> Annex Req fixupReq req@(UnmergedReq {}) = return req fixupReq req@(Req {}) = @@ -87,12 +91,13 @@   where 	check getfile getmode setfile r = case readTreeItemType (encodeBS' (getmode r)) of 		Just TreeSymlink -> do-			v <- getAnnexLinkTarget' (toRawFilePath (getfile r)) False-			case parseLinkTargetOrPointer =<< v of-				Nothing -> return r-				Just k -> withObjectLoc k $-					pure . setfile r . fromRawFilePath-		_ -> return r+			v <- getAnnexLinkTarget' f False+			maybe (return r) repoint (parseLinkTargetOrPointer =<< v)+		_ -> maybe (return r) repoint =<< liftIO (isPointerFile f)+	  where+		repoint k = withObjectLoc k $+			pure . setfile r . fromRawFilePath+		f = toRawFilePath (getfile r)  externalDiffer :: String -> [String] -> Differ externalDiffer c ps = \req -> boolSystem c (map Param ps ++ serializeReq req )
Command/Drop.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.Drop where  import Command@@ -19,7 +21,6 @@ import Annex.Wanted import Annex.Notification -import System.Log.Logger (debugM) import qualified Data.Set as S  cmd :: Command@@ -113,7 +114,7 @@ 	(tocheck, verified) <- verifiableCopies key [u] 	doDrop u (Just contentlock) key afile numcopies mincopies [] (preverified ++ verified) tocheck 		( \proof -> do-			liftIO $ debugM "drop" $ unwords+			fastDebug "Command.Drop" $ unwords 				[ "Dropping from here" 				, "proof:" 				, show proof@@ -140,7 +141,7 @@ 	(tocheck, verified) <- verifiableCopies key [uuid] 	doDrop uuid Nothing key afile numcopies mincopies [uuid] verified tocheck 		( \proof -> do -			liftIO $ debugM "drop" $ unwords+			fastDebug "Command.Drop" $ unwords 				[ "Dropping from remote" 				, show remote 				, "proof:"
Command/Forget.hs view
@@ -47,7 +47,7 @@  perform :: Transitions -> Bool -> CommandPerform perform ts True = do-	recordTransitions Branch.change ts+	recordTransitions (Branch.change (Branch.RegardingUUID [])) ts 	-- get branch committed before contining with the transition 	_ <- Branch.update 	void $ Branch.performTransitions ts True []
Command/Fsck.hs view
@@ -156,17 +156,20 @@ 	dispatch (Right True) = withtmp $ \tmpfile -> 		getfile tmpfile >>= \case 			Nothing -> go True Nothing-			Just True -> go True (Just tmpfile)-			Just False -> do+			Just (Right verification) -> go True (Just (tmpfile, verification))+			Just (Left _) -> do 				warning "failed to download file from remote" 				void $ go True Nothing 				return False 	dispatch (Right False) = go False Nothing-	go present localcopy = check+	go present lv = check 		[ verifyLocationLogRemote key ai remote present 		, verifyRequiredContent key ai-		, withLocalCopy localcopy $ checkKeySizeRemote key remote ai-		, withLocalCopy localcopy $ checkBackendRemote backend key remote ai+		, withLocalCopy (fmap fst lv) $ checkKeySizeRemote key remote ai+		, case fmap snd lv of+			Just Verified -> return True+			_ -> withLocalCopy (fmap fst lv) $+				checkBackendRemote backend key remote ai 		, checkKeyNumCopies key afile numcopies 		] 	ai = mkActionItem (key, afile)@@ -185,13 +188,13 @@ 		cleanup `after` a tmp 	getfile tmp = ifM (checkDiskSpace (Just (P.takeDirectory tmp)) key 0 True) 		( ifM (getcheap tmp)-			( return (Just True)+			( return (Just (Right UnVerified)) 			, ifM (Annex.getState Annex.fast) 				( return Nothing-				, Just . isRight <$> tryNonAsync (getfile' tmp)+				, Just <$> tryNonAsync (getfile' tmp) 				) 			)-		, return (Just False)+		, return Nothing 		) 	getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) dummymeter 	dummymeter _ = noop
Command/ImportFeed.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ - Copyright 2013-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -20,8 +20,6 @@ import Data.Time.Calendar import Data.Time.LocalTime import qualified Data.Text as T-import System.Log.Logger-import Control.Concurrent.Async import qualified System.FilePath.ByteString as P  import Command@@ -46,10 +44,8 @@ import Annex.FileMatcher import Command.AddUrl (addWorkTree) import Annex.UntrustedFilePath-import qualified Git.Ref import qualified Annex.Branch import Logs-import Git.CatFile (catObjectStream)  cmd :: Command cmd = notBareRepo $@@ -96,13 +92,13 @@ 						)   where 	debugfeedcontent feedcontent msg = do-		liftIO $ debugM "feed content" $ unlines+		fastDebug "Command.ImportFeed" $ unlines 			[ "start of feed content" 			, feedcontent 			, "end of feed content" 			] 		showEndResult =<< feedProblem url-			(msg ++ " (use --debug to see the feed content that was downloaded)")+			(msg ++ " (use --debug --debugfilter=ImportFeed to see the feed content that was downloaded)")  data ToDownload = ToDownload 	{ feed :: Feed@@ -126,41 +122,38 @@ 	( ret S.empty S.empty 	, do 		showStart "importfeed" "checking known urls" (SeekInput [])-		(is, us) <- unzip <$> knownItems+		(us, is) <- knownItems 		showEndOk-		ret (S.fromList us) (S.fromList (concat is))+		ret (S.fromList us) (S.fromList is) 	)   where 	tmpl = Utility.Format.gen $ fromMaybe defaultTemplate opttemplate 	ret us is = return $ Cache us is tmpl -knownItems :: Annex [([ItemId], URLString)]-knownItems = do-	g <- Annex.gitRepo-	config <- Annex.getGitConfig-	catObjectStream g $ \catfeeder catcloser catreader -> do-		rt <- liftIO $ async $ reader catreader []-		withKnownUrls (feeder config catfeeder catcloser)-		liftIO (wait rt)+{- Scan all url logs and metadata logs in the branch and find urls+ - and ItemIds that are already known. -}+knownItems :: Annex ([URLString], [ItemId])+knownItems = Annex.Branch.overBranchFileContents select (go [] [])   where-	feeder config catfeeder catcloser urlreader = urlreader >>= \case-		Just (k, us) -> do-			forM_ us $ \u ->-				let logf = metaDataLogFile config k-				    ref = Git.Ref.branchFileRef Annex.Branch.fullname logf-				in liftIO $ catfeeder (u, ref)-			feeder config catfeeder catcloser urlreader-		Nothing -> liftIO catcloser-	-	reader catreader c = catreader >>= \case-		Just (u, Just mdc) ->-			let !itemids = S.toList $ S.filter (/= noneValue) $-				S.map (decodeBS . fromMetaValue) $-					currentMetaDataValues itemIdField $-						parseCurrentMetaData mdc-			in reader catreader ((itemids,u):c)-		Just (u, Nothing) -> reader catreader (([],u):c)-		Nothing -> return c+	select f+		| isUrlLog f = Just ()+		| isMetaDataLog f = Just ()+		| otherwise = Nothing++	go uc ic reader = reader >>= \case+		Just ((), f, Just content)+			| isUrlLog f -> case parseUrlLog content of+				[] -> go uc ic reader+				us -> go (us++uc) ic reader+			| isMetaDataLog f ->+				let s = currentMetaDataValues itemIdField $+					parseCurrentMetaData content+				in if S.null s+					then go uc ic reader+					else go uc (map (decodeBS . fromMetaValue) (S.toList s)++ic) reader+			| otherwise -> go uc ic reader+		Just ((), _, Nothing) -> go uc ic reader+		Nothing -> return (uc, ic)  findDownloads :: URLString -> Feed -> [ToDownload] findDownloads u f = catMaybes $ map mk (feedItems f)
Command/InitRemote.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -34,6 +34,7 @@ 	{ cmdparams :: CmdParams 	, sameas :: Maybe (DeferredParse UUID) 	, whatElse :: Bool+	, privateRemote :: Bool 	}  optParser :: CmdParamsDesc -> Parser InitRemoteOptions@@ -45,6 +46,10 @@ 		<> short 'w' 		<> help "describe other configuration parameters for a special remote" 		)+	<*> switch+		( long "private"+		<> help "keep special remote information out of git-annex branch"+		)  parseSameasOption :: Parser (DeferredParse UUID) parseSameasOption = parseUUIDOption <$> strOption@@ -85,6 +90,8 @@  perform :: RemoteType -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform perform t name c o = do+	when (privateRemote o) $+		setConfig (remoteAnnexConfig c "private") (boolConfig True) 	dummycfg <- liftIO dummyRemoteGitConfig 	let c' = M.delete uuidField c 	(c'', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) Nothing c' dummycfg
Command/Move.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.Move where  import Command@@ -19,7 +21,6 @@ import Logs.File import Annex.NumCopies -import System.Log.Logger (debugM) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L @@ -175,7 +176,7 @@ 				DropWorse -> faileddrophere setpresentremote 	showproof proof = "proof: " ++ show proof 	drophere setpresentremote contentlock reason = do-		liftIO $ debugM "move" $ unwords+		fastDebug "Command.Move" $ unwords 			[ "Dropping from here" 			, "(" ++ reason ++ ")" 			]@@ -255,7 +256,7 @@ 	showproof proof = "proof: " ++ show proof 	 	dropremote reason = do-		liftIO $ debugM "move" $ unwords+		fastDebug "Command.Move" $ unwords 			[ "Dropping from remote" 			, show src 			, "(" ++ reason ++ ")"
Command/SendKey.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.SendKey where  import Command@@ -15,8 +17,6 @@ import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered -import System.Log.Logger- cmd :: Command cmd = noCommit $  	command "sendkey" SectionPlumbing @@ -45,14 +45,14 @@  fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart fieldTransfer direction key a = do-	liftIO $ debugM "fieldTransfer" "transfer start"+	fastDebug "Command.SendKey" "transfer start" 	afile <- AssociatedFile . (fmap toRawFilePath) 		<$> Fields.getField Fields.associatedFile 	ok <- maybe (a $ const noop) 		-- Using noRetry here because we're the sender. 		(\u -> runner (Transfer direction (toUUID u) (fromKey id key)) afile Nothing noRetry a) 		=<< Fields.getField Fields.remoteUUID-	liftIO $ debugM "fieldTransfer" "transfer done"+	fastDebug "Command.SendKey" "transfer done" 	liftIO $ exitBool ok   where 	{- Allow the key to be sent to the remote even if there seems to be
Command/TestRemote.hs view
@@ -102,7 +102,9 @@  perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform perform drs unavailr exportr ks = do-	st <- liftIO . newTVarIO =<< Annex.getState id+	st <- liftIO . newTVarIO =<< (,)+		<$> Annex.getState id+		<*> Annex.getRead id 	let tests = testGroup "Remote Tests" $ mkTestTrees 		(runTestCase st)  		drs@@ -198,7 +200,7 @@  type RunAnnex = forall a. Annex a -> IO a -runTestCase :: TVar Annex.AnnexState -> RunAnnex+runTestCase :: TVar (Annex.AnnexState, Annex.AnnexRead) -> RunAnnex runTestCase stv a = do 	st <- atomically $ readTVar stv 	(r, st') <- Annex.run st $ do@@ -249,6 +251,12 @@ 		lockContentForRemoval k noop removeAnnex 		get r k 	, check "fsck downloaded object" fsck+	, check "retrieveKeyFile resume from 0" $ \r k -> do+		tmp <- fromRawFilePath <$> prepTmp k+		liftIO $ writeFile tmp ""+		lockContentForRemoval k noop removeAnnex+		get r k+	, check "fsck downloaded object" fsck 	, check "retrieveKeyFile resume from 33%" $ \r k -> do 		loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) 		tmp <- fromRawFilePath <$> prepTmp k@@ -256,12 +264,6 @@ 			sz <- hFileSize h 			L.hGet h $ fromInteger $ sz `div` 3 		liftIO $ L.writeFile tmp partial-		lockContentForRemoval k noop removeAnnex-		get r k-	, check "fsck downloaded object" fsck-	, check "retrieveKeyFile resume from 0" $ \r k -> do-		tmp <- fromRawFilePath <$> prepTmp k-		liftIO $ writeFile tmp "" 		lockContentForRemoval k noop removeAnnex 		get r k 	, check "fsck downloaded object" fsck
Database/Handle.hs view
@@ -26,7 +26,7 @@ import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)-import Control.Monad.Logger (MonadLogger)+import Control.Monad.Logger (MonadLoggerIO, askLoggerIO) import Control.Concurrent import Control.Concurrent.Async import Control.Exception (throwIO, BlockedIndefinitelyOnMVar(..))@@ -245,7 +245,7 @@ -- Like withSqlConn, but more robust. withSqlConnRobustly 	:: (MonadUnliftIO m-		, MonadLogger m+		, MonadLoggerIO m 		, IsPersistBackend backend 		, BaseBackend backend ~ SqlBackend 		, BackendCompatible SqlBackend backend@@ -254,7 +254,7 @@ 	-> (backend -> m a) 	-> m a withSqlConnRobustly open f = do-	logFunc <- askLogFunc+	logFunc <- askLoggerIO 	withRunInIO $ \run -> bracket 		(open logFunc) 		closeRobustly
Database/Keys.hs view
@@ -63,7 +63,7 @@  -} runReader :: Monoid v => (SQL.ReadHandle -> Annex v) -> Annex v runReader a = do-	h <- Annex.getState Annex.keysdbhandle+	h <- Annex.getRead Annex.keysdbhandle 	withDbState h go   where 	go DbUnavailable = return (mempty, DbUnavailable)@@ -87,7 +87,7 @@  - The database is created if it doesn't exist yet. -} runWriter :: (SQL.WriteHandle -> Annex ()) -> Annex () runWriter a = do-	h <- Annex.getState Annex.keysdbhandle+	h <- Annex.getRead Annex.keysdbhandle 	withDbState h go   where 	go st@(DbOpen qh) = do@@ -144,7 +144,7 @@  - data to it.  -} closeDb :: Annex ()-closeDb = liftIO . closeDbHandle =<< Annex.getState Annex.keysdbhandle+closeDb = liftIO . closeDbHandle =<< Annex.getRead Annex.keysdbhandle  addAssociatedFile :: Key -> TopFilePath -> Annex () addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile k f
Git/Construct.hs view
@@ -133,11 +133,11 @@  {- Calculates a list of a repo's configured remotes, by parsing its config. -} fromRemotes :: Repo -> IO [Repo]-fromRemotes repo = mapM construct remotepairs+fromRemotes repo = catMaybes <$> mapM construct remotepairs   where 	filterconfig f = filter f $ M.toList $ config repo 	filterkeys f = filterconfig (\(k,_) -> f k)-	remotepairs = filterkeys isRemoteKey+	remotepairs = filterkeys isRemoteUrlKey 	construct (k,v) = remoteNamedFromKey k $ 		fromRemoteLocation (fromConfigValue v) repo @@ -149,8 +149,10 @@  {- Sets the name of a remote based on the git config key, such as  - "remote.foo.url". -}-remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo-remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName+remoteNamedFromKey :: ConfigKey -> IO Repo -> IO (Maybe Repo)+remoteNamedFromKey k r = case remoteKeyToRemoteName k of+	Nothing -> pure Nothing+	Just n -> Just <$> remoteNamed n r  {- Constructs a new Repo for one of a Repo's remotes using a given  - location (ie, an url). -}
Git/Remote.hs view
@@ -1,6 +1,6 @@ {- git remote stuff  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -23,14 +23,22 @@ import Git.FilePath #endif -{- Is a git config key one that specifies the location of a remote? -}-isRemoteKey :: ConfigKey -> Bool-isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k+{- Is a git config key one that specifies the url of a remote? -}+isRemoteUrlKey :: ConfigKey -> Bool+isRemoteUrlKey = isRemoteKey "url" -{- Get a remote's name from the config key that specifies its location. -}-remoteKeyToRemoteName :: ConfigKey -> RemoteName-remoteKeyToRemoteName (ConfigKey k) = decodeBS' $-	S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k+isRemoteKey :: S.ByteString -> ConfigKey -> Bool+isRemoteKey want (ConfigKey k) =+	"remote." `S.isPrefixOf` k && ("." <> want) `S.isSuffixOf` k++{- Get a remote's name from the a config key such as remote.name.url+ - or any other per-remote config key. -}+remoteKeyToRemoteName :: ConfigKey -> Maybe RemoteName+remoteKeyToRemoteName (ConfigKey k)+	| "remote." `S.isPrefixOf` k = +		let n = S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k+		in if S.null n then Nothing else Just (decodeBS' n)+	| otherwise = Nothing  {- Construct a legal git remote name out of an arbitrary input string.  -
Logs.hs view
@@ -139,6 +139,11 @@ exportLog :: RawFilePath exportLog = "export.log" +{- This is not a log file, it's where exported treeishes get grafted into+ - the git-annex branch. -}+exportTreeGraftPoint :: RawFilePath+exportTreeGraftPoint = "export.tree"+ {- The pathname of the location log file for a given key. -} locationLogFile :: GitConfig -> Key -> RawFilePath locationLogFile config key =
Logs/Activity.hs view
@@ -28,7 +28,7 @@ recordActivity :: Activity -> UUID -> Annex () recordActivity act uuid = do 	c <- currentVectorClock-	Annex.Branch.change activityLog $+	Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) activityLog $ 		buildLogOld buildActivity 			. changeLog c uuid (Right act) 			. parseLogOld parseActivity
Logs/Chunk.hs view
@@ -37,8 +37,10 @@ chunksStored u k chunkmethod chunkcount = do 	c <- currentVectorClock 	config <- Annex.getGitConfig-	Annex.Branch.change (chunkLogFile config k) $-		buildLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog+	Annex.Branch.change+		(Annex.Branch.RegardingUUID [u])+		(chunkLogFile config k)+		(buildLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog)  chunksRemoved :: UUID -> Key -> ChunkMethod -> Annex () chunksRemoved u k chunkmethod = chunksStored u k chunkmethod 0
Logs/Config.hs view
@@ -35,7 +35,7 @@ setGlobalConfig' :: ConfigKey -> ConfigValue -> Annex () setGlobalConfig' name new = do 	c <- currentVectorClock-	Annex.Branch.change configLog $ +	Annex.Branch.change (Annex.Branch.RegardingUUID []) configLog $  		buildGlobalConfig . changeMapLog c name new . parseGlobalConfig  unsetGlobalConfig :: ConfigKey -> Annex ()
Logs/ContentIdentifier.hs view
@@ -32,8 +32,10 @@ recordContentIdentifier (RemoteStateHandle u) cid k = do 	c <- currentVectorClock 	config <- Annex.getGitConfig-	Annex.Branch.maybeChange (remoteContentIdentifierLogFile config k) $-		addcid c . parseLog+	Annex.Branch.maybeChange+		(Annex.Branch.RegardingUUID [u])+		(remoteContentIdentifierLogFile config k)+		(addcid c . parseLog)   where 	addcid c v 		| cid `elem` l = Nothing -- no change needed
Logs/Difference.hs view
@@ -26,7 +26,7 @@ recordDifferences :: Differences -> UUID -> Annex () recordDifferences ds@(Differences {}) uuid = do 	c <- currentVectorClock-	Annex.Branch.change differenceLog $+	Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) differenceLog $ 		buildLogOld byteString  			. changeLog c uuid (encodeBS $ showDifferences ds)  			. parseLogOld A.takeByteString
Logs/Export.hs view
@@ -30,6 +30,7 @@ import Git.Sha import Git.FilePath import Logs+import Logs.Export.Pure import Logs.MapLog import Logs.File import qualified Git.LsTree@@ -37,49 +38,13 @@ import Annex.UUID  import qualified Data.ByteString.Lazy as L-import qualified Data.Attoparsec.ByteString.Lazy as A-import qualified Data.Attoparsec.ByteString.Char8 as A8-import Data.ByteString.Builder import Data.Either import Data.Char --- This constuctor is not itself exported to other modules, to enforce--- consistent use of exportedTreeishes.-data Exported = Exported-	{ exportedTreeish :: Git.Ref-	, incompleteExportedTreeish :: [Git.Ref]-	}-	deriving (Eq, Show)--mkExported :: Git.Ref -> [Git.Ref] -> Exported-mkExported = Exported---- | Get the list of exported treeishes.------ If the list contains multiple items, there was an export conflict,--- and different trees were exported to the same special remote.-exportedTreeishes :: [Exported] -> [Git.Ref]-exportedTreeishes = nub . map exportedTreeish---- | Treeishes that started to be exported, but were not finished.-incompleteExportedTreeishes :: [Exported] -> [Git.Ref]-incompleteExportedTreeishes = concatMap incompleteExportedTreeish--data ExportParticipants = ExportParticipants-	{ exportFrom :: UUID-	, exportTo :: UUID-	}-	deriving (Eq, Ord, Show)--data ExportChange = ExportChange-	{ oldTreeish :: [Git.Ref]-	, newTreeish :: Git.Ref-	}- -- | Get what's been exported to a special remote. getExport :: UUID -> Annex [Exported]-getExport remoteuuid = nub . mapMaybe get . M.toList . simpleMap -	. parseExportLog+getExport remoteuuid = nub . mapMaybe get . M.toList+	. parseExportLogMap 	<$> Annex.Branch.get exportLog   where 	get (ep, exported)@@ -95,25 +60,25 @@ 	c <- currentVectorClock 	u <- getUUID 	let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }-	old <- fromMaybe (Exported emptyTree [])-		. M.lookup ep . simpleMap -		. parseExportLog+	old <- fromMaybe (mkExported emptyTree [])+		. M.lookup ep+		. parseExportLogMap 		<$> Annex.Branch.get exportLog-	let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) }-	Annex.Branch.change exportLog $-		buildExportLog -			. changeMapLog c ep new-			. parseExportLog+	let new = updateIncompleteExportedTreeish old (nub (newtree:incompleteExportedTreeishes [old]))+	Annex.Branch.change+		(Annex.Branch.RegardingUUID [remoteuuid, u])+		exportLog+		(buildExportLog . changeMapLog c ep new . parseExportLog) 	recordExportTreeish newtree --- Grade a tree ref into the git-annex branch. This is done+-- Graft a tree ref into the git-annex branch. This is done -- to ensure that it's available later, when getting exported files -- from the remote. Since that could happen in another clone of the -- repository, the tree has to be kept available, even if it -- doesn't end up being merged into the master branch. recordExportTreeish :: Git.Ref -> Annex () recordExportTreeish t = -	Annex.Branch.rememberTreeish t (asTopFilePath "export.tree")+	Annex.Branch.rememberTreeish t (asTopFilePath exportTreeGraftPoint)  -- | Record that an export to a special remote is under way. --@@ -128,18 +93,16 @@ recordExportUnderway :: UUID -> ExportChange -> Annex () recordExportUnderway remoteuuid ec = do 	c <- currentVectorClock-	u <- getUUID-	let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }-	let exported = Exported (newTreeish ec) []-	Annex.Branch.change exportLog $+	hereuuid <- getUUID+	let ep = ExportParticipants { exportFrom = hereuuid, exportTo = remoteuuid }+	let exported = mkExported (newTreeish ec) []+	Annex.Branch.change+		(Annex.Branch.RegardingUUID [remoteuuid, hereuuid]) +		exportLog $ 		buildExportLog 			. changeMapLog c ep exported -			. M.mapWithKey (updateothers c u)+			. M.mapWithKey (updateForExportChange remoteuuid ec c hereuuid) 			. parseExportLog-  where-	updateothers c u ep le@(LogEntry _ exported@(Exported { exportedTreeish = t }))-		| u == exportFrom ep || remoteuuid /= exportTo ep || t `notElem` oldTreeish ec = le-		| otherwise = LogEntry c (exported { exportedTreeish = newTreeish ec })  -- Record information about the export to the git-annex branch. --@@ -151,37 +114,6 @@ 	when (oldTreeish ec /= [tree]) $ 		recordExportTreeish tree 	recordExportUnderway remoteuuid ec--parseExportLog :: L.ByteString -> MapLog ExportParticipants Exported-parseExportLog = parseMapLog exportParticipantsParser exportedParser--buildExportLog :: MapLog ExportParticipants Exported -> Builder-buildExportLog = buildMapLog buildExportParticipants buildExported--buildExportParticipants :: ExportParticipants -> Builder-buildExportParticipants ep = -	buildUUID (exportFrom ep) <> sep <> buildUUID (exportTo ep)-  where-	sep = charUtf8 ':'--exportParticipantsParser :: A.Parser ExportParticipants-exportParticipantsParser = ExportParticipants-	<$> (toUUID <$> A8.takeWhile1 (/= ':'))-	<* A8.char ':'-	<*> (toUUID <$> A8.takeWhile1 (const True))--buildExported :: Exported -> Builder-buildExported exported = go (exportedTreeish exported : incompleteExportedTreeish exported)-  where-	go [] = mempty-	go (r:rs) = rref r <> mconcat [ charUtf8 ' ' <> rref r' | r' <- rs ]-	rref = byteString . Git.fromRef'--exportedParser :: A.Parser Exported-exportedParser = Exported <$> refparser <*> many refparser-  where-	refparser = (Git.Ref <$> A8.takeWhile1 (/= ' ') )-		<* ((const () <$> A8.char ' ') <|> A.endOfInput)  logExportExcluded :: UUID -> ((Git.Tree.TreeItem -> IO ()) -> Annex a) -> Annex a logExportExcluded u a = do
+ Logs/Export/Pure.hs view
@@ -0,0 +1,116 @@+{- git-annex export log (also used to log imports), pure operations+ -+ - Copyright 2017-2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Logs.Export.Pure (+	Exported,+	mkExported,+	updateExportedTreeish,+	updateIncompleteExportedTreeish,+	ExportParticipants(..),+	ExportChange(..),+	exportedTreeishes,+	incompleteExportedTreeishes,+	parseExportLog,+	parseExportLogMap,+	buildExportLog,+	updateForExportChange,+) where++import Annex.Common+import qualified Git+import Logs.MapLog++import qualified Data.Map as M+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import Data.ByteString.Builder++-- This constuctor is not itself exported to other modules, to enforce+-- consistent use of exportedTreeishes.+data Exported = Exported+	{ exportedTreeish :: Git.Ref+	, incompleteExportedTreeish :: [Git.Ref]+	}+	deriving (Eq, Show)++mkExported :: Git.Ref -> [Git.Ref] -> Exported+mkExported = Exported++updateExportedTreeish :: Exported -> Git.Ref -> Exported+updateExportedTreeish ex t = ex { exportedTreeish = t }++updateIncompleteExportedTreeish :: Exported -> [Git.Ref] -> Exported+updateIncompleteExportedTreeish ex t = ex { incompleteExportedTreeish = t }++-- | Get the list of exported treeishes.+--+-- If the list contains multiple items, there was an export conflict,+-- and different trees were exported to the same special remote.+exportedTreeishes :: [Exported] -> [Git.Ref]+exportedTreeishes = nub . map exportedTreeish++-- | Treeishes that started to be exported, but were not finished.+incompleteExportedTreeishes :: [Exported] -> [Git.Ref]+incompleteExportedTreeishes = concatMap incompleteExportedTreeish++data ExportParticipants = ExportParticipants+	{ exportFrom :: UUID+	, exportTo :: UUID+	}+	deriving (Eq, Ord, Show)++data ExportChange = ExportChange+	{ oldTreeish :: [Git.Ref]+	, newTreeish :: Git.Ref+	}++parseExportLog :: L.ByteString -> MapLog ExportParticipants Exported+parseExportLog = parseMapLog exportParticipantsParser exportedParser++parseExportLogMap :: L.ByteString -> M.Map ExportParticipants Exported+parseExportLogMap = simpleMap . parseExportLog++buildExportLog :: MapLog ExportParticipants Exported -> Builder+buildExportLog = buildMapLog buildExportParticipants buildExported++buildExportParticipants :: ExportParticipants -> Builder+buildExportParticipants ep = +	buildUUID (exportFrom ep) <> sep <> buildUUID (exportTo ep)+  where+	sep = charUtf8 ':'++exportParticipantsParser :: A.Parser ExportParticipants+exportParticipantsParser = ExportParticipants+	<$> (toUUID <$> A8.takeWhile1 (/= ':'))+	<* A8.char ':'+	<*> (toUUID <$> A8.takeWhile1 (const True))++buildExported :: Exported -> Builder+buildExported exported = go (exportedTreeish exported : incompleteExportedTreeish exported)+  where+	go [] = mempty+	go (r:rs) = rref r <> mconcat [ charUtf8 ' ' <> rref r' | r' <- rs ]+	rref = byteString . Git.fromRef'++exportedParser :: A.Parser Exported+exportedParser = Exported <$> refparser <*> many refparser+  where+	refparser = (Git.Ref <$> A8.takeWhile1 (/= ' ') )+		<* ((const () <$> A8.char ' ') <|> A.endOfInput)++-- Used when recording that an export is under way.+-- Any LogEntry for the oldTreeish will be updated to the newTreeish.+-- This way, when multiple repositories are exporting to+-- the same special remote, there's no conflict as long as they move+-- forward in lock-step.+updateForExportChange :: UUID -> ExportChange -> VectorClock -> UUID -> ExportParticipants -> LogEntry Exported -> LogEntry Exported+updateForExportChange remoteuuid ec c hereuuid ep le@(LogEntry _ exported@(Exported { exportedTreeish = t }))+	| hereuuid == exportFrom ep || remoteuuid /= exportTo ep || t `notElem` oldTreeish ec = le+	| otherwise = LogEntry c (exported { exportedTreeish = newTreeish ec })
Logs/Group.hs view
@@ -39,7 +39,7 @@ groupChange uuid@(UUID _) modifier = do 	curr <- lookupGroups uuid 	c <- currentVectorClock-	Annex.Branch.change groupLog $+	Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) groupLog $ 		buildLogOld buildGroup . changeLog c uuid (modifier curr) . parseLogOld parseGroup 	 	-- The changed group invalidates the preferred content cache.
Logs/Location.hs view
@@ -66,7 +66,8 @@ logChange' :: (LogStatus -> LogInfo -> Annex LogLine) -> Key -> UUID -> LogStatus -> Annex () logChange' mklog key u@(UUID _) s = do 	config <- Annex.getGitConfig-	maybeAddLog (locationLogFile config key) =<< mklog s (LogInfo (fromUUID u))+	maybeAddLog (Annex.Branch.RegardingUUID [u]) (locationLogFile config key)+		=<< mklog s (LogInfo (fromUUID u)) logChange' _ _ NoUUID _ = noop  {- Returns a list of repository UUIDs that, according to the log, have@@ -114,7 +115,9 @@ 	ls <- compactLog <$> readLog logfile 	mapM_ (go logfile) (filter (\l -> status l == InfoMissing) ls)   where-	go logfile l = addLog logfile $ setDead' l+	go logfile l = +		let u = toUUID (fromLogInfo (info l))+		in addLog (Annex.Branch.RegardingUUID [u]) logfile (setDead' l)  {- Note that the timestamp in the log is updated minimally, so that this  - can be overruled by other location log changes. -}
Logs/MetaData.hs view
@@ -99,25 +99,25 @@ {- Adds in some metadata, which can override existing values, or unset  - them, but otherwise leaves any existing metadata as-is. -} addMetaData :: Key -> MetaData -> Annex ()-addMetaData = addMetaData' metaDataLogFile+addMetaData = addMetaData' (Annex.Branch.RegardingUUID []) metaDataLogFile -addMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex ()-addMetaData' getlogfile k metadata = -	addMetaDataClocked' getlogfile k metadata =<< currentVectorClock+addMetaData' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex ()+addMetaData' ru getlogfile k metadata = +	addMetaDataClocked' ru getlogfile k metadata =<< currentVectorClock  {- Reusing the same VectorClock when making changes to the metadata  - of multiple keys is a nice optimisation. The same metadata lines  - will tend to be generated across the different log files, and so  - git will be able to pack the data more efficiently. -} addMetaDataClocked :: Key -> MetaData -> VectorClock -> Annex ()-addMetaDataClocked = addMetaDataClocked' metaDataLogFile+addMetaDataClocked = addMetaDataClocked' (Annex.Branch.RegardingUUID []) metaDataLogFile -addMetaDataClocked' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> VectorClock -> Annex ()-addMetaDataClocked' getlogfile k d@(MetaData m) c+addMetaDataClocked' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> VectorClock -> Annex ()+addMetaDataClocked' ru getlogfile k d@(MetaData m) c 	| d == emptyMetaData = noop 	| otherwise = do 		config <- Annex.getGitConfig-		Annex.Branch.change (getlogfile config k) $+		Annex.Branch.change ru (getlogfile config k) $ 			buildLog . simplifyLog  				. S.insert (LogEntry c metadata) 				. parseLog@@ -126,7 +126,7 @@  addRemoteMetaData :: Key -> RemoteStateHandle -> MetaData -> Annex () addRemoteMetaData k (RemoteStateHandle u) m = -	addMetaData' remoteMetaDataLogFile k $ fromRemoteMetaData $+	addMetaData' (Annex.Branch.RegardingUUID [u]) remoteMetaDataLogFile k $ fromRemoteMetaData $ 		RemoteMetaData u m  getMetaDataLog :: Key -> Annex (Log MetaData)@@ -153,8 +153,10 @@ 			then return False 			else do 				config <- Annex.getGitConfig-				Annex.Branch.change (metaDataLogFile config newkey) $-					const $ buildLog l+				Annex.Branch.change+					(Annex.Branch.RegardingUUID [])+					(metaDataLogFile config newkey)+					(const $ buildLog l) 				return True  readLog :: RawFilePath -> Annex (Log MetaData)
Logs/Multicast.hs view
@@ -26,7 +26,7 @@ recordFingerprint :: Fingerprint -> UUID -> Annex () recordFingerprint fp uuid = do 	c <- currentVectorClock-	Annex.Branch.change multicastLog $+	Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) multicastLog $ 		buildLogOld buildFindgerPrint 			. changeLog c uuid fp 			. parseLogOld fingerprintParser
Logs/NumCopies.hs view
@@ -18,6 +18,7 @@  import Annex.Common import qualified Annex+import qualified Annex.Branch import Types.NumCopies import Logs import Logs.SingleValue@@ -34,13 +35,13 @@ setGlobalNumCopies new = do 	curr <- getGlobalNumCopies 	when (curr /= Just new) $-		setLog numcopiesLog new+		setLog (Annex.Branch.RegardingUUID []) numcopiesLog new  setGlobalMinCopies :: MinCopies -> Annex () setGlobalMinCopies new = do 	curr <- getGlobalMinCopies 	when (curr /= Just new) $-		setLog mincopiesLog new+		setLog (Annex.Branch.RegardingUUID []) mincopiesLog new  {- Value configured in the numcopies log. Cached for speed. -} getGlobalNumCopies :: Annex (Maybe NumCopies)
Logs/PreferredContent/Raw.hs view
@@ -31,7 +31,7 @@ setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex () setLog logfile uuid@(UUID _) val = do 	c <- currentVectorClock-	Annex.Branch.change logfile $+	Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) logfile $ 		buildLogOld buildPreferredContentExpression 		. changeLog c uuid val 		. parseLogOld parsePreferredContentExpression@@ -45,7 +45,9 @@ groupPreferredContentSet :: Group -> PreferredContentExpression -> Annex () groupPreferredContentSet g val = do 	c <- currentVectorClock-	Annex.Branch.change groupPreferredContentLog $+	Annex.Branch.change+		(Annex.Branch.RegardingUUID [])+		groupPreferredContentLog $ 		buildGroupPreferredContent 		. changeMapLog c g val  		. parseGroupPreferredContent
Logs/Presence.hs view
@@ -30,16 +30,16 @@  {- Adds a LogLine to the log, removing any LogLines that are obsoleted by  - adding it. -}-addLog :: RawFilePath -> LogLine -> Annex ()-addLog file line = Annex.Branch.change file $ \b ->+addLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogLine -> Annex ()+addLog ru file line = Annex.Branch.change ru file $ \b -> 	buildLog $ compactLog (line : parseLog b)  {- When a LogLine already exists with the same status and info, but an  - older timestamp, that LogLine is preserved, rather than updating the log  - with a newer timestamp.  -}-maybeAddLog :: RawFilePath -> LogLine -> Annex ()-maybeAddLog file line = Annex.Branch.maybeChange file $ \s -> do+maybeAddLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogLine -> Annex ()+maybeAddLog ru file line = Annex.Branch.maybeChange ru file $ \s -> do 	m <- insertNewStatus line $ logMap $ parseLog s 	return $ buildLog $ mapLog m
Logs/Remote.hs view
@@ -33,7 +33,7 @@ configSet :: UUID -> RemoteConfig -> Annex () configSet u cfg = do 	c <- currentVectorClock-	Annex.Branch.change remoteLog $+	Annex.Branch.change (Annex.Branch.RegardingUUID [u]) remoteLog $ 		buildRemoteConfigLog 			. changeLog c u (removeSameasInherited cfg) 			. parseRemoteConfigLog
Logs/RemoteState.hs view
@@ -28,8 +28,10 @@ setRemoteState (RemoteStateHandle u) k s = do 	c <- currentVectorClock 	config <- Annex.getGitConfig-	Annex.Branch.change (remoteStateLogFile config k) $-		buildRemoteState . changeLog c u s . parseRemoteState+	Annex.Branch.change+		(Annex.Branch.RegardingUUID [u])+		(remoteStateLogFile config k)+		(buildRemoteState . changeLog c u s . parseRemoteState)  buildRemoteState :: Log RemoteState -> Builder buildRemoteState = buildLogNew (byteString . encodeBS)
Logs/Schedule.hs view
@@ -33,7 +33,7 @@ scheduleSet :: UUID -> [ScheduledActivity] -> Annex () scheduleSet uuid@(UUID _) activities = do 	c <- currentVectorClock-	Annex.Branch.change scheduleLog $+	Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) scheduleLog $ 		buildLogOld byteString  			. changeLog c uuid (encodeBS val) 			. parseLogOld A.takeByteString
Logs/SingleValue.hs view
@@ -31,8 +31,8 @@ getLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Maybe v) getLog = newestValue <$$> readLog -setLog :: (SingleValueSerializable v) => RawFilePath -> v -> Annex ()-setLog f v = do+setLog :: (SingleValueSerializable v) => Annex.Branch.RegardingUUID -> RawFilePath -> v -> Annex ()+setLog ru f v = do 	c <- currentVectorClock 	let ent = LogEntry c v-	Annex.Branch.change f $ \_old -> buildLog (S.singleton ent)+	Annex.Branch.change ru f $ \_old -> buildLog (S.singleton ent)
Logs/Trust/Basic.hs view
@@ -23,7 +23,7 @@ trustSet :: UUID -> TrustLevel -> Annex () trustSet uuid@(UUID _) level = do 	c <- currentVectorClock-	Annex.Branch.change trustLog $+	Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) trustLog $ 		buildLogOld buildTrustLevel . 			changeLog c uuid level . 				parseLogOld trustLevelParser
Logs/UUID.hs view
@@ -32,7 +32,7 @@ describeUUID :: UUID -> UUIDDesc -> Annex () describeUUID uuid desc = do 	c <- currentVectorClock-	Annex.Branch.change uuidLog $+	Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) uuidLog $ 		buildLogOld buildUUIDDesc . changeLog c uuid desc . parseUUIDLog  {- The map is cached for speed. -}
Logs/Web.hs view
@@ -1,6 +1,6 @@ {- Web url logs.  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -13,28 +13,26 @@ 	getUrlsWithPrefix, 	setUrlPresent, 	setUrlMissing,-	withKnownUrls, 	Downloader(..), 	getDownloader, 	setDownloader, 	setDownloader', 	setTempUrl, 	removeTempUrl,+	parseUrlLog, ) where  import qualified Data.Map as M+import qualified Data.ByteString.Lazy as L  import Annex.Common import qualified Annex import Logs import Logs.Presence import Logs.Location-import qualified Annex.Branch-import qualified Git.LsTree-import Git.CatFile (catObjectStreamLsTree)-import Git.FilePath import Utility.Url import Annex.UUID+import qualified Annex.Branch import qualified Types.Remote as Remote  {- Gets all urls that a key might be available from. -}@@ -50,7 +48,7 @@ 		us <- currentLogInfo l 		if null us 			then go ls-			else return $ map (decodeBS  . fromLogInfo) us+			else return $ map decodeUrlLogInfo us  getUrlsWithPrefix :: Key -> String -> Annex [URLString] getUrlsWithPrefix key prefix = filter (prefix `isPrefixOf`) @@ -62,7 +60,7 @@ 	us <- getUrls key 	unless (url `elem` us) $ do 		config <- Annex.getGitConfig-		addLog (urlLogFile config key)+		addLog (Annex.Branch.RegardingUUID []) (urlLogFile config key) 			=<< logNow InfoPresent (LogInfo (encodeBS url)) 	-- If the url does not have an OtherDownloader, it must be present 	-- in the web.@@ -76,7 +74,7 @@ 	us <- getUrls key 	when (url `elem` us) $ do 		config <- Annex.getGitConfig-		addLog (urlLogFile config key)+		addLog (Annex.Branch.RegardingUUID []) (urlLogFile config key) 			=<< logNow InfoMissing (LogInfo (encodeBS url)) 		-- If the url was a web url and none of the remaining urls 		-- for the key are web urls, the key must not be present@@ -88,32 +86,6 @@ 		OtherDownloader -> False 		_ -> True -{- Finds all known urls. -}-withKnownUrls :: (Annex (Maybe (Key, [URLString])) -> Annex a) -> Annex a-withKnownUrls a = do-	{- Ensure any journalled changes are committed to the git-annex-	 - branch, since we're going to look at its tree. -}-	_ <- Annex.Branch.update-	Annex.Branch.commit =<< Annex.Branch.commitMessage-	(l, cleanup) <- inRepo $ Git.LsTree.lsTree-		Git.LsTree.LsTreeRecursive-		(Git.LsTree.LsTreeLong False)-		Annex.Branch.fullname-	g <- Annex.gitRepo-	let want = urlLogFileKey . getTopFilePath . Git.LsTree.file-	catObjectStreamLsTree l want g (\reader -> a (go reader))-		`finally` void (liftIO cleanup)-  where-	go reader = liftIO reader >>= \case-		Just (k, Just content) ->-			case geturls content of-				[] -> go reader-				us -> return (Just (k, us))-		Just (_, Nothing) -> go reader-		Nothing -> return Nothing-	-	geturls = map (decodeBS . fromLogInfo) . getLog- setTempUrl :: Key -> URLString -> Annex () setTempUrl key url = Annex.changeState $ \s -> 	s { Annex.tempurls = M.insert key url (Annex.tempurls s) }@@ -146,3 +118,11 @@ 	("quvi", u') -> (u', YoutubeDownloader) 	("", u') -> (u', OtherDownloader) 	_ -> (u, WebDownloader)++decodeUrlLogInfo :: LogInfo -> URLString+decodeUrlLogInfo = decodeBS . fromLogInfo++{- Parses the content of an url log file, returning the urls that are+ - currently recorded. -}+parseUrlLog :: L.ByteString -> [URLString]+parseUrlLog = map decodeUrlLogInfo . getLog
Messages.hs view
@@ -1,6 +1,6 @@ {- git-annex output messages  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -42,8 +42,6 @@ 	showRaw, 	setupConsole, 	enableDebugOutput,-	disableDebugOutput,-	debugEnabled, 	commandProgressDisabled, 	jsonOutputEnabled, 	outputMessage,@@ -52,10 +50,6 @@ 	mkPrompter, ) where -import System.Log.Logger-import System.Log.Formatter-import System.Log.Handler (setFormatter)-import System.Log.Handler.Simple import Control.Concurrent import Control.Monad.IO.Class import qualified Data.ByteString as S@@ -69,6 +63,7 @@ import Types.Transfer (transferKey) import Messages.Internal import Messages.Concurrent+import Annex.Debug import Annex.Concurrent.Utility import qualified Messages.JSON as JSON import qualified Annex@@ -254,31 +249,29 @@  setupConsole :: IO () setupConsole = do-	s <- setFormatter-		<$> streamHandler stderr DEBUG-		<*> pure preciseLogFormatter-	updateGlobalLogger rootLoggerName (setLevel NOTICE . setHandlers [s])+	dd <- debugDisplayer+	configureDebug dd (DebugSelector (const False)) 	{- Force output to be line buffered. This is normally the case when 	 - it's connected to a terminal, but may not be when redirected to 	 - a file or a pipe. -} 	hSetBuffering stdout LineBuffering 	hSetBuffering stderr LineBuffering -{- Log formatter with precision into fractions of a second. -}-preciseLogFormatter :: LogFormatter a-preciseLogFormatter = tfLogFormatter "%F %X%Q" "[$time] $msg"--enableDebugOutput :: IO ()-enableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel DEBUG--disableDebugOutput :: IO ()-disableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel NOTICE+enableDebugOutput :: Annex ()+enableDebugOutput = do+	selector <- Annex.getRead Annex.debugselector+	dd <- liftIO debugDisplayer+	liftIO $ configureDebug dd selector -{- Checks if debugging is enabled. -}-debugEnabled :: IO Bool-debugEnabled = do-	l <- getRootLogger-	return $ getLevel l <= Just DEBUG+debugDisplayer :: IO (S.ByteString -> IO ())+debugDisplayer = do+	-- Debug output will get mixed in with any other output+	-- made by git-annex, but use a lock to prevent two debug lines+	-- that are displayed at the same time from mixing together.+	lock <- newMVar ()+	return $ \s -> withMVar lock $ \() -> do+		S.putStr (s <> "\n")+		hFlush stderr  {- Should commands that normally output progress messages have that  - output disabled? -}
P2P/IO.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE RankNTypes, FlexibleContexts, CPP #-}+{-# LANGUAGE RankNTypes, FlexibleContexts, OverloadedStrings, CPP #-}  module P2P.IO 	( RunProto@@ -35,6 +35,7 @@ import Utility.Metered import Utility.Tor import Utility.FileMode+import Utility.Debug import Types.UUID import Annex.ChangedRefs import qualified Utility.RawFilePath as R@@ -48,7 +49,6 @@ import Control.Concurrent.STM import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import System.Log.Logger (debugM) import qualified Network.Socket as S  -- Type of interpreters of the Proto free monad.@@ -235,7 +235,7 @@ debugMessage :: P2PConnection -> String -> Message -> IO () debugMessage conn prefix m = do 	tid <- myThreadId	-	debugM "p2p" $ concat $ catMaybes $+	debug "P2P.IO" $ concat $ catMaybes $ 		[ (\ident -> "[" ++ ident ++ "] ") <$> mident 		, Just $ "[" ++ show tid ++ "] " 		, Just $ prefix ++ " " ++ unwords (formatMessage safem)
Remote/Adb.hs view
@@ -15,7 +15,6 @@ import qualified Git import Config.Cost import Remote.Helper.Special-import Remote.Helper.Messages import Remote.Helper.ExportImport import Annex.UUID import Utility.Metered@@ -77,7 +76,7 @@ 			, retrieveExport = retrieveExportM serial adir 			, removeExport = removeExportM serial adir 			, versionedExport = False-			, checkPresentExport = checkPresentExportM this serial adir+			, checkPresentExport = checkPresentExportM serial adir 			, removeExportDirectory = Just $ removeExportDirectoryM serial adir 			, renameExport = renameExportM serial adir 			}@@ -115,7 +114,7 @@ 		(store serial adir) 		(retrieve serial adir) 		(remove serial adir)-		(checkKey this serial adir)+		(checkKey serial adir) 		this   where 	adir = maybe (giveup "missing androiddirectory") AndroidPath@@ -214,12 +213,11 @@ remove' serial aloc = adbShellBool serial 	[Param "rm", Param "-f", File (fromAndroidPath aloc)] -checkKey :: Remote -> AndroidSerial -> AndroidPath -> CheckPresent-checkKey r serial adir k = checkKey' r serial (androidLocation adir k)+checkKey :: AndroidSerial -> AndroidPath -> CheckPresent+checkKey serial adir k = checkKey' serial (androidLocation adir k) -checkKey' :: Remote -> AndroidSerial -> AndroidPath -> Annex Bool-checkKey' r serial aloc = do-	showChecking r+checkKey' :: AndroidSerial -> AndroidPath -> Annex Bool+checkKey' serial aloc = do 	out <- adbShellRaw serial $ unwords 		[ "if test -e ", shellEscape (fromAndroidPath aloc) 		, "; then echo y"@@ -268,8 +266,8 @@ 	go = adbShellBool serial [Param "rm", Param "-rf", File (fromAndroidPath adir)] 	adir = androidExportLocation abase (mkExportLocation (fromExportDirectory dir)) -checkPresentExportM :: Remote -> AndroidSerial -> AndroidPath -> Key -> ExportLocation -> Annex Bool-checkPresentExportM r serial adir _k loc = checkKey' r serial aloc+checkPresentExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> Annex Bool+checkPresentExportM serial adir _k loc = checkKey' serial aloc   where 	aloc = androidExportLocation adir loc
Remote/Bup.hs view
@@ -27,7 +27,6 @@ import qualified Remote.Helper.Ssh as Ssh import Annex.SpecialRemote.Config import Remote.Helper.Special-import Remote.Helper.Messages import Remote.Helper.ExportImport import Utility.Hash import Utility.UserInfo@@ -110,7 +109,7 @@ 		(store this buprepo) 		(retrieve buprepo) 		(remove buprepo)-		(checkKey r bupr')+		(checkKey bupr') 		this   where 	buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc@@ -212,11 +211,9 @@  - in a bup repository. One way it to check if the git repository has  - a branch matching the name (as created by bup split -n).  -}-checkKey :: Git.Repo -> Git.Repo -> CheckPresent-checkKey r bupr k-	| Git.repoIsUrl bupr = do-		showChecking r-		onBupRemote bupr boolSystem "git" params+checkKey :: Git.Repo -> CheckPresent+checkKey bupr k+	| Git.repoIsUrl bupr = onBupRemote bupr boolSystem "git" params 	| otherwise = liftIO $ boolSystem "git" $ 		Git.Command.gitCommandLine params bupr   where
Remote/Directory.hs view
@@ -31,6 +31,7 @@ import Remote.Helper.ExportImport import Types.Import import qualified Remote.Directory.LegacyChunked as Legacy+import Annex.CopyFile import Annex.Content import Annex.Perms import Annex.UUID@@ -67,9 +68,10 @@ 	c <- parsedRemoteConfig remote rc 	cst <- remoteCost gc cheapRemoteCost 	let chunkconfig = getChunkConfig c+	cow <- liftIO newCopyCoWTried 	return $ Just $ specialRemote c-		(storeKeyM dir chunkconfig)-		(retrieveKeyFileM dir chunkconfig)+		(storeKeyM dir chunkconfig cow)+		(retrieveKeyFileM dir chunkconfig cow) 		(removeKeyM dir) 		(checkPresentM dir chunkconfig) 		Remote@@ -85,8 +87,8 @@ 			, checkPresent = checkPresentDummy 			, checkPresentCheap = True 			, exportActions = ExportActions-				{ storeExport = storeExportM dir-				, retrieveExport = retrieveExportM dir+				{ storeExport = storeExportM dir cow+				, retrieveExport = retrieveExportM dir cow 				, removeExport = removeExportM dir 				, versionedExport = False 				, checkPresentExport = checkPresentExportM dir@@ -98,8 +100,8 @@ 			, importActions = ImportActions 				{ listImportableContents = listImportableContentsM dir 				, importKey = Just (importKeyM dir)-				, retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM dir-				, storeExportWithContentIdentifier = storeExportWithContentIdentifierM dir+				, retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM dir cow+				, storeExportWithContentIdentifier = storeExportWithContentIdentifierM dir cow 				, removeExportWithContentIdentifier = removeExportWithContentIdentifierM dir 				-- Not needed because removeExportWithContentIdentifier 				-- auto-removes empty directories.@@ -167,43 +169,55 @@  {- Check if there is enough free disk space in the remote's directory to  - store the key. Note that the unencrypted key size is checked. -}-storeKeyM :: RawFilePath -> ChunkConfig -> Storer-storeKeyM d chunkconfig k c m = +storeKeyM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Storer+storeKeyM d chunkconfig cow k c m =  	ifM (checkDiskSpaceDirectory d k)-		( byteStorer (store d chunkconfig) k c m+		( do+			void $ liftIO $ tryIO $ createDirectoryUnder d tmpdir+			store 		, giveup "Not enough free disk space." 		)--checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool-checkDiskSpaceDirectory d k = do-	annexdir <- fromRepo gitAnnexObjectDir-	samefilesystem <- liftIO $ catchDefaultIO False $ -		(\a b -> deviceID a == deviceID b)-			<$> R.getFileStatus d-			<*> R.getFileStatus annexdir-	checkDiskSpace (Just d) k 0 samefilesystem--store :: RawFilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex ()-store d chunkconfig k b p = liftIO $ do-	void $ tryIO $ createDirectoryUnder d tmpdir-	case chunkconfig of+  where+	store = case chunkconfig of 		LegacyChunks chunksize -> -			Legacy.store+			let go _k b p = liftIO $ Legacy.store 				(fromRawFilePath d) 				chunksize 				(finalizeStoreGeneric d) 				k b p 				(fromRawFilePath tmpdir) 				(fromRawFilePath destdir)-		_ -> do-			let tmpf = tmpdir P.</> kf-			meteredWriteFile p (fromRawFilePath tmpf) b-			finalizeStoreGeneric d tmpdir destdir-  where+			in byteStorer go k c m+		NoChunks ->+			let go _k src p = do+				fileCopierUnVerified cow src tmpf k p+				liftIO $ finalizeStoreGeneric d tmpdir destdir+			in fileStorer go k c m+		_ -> +			let go _k b p = liftIO $ do+				meteredWriteFile p tmpf b+				finalizeStoreGeneric d tmpdir destdir+			in byteStorer go k c m+	 	tmpdir = P.addTrailingPathSeparator $ d P.</> "tmp" P.</> kf+	tmpf = fromRawFilePath tmpdir </> fromRawFilePath kf 	kf = keyFile k 	destdir = storeDir d k +fileCopierUnVerified :: CopyCoWTried -> FilePath -> FilePath -> Key -> MeterUpdate -> Annex ()+fileCopierUnVerified cow src dest k p = do+	(ok, _verification) <- fileCopier cow src dest k p (return True) NoVerify+	unless ok $ giveup "failed to copy file"++checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool+checkDiskSpaceDirectory d k = do+	annexdir <- fromRepo gitAnnexObjectDir+	samefilesystem <- liftIO $ catchDefaultIO False $ +		(\a b -> deviceID a == deviceID b)+			<$> R.getFileStatus d+			<*> R.getFileStatus annexdir+	checkDiskSpace (Just d) k 0 samefilesystem+ {- Passed a temp directory that contains the files that should be placed  - in the dest directory, moves it into place. Anything already existing  - in the dest directory will be deleted. File permissions will be locked@@ -220,9 +234,12 @@   where 	dest' = fromRawFilePath dest -retrieveKeyFileM :: RawFilePath -> ChunkConfig -> Retriever-retrieveKeyFileM d (LegacyChunks _) = Legacy.retrieve locations d-retrieveKeyFileM d _ = byteRetriever $ \k sink ->+retrieveKeyFileM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Retriever+retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations d+retrieveKeyFileM d NoChunks cow = fileRetriever $ \dest k p -> do+	src <- liftIO $ fromRawFilePath <$> getLocation d k+	fileCopierUnVerified cow src dest k p+retrieveKeyFileM d _ _ = byteRetriever $ \k sink -> 	sink =<< liftIO (L.readFile . fromRawFilePath =<< getLocation d k)  retrieveKeyFileCheapM :: RawFilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())@@ -286,19 +303,18 @@ 		) 	) -storeExportM :: RawFilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()-storeExportM d src _k loc p = liftIO $ do-	createDirectoryUnder d (P.takeDirectory dest)+storeExportM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()+storeExportM d cow src k loc p = do+	liftIO $ createDirectoryUnder d (P.takeDirectory dest) 	-- Write via temp file so that checkPresentGeneric will not 	-- see it until it's fully stored. 	viaTmp go (fromRawFilePath dest) ()   where 	dest = exportPath d loc-	go tmp () = withMeteredFile src p (L.writeFile tmp)+	go tmp () = fileCopierUnVerified cow src tmp k p -retrieveExportM :: RawFilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()-retrieveExportM d _k loc dest p = -	liftIO $ withMeteredFile src p (L.writeFile dest)+retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()+retrieveExportM d cow k loc dest p = fileCopierUnVerified cow src dest k p   where 	src = fromRawFilePath $ exportPath d loc @@ -393,14 +409,21 @@ 		, inodeCache = Nothing 		} -retrieveExportWithContentIdentifierM :: RawFilePath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key-retrieveExportWithContentIdentifierM dir loc cid dest mkkey p = -	precheck $ docopy postcheck+retrieveExportWithContentIdentifierM :: RawFilePath -> CopyCoWTried -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key+retrieveExportWithContentIdentifierM dir cow loc cid dest mkkey p = +	precheck docopy   where 	f = exportPath dir loc 	f' = fromRawFilePath f -	docopy cont = do+	docopy = ifM (liftIO $ tryCopyCoW cow f' dest p)+		( do+			k <- mkkey+			postcheckcow (return k)+		, docopynoncow+		)++	docopynoncow = do #ifndef mingw32_HOST_OS 		let open = do 			-- Need a duplicate fd for the post check, since@@ -421,9 +444,9 @@ 			liftIO $ hGetContentsMetered h p >>= L.writeFile dest 			k <- mkkey #ifndef mingw32_HOST_OS-			cont dupfd (return k)+			postchecknoncow dupfd (return k) #else-			cont (return k)+			postchecknoncow (return k) #endif 	 	-- Check before copy, to avoid expensive copy of wrong file@@ -446,9 +469,9 @@ 	-- situations with files being modified while it's updating the 	-- working tree for a merge. #ifndef mingw32_HOST_OS-	postcheck fd cont = do+	postchecknoncow fd cont = do #else-	postcheck cont = do+	postchecknoncow cont = do #endif 		currcid <- liftIO $ mkContentIdentifier f #ifndef mingw32_HOST_OS@@ -458,14 +481,23 @@ #endif 		guardSameContentIdentifiers cont cid currcid -storeExportWithContentIdentifierM :: RawFilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier-storeExportWithContentIdentifierM dir src _k loc overwritablecids p = do+	-- When copy-on-write was done, cannot check the handle that was+	-- copied from, but such a copy should run very fast, so+	-- it's very unlikely that the file changed after precheck,+	-- the modified version was copied CoW, and then the file was+	-- restored to the original content before this check.+	postcheckcow cont = do+		currcid <- liftIO $ mkContentIdentifier f+			=<< R.getFileStatus f+		guardSameContentIdentifiers cont cid currcid++storeExportWithContentIdentifierM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier+storeExportWithContentIdentifierM dir cow src k loc overwritablecids p = do 	liftIO $ createDirectoryUnder dir (toRawFilePath destdir) 	withTmpFileIn destdir template $ \tmpf tmph -> do-		let tmpf' = toRawFilePath tmpf-		liftIO $ withMeteredFile src p (L.hPut tmph)-		liftIO $ hFlush tmph 		liftIO $ hClose tmph+		fileCopierUnVerified cow src tmpf k p+		let tmpf' = toRawFilePath tmpf 		resetAnnexFilePerm tmpf' 		liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf' >>= \case 			Nothing -> giveup "unable to generate content identifier"
Remote/External.hs view
@@ -27,7 +27,6 @@ import Remote.Helper.Special import Remote.Helper.ExportImport import Remote.Helper.ReadOnly-import Remote.Helper.Messages import Utility.Metered import Types.Transfer import Logs.PreferredContent.Raw@@ -40,7 +39,6 @@ import Creds  import Control.Concurrent.STM-import System.Log.Logger (debugM) import qualified Data.Map as M import qualified Data.Set as S @@ -72,7 +70,7 @@ 			readonlyStorer 			retrieveUrl 			readonlyRemoveKey-			(checkKeyUrl r)+			checkKeyUrl 			Nothing 			(externalInfo externaltype) 			Nothing@@ -494,7 +492,7 @@ 	handleRemoteRequest (GETURLS key prefix) = do 		mapM_ (send . VALUE) =<< getUrlsWithPrefix key prefix 		send (VALUE "") -- end of list-	handleRemoteRequest (DEBUG msg) = liftIO $ debugM "external" msg+	handleRemoteRequest (DEBUG msg) = fastDebug "Remote.External" msg 	handleRemoteRequest (INFO msg) = showInfo msg 	handleRemoteRequest (VERSION _) = senderror "too late to send VERSION" @@ -816,9 +814,8 @@ 	unlessM (withUrlOptions $ downloadUrl k p us f) $ 		giveup "failed to download content" -checkKeyUrl :: Git.Repo -> CheckPresent-checkKeyUrl r k = do-	showChecking r+checkKeyUrl :: CheckPresent+checkKeyUrl k = do 	us <- getWebUrls k 	anyM (\u -> withUrlOptions $ checkBoth u (fromKey keySize k)) us
Remote/GCrypt.hs view
@@ -460,7 +460,7 @@ 	| accessmethod == AccessRsyncOverSsh = checkrsync 	| otherwise = unsupportedUrl   where-	checkrsync = Remote.Rsync.checkKey repo rsyncopts k+	checkrsync = Remote.Rsync.checkKey rsyncopts k 	checkshell = Ssh.inAnnex repo k  {- Annexed objects are hashed using lower-case directories for max
Remote/Git.hs view
@@ -28,6 +28,7 @@ import qualified Annex import Logs.Presence import Annex.Transfer+import Annex.CopyFile import Annex.UUID import qualified Annex.Content import qualified Annex.BranchState@@ -44,12 +45,9 @@ import qualified CmdLine.GitAnnexShell.Fields as Fields import Logs.Location import Utility.Metered-import Utility.CopyFile import Utility.Env-import Utility.FileMode import Utility.Batch import Utility.SimpleProtocol-import Utility.Touch import Remote.Helper.Git import Remote.Helper.Messages import Remote.Helper.ExportImport@@ -63,10 +61,7 @@ import Creds import Types.NumCopies import Types.ProposedAccepted-import Types.Backend-import Backend import Annex.Action-import Annex.Verify import Messages.Progress  #ifndef mingw32_HOST_OS@@ -77,7 +72,6 @@ import Control.Concurrent.MSampleVar import qualified Data.Map as M import qualified Data.ByteString as S-import Data.Time.Clock.POSIX import Network.URI  remote :: RemoteType@@ -413,7 +407,6 @@ 	| otherwise = checklocal   where 	checkhttp = do-		showChecking repo 		gc <- Annex.getGitConfig 		ifM (Url.withUrlOptionsPromptingCreds $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key)) 			( return True@@ -559,7 +552,7 @@ 		onLocalFast st $ Annex.Content.prepSendAnnex key >>= \case 			Just (object, checksuccess) -> do 				let verify = Annex.Content.RemoteVerify r-				copier <- mkCopier hardlink st+				copier <- mkFileCopier hardlink st 				(ok, v) <- runTransfer (Transfer Download u (fromKey id key)) 					file Nothing stdRetry $ \p -> 						metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' -> @@ -703,7 +696,7 @@ 			( return True 			, runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> do 				let verify = Annex.Content.RemoteVerify r-				copier <- mkCopier hardlink st+				copier <- mkFileCopier hardlink st 				let rsp = RetrievalAllKeysSecure 				res <- logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest -> 					metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' -> @@ -750,7 +743,7 @@ 		ensureInitialized 		a `finally` stopCoProcesses -data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar (Maybe Annex.AnnexState))+data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar (Maybe (Annex.AnnexState, Annex.AnnexRead)))  {- This can safely be called on a Repo that is not local, but of course  - onLocal will not work if used with the result. -}@@ -775,20 +768,20 @@ 	onLocal' lra a  onLocal' :: LocalRemoteAnnex -> Annex a -> Annex a-onLocal' (LocalRemoteAnnex repo v) a = liftIO (takeMVar v) >>= \case+onLocal' (LocalRemoteAnnex repo mv) a = liftIO (takeMVar mv) >>= \case 	Nothing -> do-		st <- liftIO $ Annex.new repo-		go (st, ensureInitialized >> a)-	Just st -> go (st, a)+		v <- liftIO $ Annex.new repo+		go (v, ensureInitialized >> a)+	Just v -> go (v, a)   where-	go (st, a') = do+	go ((st, rd), a') = do 		curro <- Annex.getState Annex.output-		let act = Annex.run (st { Annex.output = curro }) $+		let act = Annex.run (st { Annex.output = curro }, rd) $ 			a' `finally` stopCoProcesses-		(ret, st') <- liftIO $ act `onException` cache st-		liftIO $ cache st'+		(ret, (st', _rd)) <- liftIO $ act `onException` cache (st, rd)+		liftIO $ cache (st', rd) 		return ret-	cache st = putMVar v (Just st)+	cache = putMVar mv . Just  {- Faster variant of onLocal.  -@@ -830,23 +823,9 @@ 	-- because they can be modified at any time. 	<&&> (not <$> annexThin <$> Annex.getGitConfig) --- Copies from src to dest, updating a meter. If the copy finishes--- successfully, calls a final check action, which must also succeed, or--- returns false.------ If either the remote or local repository wants to use hard links,--- the copier will do so (falling back to copying if a hard link cannot be--- made).------ When a hard link is created, returns Verified; the repo being linked--- from is implicitly trusted, so no expensive verification needs to be--- done. Also returns Verified if the key's content is verified while--- copying it.-type Copier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)--mkCopier :: Bool -> State -> Annex Copier-mkCopier remotewanthardlink st = do-	let copier = fileCopier st+mkFileCopier :: Bool -> State -> Annex FileCopier+mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do+	let copier = fileCopier copycowtried 	localwanthardlink <- wantHardLink 	let linker = \src dest -> createLink src dest >> return True 	if remotewanthardlink || localwanthardlink@@ -914,129 +893,3 @@ 				)  			return (duc, getrepo)---- To avoid the overhead of trying copy-on-write every time, it's tried--- once and if it fails, is not tried again.-newtype CopyCoWTried = CopyCoWTried (MVar Bool)--newCopyCoWTried :: IO CopyCoWTried-newCopyCoWTried = CopyCoWTried <$> newEmptyMVar--{- Copys a file. Uses copy-on-write if it is supported. Otherwise,- - copies the file itself. If the destination already exists,- - an interruped copy will resume where it left off.- -- - When copy-on-write is used, returns UnVerified, because the content of- - the file has not been verified to be correct. When the file has to be- - read to copy it, a hash is calulated at the same time.- -- - Note that, when the destination file already exists, it's read both- - to start calculating the hash, and also to verify that its content is- - the same as the start of the source file. It's possible that the- - destination file was created from some other source file,- - (eg when isStableKey is false), and doing this avoids getting a- - corrupted file in such cases.- -}-fileCopier :: State -> Copier-#ifdef mingw32_HOST_OS-fileCopier _st src dest k meterupdate check verifyconfig = docopy-  where-#else-fileCopier st src dest k meterupdate check verifyconfig =-	-- If multiple threads reach this at the same time, they-	-- will both try CoW, which is acceptable.-	ifM (liftIO $ isEmptyMVar copycowtried)-		( do-			ok <- docopycow-			void $ liftIO $ tryPutMVar copycowtried ok-			if ok-				then unVerified check-				else docopy-		, ifM (liftIO $ readMVar copycowtried)-			( do-				ok <- docopycow-				if ok-					then unVerified check-					else docopy-			, docopy-			)-		)-  where-	copycowtried = case st of-		State _ _ (CopyCoWTried v) _ _ -> v-	docopycow = liftIO $ watchFileSize dest meterupdate $-		copyCoW CopyTimeStamps src dest-#endif--	dest' = toRawFilePath dest--	docopy = do-		iv <- startVerifyKeyContentIncrementally verifyconfig k--		-- The file might have had the write bit removed,-		-- so make sure we can write to it.-		void $ liftIO $ tryIO $ allowWrite dest'--		liftIO $ withBinaryFile dest ReadWriteMode $ \hdest ->-			withBinaryFile src ReadMode $ \hsrc -> do-				sofar <- compareexisting iv hdest hsrc zeroBytesProcessed-				docopy' iv hdest hsrc sofar--		-- Copy src mode and mtime.-		mode <- liftIO $ fileMode <$> getFileStatus src-		mtime <- liftIO $ utcTimeToPOSIXSeconds <$> getModificationTime src-		liftIO $ setFileMode dest mode-		liftIO $ touch dest' mtime False--		ifM check-			( case iv of-				Just x -> ifM (liftIO $ finalizeIncremental x)-					( return (True, Verified)-					, return (False, UnVerified)-					)-				Nothing -> return (True, UnVerified)-			, return (False, UnVerified)-			)-	-	docopy' iv hdest hsrc sofar = do-		s <- S.hGet hsrc defaultChunkSize-		if s == S.empty-			then return ()-			else do-				let sofar' = addBytesProcessed sofar (S.length s)-				S.hPut hdest s-				maybe noop (flip updateIncremental s) iv-				meterupdate sofar'-				docopy' iv hdest hsrc sofar'--	-- Leaves hdest and hsrc seeked to wherever the two diverge,-	-- so typically hdest will be seeked to end, and hsrc to the same-	-- position.-	compareexisting iv hdest hsrc sofar = do-		s <- S.hGet hdest defaultChunkSize-		if s == S.empty-			then return sofar-			else do-				s' <- getnoshort (S.length s) hsrc-				if s == s'-					then do-						maybe noop (flip updateIncremental s) iv-						let sofar' = addBytesProcessed sofar (S.length s)-						meterupdate sofar'-						compareexisting iv hdest hsrc sofar'-					else do-						seekbefore hdest s-						seekbefore hsrc s'-						return sofar-	-	seekbefore h s = hSeek h RelativeSeek (fromIntegral (-1*S.length s))-	-	-- Like hGet, but never returns less than the requested number of-	-- bytes, unless it reaches EOF.-	getnoshort n h = do-		s <- S.hGet h n-		if S.length s == n || S.empty == s-			then return s-			else do-				s' <- getnoshort (n - S.length s) h-				return (s <> s')
Remote/GitLFS.hs view
@@ -53,7 +53,6 @@ import Data.String import Network.HTTP.Types import Network.HTTP.Client hiding (port)-import System.Log.Logger import qualified Data.Map as M import qualified Data.ByteString.Lazy as L import qualified Data.Text as T@@ -349,11 +348,11 @@ makeSmallAPIRequest req = do 	uo <- getUrlOptions 	let req' = applyRequest uo req-	liftIO $ debugM "git-lfs" (show req')+	fastDebug "Remote.GitLFS" (show req') 	resp <- liftIO $ httpLbs req' (httpManager uo) 	-- Only debug the http status code, not the json 	-- which may include an authentication token.-	liftIO $ debugM "git-lfs" (show $ responseStatus resp)+	fastDebug "Remote.GitLFS" (show $ responseStatus resp) 	return resp  sendTransferRequest
Remote/Glacier.hs view
@@ -19,7 +19,6 @@ import Config.Cost import Annex.SpecialRemote.Config import Remote.Helper.Special-import Remote.Helper.Messages import Remote.Helper.ExportImport import qualified Remote.Helper.AWS as AWS import Creds@@ -222,9 +221,7 @@ 		]  checkKey :: Remote -> CheckPresent-checkKey r k = do-	showChecking r-	go =<< glacierEnv (config r) (gitconfig r) (uuid r)+checkKey r k = go =<< glacierEnv (config r) (gitconfig r) (uuid r)   where 	go Nothing = giveup "cannot check glacier" 	go (Just e) = do
Remote/Helper/Chunked.hs view
@@ -43,7 +43,7 @@  describeChunkConfig :: ChunkConfig -> String describeChunkConfig NoChunks = "none"-describeChunkConfig (UnpaddedChunks sz) = describeChunkSize sz ++ "chunks"+describeChunkConfig (UnpaddedChunks sz) = describeChunkSize sz ++ " chunks" describeChunkConfig (LegacyChunks sz) = describeChunkSize sz ++ " chunks (old style)"  describeChunkSize :: ChunkSize -> String
Remote/Helper/Encryptable.hs view
@@ -1,6 +1,6 @@ {- common functions for encryptable remotes  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -30,6 +30,7 @@ import qualified Data.Set as S import qualified "sandi" Codec.Binary.Base64 as B64 import qualified Data.ByteString as B+import Control.Concurrent.STM  import Annex.Common import Types.Remote@@ -218,18 +219,29 @@ {- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex  - state. -} remoteCipher' :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, StorableCipher))-remoteCipher' c gc = go $ extractCipher c-  where-	go Nothing = return Nothing-	go (Just encipher) = do-		cache <- Annex.getState Annex.ciphers-		case M.lookup encipher cache of+remoteCipher' c gc = case extractCipher c of+	Nothing -> return Nothing+	Just encipher -> do+		cachev <- Annex.getRead Annex.ciphers+		cachedciper <- liftIO $ atomically $ +			M.lookup encipher <$> readTMVar cachev+		case cachedciper of 			Just cipher -> return $ Just (cipher, encipher)-			Nothing -> do-				cmd <- gpgCmd <$> Annex.getGitConfig-				cipher <- liftIO $ decryptCipher cmd (c, gc) encipher-				Annex.changeState (\s -> s { Annex.ciphers = M.insert encipher cipher cache })-				return $ Just (cipher, encipher)+			-- Not cached; decrypt it, making sure+			-- to only decrypt one at a time. Avoids+			-- prompting for decrypting the same thing twice+			-- when this is run concurrently.+			Nothing -> bracketOnError+				(liftIO $ atomically $ takeTMVar cachev)+				(liftIO . atomically . putTMVar cachev)+				(go cachev encipher)+  where+	go cachev encipher cache = do+		cmd <- gpgCmd <$> Annex.getGitConfig+		cipher <- liftIO $ decryptCipher cmd (c, gc) encipher+		liftIO $ atomically $ putTMVar cachev $+			M.insert encipher cipher cache+		return $ Just (cipher, encipher)  {- Checks if the remote's config allows storing creds in the remote's config.  -
Remote/Helper/Messages.hs view
@@ -25,9 +25,6 @@ instance Describable String where 	describe = id -showChecking :: Describable a => a -> Annex ()-showChecking v = showAction $ "checking " ++ describe v- cantCheck :: Describable a => a -> e cantCheck v = giveup $ "unable to check " ++ describe v
Remote/Helper/Special.hs view
@@ -61,7 +61,7 @@ findSpecialRemotes :: String -> Annex [Git.Repo] findSpecialRemotes s = do 	m <- fromRepo Git.config-	liftIO $ mapM construct $ remotepairs m+	liftIO $ catMaybes <$> mapM construct (remotepairs m)   where 	remotepairs = M.toList . M.filterWithKey match 	construct (k,_) = Git.Construct.remoteNamedFromKey k
Remote/Helper/Ssh.hs view
@@ -59,8 +59,8 @@ 	dir = Git.repoPath r 	shellcmd = "git-annex-shell" 	getshellopts = do-		debug <- liftIO debugEnabled-		let params' = if debug+		debugenabled <- Annex.getRead Annex.debugenabled+		let params' = if debugenabled 			then Param "--debug" : params 			else params 		return (Param command : File (fromRawFilePath dir) : params')@@ -94,9 +94,8 @@  {- Checks if a remote contains a key. -} inAnnex :: Git.Repo -> Key -> Annex Bool-inAnnex r k = do-	showChecking r-	onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex" [Param $ serializeKey k] []+inAnnex r k = onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex"+	[Param $ serializeKey k] []   where 	runcheck c p = liftIO $ dispatch =<< safeSystem c p 	dispatch ExitSuccess = return True
Remote/Hook.hs view
@@ -17,7 +17,6 @@ import Annex.UUID import Annex.SpecialRemote.Config import Remote.Helper.Special-import Remote.Helper.Messages import Remote.Helper.ExportImport import Utility.Env import Messages.Progress@@ -54,7 +53,7 @@ 		(store hooktype) 		(retrieve hooktype) 		(remove hooktype)-		(checkKey r hooktype)+		(checkKey hooktype) 		Remote 			{ uuid = u 			, cost = cst@@ -169,9 +168,8 @@ 	unlessM (runHook' h "remove" k Nothing $ return True) $ 		giveup "failed to remove content" -checkKey :: Git.Repo -> HookName -> CheckPresent-checkKey r h k = do-	showChecking r+checkKey :: HookName -> CheckPresent+checkKey h k = do 	v <- lookupHook h action 	liftIO $ check v   where
Remote/HttpAlso.hs view
@@ -11,7 +11,6 @@ import Types.Remote import Types.ProposedAccepted import Types.Export-import Remote.Helper.Messages import Remote.Helper.ExportImport import Remote.Helper.Special import qualified Git@@ -67,7 +66,7 @@ 		, retrievalSecurityPolicy = RetrievalAllKeysSecure 		, removeKey = cannotModify 		, lockContent = Nothing-		, checkPresent = checkKey url ll (this url ll c cst)+		, checkPresent = checkKey url ll 		, checkPresentCheap = False 		, exportActions = ExportActions 			{ storeExport = cannotModify@@ -130,9 +129,8 @@ 			run (\url -> Url.download' p url dest uo) 				>>= either giveup (const (return ())) -checkKey :: Maybe URLString -> LearnedLayout -> Remote -> Key -> Annex Bool-checkKey baseurl ll r key = do-	showChecking r+checkKey :: Maybe URLString -> LearnedLayout -> Key -> Annex Bool+checkKey baseurl ll key = 	isRight <$> keyUrlAction baseurl ll key (checkKey' key)  checkKey' :: Key -> URLString -> Annex (Either String ())
Remote/Rsync.hs view
@@ -29,7 +29,6 @@ import Annex.Ssh import Annex.Perms import Remote.Helper.Special-import Remote.Helper.Messages import Remote.Helper.ExportImport import Types.Export import Types.ProposedAccepted@@ -84,7 +83,7 @@ 		(fileStorer $ store o) 		(fileRetriever $ retrieve o) 		(remove o)-		(checkKey r o)+		(checkKey o) 		Remote 			{ uuid = u 			, cost = cst@@ -280,10 +279,8 @@ 	unless ok $ 		giveup "rsync failed" -checkKey :: Git.Repo -> RsyncOpts -> CheckPresent-checkKey r o k = do-	showChecking r-	checkPresentGeneric o (rsyncUrls o k)+checkKey :: RsyncOpts -> CheckPresent+checkKey o k = checkPresentGeneric o (rsyncUrls o k)  checkPresentGeneric :: RsyncOpts -> [RsyncUrl] -> Annex Bool checkPresentGeneric o rsyncurls = do
Remote/S3.hs view
@@ -33,7 +33,6 @@ import Control.Monad.Trans.Resource import Control.Monad.Catch import Data.IORef-import System.Log.Logger import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar import Data.Maybe@@ -48,7 +47,6 @@ import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.Http-import Remote.Helper.Messages import Remote.Helper.ExportImport import Types.Import import qualified Remote.Helper.AWS as AWS@@ -450,20 +448,17 @@  checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent checkKey hv r rs c info k = withS3Handle hv $ \case-	Just h -> do-		showChecking r-		eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case-			Left failreason -> do-				warning failreason-				giveup "cannot check content"-			Right loc -> checkKeyHelper info h loc+	Just h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case+		Left failreason -> do+			warning failreason+			giveup "cannot check content"+		Right loc -> checkKeyHelper info h loc 	Nothing -> 		getPublicWebUrls' (uuid r) rs info c k >>= \case 			Left failreason -> do 				warning failreason 				giveup "cannot check content" 			Right us -> do-				showChecking r 				let check u = withUrlOptions $  					Url.checkBoth u (fromKey keySize k) 				anyM check us@@ -1069,13 +1064,13 @@ mkLocationConstraint r = r  debugMapper :: AWS.Logger-debugMapper level t = forward "S3" (T.unpack t)+debugMapper level t = forward "Remote.S3" (T.unpack t)   where 	forward = case level of-		AWS.Debug -> debugM-		AWS.Info -> infoM-		AWS.Warning -> warningM-		AWS.Error -> errorM+		AWS.Debug -> debug+		AWS.Warning -> debug+		AWS.Error -> debug+		AWS.Info -> \_ _ -> return ()  s3Info :: ParsedRemoteConfig -> S3Info -> [(String, String)] s3Info c info = catMaybes
Remote/Web.hs view
@@ -9,7 +9,6 @@  import Annex.Common import Types.Remote-import Remote.Helper.Messages import Remote.Helper.ExportImport import qualified Git import qualified Git.Construct@@ -112,7 +111,6 @@ checkKey' :: Key -> [URLString] -> Annex (Either String Bool) checkKey' key us = firsthit us (Right False) $ \u -> do 	let (u', downloader) = getDownloader u-	showChecking u' 	case downloader of 		YoutubeDownloader -> youtubeDlCheck u' 		_ -> catchMsgIO $
Remote/WebDAV.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}  module Remote.WebDAV (remote, davCreds, configUrl) where @@ -21,7 +22,6 @@ import System.IO.Error import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO)-import System.Log.Logger (debugM) import Control.Concurrent.STM hiding (check)  import Annex.Common@@ -33,7 +33,6 @@ import Config.Cost import Annex.SpecialRemote.Config import Remote.Helper.Special-import Remote.Helper.Messages import Remote.Helper.Http import Remote.Helper.ExportImport import qualified Remote.Helper.Chunked.Legacy as Legacy@@ -78,7 +77,7 @@ 		(store hdl chunkconfig) 		(retrieve hdl chunkconfig) 		(remove hdl)-		(checkKey hdl this chunkconfig)+		(checkKey hdl chunkconfig) 		this 	  where 		this = Remote@@ -198,9 +197,8 @@ 				Right False -> return () 				_ -> giveup "failed to remove content from remote" -checkKey :: DavHandleVar -> Remote -> ChunkConfig -> CheckPresent-checkKey hv r chunkconfig k = withDavHandle hv $ \dav -> do-	showChecking r+checkKey :: DavHandleVar -> ChunkConfig -> CheckPresent+checkKey hv chunkconfig k = withDavHandle hv $ \dav -> 	case chunkconfig of 		LegacyChunks _ -> checkKeyLegacyChunked dav k 		_ -> do@@ -533,4 +531,4 @@ 	keyloc = keyLocation k  debugDav :: MonadIO m => String -> DAVT m ()-debugDav msg = liftIO $ debugM "WebDAV" msg+debugDav msg = liftIO $ debug "Remote.WebDAV" msg
RemoteDaemon/Common.hs view
@@ -26,14 +26,14 @@ -- since only one liftAnnex can be running at a time, across all -- transports. liftAnnex :: TransportHandle -> Annex a -> IO a-liftAnnex (TransportHandle _ annexstate) a = do-	st <- takeMVar annexstate-	(r, st') <- Annex.run st a-	putMVar annexstate st'+liftAnnex (TransportHandle _ stmv rd) a = do+	st <- takeMVar stmv+	(r, (st', _rd)) <- Annex.run (st, rd) a+	putMVar stmv st' 	return r  inLocalRepo :: TransportHandle -> (Git.Repo -> IO a) -> IO a-inLocalRepo (TransportHandle (LocalRepo g) _) a = a g+inLocalRepo (TransportHandle (LocalRepo g) _ _) a = a g  -- Check if some shas should be fetched from the remote, -- and presumably later merged.
RemoteDaemon/Core.hs view
@@ -139,7 +139,7 @@ -- Generates a map with a transport for each supported remote in the git repo, -- except those that have annex.sync = false genRemoteMap :: TransportHandle -> TChan Emitted -> IO RemoteMap-genRemoteMap h@(TransportHandle (LocalRepo g) _) ochan = do+genRemoteMap h@(TransportHandle (LocalRepo g) _ _) ochan = do 	rs <- Git.Construct.fromRemotes g 	M.fromList . catMaybes <$> mapM gen rs   where@@ -161,17 +161,18 @@  genTransportHandle :: IO TransportHandle genTransportHandle = do-	annexstate <- newMVar =<< Annex.new =<< Git.CurrentRepo.get-	g <- Annex.repo <$> readMVar annexstate-	let h = TransportHandle (LocalRepo g) annexstate+	(st, rd) <- Annex.new =<< Git.CurrentRepo.get+	mvar <- newMVar st+	let g = Annex.repo st+	let h = TransportHandle (LocalRepo g) mvar rd 	liftAnnex h $ do 		Annex.setOutput QuietOutput 		enableInteractiveBranchAccess 	return h  updateTransportHandle :: TransportHandle -> IO TransportHandle-updateTransportHandle h@(TransportHandle _g annexstate) = do+updateTransportHandle h@(TransportHandle _g st rd) = do 	g' <- liftAnnex h $ do 		reloadConfig 		Annex.gitRepo-	return (TransportHandle (LocalRepo g') annexstate)+	return (TransportHandle (LocalRepo g') st rd)
RemoteDaemon/Transport/GCrypt.hs view
@@ -17,7 +17,7 @@ import Annex.Ssh  transport :: Transport-transport rr@(RemoteRepo r gc) url h@(TransportHandle (LocalRepo g) _) ichan ochan+transport rr@(RemoteRepo r gc) url h@(TransportHandle (LocalRepo g) _ _) ichan ochan 	| accessShellConfig gc = do 		r' <- encryptedRemote g r 		v <- liftAnnex h $ git_annex_shell ConsumeStdin r' "notifychanges" [] []
RemoteDaemon/Transport/Ssh.hs view
@@ -29,10 +29,10 @@ 		Just (cmd, params) -> transportUsingCmd cmd params rr url h ichan ochan  transportUsingCmd :: FilePath -> [CommandParam] -> Transport-transportUsingCmd cmd params rr@(RemoteRepo r gc) url h@(TransportHandle (LocalRepo g) s) ichan ochan = do+transportUsingCmd cmd params rr@(RemoteRepo r gc) url h@(TransportHandle (LocalRepo g) st rd) ichan ochan = do 	-- enable ssh connection caching wherever inLocalRepo is called 	g' <- liftAnnex h $ sshOptionsTo r gc g-	let transporthandle = TransportHandle (LocalRepo g') s+	let transporthandle = TransportHandle (LocalRepo g') st rd 	transportUsingCmd' cmd params rr url transporthandle ichan ochan  transportUsingCmd' :: FilePath -> [CommandParam] -> Transport
RemoteDaemon/Transport/Tor.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module RemoteDaemon.Transport.Tor (server, transport, torSocketFile) where @@ -27,9 +28,9 @@ import Messages import Git import Git.Command+import Utility.Debug  import Control.Concurrent-import System.Log.Logger (debugM) import Control.Concurrent.STM import Control.Concurrent.STM.TBMQueue import Control.Concurrent.Async@@ -39,7 +40,7 @@  -- Run tor hidden service. server :: Server-server ichan th@(TransportHandle (LocalRepo r) _) = go+server ichan th@(TransportHandle (LocalRepo r) _ _) = go   where 	go = checkstartservice >>= handlecontrol @@ -48,7 +49,7 @@ 		msock <- liftAnnex th torSocketFile 		case msock of 			Nothing -> do-				debugM "remotedaemon" "Tor hidden service not enabled"+				debugTor "Tor hidden service not enabled" 				return False 			Just sock -> do 				void $ async $ startservice sock u@@ -59,7 +60,7 @@ 		replicateM_ maxConnections $ 			forkIO $ forever $ serveClient th u r q -		debugM "remotedaemon" "Tor hidden service running"+		debugTor "Tor hidden service running" 		serveUnixSocket sock $ \conn -> do 			ok <- atomically $ ifM (isFullTBMQueue q) 				( return False@@ -88,16 +89,16 @@ maxConnections = 100  serveClient :: TransportHandle -> UUID -> Repo -> TBMQueue Handle -> IO ()-serveClient th u r q = bracket setup cleanup start+serveClient th@(TransportHandle _ _ rd) u r q = bracket setup cleanup start   where 	setup = do 		h <- atomically $ readTBMQueue q-		debugM "remotedaemon" "serving a Tor connection"+		debugTor "serving a Tor connection" 		return h 	 	cleanup Nothing = return () 	cleanup (Just h) = do-		debugM "remotedaemon" "done with Tor connection"+		debugTor "done with Tor connection" 		hClose h  	start Nothing = return ()@@ -105,7 +106,7 @@ 		-- Avoid doing any work in the liftAnnex, since only one 		-- can run at a time. 		st <- liftAnnex th dupState-		((), st') <- Annex.run st $ do+		((), (st', _rd)) <- Annex.run (st, rd) $ do 			-- Load auth tokens for every connection, to notice 			-- when the allowed set is changed. 			allowed <- loadP2PAuthTokens@@ -121,9 +122,9 @@ 			v <- liftIO $ runNetProto runstauth conn $ P2P.serveAuth u 			case v of 				Right (Just theiruuid) -> authed conn theiruuid-				Right Nothing -> liftIO $ debugM "remotedaemon"+				Right Nothing -> liftIO $ debugTor 					"Tor connection failed to authenticate"-				Left e -> liftIO $ debugM "remotedaemon" $+				Left e -> liftIO $ debugTor $ 					"Tor connection error before authentication: " ++ describeProtoFailure e 		-- Merge the duplicated state back in. 		liftAnnex th $ mergeState st'@@ -135,7 +136,7 @@ 				P2P.serveAuthed P2P.ServeReadWrite u 			case v' of 				Right () -> return ()-				Left e -> liftIO $ debugM "remotedaemon" $ +				Left e -> liftIO $ debugTor $  					"Tor connection error: " ++ describeProtoFailure e  -- Connect to peer's tor hidden service.@@ -200,3 +201,6 @@ 	let uid = 0 #endif 	liftIO $ getHiddenServiceSocketFile torAppName uid ident++debugTor :: String -> IO ()+debugTor = debug "RemoteDaemon.Transport.Tor"
RemoteDaemon/Types.hs view
@@ -35,12 +35,12 @@ data RemoteRepo = RemoteRepo Git.Repo RemoteGitConfig newtype LocalRepo = LocalRepo Git.Repo --- All Transports share a single AnnexState MVar+-- All Transports share a single AnnexState MVar and an AnnexRead. -- -- Different TransportHandles may have different versions of the LocalRepo. -- (For example, the ssh transport modifies it to enable ssh connection -- caching.)-data TransportHandle = TransportHandle LocalRepo (MVar Annex.AnnexState)+data TransportHandle = TransportHandle LocalRepo (MVar Annex.AnnexState) Annex.AnnexRead  -- Messages that the daemon emits. data Emitted
Test.hs view
@@ -223,7 +223,13 @@ 		]  testRemotes :: TestTree-testRemotes = testGroup "Remote Tests"+testRemotes = testGroup "Remote Tests" $+	-- These tests are failing in really strange ways on Windows,+	-- apparently not due to an actual problem with the remotes being+	-- tested, so are disabled there.+#ifdef mingw32_HOST_OS+	filter (\_ -> False)+#endif 	[ testGitRemote 	, testDirectoryRemote 	]
Types/DeferredParse.hs view
@@ -1,6 +1,6 @@ {- git-annex deferred parse values  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -12,6 +12,8 @@ import Annex  import Options.Applicative+import qualified Data.Semigroup as Sem+import Prelude  -- Some values cannot be fully parsed without performing an action. -- The action may be expensive, so it's best to call finishParse on such a@@ -36,6 +38,20 @@ instance DeferredParseClass [DeferredParse a] where 	finishParse v = mapM finishParse v --- Use when the Annex action modifies Annex state.-type GlobalSetter = DeferredParse () type GlobalOption = Parser GlobalSetter++-- Used for global options that can modify Annex state by running+-- an arbitrary action in it, and can also set up AnnexRead.+data GlobalSetter = GlobalSetter+	{ annexStateSetter :: Annex ()+	, annexReadSetter :: AnnexRead -> AnnexRead+	}++instance Sem.Semigroup GlobalSetter where+	a <> b = GlobalSetter+		{ annexStateSetter = annexStateSetter a >> annexStateSetter b+		, annexReadSetter = annexReadSetter b . annexReadSetter a+		}++instance Monoid GlobalSetter where+	mempty = GlobalSetter (return ()) id
Types/GitConfig.hs view
@@ -1,6 +1,6 @@ {- git-annex configuration  -- - Copyright 2012-2020 Joey Hess <id@joeyh.name>+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -30,6 +30,7 @@ import qualified Git.Construct import Git.Types import Git.ConfigTypes+import Git.Remote (isRemoteKey, remoteKeyToRemoteName) import Git.Branch (CommitMode(..)) import Utility.DataUnits import Config.Cost@@ -50,6 +51,7 @@  import Control.Concurrent.STM import qualified Data.Set as S+import qualified Data.Map as M import qualified Data.ByteString as B  -- | A configurable value, that may not be fully determined yet because@@ -90,6 +92,7 @@ 	, annexSyncContent :: GlobalConfigurable Bool 	, annexSyncOnlyAnnex :: GlobalConfigurable Bool 	, annexDebug :: Bool+	, annexDebugFilter :: Maybe String 	, annexWebOptions :: [String] 	, annexYoutubeDlOptions :: [String] 	, annexAriaTorrentOptions :: [String]@@ -135,12 +138,13 @@ 	, gcryptId :: Maybe String 	, gpgCmd :: GpgCmd 	, mergeDirectoryRenames :: Maybe String+	, annexPrivateRepos :: S.Set UUID 	}  extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig extractGitConfig configsource r = GitConfig 	{ annexVersion = RepoVersion <$> getmayberead (annexConfig "version")-	, annexUUID = maybe NoUUID toUUID $ getmaybe (annexConfig "uuid")+	, annexUUID = hereuuid 	, annexNumCopies = NumCopies <$> getmayberead (annexConfig "numcopies") 	, annexDiskReserve = fromMaybe onemegabyte $ 		readSize dataUnits =<< getmaybe (annexConfig "diskreserve")@@ -170,6 +174,7 @@ 	, annexSyncOnlyAnnex = configurable False $  		getmaybebool (annexConfig "synconlyannex") 	, annexDebug = getbool (annexConfig "debug") False+	, annexDebugFilter = getmaybe (annexConfig "debugfilter") 	, annexWebOptions = getwords (annexConfig "web-options") 	, annexYoutubeDlOptions = getwords (annexConfig "youtube-dl-options") 	, annexAriaTorrentOptions = getwords (annexConfig "aria-torrent-options")@@ -237,6 +242,19 @@ 	, gcryptId = getmaybe "core.gcrypt-id" 	, gpgCmd = mkGpgCmd (getmaybe "gpg.program") 	, mergeDirectoryRenames = getmaybe "directoryrenames"+	, annexPrivateRepos = S.fromList $ concat+		[ if getbool (annexConfig "private") False+			then [hereuuid]+			else []+		, let get (k, v)+			| Git.Config.isTrueFalse' v /= Just True = Nothing+			| isRemoteKey (remoteAnnexConfigEnd "private") k = do+				remotename <- remoteKeyToRemoteName k+				toUUID <$> Git.Config.getMaybe+					(remoteAnnexConfig remotename "uuid") r+			| otherwise = Nothing+		  in mapMaybe get (M.toList (Git.config r))+		] 	}   where 	getbool k d = fromMaybe d $ getmaybebool k@@ -253,6 +271,8 @@ 		FromGlobalConfig -> HasGlobalConfig v  	onemegabyte = 1000000+	+	hereuuid = maybe NoUUID toUUID $ getmaybe (annexConfig "uuid")  {- Merge a GitConfig that comes from git-config with one containing  - repository-global defaults. -}@@ -277,13 +297,14 @@ {- Configs that can be set repository-global. -} globalConfigs :: [ConfigKey] globalConfigs =-	[ annexConfig "autocommit"-	, annexConfig "synccontent"-	, annexConfig "synconlyannex"-	, annexConfig "resolvemerge"-	, annexConfig "largefiles"+	[ annexConfig "largefiles" 	, annexConfig "dotfiles" 	, annexConfig "addunlocked"+	, annexConfig "autocommit"+	, annexConfig "resolvemerge"+	, annexConfig "synccontent"+	, annexConfig "synconlyannex"+	, annexConfig "securehashesonly" 	]  {- Per-remote git-annex settings. Each setting corresponds to a git-config@@ -441,7 +462,10 @@  {- A per-remote annex setting in git config. -} remoteAnnexConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey-remoteAnnexConfig r key = remoteConfig r ("annex-" <> key)+remoteAnnexConfig r = remoteConfig r . remoteAnnexConfigEnd++remoteAnnexConfigEnd :: UnqualifiedConfigKey -> UnqualifiedConfigKey+remoteAnnexConfigEnd key = "annex-" <> key  {- A per-remote setting in git config. -} remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
Types/NumCopies.hs view
@@ -145,9 +145,9 @@  - dropped from the local repo. That lock will prevent other git repos  - that are concurrently dropping from using the local copy as a VerifiedCopy.  - So, no additional locking is needed; all we need is verifications- - of any kind of N other copies of the content. -}-isSafeDrop (NumCopies n) _ l (Just (ContentRemovalLock _)) = -	length (deDupVerifiedCopies l) >= n+ - of any kind of enough other copies of the content. -}+isSafeDrop (NumCopies n) (MinCopies m) l (Just (ContentRemovalLock _)) = +	length (deDupVerifiedCopies l) >= max n m {- Dropping from a remote repo.  -  - To guarantee MinCopies is never violated, at least that many LockedCopy
Upgrade/V2.hs view
@@ -83,7 +83,7 @@ inject source dest = do 	old <- fromRepo olddir 	new <- liftIO (readFile $ old </> source)-	Annex.Branch.change (toRawFilePath dest) $ \prev -> +	Annex.Branch.change (Annex.Branch.RegardingUUID []) (toRawFilePath dest) $ \prev ->  		encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new  logFiles :: FilePath -> Annex [FilePath]
+ Utility/Debug.hs view
@@ -0,0 +1,102 @@+{- Debug output+ -+ - Copyright 2021 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-tabs -w #-}++module Utility.Debug (+	DebugSource(..),+	DebugSelector(..),+	configureDebug,+	getDebugSelector,+	debug,+	fastDebug+) where++import qualified Data.ByteString as S+import Data.IORef+import Data.String+import Data.Time+import System.IO.Unsafe (unsafePerformIO)+import qualified Data.Semigroup as Sem+import Prelude++import Utility.FileSystemEncoding++-- | The source of a debug message. For example, this could be a module or+-- function name.+newtype DebugSource = DebugSource S.ByteString+	deriving (Eq, Show)++instance IsString DebugSource where+	fromString = DebugSource . encodeBS'++-- | Selects whether to display a message from a source.+data DebugSelector +	= DebugSelector (DebugSource -> Bool)+	| NoDebugSelector++instance Sem.Semigroup DebugSelector where+	DebugSelector a <> DebugSelector b = DebugSelector (\v -> a v || b v)+	NoDebugSelector <> NoDebugSelector = NoDebugSelector+	NoDebugSelector <> b = b+	a <> NoDebugSelector = a++instance Monoid DebugSelector where+	mempty = NoDebugSelector++-- | Configures debugging.+configureDebug+	:: (S.ByteString -> IO ())+	-- ^ Used to display debug output.+	-> DebugSelector+	-> IO ()+configureDebug src p = writeIORef debugConfigGlobal (src, p)++-- | Gets the currently configured DebugSelector.+getDebugSelector :: IO DebugSelector+getDebugSelector = snd <$> readIORef debugConfigGlobal++-- A global variable for the debug configuration.+{-# NOINLINE debugConfigGlobal #-}+debugConfigGlobal :: IORef (S.ByteString -> IO (), DebugSelector)+debugConfigGlobal = unsafePerformIO $ newIORef (dontshow, selectnone)+  where+	dontshow _ = return ()+	selectnone = NoDebugSelector++-- | Displays a debug message, if that has been enabled by configureDebug.+--+-- This is reasonably fast when debugging is not enabled, but since it does+-- have to consult a IORef each time, using it in a tight loop may slow+-- down the program.+debug :: DebugSource -> String -> IO ()+debug src msg = readIORef debugConfigGlobal >>= \case+	(displayer, NoDebugSelector) ->+		displayer =<< formatDebugMessage src msg+	(displayer, DebugSelector p)+		| p src -> displayer =<< formatDebugMessage src msg+		| otherwise -> return ()++-- | Displays a debug message, if the DebugSelector allows.+--+-- When the DebugSelector does not let the message be displayed, this runs+-- very quickly, allowing it to be used inside tight loops.+fastDebug :: DebugSelector -> DebugSource -> String -> IO ()+fastDebug NoDebugSelector src msg = do+	(displayer, _) <- readIORef debugConfigGlobal+	displayer =<< formatDebugMessage src msg+fastDebug (DebugSelector p) src msg+	| p src = fastDebug NoDebugSelector src msg+	| otherwise = return ()++formatDebugMessage :: DebugSource -> String -> IO S.ByteString+formatDebugMessage (DebugSource src) msg = do+	t <- encodeBS' . formatTime defaultTimeLocale "[%F %X%Q]"+		<$> getZonedTime+	return (t <> " (" <> src <> ") " <> encodeBS msg)
Utility/Process.hs view
@@ -7,6 +7,7 @@  -}  {-# LANGUAGE CPP, Rank2Types, LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Process (@@ -38,10 +39,10 @@ import Utility.Misc import Utility.Exception import Utility.Monad+import Utility.Debug  import System.Exit import System.IO-import System.Log.Logger import Control.Monad.IO.Class import Control.Concurrent.Async import qualified Data.ByteString as S@@ -187,7 +188,7 @@ debugProcess :: CreateProcess -> ProcessHandle -> IO () debugProcess p h = do 	pid <- getPid h-	debugM "Utility.Process" $ unwords+	debug "Utility.Process" $ unwords 		[ describePid pid 		, action ++ ":" 		, showCmd p@@ -211,7 +212,7 @@ 	-- Have to get pid before waiting, which closes the ProcessHandle. 	pid <- getPid h 	r <- Utility.Process.Shim.waitForProcess h-	debugM "Utility.Process" (describePid pid ++ " done " ++ show r)+	debug "Utility.Process" (describePid pid ++ " done " ++ show r) 	return r  cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
Utility/Url.hs view
@@ -44,6 +44,7 @@ ) where  import Common+import Utility.Debug import Utility.Metered #ifdef WITH_HTTP_CLIENT_RESTRICTED import Network.HTTP.Client.Restricted@@ -73,7 +74,6 @@ import Data.Either import Data.Conduit import Text.Read-import System.Log.Logger  type URLString = String @@ -269,7 +269,7 @@  	existsconduit' req uo' = do 		let req' = headRequest (applyRequest uo req)-		debugM "url" (show req')+		debug "Utility.Url" (show req') 		join $ runResourceT $ do 			resp <- http req' (httpManager uo) 			if responseStatus resp == ok200@@ -383,7 +383,7 @@ 					| isfileurl u -> downloadfile u 					| otherwise -> downloadcurl url basecurlparams 		Nothing -> do-			liftIO $ debugM "url" url+			liftIO $ debug "Utility.Url" url 			dlfailed "invalid url" 	 	isfileurl u = uriScheme u == "file:"@@ -458,7 +458,7 @@ 	catchMaybeIO (getFileSize (toRawFilePath file)) >>= \case 		Just sz | sz > 0 -> resumedownload sz 		_ -> join $ runResourceT $ do-			liftIO $ debugM "url" (show req')+			liftIO $ debug "Utility.Url" (show req') 			resp <- http req' (httpManager uo) 			if responseStatus resp == ok200 				then do@@ -490,7 +490,7 @@ 	-- send the whole file rather than resuming. 	resumedownload sz = join $ runResourceT $ do 		let req'' = req' { requestHeaders = resumeFromHeader sz : requestHeaders req' }-		liftIO $ debugM "url" (show req'')+		liftIO $ debug "Urility.Url" (show req'') 		resp <- http req'' (httpManager uo) 		if responseStatus resp == partialContent206 			then do@@ -579,7 +579,7 @@ 		Nothing -> return Nothing 		Just req -> do 			let req' = applyRequest uo req-			liftIO $ debugM "url" (show req')+			liftIO $ debug "Utility.Url" (show req') 			withResponse req' (httpManager uo) $ \resp -> 				if responseStatus resp == ok200 					then Just <$> brReadSome (responseBody resp) n
+ doc/git-annex-config.mdwn view
@@ -0,0 +1,132 @@+# NAME++git-annex config - configuration stored in git-annex branch++# SYNOPSIS++git annex config --set name value++git annex config --get name++git annex config --unset name++# DESCRIPTION++Set or get configuration settings stored in the git-annex branch.++Unlike `git config` settings, these settings can be seen+in all clones of the repository, once they have gotten their+git-annex branches in sync.++These settings can be overridden on a per-repository basis using+`git config`.++git-annex does not check the git-annex branch for all the `git config`+settings that affect it (which are listed on the git-annex man page+CONFIGURATION section). Only a few make sense to be able to set such+that all clones of a repository see the setting, and so git-annex only+looks for these.++# SUPPORTED SETTINGS++* `annex.largefiles`++   Used to configure which files are large enough to be added to the annex.+   It is an expression that matches the large files, eg+   "`include=*.mp3 or largerthan(500kb)`".+   See [[git-annex-matching-expression]](1) for details on the syntax.++   This sets a default, which can be overridden by annex.largefiles+   attributes in `.gitattributes` files, or by `git config`.++* `annex.dotfiles`++   Normally, dotfiles are assumed to be files like .gitignore,+   whose content should always be part of the git repository, so +   they will not be added to the annex. Setting annex.dotfiles to true+   makes dotfiles be added to the annex the same as any other file. ++   This sets a default, which can be overridden by annex.dotfiles+   in `git config`.++* `annex.addunlocked`++   Commands like `git-annex add` default to adding files to the repository+   in locked form. This can make them add the files in unlocked form,+   the same as if [[git-annex-unlock]](1) were run on the files.+ +   This can be set to "true" to add everything unlocked, or it can be a more+   complicated expression that matches files by name, size, or content. See+   [[git-annex-matching-expression]](1) for details.++   This sets a default, which can be overridden by annex.addunlocked+   in `git config`.++* `annex.autocommit`++  Set to false to prevent the `git-annex assistant` and `git-annex sync`+  from automatically committing changes to files in the repository.++* `annex.resolvemerge`++  Set to false to prevent merge conflicts in the checked out branch+  being automatically resolved by the `git-annex assitant`,+  `git-annex sync`, `git-annex merge`, and the `git-annex post-receive`+  hook.++* `annex.synccontent`++  Set to true to make git-annex sync default to syncing annexed content.++* `annex.synconlyannex`++  Set to true to make git-annex sync default to only sincing the git-annex+  branch and annexed content.++* `annex.securehashesonly`++  Set to true to indicate that the repository should only use+  cryptographically secure hashes (SHA2, SHA3) and not insecure+  hashes (MD5, SHA1) for content.++  When this is set, the contents of files using cryptographically+  insecure hashes will not be allowed to be added to the repository.++  Also, `git-annex fsck` will complain about any files present in+  the repository that use insecure hashes.+  +  Note that this is only read from the git-annex branch by+  `git annex init`, and is copied to the corresponding git config setting. +  So, changes to the value in the git-annex branch won't affect a+  repository once it has been initialized.++# EXAMPLE++Suppose you want to prevent git annex sync from committing changes+to files, so a manual git commit workflow is used in all clones of the+repository. Then run:++	git annex config --set annex.autocommit false++If you want to override that in a partiticular clone, just use git config+in the clone:++	git config annex.autocommit true++And to get back to the default behavior:++	git annex config --unset annex.autocommit++# SEE ALSO++[[git-annex]](1)++git-config(1)++[[git-annex-vicfg]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.
doc/git-annex-diffdriver.mdwn view
@@ -9,10 +9,10 @@ # DESCRIPTION  This is an external git diff driver shim. Normally, when using `git diff`-with an external diff driver, the symlinks to annexed files are not set up-right, so the external diff driver cannot read them in order to perform-smart diffing of their contents. This command works around the problem,-by passing the fixed up files to the real external diff driver.+with an external diff driver, it will not see the contents of annexed+files, since git passes to it the git-annex symlinks or pointer files.+This command works around the problem, by running the +real external diff driver, and passing it the paths to the annexed content.  To use this, you will need to have installed some git external diff driver command. This is not the regular diff command; it takes a git-specific
doc/git-annex-initremote.mdwn view
@@ -74,6 +74,12 @@   compatabilities.   <http://git-annex.branchable.com/tips/multiple_remotes_accessing_the_same_data_store/> +* `--private`++  Avoid recording information about the special remote in the git-annex+  branch. The special remote will only be usable from the repository where+  it was created.+ # COMMON CONFIGURATION PARAMETERS  * `encryption`
doc/git-annex-log.mdwn view
@@ -8,10 +8,18 @@  # DESCRIPTION -Displays the location log for the specified file or files,-showing each repository they were added to ("+") and removed from ("-").-Note that the location log is for the particular file contents currently at these paths,+Displays the location log for the specified file or files, showing each+repository they were added to ("+") and removed from ("-"). Note that the+location log is for the particular file contents currently at these paths, not for any different content that was there in earlier commits.++This displays information from the history of the git-annex branch. Several+things can prevent that information being available to display. When+[[git-annex-dead]] and [[git-annex-forget]] are used, old historical+data gets cleared from the branch. When annex.private or +remote.name.annex-private is configured, git-annex does not write+information to the branch at all. And when annex.alwayscommit is set to+false, information may not have been committed to the branch yet.  # OPTIONS
doc/git-annex-sync.mdwn view
@@ -34,6 +34,17 @@ remote, it will merge the `synced/` branches that the repository has received. +Some special remotes contain a tree of files that can be imported+and/or exported, and syncing with these remotes behaves differently.+See  [[git-annex-import]](1) and [[git-annex-export]](1) for details+about how importing and exporting work; syncing with such a remote +is essentially an import followed by an export. In many cases,+importing needs to download content from the remote, and so sync will+only import when the --content option is used. (And exporting only+ever happens when --content is used.) The remote's +`remote.<name>.annex-tracking-branch` also must be configured, and+have the same value as the currently checked out branch.+ # OPTIONS  * `[remote]`@@ -97,25 +108,18 @@    Normally, syncing does not transfer the contents of annexed files.   The --content option causes the content of annexed files-  to also be uploaded and downloaded as necessary.+  to also be uploaded and downloaded as necessary, to sync the content+  between the repository and its remotes.    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 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).--  When `remote.<name>.annex-tracking-branch` is configured for a special-  remote and that branch is checked out, syncing with --content will-  import changes from the remote, merge them into the branch, and export-  any changes that have been committed to the branch back to the remote.-  With --no-content, imports will only be made from special remotes that-  support importing without transferring files, and no exports will be done.-  See [[git-annex-import]](1) and [[git-annex-export]](1) for details-  about how importing and exporting work.+  and whose content the local repository does not yet have, from any remote+  that it's syncing with that has a copy, and then copies each file to+  every remote that it is syncing with. This behavior can be overridden by+  configuring the preferred content of repositories. See+  [[git-annex-preferred-content]](1).  * `--content-of=path` `-C path`
+ doc/git-annex-unregisterurl.mdwn view
@@ -0,0 +1,41 @@+# NAME++git-annex unregisterurl - unregisters an url for a key++# SYNOPSIS++git annex unregisterurl `[key url]`++# DESCRIPTION++This plumbing-level command can be used to unregister urls when keys can+no longer be downloaded from them.++Unregistering a key's last web url will make git-annex no longer treat content+as being present in the web special remote.++# OPTIONS++* `--batch`++  In batch input mode, lines are read from stdin, and each line+  should contain a key and url, separated by a single space.++* `-z`++   When in batch mode, the input is delimited by nulls instead of the usual+   newlines.++# SEE ALSO++[[git-annex]](1)++[[git-annex-registerurl]](1)++[[git-annex-rmurl]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.
doc/git-annex.mdwn view
@@ -780,12 +780,28 @@  * `--debug` -  Show debug messages.+  Display debug messages.  * `--no-debug` -  Disable debug messages.+  Disable display of debug messages. +* `--debugfilter=name[,name..]`++  When debug message display has been enabled by `--debug`, this filters+  the debug messages that are displayed to ones coming from modules with+  the specified names.+  +  To find the names of modules, see the full debug output, which includes+  the module name, eg "(Utility.Process)"++  The full module name does not need to be+  specified when using this, a substring of the name will do.++  For example, `--debugfilter=Process,External` will display debugging+  output when git-annex runs processes, and when it communicates with+  external special remotes.+ * `--numcopies=n`    Overrides the numcopies setting.@@ -796,7 +812,7 @@    Overrides the mincopies setting. -  Note that setting numcopies to 0 is very unsafe.+  Note that setting mincopies to 0 is very unsafe.  * `--time-limit=time` @@ -1142,6 +1158,19 @@   To avoid that merging, set this to "false". This can be useful   particularly when you don't have write permission to the repository. +* `annex.private`++  When this is set to true, no information about the repository will be+  recorded in the git-annex branch.++  For example, to make a repository without any mention of it ever+  appearing in the git-annex branch:++	git init myprivate+	cd myprivaterepo+	git config annex.private true+	git annex init+ * `annex.hardlink`    Set this to `true` to make file contents be hard linked between the@@ -1171,7 +1200,7 @@   And when multiple files in the work tree have the same content, only   one of them gets hard linked to the annex. -* `annex.supportunlocked'+* `annex.supportunlocked`    By default git-annex supports unlocked files as well as locked files,   so this defaults to true. If set to false, git-annex will only support@@ -1214,6 +1243,12 @@    Set to true to enable debug logging by default. +* `annex.debugfilter`++  Set to configure which debug messages to display (when debug message+  display has been enabled by annex.debug or --debug). The value is one+  or more module names, separated by commas.+ * `annex.version`    The current version of the git-annex repository. This is@@ -1505,6 +1540,13 @@   indicate that it does. This will cause git-annex to try to get all file   contents from the remote. Can be useful in setting up a caching remote. +* `remote.<name>.annex-private`++  When this is set to true, no information about the remote will be+  recorded in the git-annex branch. This is mostly useful for special+  remotes, and is set when using [[git-annex-initremote]](1) with the+  `--private` option.+ * `remote.<name>.annex-bare`    Can be used to tell git-annex if a remote is a bare repository@@ -1898,7 +1940,7 @@ 	*.wav annex.numcopies=2 	*.flac annex.numcopies=3 -Note that setting numcopies and mincopies to 0 is very unsafe.+Note that setting numcopies or mincopies to 0 is very unsafe.  These settings are honored by git-annex whenever it's operating on a matching file. However, when using --all, --unused, or --key to specify
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20210330+Version: 8.20210428 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -48,6 +48,7 @@   doc/git-annex-assistant.mdwn   doc/git-annex-calckey.mdwn   doc/git-annex-checkpresentkey.mdwn+  doc/git-annex-config.mdwn   doc/git-annex-contentlocation.mdwn   doc/git-annex-copy.mdwn   doc/git-annex-dead.mdwn@@ -128,6 +129,7 @@   doc/git-annex-uninit.mdwn   doc/git-annex-unlock.mdwn   doc/git-annex-untrust.mdwn+  doc/git-annex-unregisterurl.mdwn   doc/git-annex-unused.mdwn   doc/git-annex-upgrade.mdwn   doc/git-annex-vadd.mdwn@@ -297,10 +299,11 @@   location: git://git-annex.branchable.com/  custom-setup-  Setup-Depends: base (>= 4.11.1.0), hslogger, split, unix-compat, +  Setup-Depends: base (>= 4.11.1.0), split, unix-compat,      filepath, exceptions, bytestring, directory, IfElse, data-default,     filepath-bytestring (>= 1.4.2.1.4),     process (>= 1.6.3),+    time (>= 1.5.0),     async, utf8-string, transformers, Cabal  Executable git-annex@@ -327,8 +330,7 @@    filepath,    filepath-bytestring (>= 1.4.2.1.1),    IfElse,-   hslogger,-   monad-logger,+   monad-logger (>= 0.3.10),    free,    utf8-string,    bytestring,@@ -626,7 +628,10 @@     Annex.Content.Presence     Annex.Content.LowLevel     Annex.Content.PointerFile+    Annex.CopyFile     Annex.CurrentBranch+    Annex.Debug+    Annex.Debug.Utility     Annex.Difference     Annex.DirHashes     Annex.Drop@@ -901,6 +906,7 @@     Logs.Difference     Logs.Difference.Pure     Logs.Export+    Logs.Export.Pure     Logs.File     Logs.FsckResults     Logs.Group@@ -1068,6 +1074,7 @@     Utility.Daemon     Utility.Data     Utility.DataUnits+    Utility.Debug     Utility.DebugLocks     Utility.DirWatcher     Utility.DirWatcher.Types