git-annex 10.20220822 → 10.20220927
raw patch · 66 files changed
+852/−372 lines, 66 files
Files
- Annex.hs +6/−2
- Annex/FileMatcher.hs +1/−1
- Annex/Import.hs +3/−3
- Annex/Init.hs +25/−14
- Annex/Link.hs +104/−72
- Annex/Locations.hs +11/−1
- Annex/Perms.hs +7/−8
- Annex/PidLock.hs +10/−6
- Annex/Queue.hs +1/−1
- Annex/TransferrerPool.hs +16/−2
- Annex/Url.hs +6/−7
- BuildFlags.hs +4/−1
- CHANGELOG +49/−0
- CmdLine/Action.hs +9/−9
- CmdLine/GitAnnex.hs +3/−1
- CmdLine/Seek.hs +25/−14
- Command.hs +2/−1
- Command/Assistant.hs +2/−1
- Command/EnableTor.hs +12/−1
- Command/Fsck.hs +1/−1
- Command/Move.hs +1/−2
- Command/Reinit.hs +1/−1
- Command/Restage.hs +25/−0
- Command/VCycle.hs +1/−1
- Command/Vicfg.hs +10/−1
- Git.hs +1/−1
- Git/Config.hs +29/−17
- Git/Construct.hs +1/−0
- Git/Credential.hs +57/−13
- Git/CurrentRepo.hs +3/−2
- Git/Queue.hs +3/−3
- Git/Types.hs +2/−0
- Git/UpdateIndex.hs +22/−11
- Limit.hs +1/−1
- Logs/File.hs +34/−9
- Logs/Restage.hs +63/−0
- Logs/Smudge.hs +1/−1
- Remote/Adb.hs +6/−5
- Remote/Borg.hs +1/−1
- Remote/Ddar.hs +2/−1
- Remote/Directory.hs +32/−18
- Remote/Git.hs +3/−3
- Remote/Helper/ExportImport.hs +17/−14
- Remote/S3.hs +3/−2
- Test.hs +16/−4
- Test/Framework.hs +11/−4
- Types/GitConfig.hs +1/−1
- Types/Remote.hs +2/−2
- Types/Test.hs +2/−0
- Upgrade.hs +15/−19
- Upgrade/V9.hs +1/−1
- Utility/InodeCache.hs +6/−1
- Utility/MagicWormhole.hs +12/−7
- Utility/MoveFile.hs +1/−1
- Utility/Url.hs +1/−1
- doc/git-annex-backends.mdwn +24/−0
- doc/git-annex-dead.mdwn +2/−2
- doc/git-annex-log.mdwn +1/−1
- doc/git-annex-migrate.mdwn +2/−0
- doc/git-annex-preferred-content.mdwn +3/−1
- doc/git-annex-restage.mdwn +34/−0
- doc/git-annex-test.mdwn +14/−0
- doc/git-annex-whereis.mdwn +3/−0
- doc/git-annex.mdwn +25/−10
- git-annex.cabal +60/−63
- stack.yaml +0/−1
Annex.hs view
@@ -81,6 +81,7 @@ import Utility.Url import Utility.ResourcePool import Utility.HumanTime+import Git.Credential (CredentialCache(..)) import "mtl" Control.Monad.Reader import Control.Concurrent@@ -129,6 +130,7 @@ , forcebackend :: Maybe String , useragent :: Maybe String , desktopnotify :: DesktopNotify+ , gitcredentialcache :: TMVar CredentialCache } newAnnexRead :: GitConfig -> IO AnnexRead@@ -140,6 +142,7 @@ si <- newTVarIO M.empty tp <- newTransferrerPool cm <- newTMVarIO M.empty+ cc <- newTMVarIO (CredentialCache M.empty) return $ AnnexRead { activekeys = emptyactivekeys , activeremotes = emptyactiveremotes@@ -157,6 +160,7 @@ , forcemincopies = Nothing , useragent = Nothing , desktopnotify = mempty+ , gitcredentialcache = cc } -- Values that can change while running an Annex action.@@ -196,7 +200,7 @@ , cleanupactions :: M.Map CleanupAction (Annex ()) , sentinalstatus :: Maybe SentinalStatus , errcounter :: Integer- , skippedfiles :: Bool+ , reachedlimit :: Bool , adjustedbranchrefreshcounter :: Integer , unusedkeys :: Maybe (S.Set Key) , tempurls :: M.Map Key URLString@@ -249,7 +253,7 @@ , cleanupactions = M.empty , sentinalstatus = Nothing , errcounter = 0- , skippedfiles = False+ , reachedlimit = False , adjustedbranchrefreshcounter = 0 , unusedkeys = Nothing , tempurls = M.empty
Annex/FileMatcher.hs view
@@ -180,7 +180,7 @@ , ValueToken "copies" (usev limitCopies) , ValueToken "lackingcopies" (usev $ limitLackingCopies False) , ValueToken "approxlackingcopies" (usev $ limitLackingCopies True)- , ValueToken "inbacked" (usev limitInBackend)+ , ValueToken "inbackend" (usev limitInBackend) , ValueToken "metadata" (usev limitMetaData) , ValueToken "inallgroup" (usev $ limitInAllGroup $ getGroupMap pcd) ] ++ commonKeyedTokens
Annex/Import.hs view
@@ -600,7 +600,7 @@ let af = AssociatedFile (Just f) let downloader p' tmpfile = do _ <- Remote.retrieveExportWithContentIdentifier- ia loc cid (fromRawFilePath tmpfile)+ ia loc [cid] (fromRawFilePath tmpfile) (Left k) (combineMeterUpdate p' p) ok <- moveAnnex k af tmpfile@@ -618,7 +618,7 @@ doimportsmall cidmap db loc cid sz p = do let downloader tmpfile = do (k, _) <- Remote.retrieveExportWithContentIdentifier- ia loc cid (fromRawFilePath tmpfile)+ ia loc [cid] (fromRawFilePath tmpfile) (Right (mkkey tmpfile)) p case keyGitSha k of@@ -641,7 +641,7 @@ let af = AssociatedFile (Just f) let downloader tmpfile p = do (k, _) <- Remote.retrieveExportWithContentIdentifier- ia loc cid (fromRawFilePath tmpfile)+ ia loc [cid] (fromRawFilePath tmpfile) (Right (mkkey tmpfile)) p case keyGitSha k of
Annex/Init.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} module Annex.Init (+ checkInitializeAllowed, ensureInitialized, autoInitialize, isInitialized,@@ -68,11 +69,13 @@ import Control.Concurrent.Async #endif -checkInitializeAllowed :: Annex a -> Annex a+data InitializeAllowed = InitializeAllowed++checkInitializeAllowed :: (InitializeAllowed -> Annex a) -> Annex a checkInitializeAllowed a = guardSafeToUseRepo $ noAnnexFileContent' >>= \case Nothing -> do checkSqliteWorks- a+ a InitializeAllowed Just noannexmsg -> do warning "Initialization prevented by .noannex file (remove the file to override)" unless (null noannexmsg) $@@ -100,7 +103,7 @@ Left _ -> [hostname, ":", reldir] initialize :: Bool -> Maybe String -> Maybe RepoVersion -> Annex ()-initialize autoinit mdescription mversion = checkInitializeAllowed $ do+initialize autoinit mdescription mversion = checkInitializeAllowed $ \initallowed -> do {- Has to come before any commits are made as the shared - clone heuristic expects no local objects. -} sharedclone <- checkSharedClone@@ -110,7 +113,7 @@ ensureCommit $ Annex.Branch.create prepUUID- initialize' autoinit mversion+ initialize' autoinit mversion initallowed initSharedClone sharedclone @@ -122,8 +125,8 @@ -- Everything except for uuid setup, shared clone setup, and initial -- description.-initialize' :: Bool -> Maybe RepoVersion -> Annex ()-initialize' autoinit mversion = checkInitializeAllowed $ do+initialize' :: Bool -> Maybe RepoVersion -> InitializeAllowed -> Annex ()+initialize' autoinit mversion _initallowed = do checkLockSupport checkFifoSupport checkCrippledFileSystem@@ -198,8 +201,8 @@ - - Checks repository version and handles upgrades too. -}-ensureInitialized :: Annex ()-ensureInitialized = getInitializedVersion >>= maybe needsinit checkUpgrade+ensureInitialized :: Annex [Remote] -> Annex ()+ensureInitialized remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade where needsinit = ifM autoInitializeAllowed ( do@@ -207,7 +210,7 @@ Right () -> noop Left e -> giveup $ show e ++ "\n" ++ "git-annex: automatic initialization failed due to above problems"- autoEnableSpecialRemotes+ autoEnableSpecialRemotes remotelist , giveup "First run: git-annex init" ) @@ -251,13 +254,13 @@ - - Checks repository version and handles upgrades too. -}-autoInitialize :: Annex ()-autoInitialize = getInitializedVersion >>= maybe needsinit checkUpgrade+autoInitialize :: Annex [Remote] -> Annex ()+autoInitialize remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade where needsinit = whenM (initializeAllowed <&&> autoInitializeAllowed) $ do initialize True Nothing Nothing- autoEnableSpecialRemotes+ autoEnableSpecialRemotes remotelist {- Checks if a repository is initialized. Does not check version for ugrade. -} isInitialized :: Annex Bool@@ -437,9 +440,17 @@ {- Try to enable any special remotes that are configured to do so. - - The enabling is done in a child process to avoid it using stdio.+ -+ - The remotelist should be Remote.List.remoteList, which cannot+ - be imported here due to a dependency loop. -}-autoEnableSpecialRemotes :: Annex ()-autoEnableSpecialRemotes = do+autoEnableSpecialRemotes :: Annex [Remote] -> Annex ()+autoEnableSpecialRemotes remotelist = do+ -- Get all existing git remotes to probe for their uuid here,+ -- so it is not done inside the child process. Doing it in there+ -- could result in password prompts for http credentials,+ -- which would then not end up cached in this process's state.+ _ <- remotelist rp <- fromRawFilePath <$> fromRepo Git.repoPath withNullHandle $ \nullh -> gitAnnexChildProcess "init" [ Param "--autoenable" ]
Annex/Link.hs view
@@ -25,6 +25,7 @@ import qualified Git.LockFile import qualified Git.Env import qualified Git+import Logs.Restage import Git.Types import Git.FilePath import Git.Config@@ -35,7 +36,6 @@ import Utility.InodeCache import Utility.Tmp.Dir import Utility.CopyFile-import Utility.Tuple import qualified Database.Keys.Handle import qualified Utility.RawFilePath as R @@ -155,6 +155,10 @@ - when content is added/removed, to prevent git status from showing - it as modified. -+ - The InodeCache is for the worktree file. It is used to detect when+ - the worktree file is changed by something else before git update-index+ - gets to look at it.+ - - Asks git to refresh its index information for the file. - That in turn runs the clean filter on the file; when the clean - filter produces the same pointer that was in the index before, git@@ -165,92 +169,120 @@ - that. So it's safe to call at any time and any situation. - - If the index is known to be locked (eg, git add has run git-annex),- - that would fail. Restage False will prevent the index being updated.- - Will display a message to help the user understand why- - the file will appear to be modified.+ - that would fail. Restage False will prevent the index being updated,+ - and will store it in the restage log. Displays a message to help the+ - user understand why the file will appear to be modified. - - This uses the git queue, so the update is not performed immediately,- - and this can be run multiple times cheaply.- -- - The InodeCache is for the worktree file. It is used to detect when- - the worktree file is changed by something else before git update-index- - gets to look at it.+ - and this can be run multiple times cheaply. Using the git queue also+ - prevents building up too large a number of updates when many files+ - are being processed. It's also recorded in the restage log so that,+ - if the process is interrupted before the git queue is fulushed, the+ - restage will be taken care of later. -} restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex ()-restagePointerFile (Restage False) f _ =+restagePointerFile (Restage False) f orig = do+ flip writeRestageLog orig =<< inRepo (toTopFilePath f) toplevelWarning True $ unableToRestage $ Just $ fromRawFilePath f-restagePointerFile (Restage True) f orig = withTSDelta $ \tsd ->+restagePointerFile (Restage True) f orig = do+ flip writeRestageLog orig =<< inRepo (toTopFilePath f) -- Avoid refreshing the index if run by the -- smudge clean filter, because git uses that when -- it's already refreshing the index, probably because -- this very action is running. Running it again would likely -- deadlock.- unlessM (Annex.getState Annex.insmudgecleanfilter) $ do- -- update-index is documented as picky about "./file" and it- -- fails on "../../repo/path/file" when cwd is not in the repo - -- being acted on. Avoid these problems with an absolute path.- absf <- liftIO $ absPath f- Annex.Queue.addFlushAction runner [(absf, isunmodified tsd, inodeCacheFileSize orig)]- where- isunmodified tsd = genInodeCache f tsd >>= return . \case- Nothing -> False- Just new -> compareStrong orig new+ unlessM (Annex.getState Annex.insmudgecleanfilter) $+ Annex.Queue.addFlushAction restagePointerFileRunner [f] - -- Other changes to the files may have been staged before this- -- gets a chance to run. To avoid a race with any staging of- -- changes, first lock the index file. Then run git update-index- -- on all still-unmodified files, using a copy of the index file,- -- to bypass the lock. Then replace the old index file with the new- -- updated index file.- runner :: Git.Queue.FlushActionRunner Annex- runner = Git.Queue.FlushActionRunner "restagePointerFile" $ \r l -> do- -- Flush any queued changes to the keys database, so they- -- are visible to child processes.- -- The database is closed because that may improve behavior- -- when run in Windows's WSL1, which has issues with- -- multiple writers to SQL databases.- liftIO . Database.Keys.Handle.closeDbHandle- =<< Annex.getRead Annex.keysdbhandle- realindex <- liftIO $ Git.Index.currentIndexFile r- let lock = fromRawFilePath (Git.Index.indexFileLock realindex)- lockindex = liftIO $ catchMaybeIO $ Git.LockFile.openLock' lock- unlockindex = liftIO . maybe noop Git.LockFile.closeLock- showwarning = warning $ unableToRestage Nothing- go Nothing = showwarning- go (Just _) = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex" $ \tmpdir -> do- let tmpindex = toRawFilePath (tmpdir </> "index")- let updatetmpindex = do- r' <- liftIO $ Git.Env.addGitEnv r Git.Index.indexEnv- =<< Git.Index.indexEnvVal tmpindex- -- Avoid git warning about CRLF munging.- let r'' = r' { gitGlobalOpts = gitGlobalOpts r' ++- [ Param "-c"- , Param $ "core.safecrlf=" ++ boolConfig False- ] }- configfilterprocess l $ runsGitAnnexChildProcessViaGit' r'' $ \r''' ->- liftIO $ Git.UpdateIndex.refreshIndex r''' $ \feed ->- forM_ l $ \(f', checkunmodified, _) ->- whenM checkunmodified $- feed f'- let replaceindex = catchBoolIO $ do- moveFile tmpindex realindex- return True- ok <- liftIO (createLinkOrCopy realindex tmpindex)- <&&> updatetmpindex- <&&> liftIO replaceindex- unless ok showwarning+restagePointerFileRunner :: Git.Queue.FlushActionRunner Annex+restagePointerFileRunner = + Git.Queue.FlushActionRunner "restagePointerFiles" $ \r _fs ->+ restagePointerFiles r++-- Restage all files in the restage log that have not been modified.+--+-- Other changes to the files may have been staged before this+-- gets a chance to run. To avoid a race with any staging of+-- changes, first lock the index file. Then run git update-index+-- on all still-unmodified files, using a copy of the index file,+-- to bypass the lock. Then replace the old index file with the new+-- updated index file.+restagePointerFiles :: Git.Repo -> Annex ()+restagePointerFiles r = unlessM (Annex.getState Annex.insmudgecleanfilter) $ do+ -- Flush any queued changes to the keys database, so they+ -- are visible to child processes.+ -- The database is closed because that may improve behavior+ -- when run in Windows's WSL1, which has issues with+ -- multiple writers to SQL databases.+ liftIO . Database.Keys.Handle.closeDbHandle+ =<< Annex.getRead Annex.keysdbhandle+ realindex <- liftIO $ Git.Index.currentIndexFile r+ numsz@(numfiles, _) <- calcnumsz+ let lock = fromRawFilePath (Git.Index.indexFileLock realindex)+ lockindex = liftIO $ catchMaybeIO $ Git.LockFile.openLock' lock+ unlockindex = liftIO . maybe noop Git.LockFile.closeLock+ showwarning = warning $ unableToRestage Nothing+ go Nothing = showwarning+ go (Just _) = withtmpdir $ \tmpdir -> do+ tsd <- getTSDelta + let tmpindex = toRawFilePath (tmpdir </> "index")+ let replaceindex = liftIO $ moveFile tmpindex realindex+ let updatetmpindex = do+ r' <- liftIO $ Git.Env.addGitEnv r Git.Index.indexEnv+ =<< Git.Index.indexEnvVal tmpindex+ configfilterprocess numsz $+ runupdateindex tsd r' replaceindex+ return True+ ok <- liftIO (createLinkOrCopy realindex tmpindex)+ <&&> catchBoolIO updatetmpindex+ unless ok showwarning+ when (numfiles > 0) $ bracket lockindex unlockindex go+ where+ withtmpdir = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex"++ isunmodified tsd f orig = + genInodeCache f tsd >>= return . \case+ Nothing -> False+ Just new -> compareStrong orig new+ + {- Avoid git warning about CRLF munging -}+ avoidcrlfwarning r' = r' { gitGlobalOpts = gitGlobalOpts r' +++ [ Param "-c"+ , Param $ "core.safecrlf=" ++ boolConfig False+ ] }+ + runupdateindex tsd r' replaceindex = + runsGitAnnexChildProcessViaGit' (avoidcrlfwarning r') $ \r'' ->+ Git.UpdateIndex.refreshIndex r'' $ \feeder -> do+ let atend = do+ -- wait for index write+ liftIO $ feeder Nothing+ replaceindex+ streamRestageLog atend $ \topf ic -> do+ let f = fromTopFilePath topf r''+ liftIO $ whenM (isunmodified tsd f ic) $+ feedupdateindex f feeder + {- update-index is documented as picky about "./file" and it+ - fails on "../../repo/path/file" when cwd is not in the repo + - being acted on. Avoid these problems with an absolute path.+ -}+ feedupdateindex f feeder = do+ absf <- absPath f+ feeder (Just absf)+ + calcnumsz = calcRestageLog (0, 0) $ \(_f, ic) (numfiles, sizefiles) ->+ (numfiles+1, sizefiles + inodeCacheFileSize ic)+ {- filter.annex.process configured to use git-annex filter-process - is sometimes faster and sometimes slower than using - git-annex smudge. The latter is run once per file, while - the former has the content of files piped to it. -}- filterprocessfaster l = - let numfiles = genericLength l- sizefiles = sum (map thd3 l)- -- estimates based on benchmarking- estimate_enabled = sizefiles `div` 191739611+ filterprocessfaster :: (Integer, FileSize) -> Bool+ filterprocessfaster (numfiles, sizefiles) = + let estimate_enabled = sizefiles `div` 191739611 estimate_disabled = numfiles `div` 7 in estimate_enabled <= estimate_disabled @@ -262,10 +294,10 @@ - case this process is terminated early, the next time this - runs it will take care of reversing the modification. -}- configfilterprocess l = bracket setup cleanup . const+ configfilterprocess numsz = bracket setup cleanup . const where setup- | filterprocessfaster l = return Nothing+ | filterprocessfaster numsz = return Nothing | otherwise = fromRepo (Git.Config.getMaybe ck) >>= \case Nothing -> return Nothing Just v -> do@@ -292,7 +324,7 @@ , "This is only a cosmetic problem affecting git status; git add," , "git commit, etc won't be affected." , "To fix the git status display, you can run:"- , "git update-index -q --refresh " ++ fromMaybe "<file>" mf+ , "git-annex restage" ] {- Parses a symlink target or a pointer file to a Key.
Annex/Locations.hs view
@@ -49,6 +49,8 @@ gitAnnexUpgradeLock, gitAnnexSmudgeLog, gitAnnexSmudgeLock,+ gitAnnexRestageLog,+ gitAnnexRestageLock, gitAnnexMoveLog, gitAnnexMoveLock, gitAnnexExportDir,@@ -370,13 +372,21 @@ gitAnnexUpgradeLock :: Git.Repo -> RawFilePath gitAnnexUpgradeLock r = gitAnnexDir r P.</> "upgrade.lck" -{- .git/annex/smudge.log is used to log smudges worktree files that need to+{- .git/annex/smudge.log is used to log smudged worktree files that need to - be updated. -} gitAnnexSmudgeLog :: Git.Repo -> RawFilePath gitAnnexSmudgeLog r = gitAnnexDir r P.</> "smudge.log" gitAnnexSmudgeLock :: Git.Repo -> RawFilePath gitAnnexSmudgeLock r = gitAnnexDir r P.</> "smudge.lck"++{- .git/annex/restage.log is used to log worktree files that need to be+ - restaged in git -}+gitAnnexRestageLog :: Git.Repo -> RawFilePath+gitAnnexRestageLog r = gitAnnexDir r P.</> "restage.log"++gitAnnexRestageLock :: Git.Repo -> RawFilePath+gitAnnexRestageLock r = gitAnnexDir r P.</> "restage.lck" {- .git/annex/move.log is used to log moves that are in progress, - to better support resuming an interrupted move. -}
Annex/Perms.hs view
@@ -154,7 +154,7 @@ - that happens with write permissions. -} freezeContent :: RawFilePath -> Annex ()-freezeContent file = unlessM crippledFileSystem $+freezeContent file = withShared $ \sr -> freezeContent' sr file freezeContent' :: SharedRepository -> RawFilePath -> Annex ()@@ -163,7 +163,7 @@ freezeContent'' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Annex () freezeContent'' sr file rv = do fastDebug "Annex.Perms" ("freezing content " ++ fromRawFilePath file)- go sr+ unlessM crippledFileSystem $ go sr freezeHook file where go GroupShared = if versionNeedsWritableContentFiles rv@@ -253,7 +253,7 @@ - permissions. -} thawPerms :: Annex () -> Annex () -> Annex () thawPerms a hook = ifM crippledFileSystem- ( void (tryNonAsync a)+ ( hook >> void (tryNonAsync a) , hook >> a ) @@ -263,9 +263,9 @@ - file. -} freezeContentDir :: RawFilePath -> Annex ()-freezeContentDir file = unlessM crippledFileSystem $ do+freezeContentDir file = do fastDebug "Annex.Perms" ("freezing content directory " ++ fromRawFilePath dir)- withShared go+ unlessM crippledFileSystem $ withShared go freezeHook dir where dir = parentDir file@@ -287,9 +287,8 @@ unlessM (liftIO $ R.doesPathExist dir) $ createAnnexDirectory dir -- might have already existed with restricted perms- unlessM crippledFileSystem $ do- thawHook dir- liftIO $ allowWrite dir+ thawHook dir+ unlessM crippledFileSystem $ liftIO $ allowWrite dir where dir = parentDir dest
Annex/PidLock.hs view
@@ -106,11 +106,15 @@ runsGitAnnexChildProcessViaGit a = a #endif -runsGitAnnexChildProcessViaGit' :: Git.Repo -> (Git.Repo -> IO a) -> Annex a+{- Like runsGitAnnexChildProcessViaGit, but the Annex state is not+ - modified. Instead the input Repo's state is modified to set the + - necessary env var when git is run in that Repo.+ -}+runsGitAnnexChildProcessViaGit' :: Git.Repo -> (Git.Repo -> Annex a) -> Annex a #ifndef mingw32_HOST_OS runsGitAnnexChildProcessViaGit' r a = pidLockFile >>= \case- Nothing -> liftIO $ a r- Just pidlock -> liftIO $ bracket (setup pidlock) cleanup (go pidlock)+ Nothing -> a r+ Just pidlock -> bracketIO (setup pidlock) cleanup (go pidlock) where setup pidlock = fmap fst <$> PidP.tryLock' pidlock @@ -119,9 +123,9 @@ go _ Nothing = a r go pidlock (Just _h) = do- v <- PidF.pidLockEnv pidlock- r' <- addGitEnv r v PidF.pidLockEnvValue+ v <- liftIO $ PidF.pidLockEnv pidlock+ r' <- liftIO $ addGitEnv r v PidF.pidLockEnvValue a r' #else-runsGitAnnexChildProcessViaGit' r a = liftIO $ a r+runsGitAnnexChildProcessViaGit' r a = a r #endif
Annex/Queue.hs view
@@ -31,7 +31,7 @@ store =<< flushWhenFull =<< (Git.Queue.addCommand commonparams command params files q =<< gitRepo) -addFlushAction :: Git.Queue.FlushActionRunner Annex -> [(RawFilePath, IO Bool, FileSize)] -> Annex ()+addFlushAction :: Git.Queue.FlushActionRunner Annex -> [RawFilePath] -> Annex () addFlushAction runner files = do q <- get store =<< flushWhenFull =<<
Annex/TransferrerPool.hs view
@@ -1,6 +1,6 @@ {- A pool of "git-annex transferrer" processes -- - Copyright 2013-2021 Joey Hess <id@joeyh.name>+ - Copyright 2013-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -22,6 +22,7 @@ import Messages.Serialized import Annex.Path import Annex.StallDetection+import Annex.Link import Utility.Batch import Utility.Metered import qualified Utility.SimpleProtocol as Proto@@ -217,9 +218,15 @@ , transferrerWrite = writeh , transferrerHandle = ph , transferrerShutdown = do- hClose readh+ -- The transferrer may write to stdout+ -- as it's shutting down, so don't close+ -- the readh right away. Instead, drain+ -- anything sent to it.+ drainer <- async $ void $ hGetContents readh hClose writeh void $ waitForProcess ph+ wait drainer+ hClose readh unregistersignalprop } @@ -280,3 +287,10 @@ liftIO $ forM_ pool $ \case TransferrerPoolItem (Just t) _ -> transferrerShutdown t TransferrerPoolItem Nothing _ -> noop+ -- Transferrers usually restage pointer files themselves,+ -- but when killTransferrer is used, a transferrer may have+ -- pointer files it has not gotten around to restaging yet.+ -- So, restage pointer files here in clean up from such killed+ -- transferrers.+ unless (null pool) $+ restagePointerFiles =<< Annex.gitRepo
Annex/Url.hs view
@@ -147,20 +147,19 @@ -- When downloading an url, if authentication is needed, uses -- git-credential to prompt for username and password.+--+-- Note that, when the downloader is curl, it will not use git-credential.+-- If the user wants to, they can configure curl to use a netrc file that+-- handles authentication. withUrlOptionsPromptingCreds :: (U.UrlOptions -> Annex a) -> Annex a withUrlOptionsPromptingCreds a = do g <- Annex.gitRepo uo <- getUrlOptions prompter <- mkPrompter+ cc <- Annex.getRead Annex.gitcredentialcache a $ uo { U.getBasicAuth = \u -> prompter $- getBasicAuthFromCredential g u- -- Can't download with curl and handle basic auth,- -- so make sure it uses conduit.- , U.urlDownloader = case U.urlDownloader uo of- U.DownloadWithCurl _ -> U.DownloadWithConduit $- U.DownloadWithCurlRestricted mempty- v -> v+ getBasicAuthFromCredential g cc u } checkBoth :: U.URLString -> Maybe Integer -> U.UrlOptions -> Annex Bool
BuildFlags.hs view
@@ -24,7 +24,7 @@ #ifdef WITH_WEBAPP , "Webapp" #else-#warning Building without the webapp. You probably need to install Yesod..+#warning Building without the webapp. #endif #ifdef WITH_PAIRING , "Pairing"@@ -51,6 +51,9 @@ #endif #ifdef WITH_MAGICMIME , "MagicMime"+#endif+#ifdef WITH_BENCHMARK+ , "Benchmark" #endif #ifdef DEBUGLOCKS , "DebugLocks"
CHANGELOG view
@@ -1,3 +1,52 @@+git-annex (10.20220927) upstream; urgency=medium++ * Fix a bug in the last release that caused v8 repositories to upgrade+ immediately to v10, rather than taking the scheduled 1 year to do so.+ * annex.diskreserve default increased from 1 mb to 100 mb.+ * Include the assistant and webapp when building with cabal 3.4.1.0.+ * Merged the webapp build flag into the assistant build flag.+ * Optimise linker in linux standalone tarballs.+ * Fix crash importing from a directory special remote that contains+ a broken symlink.+ * When accessing a git remote over http needs a git credential+ prompt for a password, cache it for the lifetime of the git-annex+ process, rather than repeatedly prompting.+ * Use curl for downloads from git remotes when annex.url-options is set.+ * Fix a reversion that made dead keys not be skipped when operating on+ all keys via --all or in a bare repo.+ (Introduced in version 8.20200720)+ * vicfg: Include mincopies configuration.+ * Improve handling of directory special remotes with importtree=yes whose+ ignoreinode setting has been changed. When getting a file from such a+ remote, accept the content that would have been accepted with the+ previous ignoreinode setting.+ * directory, adb: Fixed a bug with importtree=yes and multiple files+ in the special remote have the same content, that caused it to+ refuse to get a file from the special remote, incorrectly complaining+ that it had changed, due to only accepting the inode+mtime of one file+ (that was since modified or deleted) and not accepting the inode+mtime+ of other duplicate files.+ * Fix a reversion that prevented git-annex from working in a+ repository when --git-dir or GIT_DIR is specified to relocate the git+ directory to somewhere else.+ (Introduced in version 10.20220525)+ * Improved handling of --time-limit when combined with -J+ * Fix updating git index file after getting an unlocked file + when annex.stalldetection is set.+ * restage: New git-annex command, handles restaging unlocked files.+ * test: Added --test-with-git-config option.+ * Run annex.freezecontent-command and annex.thawcontent-command+ when on a crippled filesystem.+ Thanks, Reiko Asakura+ * enable-tor: Fix breakage caused by git's fix for CVE-2022-24765.+ * Let GIT_DIR and --git-dir override git's protection against operating+ in a repository owned by another user.+ * p2p: Pass wormhole the --appid option before the receive/send command,+ as it does not accept that option after the command+ * Support "inbackend" in preferred content expressions.++ -- Joey Hess <id@joeyh.name> Tue, 27 Sep 2022 13:31:18 -0400+ git-annex (10.20220822) upstream; urgency=medium * v8 repositories now automatically upgrade to v9, which will in turn
CmdLine/Action.hs view
@@ -32,8 +32,8 @@ {- Runs a command, starting with the check stage, and then - the seek stage. Finishes by running the continuation. -- - Can exit when there was a problem or when files were skipped.- - Also shows a count of any failures when that is enabled.+ - Can exit when there was a problem or when a time or size limit was+ - reached. Also shows a count of any failures when that is enabled. -} performCommandAction :: Bool -> Command -> CommandSeek -> Annex () -> Annex () performCommandAction canexit (Command { cmdcheck = c, cmdname = name }) seek cont = do@@ -43,19 +43,19 @@ finishCommandActions cont st <- Annex.getState id- when canexit $ liftIO $ case (Annex.errcounter st, Annex.skippedfiles st) of+ when canexit $ liftIO $ case (Annex.errcounter st, Annex.reachedlimit st) of (0, False) -> noop (errcnt, False) -> do showerrcount errcnt exitWith $ ExitFailure 1- (0, True) -> exitskipped+ (0, True) -> exitreachedlimit (errcnt, True) -> do showerrcount errcnt- exitskipped+ exitreachedlimit where showerrcount cnt = hPutStrLn stderr $ name ++ ": " ++ show cnt ++ " failed"- exitskipped = exitWith $ ExitFailure 101+ exitreachedlimit = exitWith $ ExitFailure 101 commandActions :: [CommandStart] -> Annex () commandActions = mapM_ commandAction@@ -328,7 +328,7 @@ Nothing -> do fsz <- catchMaybeIO $ withObjectLoc k $ liftIO . getFileSize- maybe skipped go fsz+ maybe reachedlimit go fsz Nothing -> a where go sz = do@@ -342,6 +342,6 @@ else return False if fits then a- else skipped+ else reachedlimit - skipped = Annex.changeState $ \s -> s { Annex.skippedfiles = True }+ reachedlimit = Annex.changeState $ \s -> s { Annex.reachedlimit = True }
CmdLine/GitAnnex.hs view
@@ -1,6 +1,6 @@ {- git-annex main program -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -114,6 +114,7 @@ import qualified Command.DiffDriver import qualified Command.Smudge import qualified Command.FilterProcess+import qualified Command.Restage import qualified Command.Undo import qualified Command.Version import qualified Command.RemoteDaemon@@ -228,6 +229,7 @@ , Command.DiffDriver.cmd , Command.Smudge.cmd , Command.FilterProcess.cmd+ , Command.Restage.cmd , Command.Undo.cmd , Command.Version.cmd , Command.RemoteDaemon.cmd
CmdLine/Seek.hs view
@@ -4,7 +4,7 @@ - the values a user passes to a command, and prepare actions operating - on them. -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -27,6 +27,7 @@ import CmdLine.Action import Logs import Logs.Unused+import Logs.Location import Types.Transfer import Logs.Transfer import Types.Link@@ -40,7 +41,6 @@ import Annex.InodeSentinal import Annex.Concurrent import Annex.CheckIgnore-import Annex.Action import qualified Annex.Branch import qualified Database.Keys import qualified Utility.RawFilePath as R@@ -48,6 +48,7 @@ import Utility.HumanTime import Control.Concurrent.Async+import Control.Concurrent.STM import System.Posix.Types import Data.IORef import Data.Time.Clock.POSIX@@ -109,6 +110,10 @@ a f go matcher checktimelimit ps fs + -- Using getFileStatus not getSymbolicLinkStatus because it should+ -- fail if the path that the user provided is a broken symlink,+ -- the same as it fails if the path that the user provided does not+ -- exist. get p = ifM (isDirectory <$> getFileStatus p) ( map (\f -> let f' = toRawFilePath f@@ -279,7 +284,8 @@ 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)+ unlessM (checkDead k) $+ keyaction Nothing (SeekInput [], k, mkActionItem k) go reader Nothing -> return () Annex.Branch.overBranchFileContents getk go >>= \case@@ -604,20 +610,25 @@ 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 first action is run when over the- - time limit, otherwise the second action is run. -}+ - to check it before processing a file. The first action is run when+ - over the time limit, otherwise the second action is run one time to+ - clean up. -} mkCheckTimeLimit :: Annex (Annex () -> Annex () -> Annex ()) mkCheckTimeLimit = Annex.getState Annex.timelimit >>= \case Nothing -> return $ \_ a -> a- Just (duration, cutoff) -> return $ \cleanup a -> do- now <- liftIO getPOSIXTime- if now > cutoff- then do- warning $ "Time limit (" ++ fromDuration duration ++ ") reached! Shutting down..."- shutdown True- cleanup- liftIO $ exitWith $ ExitFailure 101- else a+ Just (duration, cutoff) -> do+ warningshownv <- liftIO $ newTVarIO False+ return $ \cleanup a -> do+ now <- liftIO getPOSIXTime+ if now > cutoff+ then do+ warningshown <- liftIO $ atomically $+ swapTVar warningshownv True+ unless warningshown $ do+ Annex.changeState $ \s -> s { Annex.reachedlimit = True }+ warning $ "Time limit (" ++ fromDuration duration ++ ") reached! Shutting down..."+ cleanup+ else a propagateLsFilesError :: IO Bool -> Annex () propagateLsFilesError cleanup =
Command.hs view
@@ -28,6 +28,7 @@ import Types.Transfer import Types.ActionItem import Types.WorkerPool as ReExported+import Remote.List {- Generates a normal Command -} command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command@@ -125,7 +126,7 @@ commonChecks = [repoExists] repoExists :: CommandCheck-repoExists = CommandCheck 0 ensureInitialized+repoExists = CommandCheck 0 (ensureInitialized remoteList) notBareRepo :: Command -> Command notBareRepo = addCheck checkNotBareRepo
Command/Assistant.hs view
@@ -16,6 +16,7 @@ import qualified BuildInfo import Utility.HumanTime import Assistant.Install+import Remote.List import Control.Concurrent.Async @@ -62,7 +63,7 @@ stop | otherwise = do liftIO ensureInstalled- ensureInitialized+ ensureInitialized remoteList Command.Watch.start True (daemonOptions o) (startDelayOption o) startNoRepo :: AssistantOptions -> IO ()
Command/EnableTor.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -22,6 +22,8 @@ import qualified P2P.Protocol as P2P import Utility.ThreadScheduler import RemoteDaemon.Transport.Tor+import Git.Types+import Config import Control.Concurrent.Async import qualified Network.Socket as S@@ -70,6 +72,15 @@ #endif where go userid = do+ -- Usually git will refuse to read local configs of a git+ -- repo belonging to another user. But in this case, the+ -- user wants this command, run as root, to operate on+ -- their repo. Behave as if --git-dir had been used to+ -- specify that the git directory is intended to be used.+ Annex.adjustGitRepo $ \r -> return $ r+ { gitDirSpecifiedExplicitly = True }+ reloadConfig+ uuid <- getUUID when (uuid == NoUUID) $ giveup "This can only be run in a git-annex repository."
Command/Fsck.hs view
@@ -574,7 +574,7 @@ (deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations let present = length safelocations if present < fromNumCopies numcopies- then ifM (pure (not hasafile) <&&> checkDead key)+ then ifM (checkDead key) ( do showLongNote $ "This key is dead, skipping." return True
Command/Move.hs view
@@ -396,8 +396,7 @@ go logf -- Only need to check log when there is a copy. | deststartedwithcopy = do- lck <- fromRepo gitAnnexMoveLock- wasnocopy <- checkLogFile (fromRawFilePath logf) lck+ wasnocopy <- checkLogFile (fromRawFilePath logf) (== logline) if wasnocopy then go' logf False
Command/Reinit.hs view
@@ -35,6 +35,6 @@ then return $ toUUID s else Remote.nameToUUID s storeUUID u- initialize' False Nothing+ checkInitializeAllowed $ initialize' False Nothing Annex.SpecialRemote.autoEnable next $ return True
+ Command/Restage.hs view
@@ -0,0 +1,25 @@+{- git-annex command+ -+ - Copyright 2022 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Command.Restage where++import Command+import qualified Annex+import Annex.Link++cmd :: Command+cmd = command "restage" SectionPlumbing + "estages unlocked files in the git index"+ paramNothing (withParams seek)++seek :: CmdParams -> CommandSeek+seek = withNothing (commandAction start)++start :: CommandStart+start = starting "restage" (ActionItemOther Nothing) (SeekInput []) $ do+ restagePointerFiles =<< Annex.gitRepo+ next $ return True
Command/VCycle.hs view
@@ -26,7 +26,7 @@ start = go =<< currentView where go Nothing = giveup "Not in a view."- go (Just v) = starting "vcycle" (ActionItemOther Nothing) (SeekInput [])$ do+ go (Just v) = starting "vcycle" (ActionItemOther Nothing) (SeekInput []) $ do let v' = v { viewComponents = vcycle [] (viewComponents v) } if v == v' then do
Command/Vicfg.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2012-2017 Joey Hess <id@joeyh.name>+ - Copyright 2012-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -75,6 +75,7 @@ , cfgScheduleMap :: M.Map UUID [ScheduledActivity] , cfgGlobalConfigs :: M.Map ConfigKey ConfigValue , cfgNumCopies :: Maybe NumCopies+ , cfgMinCopies :: Maybe MinCopies } getCfg :: Annex Cfg@@ -87,6 +88,7 @@ <*> scheduleMap <*> loadGlobalConfig <*> getGlobalNumCopies+ <*> getGlobalMinCopies setCfg :: Cfg -> Cfg -> Annex () setCfg curcfg newcfg = do@@ -99,6 +101,7 @@ mapM_ (uncurry scheduleSet) $ M.toList $ cfgScheduleMap diff mapM_ (uncurry setGlobalConfig) $ M.toList $ cfgGlobalConfigs diff maybe noop setGlobalNumCopies $ cfgNumCopies diff+ maybe noop setGlobalMinCopies $ cfgMinCopies diff {- Default config has all the keys from the input config, but with their - default values. -}@@ -112,6 +115,7 @@ , cfgScheduleMap = mapdef $ cfgScheduleMap curcfg , cfgGlobalConfigs = mapdef $ cfgGlobalConfigs curcfg , cfgNumCopies = Nothing+ , cfgMinCopies = Nothing } where mapdef :: forall k v. Default v => M.Map k v -> M.Map k v@@ -127,6 +131,7 @@ , cfgScheduleMap = diff cfgScheduleMap , cfgGlobalConfigs = diff cfgGlobalConfigs , cfgNumCopies = cfgNumCopies newcfg+ , cfgMinCopies = cfgMinCopies newcfg } where diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x)@@ -236,6 +241,7 @@ numcopies = [ com "Numcopies configuration" , line' "numcopies" (show . fromNumCopies <$> cfgNumCopies cfg)+ , line' "mincopies" (show . fromMinCopies <$> cfgMinCopies cfg) ] settings :: Ord v => Cfg -> UUIDDescMap -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String]@@ -316,6 +322,9 @@ | setting == "numcopies" = case readish val of Nothing -> Left "parse error (expected an integer)" Just n -> Right $ cfg { cfgNumCopies = Just (configuredNumCopies n) }+ | setting == "mincopies" = case readish val of+ Nothing -> Left "parse error (expected an integer)"+ Just n -> Right $ cfg { cfgMinCopies = Just (configuredMinCopies n) } | otherwise = badval "setting" setting where u = toUUID f
Git.hs view
@@ -156,7 +156,7 @@ #if mingw32_HOST_OS isexecutable f = doesFileExist f #else- isexecutable f = isExecutable . fileMode <$> getFileStatus f+ isexecutable f = isExecutable . fileMode <$> getSymbolicLinkStatus f #endif {- Makes the path to a local Repo be relative to the cwd. -}
Git/Config.hs view
@@ -57,12 +57,20 @@ read' :: Repo -> IO Repo read' repo = go repo where- go Repo { location = Local { gitdir = d } } = git_config d- go Repo { location = LocalUnknown d } = git_config d+ go Repo { location = Local { gitdir = d } } = git_config True d+ go Repo { location = LocalUnknown d } = git_config False d go _ = assertLocal repo $ error "internal"- git_config d = withCreateProcess p (git_config' p)+ git_config isgitdir d = withCreateProcess p (git_config' p) where- params = ["config", "--null", "--list"]+ params = + -- Passing --git-dir changes git's behavior+ -- when run in a repository belonging to another+ -- user. When a gitdir is known, pass that in order+ -- to get the local git config.+ (if isgitdir && gitDirSpecifiedExplicitly repo+ then ["--git-dir=."]+ else [])+ ++ ["config", "--null", "--list"] p = (proc "git" params) { cwd = Just (fromRawFilePath d) , env = gitEnv repo@@ -282,16 +290,20 @@ - repo. -} checkRepoConfigInaccessible :: Repo -> IO Bool-checkRepoConfigInaccessible r = do- -- Cannot use gitCommandLine here because specifying --git-dir- -- will bypass the git security check.- let p = (proc "git" ["config", "--local", "--list"])- { cwd = Just (fromRawFilePath (repoPath r))- , env = gitEnv r- }- (out, ok) <- processTranscript' p Nothing- if not ok- then do- debug (DebugSource "Git.Config") ("config output: " ++ out)- return True- else return False+checkRepoConfigInaccessible r+ -- When --git-dir or GIT_DIR is used to specify the git+ -- directory, git does not check for CVE-2022-24765.+ | gitDirSpecifiedExplicitly r = return False+ | otherwise = do+ -- Cannot use gitCommandLine here because specifying --git-dir+ -- will bypass the git security check.+ let p = (proc "git" ["config", "--local", "--list"])+ { cwd = Just (fromRawFilePath (repoPath r))+ , env = gitEnv r+ }+ (out, ok) <- processTranscript' p Nothing+ if not ok+ then do+ debug (DebugSource "Git.Config") ("config output: " ++ out)+ return True+ else return False
Git/Construct.hs view
@@ -277,5 +277,6 @@ , gitEnv = Nothing , gitEnvOverridesGitDir = False , gitGlobalOpts = []+ , gitDirSpecifiedExplicitly = False }
Git/Credential.hs view
@@ -1,18 +1,24 @@ {- git credential interface -- - Copyright 2019-2020 Joey Hess <id@joeyh.name>+ - Copyright 2019-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-}+ module Git.Credential where import Common import Git+import Git.Types import Git.Command+import qualified Git.Config as Config import Utility.Url import qualified Data.Map as M+import Network.URI+import Control.Concurrent.STM data Credential = Credential { fromCredential :: M.Map String String } @@ -27,20 +33,33 @@ <$> credentialUsername cred <*> credentialPassword cred -getBasicAuthFromCredential :: Repo -> GetBasicAuth-getBasicAuthFromCredential r u = do- c <- getUrlCredential u r- case credentialBasicAuth c of- Just ba -> return $ Just (ba, signalsuccess c)- Nothing -> do- signalsuccess c False- return Nothing+getBasicAuthFromCredential :: Repo -> TMVar CredentialCache -> GetBasicAuth+getBasicAuthFromCredential r ccv u = do+ (CredentialCache cc) <- atomically $ readTMVar ccv+ case mkCredentialBaseURL r u of+ Just bu -> case M.lookup bu cc of+ Just c -> go (const noop) c+ Nothing -> do+ let storeincache = \c -> atomically $ do+ (CredentialCache cc') <- takeTMVar ccv+ putTMVar ccv (CredentialCache (M.insert bu c cc'))+ go storeincache =<< getUrlCredential u r+ Nothing -> go (const noop) =<< getUrlCredential u r where- signalsuccess c True = approveUrlCredential c r- signalsuccess c False = rejectUrlCredential c r+ go storeincache c =+ case credentialBasicAuth c of+ Just ba -> return $ Just (ba, signalsuccess)+ Nothing -> do+ signalsuccess False+ return Nothing+ where+ signalsuccess True = do+ () <- storeincache c+ approveUrlCredential c r+ signalsuccess False = rejectUrlCredential c r --- | This may prompt the user for login information, or get cached login--- information.+-- | This may prompt the user for the credential, or get a cached+-- credential from git. getUrlCredential :: URLString -> Repo -> IO Credential getUrlCredential = runCredential "fill" . urlCredential @@ -79,3 +98,28 @@ go l = case break (== '=') l of (k, _:v) -> (k, v) (k, []) -> (k, "")++-- This is not the cache used by git, but is an in-process cache, +-- allowing a process to avoid prompting repeatedly when accessing related+-- urls even when git is not configured to cache credentials.+data CredentialCache = CredentialCache (M.Map CredentialBaseURL Credential)++-- An url with the uriPath empty when credential.useHttpPath is false.+--+-- When credential.useHttpPath is true, no caching is done, since each +-- distinct url would need a different credential to be cached, which+-- could cause the CredentialCache to use a lot of memory. Presumably,+-- when credential.useHttpPath is false, one Credential is cached+-- for each git repo accessed, and there are a reasonably small number of+-- those, so the cache will not grow too large.+data CredentialBaseURL = CredentialBaseURL URI+ deriving (Show, Eq, Ord)++mkCredentialBaseURL :: Repo -> URLString -> Maybe CredentialBaseURL+mkCredentialBaseURL r s = do+ u <- parseURI s+ let usehttppath = fromMaybe False $ Config.isTrueFalse' $+ Config.get (ConfigKey "credential.useHttpPath") (ConfigValue "") r+ if usehttppath+ then Nothing+ else Just $ CredentialBaseURL $ u { uriPath = "" }
Git/CurrentRepo.hs view
@@ -1,6 +1,6 @@ {- The current git repository. -- - Copyright 2012-2020 Joey Hess <id@joeyh.name>+ - Copyright 2012-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -79,7 +79,8 @@ { gitdir = absd , worktree = Just curr }- r <- Git.Config.read $ newFrom loc+ r <- Git.Config.read $ (newFrom loc)+ { gitDirSpecifiedExplicitly = True } return $ if Git.Config.isBare r then r { location = (location r) { worktree = Nothing } } else r
Git/Queue.hs view
@@ -53,11 +53,11 @@ - those will be run before the FlushAction is. -} | FlushAction { getFlushActionRunner :: FlushActionRunner m- , getFlushActionFiles :: [(RawFilePath, IO Bool, FileSize)]+ , getFlushActionFiles :: [RawFilePath] } {- The String must be unique for each flush action. -}-data FlushActionRunner m = FlushActionRunner String (Repo -> [(RawFilePath, IO Bool, FileSize)] -> m ())+data FlushActionRunner m = FlushActionRunner String (Repo -> [RawFilePath] -> m ()) instance Eq (FlushActionRunner m) where FlushActionRunner s1 _ == FlushActionRunner s2 _ = s1 == s2@@ -140,7 +140,7 @@ {- Adds an flush action to the queue. This can co-exist with anything else - that gets added to the queue, and when the queue is eventually flushed, - it will be run after the other things in the queue. -}-addFlushAction :: MonadIO m => FlushActionRunner m -> [(RawFilePath, IO Bool, FileSize)] -> Queue m -> Repo -> m (Queue m)+addFlushAction :: MonadIO m => FlushActionRunner m -> [RawFilePath] -> Queue m -> Repo -> m (Queue m) addFlushAction runner files q repo = updateQueue action (const False) (length files) q repo where
Git/Types.hs view
@@ -51,6 +51,8 @@ , gitEnvOverridesGitDir :: Bool -- global options to pass to git when running git commands , gitGlobalOpts :: [CommandParam]+ -- True only when --git-dir or GIT_DIR was used+ , gitDirSpecifiedExplicitly :: Bool } deriving (Show, Eq, Ord) newtype ConfigKey = ConfigKey S.ByteString
Git/UpdateIndex.hs view
@@ -1,6 +1,6 @@ {- git-update-index library -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -135,9 +135,17 @@ indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath -{- Refreshes the index, by checking file stat information. -}-refreshIndex :: Repo -> ((RawFilePath -> IO ()) -> IO ()) -> IO Bool-refreshIndex repo feeder = withCreateProcess p go+{- Refreshes the index, by checking file stat information.+ -+ - The action is passed a callback that it can use to send filenames to+ - update-index. Sending Nothing will wait for update-index to finish+ - updating the index.+ -}+refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe RawFilePath -> IO ()) -> m ()) -> m ()+refreshIndex repo feeder = bracket+ (liftIO $ createProcess p)+ (liftIO . cleanupProcess)+ go where params = [ Param "update-index"@@ -150,10 +158,13 @@ p = (gitCreateProcess params repo) { std_in = CreatePipe } - go (Just h) _ _ pid = do- feeder $ \f ->- S.hPut h (S.snoc f 0)- hFlush h- hClose h- checkSuccessProcess pid- go _ _ _ _ = error "internal"+ go (Just h, _, _, pid) = do+ let closer = do+ hFlush h+ hClose h+ forceSuccessProcess p pid+ feeder $ \case+ Just f -> S.hPut h (S.snoc f 0)+ Nothing -> closer+ liftIO $ closer+ go _ = error "internal"
Limit.hs view
@@ -572,7 +572,7 @@ where check now k = inAnnexCheck k $ \f -> liftIO $ catchDefaultIO False $ do- s <- R.getFileStatus f+ s <- R.getSymbolicLinkStatus f let accessed = realToFrac (accessTime s) let delta = now - accessed return $ delta <= secs
Logs/File.hs view
@@ -14,6 +14,7 @@ modifyLogFile, streamLogFile, checkLogFile,+ calcLogFile, ) where import Annex.Common@@ -88,8 +89,8 @@ -- action is concurrently modifying the file. It does not lock the file, -- for speed, but instead relies on the fact that a log file usually -- ends in a newline.-checkLogFile :: FilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool-checkLogFile f lck matchf = withExclusiveLock lck $ bracket setup cleanup go+checkLogFile :: FilePath -> (L.ByteString -> Bool) -> Annex Bool+checkLogFile f matchf = bracket setup cleanup go where setup = liftIO $ tryWhenExists $ openFile f ReadMode cleanup Nothing = noop@@ -99,6 +100,25 @@ !r <- liftIO (any matchf . fullLines <$> L.hGetContents h) return r +-- | Folds a function over lines of a log file to calculate a value.+--+-- This can safely be used while appendLogFile or any atomic+-- action is concurrently modifying the file. It does not lock the file,+-- for speed, but instead relies on the fact that a log file usually+-- ends in a newline.+calcLogFile :: FilePath -> t -> (L.ByteString -> t -> t) -> Annex t+calcLogFile f start update = bracket setup cleanup go+ where+ setup = liftIO $ tryWhenExists $ openFile f ReadMode+ cleanup Nothing = noop+ cleanup (Just h) = liftIO $ hClose h+ go Nothing = return start+ go (Just h) = go' start =<< liftIO (fullLines <$> L.hGetContents h)+ go' v [] = return v+ go' v (l:ls) = do+ let !v' = update l v+ go' v' ls+ -- | Gets only the lines that end in a newline. If the last part of a file -- does not, it's assumed to be a new line being logged that is incomplete, -- and is omitted.@@ -113,25 +133,30 @@ let (l, b') = L.splitAt n b in go (l:c) (L.drop 1 b') --- | Streams lines from a log file, and then empties the file at the end.+-- | Streams lines from a log file, passing each line to the processor,+-- and then empties the file at the end. ----- If the action is interrupted or throws an exception, the log file is+-- If the processor is interrupted or throws an exception, the log file is -- left unchanged. ----- Does nothing if the log file does not exist.+-- There is also a finalizer, that is run once all lines have been+-- streamed. It is run even if the log file does not exist. If the+-- finalizer throws an exception, the log file is left unchanged. -- -- Locking is used to prevent writes to to the log file while this -- is running.-streamLogFile :: FilePath -> RawFilePath -> (String -> Annex ()) -> Annex ()-streamLogFile f lck a = withExclusiveLock lck $ bracketOnError setup cleanup go+streamLogFile :: FilePath -> RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()+streamLogFile f lck finalizer processor = + withExclusiveLock lck $ bracketOnError setup cleanup go where setup = liftIO $ tryWhenExists $ openFile f ReadMode cleanup Nothing = noop cleanup (Just h) = liftIO $ hClose h- go Nothing = noop+ go Nothing = finalizer go (Just h) = do- mapM_ a =<< liftIO (lines <$> hGetContents h)+ mapM_ processor =<< liftIO (lines <$> hGetContents h) liftIO $ hClose h+ finalizer liftIO $ writeFile f "" setAnnexFilePerm (toRawFilePath f)
+ Logs/Restage.hs view
@@ -0,0 +1,63 @@+{- git-annex restage log file+ -+ - Copyright 2022 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Logs.Restage where++import Annex.Common+import Git.FilePath+import Logs.File+import Utility.InodeCache++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++-- | Log a file whose pointer needs to be restaged in git.+-- The content of the file may not be a pointer, if it is populated with+-- the annex content. The InodeCache is used to verify that the file+-- still contains the content, and it's still safe to restage its pointer.+writeRestageLog :: TopFilePath -> InodeCache -> Annex ()+writeRestageLog f ic = do+ logf <- fromRepo gitAnnexRestageLog+ lckf <- fromRepo gitAnnexRestageLock+ appendLogFile logf lckf $ L.fromStrict $ formatRestageLog f ic++-- | Streams the content of the restage log, and then empties the log at+-- the end.+--+-- If the processor or finalizer is interrupted or throws an exception,+-- the log file is left unchanged.+--+-- Locking is used to prevent new items being added to the log while this+-- is running.+streamRestageLog :: Annex () -> (TopFilePath -> InodeCache -> Annex ()) -> Annex ()+streamRestageLog finalizer processor = do+ logf <- fromRepo gitAnnexRestageLog+ lckf <- fromRepo gitAnnexRestageLock+ streamLogFile (fromRawFilePath logf) lckf finalizer $ \l -> + case parseRestageLog l of+ Just (f, ic) -> processor f ic+ Nothing -> noop++calcRestageLog :: t -> ((TopFilePath, InodeCache) -> t -> t) -> Annex t+calcRestageLog start update = do+ logf <- fromRepo gitAnnexRestageLog+ calcLogFile (fromRawFilePath logf) start $ \l v -> + case parseRestageLog (decodeBL l) of+ Just pl -> update pl v+ Nothing -> v++formatRestageLog :: TopFilePath -> InodeCache -> S.ByteString+formatRestageLog f ic = encodeBS (showInodeCache ic) <> ":" <> getTopFilePath f++parseRestageLog :: String -> Maybe (TopFilePath, InodeCache)+parseRestageLog l = + let (ics, f) = separate (== ':') l+ in do+ ic <- readInodeCache ics+ return (asTopFilePath (toRawFilePath f), ic)
Logs/Smudge.hs view
@@ -34,7 +34,7 @@ streamSmudged a = do logf <- fromRepo gitAnnexSmudgeLog lckf <- fromRepo gitAnnexSmudgeLock- streamLogFile (fromRawFilePath logf) lckf $ \l -> + streamLogFile (fromRawFilePath logf) lckf noop $ \l -> case parse l of Nothing -> noop Just (k, f) -> a k f
Remote/Adb.hs view
@@ -360,8 +360,8 @@ -- connection is resonably fast, it's probably as good as -- git's handling of similar situations with files being modified while -- it's updating the working tree for a merge.-retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> ContentIdentifier -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)-retrieveExportWithContentIdentifierM serial adir loc cid dest gk _p = do+retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)+retrieveExportWithContentIdentifierM serial adir loc cids dest gk _p = do case gk of Right mkkey -> do go@@ -374,9 +374,10 @@ where go = do retrieve' serial src dest- currcid <- getExportContentIdentifier serial adir loc- when (currcid /= Right (Just cid)) $- giveup "the file on the android device has changed"+ getExportContentIdentifier serial adir loc >>= \case+ Right (Just currcid)+ | any (currcid ==) cids -> return ()+ _ -> giveup "the file on the android device has changed" src = androidExportLocation adir loc storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
Remote/Borg.hs view
@@ -371,7 +371,7 @@ , giveup $ "Unable to access borg repository " ++ locBorgRepo borgrepo ) -retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> ContentIdentifier -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)+retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) retrieveExportWithContentIdentifierM borgrepo loc _ dest gk _ = do showOutput case gk of
Remote/Ddar.hs view
@@ -184,7 +184,8 @@ ddarDirectoryExists :: DdarRepo -> Annex (Either String Bool) ddarDirectoryExists ddarrepo | ddarLocal ddarrepo = do- maybeStatus <- liftIO $ tryJust (guard . isDoesNotExistError) $ getFileStatus $ ddarRepoLocation ddarrepo+ maybeStatus <- liftIO $ tryJust (guard . isDoesNotExistError) $+ getSymbolicLinkStatus $ ddarRepoLocation ddarrepo return $ case maybeStatus of Left _ -> Right False Right status -> Right $ isDirectory status
Remote/Directory.hs view
@@ -218,8 +218,8 @@ annexdir <- fromRepo gitAnnexObjectDir samefilesystem <- liftIO $ catchDefaultIO False $ (\a b -> deviceID a == deviceID b)- <$> R.getFileStatus d- <*> R.getFileStatus annexdir+ <$> R.getSymbolicLinkStatus d+ <*> R.getSymbolicLinkStatus annexdir checkDiskSpace (Just d) k 0 samefilesystem {- Passed a temp directory that contains the files that should be placed@@ -369,7 +369,7 @@ ImportableContents (catMaybes l') [] where go f = do- st <- R.getFileStatus f+ st <- R.getSymbolicLinkStatus f mkContentIdentifier ii f st >>= \case Nothing -> return Nothing Just cid -> do@@ -390,10 +390,24 @@ then toInodeCache' noTSDelta f st 0 else toInodeCache noTSDelta f st -guardSameContentIdentifiers :: a -> ContentIdentifier -> Maybe ContentIdentifier -> a-guardSameContentIdentifiers cont old new- | new == Just old = cont+-- Since ignoreinodes can be changed by enableremote, and since previous+-- versions of git-annex ignored inodes by default, treat two content+-- idenfiers as the same if they differ only by one having the inode+-- ignored.+guardSameContentIdentifiers :: a -> [ContentIdentifier] -> Maybe ContentIdentifier -> a+guardSameContentIdentifiers _ _ Nothing = giveup "file not found"+guardSameContentIdentifiers cont olds (Just new)+ | any (new ==) olds = cont+ | any (ignoreinode new ==) olds = cont+ | any (\old -> new == ignoreinode old) olds = cont | otherwise = giveup "file content has changed"+ where+ ignoreinode cid@(ContentIdentifier b) = + case readInodeCache (decodeBS b) of+ Nothing -> cid+ Just ic -> + let ic' = replaceInode 0 ic+ in ContentIdentifier (encodeBS (showInodeCache ic')) importKeyM :: IgnoreInodes -> RawFilePath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) importKeyM ii dir loc cid sz p = do@@ -402,8 +416,8 @@ let k = alterKey unsizedk $ \kd -> kd { keySize = keySize kd <|> Just sz } currcid <- liftIO $ mkContentIdentifier ii absf- =<< R.getFileStatus absf- guardSameContentIdentifiers (return (Just k)) cid currcid+ =<< R.getSymbolicLinkStatus absf+ guardSameContentIdentifiers (return (Just k)) [cid] currcid where f = fromExportLocation loc absf = dir P.</> f@@ -413,8 +427,8 @@ , inodeCache = Nothing } -retrieveExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> ExportLocation -> ContentIdentifier -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)-retrieveExportWithContentIdentifierM ii dir cow loc cid dest gk p =+retrieveExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)+retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p = case gk of Right mkkey -> do go Nothing@@ -460,9 +474,9 @@ -- Check before copy, to avoid expensive copy of wrong file -- content.- precheck cont = guardSameContentIdentifiers cont cid+ precheck cont = guardSameContentIdentifiers cont cids =<< liftIO . mkContentIdentifier ii f- =<< liftIO (R.getFileStatus f)+ =<< liftIO (R.getSymbolicLinkStatus f) -- Check after copy, in case the file was changed while it was -- being copied.@@ -486,9 +500,9 @@ #ifndef mingw32_HOST_OS =<< getFdStatus fd #else- =<< R.getFileStatus f+ =<< R.getSymbolicLinkStatus f #endif- guardSameContentIdentifiers cont cid currcid+ guardSameContentIdentifiers cont cids currcid -- When copy-on-write was done, cannot check the handle that was -- copied from, but such a copy should run very fast, so@@ -497,8 +511,8 @@ -- restored to the original content before this check. postcheckcow cont = do currcid <- liftIO $ mkContentIdentifier ii f- =<< R.getFileStatus f- guardSameContentIdentifiers cont cid currcid+ =<< R.getSymbolicLinkStatus f+ guardSameContentIdentifiers cont cids currcid storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do@@ -508,7 +522,7 @@ void $ liftIO $ fileCopier cow src tmpf p Nothing let tmpf' = toRawFilePath tmpf resetAnnexFilePerm tmpf'- liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier ii tmpf' >>= \case+ liftIO (getSymbolicLinkStatus tmpf) >>= liftIO . mkContentIdentifier ii tmpf' >>= \case Nothing -> giveup "unable to generate content identifier" Just newcid -> do checkExportContent ii dir loc@@ -553,7 +567,7 @@ -- content is known, and immediately run the callback. checkExportContent :: IgnoreInodes -> RawFilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a checkExportContent ii dir loc knowncids unsafe callback = - tryWhenExists (liftIO $ R.getFileStatus dest) >>= \case+ tryWhenExists (liftIO $ R.getSymbolicLinkStatus dest) >>= \case Just destst | not (isRegularFile destst) -> unsafe | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier ii dest destst) >>= \case
Remote/Git.hs view
@@ -350,7 +350,7 @@ readlocalannexconfig = do let check = do Annex.BranchState.disableUpdate- catchNonAsync autoInitialize $ \e ->+ catchNonAsync (autoInitialize (pure [])) $ \e -> warning $ "remote " ++ Git.repoDescribe r ++ ":" ++ show e Annex.getState Annex.repo@@ -605,7 +605,7 @@ s <- Annex.new r Annex.eval s $ do Annex.BranchState.disableUpdate- ensureInitialized+ ensureInitialized (pure []) a `finally` stopCoProcesses data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar [(Annex.AnnexState, Annex.AnnexRead)])@@ -647,7 +647,7 @@ [] -> do liftIO $ putMVar mv [] v <- newLocal repo- go (v, ensureInitialized >> a)+ go (v, ensureInitialized (pure []) >> a) (v:rest) -> do liftIO $ putMVar mv rest go (v, a)
Remote/Helper/ExportImport.hs view
@@ -327,11 +327,6 @@ db <- getexportdb dbv liftIO $ Export.getExportTree db k - getfirstexportloc dbv k = do- getexportlocs dbv k >>= \case- [] -> giveup "unknown export location"- (l:_) -> return l- getexportlocs dbv k = do db <- getexportdb dbv liftIO $ Export.getExportTree db k >>= \case@@ -340,6 +335,15 @@ , return [] ) ls -> return ls+ + tryexportlocs dbv k a = + go Nothing =<< getexportlocs dbv k+ where+ go Nothing [] = giveup "unknown export location"+ go (Just ex) [] = throwM ex+ go _ (l:ls) = tryNonAsync (a l) >>= \case+ Right v -> return v+ Left e -> go (Just e) ls getkeycids ciddbv k = do db <- getciddb ciddbv@@ -350,23 +354,22 @@ -- have replaced with content not of the requested key, the content -- has to be strongly verified. retrieveKeyFileFromExport dbv k _af dest p = ifM (isVerifiable k)- ( do- l <- getfirstexportloc dbv k- retrieveExport (exportActions r) k l dest p >>= return . \case+ ( tryexportlocs dbv k $ \loc -> + retrieveExport (exportActions r) k loc dest p >>= return . \case UnVerified -> MustVerify IncompleteVerify iv -> MustFinishIncompleteVerify iv v -> v , giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend" ) - retrieveKeyFileFromImport dbv ciddbv k af dest p =- getkeycids ciddbv k >>= \case- (cid:_) -> do- l <- getfirstexportloc dbv k- snd <$> retrieveExportWithContentIdentifier (importActions r) l cid dest (Left k) p+ retrieveKeyFileFromImport dbv ciddbv k af dest p = do+ cids <- getkeycids ciddbv k+ if not (null cids)+ then tryexportlocs dbv k $ \loc ->+ snd <$> retrieveExportWithContentIdentifier (importActions r) loc cids dest (Left k) p -- In case a content identifier is somehow missing, -- try this instead.- [] -> if isexport+ else if isexport then retrieveKeyFileFromExport dbv k af dest p else giveup "no content identifier is recorded, unable to retrieve"
Remote/S3.hs view
@@ -649,8 +649,8 @@ | otherwise = i : removemostrecent mtime rest -retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)-retrieveExportWithContentIdentifierS3 hv r rs info loc cid dest gk p =+retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)+retrieveExportWithContentIdentifierS3 hv r rs info loc (cid:_) dest gk p = case gk of Right _mkkey -> do k <- go Nothing@@ -675,6 +675,7 @@ return k Nothing -> giveup $ needS3Creds (uuid r) o = T.pack $ bucketExportLocation info loc+retrieveExportWithContentIdentifierS3 _ _ _ _ _ [] _ _ _ = giveup "missing content identifier" {- Catch exception getObject returns when a precondition is not met, - and replace with a more understandable message for the user. -}
Test.hs view
@@ -1,6 +1,6 @@ {- git-annex test suite -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2022 oey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -13,12 +13,12 @@ import Types.RepoVersion import Types.Concurrency import Test.Framework-import Options.Applicative.Types import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck-import Options.Applicative (switch, long, short, help, internal, maybeReader, option)+import Options.Applicative.Types+import Options.Applicative (switch, long, short, help, internal, maybeReader, option, metavar) import qualified Data.Map as M import qualified Data.ByteString.Lazy.UTF8 as BU8@@ -92,7 +92,7 @@ optParser :: Parser TestOptions optParser = TestOptions- <$> snd (tastyParser (tests 1 False True (TestOptions mempty False False Nothing mempty)))+ <$> snd (tastyParser (tests 1 False True (TestOptions mempty False False Nothing mempty mempty))) <*> switch ( long "keep-failures" <> help "preserve repositories on test failure"@@ -106,7 +106,19 @@ <> short 'J' <> help "number of concurrent jobs" ))+ <*> many (option (maybeReader parseconfigvalue)+ ( long "test-git-config"+ <> help "run tests with a git config set"+ <> metavar "NAME=VALUE"+ )) <*> cmdParams "non-options are for internal use only"+ where+ parseconfigvalue s = case break (== '=') s of+ (_, []) -> Nothing+ (k, v) -> Just + ( Git.Types.ConfigKey (encodeBS k)+ , Git.Types.ConfigValue (encodeBS (drop 1 v))+ ) runner :: TestOptions -> IO () runner opts = parallelTestRunner opts tests
Test/Framework.hs view
@@ -169,7 +169,7 @@ case r of Right () -> return () Left e -> do- whenM (keepFailures <$> getTestMode) $+ whenM (keepFailuresOption . testOptions <$> getTestMode) $ putStrLn $ "** Preserving repo for failure analysis in " ++ clone throwM e @@ -255,6 +255,13 @@ -- tell git-annex to not annex the ingitfile git "config" ["annex.largefiles", "exclude=" ++ ingitfile] "git config annex.largefiles"+ -- set any additional git configs the user wants to test with+ gc <- testGitConfig . testOptions <$> getTestMode+ forM_ gc $ \case+ (Git.Types.ConfigKey k, Git.Types.ConfigValue v) -> + git "config" [decodeBS k, decodeBS v]+ "git config from test options"+ (Git.Types.ConfigKey _, Git.Types.NoConfigValue) -> noop ensuredir :: FilePath -> IO () ensuredir d = do@@ -483,15 +490,15 @@ { unlockedFiles :: Bool , adjustedUnlockedBranch :: Bool , annexVersion :: Types.RepoVersion.RepoVersion- , keepFailures :: Bool- } deriving (Show)+ , testOptions :: TestOptions+ } testMode :: TestOptions -> Types.RepoVersion.RepoVersion -> TestMode testMode opts v = TestMode { unlockedFiles = False , adjustedUnlockedBranch = False , annexVersion = v- , keepFailures = keepFailuresOption opts+ , testOptions = opts } hasUnlockedFiles :: TestMode -> Bool
Types/GitConfig.hs view
@@ -153,7 +153,7 @@ , annexUUID = hereuuid , annexNumCopies = configuredNumCopies <$> getmayberead (annexConfig "numcopies")- , annexDiskReserve = fromMaybe onemegabyte $+ , annexDiskReserve = fromMaybe (onemegabyte * 100) $ readSize dataUnits =<< getmaybe (annexConfig "diskreserve") , annexDirect = getbool (annexConfig "direct") False , annexBackend = maybe
Types/Remote.hs view
@@ -334,7 +334,7 @@ -- Throws exception on failure to access the remote. , importKey :: Maybe (ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> a (Maybe Key)) -- Retrieves a file from the remote. Ensures that the file- -- it retrieves has the requested ContentIdentifier.+ -- it retrieves has one of the requested ContentIdentifiers. -- -- This has to be used rather than retrieveExport -- when a special remote supports imports, since files on such a@@ -343,7 +343,7 @@ -- Throws exception on failure. , retrieveExportWithContentIdentifier :: ExportLocation- -> ContentIdentifier+ -> [ContentIdentifier] -- file to write content to -> FilePath -- Either the key, or when it's not yet known, a callback
Types/Test.hs view
@@ -11,12 +11,14 @@ import Types.Concurrency import Types.Command+import Git.Types data TestOptions = TestOptions { tastyOptionSet :: OptionSet , keepFailuresOption :: Bool , fakeSsh :: Bool , concurrentJobs :: Maybe Concurrency+ , testGitConfig :: [(ConfigKey, ConfigValue)] , internalData :: CmdParams }
Upgrade.hs view
@@ -74,31 +74,24 @@ Left ex -> err $ "Automatic upgrade exception! " ++ show ex upgrade :: Bool -> RepoVersion -> Annex Bool-upgrade automatic destversion = do- startversion <- getVersion- (ok, newversion) <- go startversion- when (ok && newversion /= startversion) $- postupgrade newversion- return ok+upgrade automatic destversion = go =<< getVersion where go (Just v)- | v >= destversion = return (True, Just v)+ | v >= destversion = return True | otherwise = ifM upgradingRemote ( upgraderemote , up v >>= \case- UpgradeSuccess -> go (Just (incrversion v) )- UpgradeFailed -> return (False, Just v)- UpgradeDeferred -> return (True, Just v)+ UpgradeSuccess -> do+ let v' = incrversion v+ upgradedto v'+ go (Just v')+ UpgradeFailed -> return False+ UpgradeDeferred -> return True )- go Nothing = return (True, Nothing)+ go Nothing = return True incrversion v = RepoVersion (fromRepoVersion v + 1) - postupgrade newversion = ifM upgradingRemote- ( reloadConfig- , maybe noop upgradedto newversion- )- #ifndef mingw32_HOST_OS up (RepoVersion 0) = Upgrade.V0.upgrade up (RepoVersion 1) = Upgrade.V1.upgrade@@ -121,15 +114,18 @@ -- upgrading a git repo other than the current repo. upgraderemote = do rp <- fromRawFilePath <$> fromRepo Git.repoPath- gitAnnexChildProcess "upgrade"+ ok <- gitAnnexChildProcess "upgrade" [ Param "--quiet" , Param "--autoonly" ] (\p -> p { cwd = Just rp }) (\_ _ _ pid -> waitForProcess pid >>= return . \case- ExitSuccess -> (True, Nothing)- _ -> (False, Nothing)+ ExitSuccess -> True+ _ -> False )+ when ok+ reloadConfig+ return ok upgradedto v = do setVersion v
Upgrade/V9.hs view
@@ -46,7 +46,7 @@ then return True else assistantrunning -- Initialized at v9, so no old process danger exists.- Nothing -> return False+ Nothing -> pure False {- Skip upgrade when git-annex assistant (or watch) is running, - because these are long-running daemons that could conceivably
Utility/InodeCache.hs view
@@ -32,6 +32,7 @@ inodeCacheToMtime, inodeCacheToEpochTime, inodeCacheEpochTimeRange,+ replaceInode, SentinalFile(..), SentinalStatus(..),@@ -125,6 +126,10 @@ let t = inodeCacheToEpochTime i in (t-1, t+1) +replaceInode :: FileID -> InodeCache -> InodeCache+replaceInode inode (InodeCache (InodeCachePrim _ sz mtime)) =+ InodeCache (InodeCachePrim inode sz mtime)+ {- For backwards compatability, support low-res mtime with no - fractional seconds. -} data MTime = MTimeLowRes EpochTime | MTimeHighRes POSIXTime@@ -187,7 +192,7 @@ genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) genInodeCache f delta = catchDefaultIO Nothing $- toInodeCache delta f =<< R.getFileStatus f+ toInodeCache delta f =<< R.getSymbolicLinkStatus f toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache) toInodeCache d f s = toInodeCache' d f s (fileID s)
Utility/MagicWormhole.hs view
@@ -119,17 +119,22 @@ (findcode ph herr) return (inout || inerr) where- p = wormHoleProcess (Param "send" : ps ++ [File f])- findcode ph h = findcode' =<< getwords ph h []+ p = wormHoleProcess (ps ++ [Param "send", File f])+ findcode ph h = hGetLineUntilExitOrEOF ph h >>= \case+ Nothing -> return False+ Just l -> ifM (findcode' (words l))+ ( drain ph h >> return True+ , findcode ph h+ ) findcode' [] = return False findcode' (w:ws) = case mkCode w of Just code -> do _ <- tryPutMVar observer code return True Nothing -> findcode' ws- getwords ph h c = hGetLineUntilExitOrEOF ph h >>= \case- Nothing -> return $ concatMap words $ reverse c- Just l -> getwords ph h (l:c)+ drain ph h = hGetLineUntilExitOrEOF ph h >>= \case+ Just _ -> drain ph h+ Nothing -> return () -- | Receives a file. Once the receive is under way, the Code will be -- read from the CodeProducer, and fed to wormhole on stdin.@@ -140,12 +145,12 @@ hFlush hin return True where- p = wormHoleProcess $+ p = wormHoleProcess $ ps ++ [ Param "receive" , Param "--accept-file" , Param "--output-file" , File f- ] ++ ps+ ] wormHoleProcess :: WormHoleParams -> CreateProcess wormHoleProcess = proc "wormhole" . toCommand
Utility/MoveFile.hs view
@@ -72,7 +72,7 @@ #ifndef mingw32_HOST_OS isdir f = do- r <- tryIO $ R.getFileStatus f+ r <- tryIO $ R.getSymbolicLinkStatus f case r of (Left _) -> return False (Right s) -> return $ isDirectory s
Utility/Url.hs view
@@ -313,7 +313,7 @@ existsfile u = do let f = toRawFilePath (unEscapeString (uriPath u))- s <- catchMaybeIO $ R.getFileStatus f+ s <- catchMaybeIO $ R.getSymbolicLinkStatus f case s of Just stat -> do sz <- getFileSize' f stat
+ doc/git-annex-backends.mdwn view
@@ -0,0 +1,24 @@+# NAME++git-annex-backends - key/value backends for git-annex++# DESCRIPTION++The "backend" in git-annex controls how a key is generated from a file's+content and/or filesystem metadata. Most backends are different kinds of+hashes. A single repository can use different backends for different files.++For a list of available backends, see `git-annex version`. For more+details, see <https://git-annex.branchable.com/backends/>++# SEE ALSO++[[git-annex]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++<http://git-annex.branchable.com/>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.
doc/git-annex-dead.mdwn view
@@ -17,8 +17,8 @@ description, or their UUID. (To undo, use `git-annex semitrust`.) When a key is specified, indicates that the content of that key has been-irretrievably lost. This prevents commands like `git annex fsck --all`-from complaining about it. +irretrievably lost. This makes the key be skipped when operating+on all keys with eg `--all`. (To undo, add the key's content back to the repository, by using eg, `git-annex reinject`.)
doc/git-annex-log.mdwn view
@@ -46,7 +46,7 @@ * `--all` `-A` - Shows location log changes to all files, with the most recent changes first.+ Shows location log changes to all content, with the most recent changes first. In this mode, the names of files are not available and keys are displayed instead.
doc/git-annex-migrate.mdwn view
@@ -57,6 +57,8 @@ [[git-annex-upgrade]](1) +[[git-annex-backend]](1)+ # AUTHOR Joey Hess <id@joeyh.name>
doc/git-annex-preferred-content.mdwn view
@@ -99,10 +99,12 @@ Like lackingcopies, but does not look at .gitattributes annex.numcopies settings. This makes it significantly faster. -* `inbackend=name`+* `inbackend=backendname` Matches only files whose content is stored using the specified key-value backend.++ See [[git-annex-backends]](1) for information about available backends. * `securehash`
+ doc/git-annex-restage.mdwn view
@@ -0,0 +1,34 @@+# NAME++git-annex restage - restages unlocked files in the git index++# SYNOPSIS++git annex restage++# DESCRIPTION++Since getting or dropping an unlocked file modifies the file in the work+tree, git needs to be told that the modification does not change the+content that it has recorded (the annex pointer). Restaging the file+accomplishes that.++You do not normally need to run this command, because usually git-annex+is able to restage unlocked files itself. There are some situations+where git-annex needs to restage a file, but the git index is locked,+and so it cannot. It will then display a warning suggesting you run this+command.++It's safe to run this command even after you have made a modification to an+unlocked file.++# SEE ALSO++[[git-annex]](1)+[[git-annex-smudge]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.
doc/git-annex-test.mdwn view
@@ -30,6 +30,20 @@ When there are test failures, leave the `.t` directory populated with repositories that demonstate the failures, for later analysis. +* `--test-git-config name=value`++ The test suite prevents git from reading any git configuration files.+ Usually it is a good idea to run the test suite with a standard + git configuration. However, this option can be useful to see what+ effect a git configuration setting has on the test suite. ++ Some configuration settings will break the test suite, in ways that are+ due to a bug in git-annex. But it is possible that changing a+ configuration can find a legitimate bug in git-annex.++ One valid use of this is to change a git configuration to a value that+ is planned to be the new default in a future version of git.+ # SEE ALSO [[git-annex]](1)
doc/git-annex-whereis.mdwn view
@@ -38,6 +38,9 @@ * `--all` `-A` Show whereis information for all known keys.+ + (Except for keys that have been marked as dead,+ see [[git-annex-dead]](1).) * `--branch=ref`
doc/git-annex.mdwn view
@@ -708,8 +708,8 @@ * `smudge` This command lets git-annex be used as a git filter driver, allowing- annexed files in the git repository to be unlocked at all times, instead- of being symlinks.+ annexed files in the git repository to be unlocked regular files instead+ of symlinks. See [[git-annex-smudge]](1) for details. @@ -720,6 +720,12 @@ See [[git-annex-filter-process]](1) for details. +* `restage`+ + Restages unlocked files in the git index.++ See [[git-annex-restage]](1) for details.+ * `findref [ref]` Lists files in a git ref. (deprecated)@@ -786,7 +792,8 @@ * `annex.backend` Name of the default key-value backend to use when adding new files- to the repository.+ to the repository. See [[git-annex-backends]](1) for information about+ available backends. This is overridden by annex annex.backend configuration in the .gitattributes files, and by the --backend option.@@ -822,12 +829,12 @@ * `annex.diskreserve` Amount of disk space to reserve. Disk space is checked when transferring- content to avoid running out, and additional free space can be reserved- via this option, to make space for more important content (such as git- commit logs). Can be specified with any commonly used units, for example,- "0.5 gb", "500M", or "100 KiloBytes"+ annexed content to avoid running out, and additional free space can be+ reserved via this option, to make space for other data (such as git + commit logs). Can be specified with any commonly used units, for + example, "0.5 gb", "500M", or "100 KiloBytes" - The default reserve is 1 megabyte.+ The default reserve is 100 megabytes. * `annex.skipunknown` @@ -1273,6 +1280,9 @@ In the command line, %path is replaced with the file or directory to operate on. + (When annex.crippledfilesystem is set, git-annex will not try to+ remove/restore the write bit, but it will still run these hooks.)+ * `annex.tune.objecthash1`, `annex.tune.objecthashlower`, `annex.tune.branchhash1` These can be passed to `git annex init` to tune the repository.@@ -1698,12 +1708,15 @@ (rather than the default built-in url downloader). For example, to force IPv4 only, set it to "-4".- Or to make curl use your ~/.netrc file, set it to "--netrc". Setting this option makes git-annex use curl, but only when annex.security.allowed-ip-addresses is configured in a specific way. See its documentation. + Setting this option prevents git-annex from using git-credential+ for prompting for http passwords. Instead, you can include "--netrc"+ to make curl use your ~/.netrc file and record the passwords there.+ * `annex.youtube-dl-options` Options to pass to youtube-dl when using it to find the url to download@@ -1896,7 +1909,9 @@ The key-value backend used when adding a new file to the annex can be configured on a per-file-type basis via `.gitattributes` files. In the file, the `annex.backend` attribute can be set to the name of the backend to-use. For example, this here's how to use the WORM backend by default,+use. (See [[git-annex-backends]](1) for information about+available backends.)+For example, this here's how to use the WORM backend by default, but the SHA256E backend for ogg files: * annex.backend=WORM
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20220822+Version: 10.20220927 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -46,6 +46,7 @@ doc/git-annex-addurl.mdwn doc/git-annex-adjust.mdwn doc/git-annex-assistant.mdwn+ doc/git-annex-backends.mdwn doc/git-annex-calckey.mdwn doc/git-annex-checkpresentkey.mdwn doc/git-annex-config.mdwn@@ -109,6 +110,7 @@ doc/git-annex-renameremote.mdwn doc/git-annex-repair.mdwn doc/git-annex-required.mdwn+ doc/git-annex-restage.mdwn doc/git-annex-resolvemerge.mdwn doc/git-annex-rmurl.mdwn doc/git-annex-schedule.mdwn@@ -256,10 +258,8 @@ Utility/libkqueue.h Flag Assistant- Description: Enable git-annex assistant and watch command--Flag Webapp- Description: Enable git-annex webapp+ Description: Enable git-annex assistant, webapp, and watch command+ Default: True Flag Pairing Description: Enable pairing@@ -376,7 +376,21 @@ aws (>= 0.20), DAV (>= 1.0), network (>= 3.0.0.0),- network-bsd+ network-bsd,+ mountpoints,+ yesod (>= 1.4.3), + yesod-static (>= 1.5.1),+ yesod-form (>= 1.4.8),+ yesod-core (>= 1.6.0),+ path-pieces (>= 0.2.1),+ warp (>= 3.2.8),+ warp-tls (>= 3.2.2),+ wai,+ wai-extra,+ blaze-builder,+ clientsession,+ template-haskell,+ shakespeare (>= 2.0.11) CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs -Wincomplete-uni-patterns Default-Language: Haskell2010@@ -416,8 +430,7 @@ Other-Modules: Utility.GitLFS if flag(Assistant) && ! os(solaris) && ! os(gnu)- Build-Depends: mountpoints- CPP-Options: -DWITH_ASSISTANT+ CPP-Options: -DWITH_ASSISTANT -DWITH_WEBAPP Other-Modules: Assistant Assistant.Alert@@ -436,6 +449,7 @@ Assistant.Install.AutoStart Assistant.Install.Menu Assistant.MakeRemote+ Assistant.MakeRepo Assistant.Monad Assistant.NamedThread Assistant.Pairing@@ -458,6 +472,7 @@ Assistant.Threads.Merger Assistant.Threads.MountWatcher Assistant.Threads.NetWatcher+ Assistant.Threads.PairListener Assistant.Threads.ProblemFixer Assistant.Threads.Pusher Assistant.Threads.RemoteControl@@ -469,6 +484,7 @@ Assistant.Threads.UpgradeWatcher Assistant.Threads.Upgrader Assistant.Threads.Watcher+ Assistant.Threads.WebApp Assistant.TransferQueue Assistant.TransferSlots Assistant.Types.Alert@@ -489,11 +505,44 @@ Assistant.Types.UrlRenderer Assistant.Unused Assistant.Upgrade+ Assistant.WebApp+ Assistant.WebApp.Common+ Assistant.WebApp.Configurators+ Assistant.WebApp.Configurators.AWS+ Assistant.WebApp.Configurators.Delete+ Assistant.WebApp.Configurators.Edit+ Assistant.WebApp.Configurators.Fsck+ Assistant.WebApp.Configurators.IA+ Assistant.WebApp.Configurators.Local+ Assistant.WebApp.Configurators.Pairing+ Assistant.WebApp.Configurators.Preferences+ Assistant.WebApp.Configurators.Ssh+ Assistant.WebApp.Configurators.Unused+ Assistant.WebApp.Configurators.Upgrade+ Assistant.WebApp.Configurators.WebDAV+ Assistant.WebApp.Control+ Assistant.WebApp.DashBoard+ Assistant.WebApp.Documentation+ Assistant.WebApp.Form+ Assistant.WebApp.Gpg+ Assistant.WebApp.MakeRemote+ Assistant.WebApp.Notifications+ Assistant.WebApp.OtherRepos+ Assistant.WebApp.Page+ Assistant.WebApp.Pairing+ Assistant.WebApp.Repair+ Assistant.WebApp.RepoId+ Assistant.WebApp.RepoList+ Assistant.WebApp.SideBar+ Assistant.WebApp.Types Command.Assistant Command.Watch+ Command.WebApp Utility.Mounts Utility.OSX-+ Utility.Yesod+ Utility.WebApp+ if os(linux) Build-Depends: hinotify (>= 0.3.10) CPP-Options: -DWITH_INOTIFY@@ -516,60 +565,6 @@ Includes: Utility/libkqueue.h Other-Modules: Utility.DirWatcher.Kqueue - if flag(Webapp)- Build-Depends:- yesod (>= 1.4.3), - yesod-static (>= 1.5.1),- yesod-form (>= 1.4.8),- yesod-core (>= 1.6.0),- path-pieces (>= 0.2.1),- warp (>= 3.2.8),- warp-tls (>= 3.2.2),- wai,- wai-extra,- blaze-builder,- clientsession,- template-haskell,- shakespeare (>= 2.0.11)- CPP-Options: -DWITH_WEBAPP- Other-Modules:- Command.WebApp- Assistant.Threads.WebApp- Assistant.Threads.PairListener- Assistant.WebApp- Assistant.WebApp.Common- Assistant.WebApp.Configurators- Assistant.WebApp.Configurators.AWS- Assistant.WebApp.Configurators.Delete- Assistant.WebApp.Configurators.Edit- Assistant.WebApp.Configurators.Fsck- Assistant.WebApp.Configurators.IA- Assistant.WebApp.Configurators.Local- Assistant.WebApp.Configurators.Pairing- Assistant.WebApp.Configurators.Preferences- Assistant.WebApp.Configurators.Ssh- Assistant.WebApp.Configurators.Unused- Assistant.WebApp.Configurators.Upgrade- Assistant.WebApp.Configurators.WebDAV- Assistant.WebApp.Control- Assistant.WebApp.DashBoard- Assistant.WebApp.Documentation- Assistant.WebApp.Form- Assistant.WebApp.Gpg- Assistant.WebApp.MakeRemote- Assistant.WebApp.Notifications- Assistant.WebApp.OtherRepos- Assistant.WebApp.Page- Assistant.WebApp.Pairing- Assistant.WebApp.Repair- Assistant.WebApp.RepoId- Assistant.WebApp.RepoList- Assistant.WebApp.SideBar- Assistant.WebApp.Types- Assistant.MakeRepo- Utility.Yesod- Utility.WebApp- if flag(Dbus) if (os(linux)) Build-Depends: dbus (>= 0.10.7), fdo-notify (>= 0.3)@@ -782,6 +777,7 @@ Command.Repair Command.Required Command.ResolveMerge+ Command.Restage Command.RmUrl Command.Schedule Command.Semitrust@@ -916,6 +912,7 @@ Logs.Remote Logs.Remote.Pure Logs.RemoteState+ Logs.Restage Logs.Schedule Logs.SingleValue Logs.SingleValue.Pure
stack.yaml view
@@ -4,7 +4,6 @@ assistant: true pairing: true torrentparser: true- webapp: true magicmime: false dbus: false debuglocks: false