diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -1,6 +1,6 @@ {- git-annex monad - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -78,6 +78,7 @@ import Utility.InodeCache import Utility.Url import Utility.ResourcePool +import Utility.HumanTime import "mtl" Control.Monad.Reader import Control.Concurrent @@ -85,6 +86,7 @@ import qualified Control.Monad.Fail as Fail import qualified Data.Map.Strict as M 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. @@ -131,8 +133,11 @@ , checkignorehandle :: Maybe (ResourcePool CheckIgnoreHandle) , forcebackend :: Maybe String , globalnumcopies :: Maybe NumCopies + , globalmincopies :: Maybe MinCopies , forcenumcopies :: Maybe NumCopies + , forcemincopies :: Maybe MinCopies , limit :: ExpandableMatcher Annex + , timelimit :: Maybe (Duration, POSIXTime) , uuiddescmap :: Maybe UUIDDescMap , preferredcontentmap :: Maybe (FileMatcherMap Annex) , requiredcontentmap :: Maybe (FileMatcherMap Annex) @@ -199,8 +204,11 @@ , checkignorehandle = Nothing , forcebackend = Nothing , globalnumcopies = Nothing + , globalmincopies = Nothing , forcenumcopies = Nothing + , forcemincopies = Nothing , limit = BuildingMatcher [] + , timelimit = Nothing , uuiddescmap = Nothing , preferredcontentmap = Nothing , requiredcontentmap = Nothing diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -147,7 +147,7 @@ unless inoverlay $ do (deleted, cleanup2) <- inRepo (LsFiles.deleted [] [top]) unless (null deleted) $ - Annex.Queue.addCommand "rm" + Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] (map fromRawFilePath deleted) void $ liftIO cleanup2 @@ -288,8 +288,13 @@ resolveby ks a = do {- Remove conflicted file from index so merge can be resolved. -} - Annex.Queue.addCommand "rm" - [Param "--quiet", Param "-f", Param "--cached", Param "--"] [file] + Annex.Queue.addCommand [] "rm" + [ Param "--quiet" + , Param "-f" + , Param "--cached" + , Param "--" + ] + [file] void a return (ks, Just file) diff --git a/Annex/CheckAttr.hs b/Annex/CheckAttr.hs --- a/Annex/CheckAttr.hs +++ b/Annex/CheckAttr.hs @@ -1,4 +1,4 @@ -{- git check-attr interface, with handle automatically stored in the Annex monad +{- git check-attr interface - - Copyright 2012-2020 Joey Hess - @@ -7,6 +7,7 @@ module Annex.CheckAttr ( checkAttr, + checkAttrs, checkAttrStop, mkConcurrentCheckAttrHandle, ) where @@ -22,13 +23,18 @@ annexAttrs :: [Git.Attr] annexAttrs = [ "annex.backend" - , "annex.numcopies" , "annex.largefiles" + , "annex.numcopies" + , "annex.mincopies" ] checkAttr :: Git.Attr -> RawFilePath -> Annex String checkAttr attr file = withCheckAttrHandle $ \h -> liftIO $ Git.checkAttr h attr file + +checkAttrs :: [Git.Attr] -> RawFilePath -> Annex [String] +checkAttrs attrs file = withCheckAttrHandle $ \h -> + liftIO $ Git.checkAttrs h attrs file withCheckAttrHandle :: (Git.CheckAttrHandle -> Annex a) -> Annex a withCheckAttrHandle a = diff --git a/Annex/Drop.hs b/Annex/Drop.hs --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -1,6 +1,6 @@ {- dropping of unwanted content - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -63,23 +63,30 @@ where getcopies fs = do (untrusted, have) <- trustPartition UnTrusted locs - numcopies <- if null fs - then getNumCopies - else maximum <$> mapM getFileNumCopies fs - return (NumCopies (length have), numcopies, S.fromList untrusted) + (numcopies, mincopies) <- if null fs + then (,) <$> getNumCopies <*> getMinCopies + else do + l <- mapM getFileNumMinCopies fs + return (maximum $ map fst l, maximum $ map snd l) + return (NumCopies (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 - counted as a copy, so having only numcopies suffices. Otherwise, - - we need more than numcopies to safely drop. -} - checkcopies (have, numcopies, _untrusted) Nothing = have > numcopies - checkcopies (have, numcopies, untrusted) (Just u) + - we need more than numcopies to safely drop. + - + - This is not the final check that it's safe to drop, but it + - 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 - decrcopies (have, numcopies, untrusted) Nothing = - (NumCopies (fromNumCopies have - 1), numcopies, untrusted) - decrcopies v@(_have, _numcopies, untrusted) (Just u) + decrcopies (have, numcopies, mincopies, untrusted) Nothing = + (NumCopies (fromNumCopies have - 1), numcopies, mincopies, untrusted) + decrcopies v@(_have, _numcopies, _mincopies, untrusted) (Just u) | S.member u untrusted = v | otherwise = decrcopies v Nothing @@ -105,8 +112,8 @@ , return n ) - dodrop n@(have, numcopies, _untrusted) u a = - ifM (safely $ runner $ a numcopies) + dodrop n@(have, numcopies, mincopies, _untrusted) u a = + ifM (safely $ runner $ a numcopies mincopies) ( do liftIO $ debugM "drop" $ unwords [ "dropped" @@ -121,12 +128,12 @@ , return n ) - dropl fs n = checkdrop fs n Nothing $ \numcopies -> + dropl fs n = checkdrop fs n Nothing $ \numcopies mincopies -> stopUnless (inAnnex key) $ - Command.Drop.startLocal afile ai si numcopies key preverified + Command.Drop.startLocal afile ai si numcopies mincopies key preverified - dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies -> - Command.Drop.startRemote afile ai si numcopies key r + dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies mincopies -> + Command.Drop.startRemote afile ai si numcopies mincopies key r ai = mkActionItem (key, afile) diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -93,8 +93,8 @@ | needsSubmoduleFixup r = do when (coreSymlinks c) $ (replacedotgit >> unsetcoreworktree) - `catchNonAsync` \_e -> hPutStrLn stderr - "warning: unable to convert submodule to form that will work with git-annex" + `catchNonAsync` \e -> hPutStrLn stderr $ + "warning: unable to convert submodule to form that will work with git-annex: " ++ show e return $ r' { config = M.delete "core.worktree" (config r) } @@ -102,8 +102,8 @@ ( do when (coreSymlinks c) $ (replacedotgit >> worktreefixup) - `catchNonAsync` \_e -> hPutStrLn stderr - "warning: unable to convert .git file to symlink that will work with git-annex" + `catchNonAsync` \e -> hPutStrLn stderr $ + "warning: unable to convert .git file to symlink that will work with git-annex: " ++ show e return r' , return r ) @@ -115,9 +115,8 @@ removeWhenExistsWith R.removeLink dotgit R.createSymbolicLink linktarget dotgit - unsetcoreworktree = - maybe (error "unset core.worktree failed") (\_ -> return ()) - =<< Git.Config.unset "core.worktree" r + -- Unsetting a config fails if it's not set, so ignore failure. + unsetcoreworktree = void $ Git.Config.unset "core.worktree" r worktreefixup = -- git-worktree sets up a "commondir" file that contains diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -20,6 +20,7 @@ import Git.Env import qualified Annex import qualified Annex.Queue +import Config.Smudge {- Runs an action using a different git index file. -} withIndexFile :: AltIndexFile -> (FilePath -> Annex a) -> Annex a @@ -67,16 +68,12 @@ - Smudge and clean filters are disabled in this work tree. -} withWorkTree :: FilePath -> Annex a -> Annex a withWorkTree d a = withAltRepo - (\g -> return $ (g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ disableSmudgeConfig }, ())) + (\g -> return $ (g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ bypassSmudgeConfig }, ())) (\g g' -> g' { location = location g, gitGlobalOpts = gitGlobalOpts g }) (const a) where modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) } modlocation _ = error "withWorkTree of non-local git repo" - disableSmudgeConfig = map Param - [ "-c", "filter.annex.smudge=" - , "-c", "filter.annex.clean=" - ] {- Runs an action with the git index file and HEAD, and a few other - files that are related to the work tree coming from an overlay diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -308,7 +308,8 @@ ( do _ <- makeLink file key mcache ps <- gitAddParams ci - Annex.Queue.addCommand "add" (ps++[Param "--"]) [fromRawFilePath file] + Annex.Queue.addCommand [] "add" (ps++[Param "--"]) + [fromRawFilePath file] , do l <- makeLink file key mcache addAnnexLink l file diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -35,6 +35,7 @@ import Utility.InodeCache import Utility.Tmp.Dir import Utility.CopyFile +import qualified Database.Keys.Handle import qualified Utility.RawFilePath as R import qualified Data.ByteString as S @@ -202,6 +203,8 @@ -- updated index file. runner :: Git.Queue.InternalActionRunner Annex runner = Git.Queue.InternalActionRunner "restagePointerFile" $ \r l -> do + liftIO . Database.Keys.Handle.flushDbQueue + =<< Annex.getState Annex.keysdbhandle realindex <- liftIO $ Git.Index.currentIndexFile r let lock = fromRawFilePath (Git.Index.indexFileLock realindex) lockindex = liftIO $ catchMaybeIO $ Git.LockFile.openLock' lock diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -1,6 +1,6 @@ {- git-annex numcopies configuration and checking - - - Copyright 2014-2015 Joey Hess + - Copyright 2014-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,10 +10,11 @@ module Annex.NumCopies ( module Types.NumCopies, module Logs.NumCopies, - getFileNumCopies, - getAssociatedFileNumCopies, + getFileNumMinCopies, + getAssociatedFileNumMinCopies, getGlobalFileNumCopies, getNumCopies, + getMinCopies, deprecatedNumCopies, defaultNumCopies, numCopiesCheck, @@ -41,9 +42,12 @@ defaultNumCopies :: NumCopies defaultNumCopies = NumCopies 1 -fromSources :: [Annex (Maybe NumCopies)] -> Annex NumCopies -fromSources = fromMaybe defaultNumCopies <$$> getM id +defaultMinCopies :: MinCopies +defaultMinCopies = MinCopies 1 +fromSourcesOr :: v -> [Annex (Maybe v)] -> Annex v +fromSourcesOr v = fromMaybe v <$$> getM id + {- The git config annex.numcopies is deprecated. -} deprecatedNumCopies :: Annex (Maybe NumCopies) deprecatedNumCopies = annexNumCopies <$> Annex.getGitConfig @@ -52,41 +56,93 @@ getForcedNumCopies :: Annex (Maybe NumCopies) getForcedNumCopies = Annex.getState Annex.forcenumcopies -{- Numcopies value from any of the non-.gitattributes configuration +{- Value forced on the command line by --mincopies. -} +getForcedMinCopies :: Annex (Maybe MinCopies) +getForcedMinCopies = Annex.getState Annex.forcemincopies + +{- NumCopies value from any of the non-.gitattributes configuration - sources. -} getNumCopies :: Annex NumCopies -getNumCopies = fromSources +getNumCopies = fromSourcesOr defaultNumCopies [ getForcedNumCopies , getGlobalNumCopies , deprecatedNumCopies ] -{- Numcopies value for a file, from any configuration source, including the - - deprecated git config. -} -getFileNumCopies :: RawFilePath -> Annex NumCopies -getFileNumCopies f = fromSources - [ getForcedNumCopies - , getFileNumCopies' f - , deprecatedNumCopies +{- MinCopies value from any of the non-.gitattributes configuration + - sources. -} +getMinCopies :: Annex MinCopies +getMinCopies = fromSourcesOr defaultMinCopies + [ getForcedMinCopies + , getGlobalMinCopies ] -getAssociatedFileNumCopies :: AssociatedFile -> Annex NumCopies -getAssociatedFileNumCopies (AssociatedFile afile) = - maybe getNumCopies getFileNumCopies afile +{- NumCopies and MinCopies value for a file, from any configuration source, + - including .gitattributes. -} +getFileNumMinCopies :: RawFilePath -> Annex (NumCopies, MinCopies) +getFileNumMinCopies f = do + fnumc <- getForcedNumCopies + fminc <- getForcedMinCopies + case (fnumc, fminc) of + (Just numc, Just minc) -> return (numc, minc) + (Just numc, Nothing) -> do + minc <- fromSourcesOr defaultMinCopies + [ snd <$> getNumMinCopiesAttr f + , getGlobalMinCopies + ] + return (numc, minc) + (Nothing, Just minc) -> do + numc <- fromSourcesOr defaultNumCopies + [ fst <$> getNumMinCopiesAttr f + , getGlobalNumCopies + , deprecatedNumCopies + ] + return (numc, minc) + (Nothing, Nothing) -> do + let fallbacknum = fromSourcesOr defaultNumCopies + [ getGlobalNumCopies + , deprecatedNumCopies + ] + let fallbackmin = fromSourcesOr defaultMinCopies + [ getGlobalMinCopies + ] + getNumMinCopiesAttr f >>= \case + (Just numc, Just minc) -> + return (numc, minc) + (Just numc, Nothing) -> (,) + <$> pure numc + <*> fallbackmin + (Nothing, Just minc) -> (,) + <$> fallbacknum + <*> pure minc + (Nothing, Nothing) -> (,) + <$> fallbacknum + <*> fallbackmin +getAssociatedFileNumMinCopies :: AssociatedFile -> Annex (NumCopies, MinCopies) +getAssociatedFileNumMinCopies (AssociatedFile (Just file)) = + getFileNumMinCopies file +getAssociatedFileNumMinCopies (AssociatedFile Nothing) = (,) + <$> getNumCopies + <*> getMinCopies + {- This is the globally visible numcopies value for a file. So it does - not include local configuration in the git config or command line - options. -} getGlobalFileNumCopies :: RawFilePath -> Annex NumCopies -getGlobalFileNumCopies f = fromSources - [ getFileNumCopies' f +getGlobalFileNumCopies f = fromSourcesOr defaultNumCopies + [ fst <$> getNumMinCopiesAttr f + , getGlobalNumCopies ] -getFileNumCopies' :: RawFilePath -> Annex (Maybe NumCopies) -getFileNumCopies' file = maybe getGlobalNumCopies (return . Just) =<< getattr - where - getattr = (NumCopies <$$> readish) - <$> checkAttr "annex.numcopies" file +getNumMinCopiesAttr :: RawFilePath -> Annex (Maybe NumCopies, Maybe MinCopies) +getNumMinCopiesAttr file = + checkAttrs ["annex.numcopies", "annex.mincopies"] file >>= \case + (n:m:[]) -> return + ( NumCopies <$> readish n + , MinCopies <$> readish m + ) + _ -> error "internal" {- Checks if numcopies are satisfied for a file by running a comparison - between the number of (not untrusted) copies that are @@ -102,7 +158,7 @@ numCopiesCheck' :: RawFilePath -> (Int -> Int -> v) -> [UUID] -> Annex v numCopiesCheck' file vs have = do - NumCopies needed <- getFileNumCopies file + NumCopies needed <- fst <$> getFileNumMinCopies file return $ length have `vs` needed data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere @@ -117,24 +173,25 @@ -> Key -> Maybe ContentRemovalLock -> NumCopies + -> MinCopies -> [UUID] -- repos to skip considering (generally untrusted remotes) -> [VerifiedCopy] -- copies already verified to exist -> [UnVerifiedCopy] -- places to check to see if they have copies -> (SafeDropProof -> Annex a) -- action to perform the drop -> Annex a -- action to perform when unable to drop -> Annex a -verifyEnoughCopiesToDrop nolocmsg key removallock need skip preverified tocheck dropaction nodropaction = +verifyEnoughCopiesToDrop nolocmsg key removallock neednum needmin skip preverified tocheck dropaction nodropaction = helper [] [] preverified (nub tocheck) [] where helper bad missing have [] lockunsupported = - liftIO (mkSafeDropProof need have removallock) >>= \case + liftIO (mkSafeDropProof neednum needmin have removallock) >>= \case Right proof -> dropaction proof Left stillhave -> do - notEnoughCopies key need stillhave (skip++missing) bad nolocmsg lockunsupported + notEnoughCopies key neednum needmin stillhave (skip++missing) bad nolocmsg lockunsupported nodropaction helper bad missing have (c:cs) lockunsupported - | isSafeDrop need have removallock = - liftIO (mkSafeDropProof need have removallock) >>= \case + | isSafeDrop neednum needmin have removallock = + liftIO (mkSafeDropProof neednum needmin have removallock) >>= \case Right proof -> dropaction proof Left stillhave -> helper bad missing stillhave (c:cs) lockunsupported | otherwise = case c of @@ -177,16 +234,16 @@ instance Exception DropException -notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> [Remote] -> Annex () -notEnoughCopies key need have skip bad nolocmsg lockunsupported = do +notEnoughCopies :: Key -> NumCopies -> MinCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> [Remote] -> Annex () +notEnoughCopies key neednum needmin have skip bad nolocmsg lockunsupported = do showNote "unsafe" - if length have < fromNumCopies need + if length have < fromNumCopies neednum then showLongNote $ "Could only verify the existence of " ++ - show (length have) ++ " out of " ++ show (fromNumCopies need) ++ + show (length have) ++ " out of " ++ show (fromNumCopies neednum) ++ " necessary copies" else do - showLongNote $ "Unable to lock down 1 copy of file that is required to safely drop it." + showLongNote $ "Unable to lock down " ++ show (fromMinCopies needmin) ++ " copy of file that is required 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: " diff --git a/Annex/Queue.hs b/Annex/Queue.hs --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -1,6 +1,6 @@ {- git-annex command queue - - - Copyright 2011, 2012, 2019 Joey Hess + - Copyright 2011-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -25,11 +25,11 @@ import qualified Git.UpdateIndex {- Adds a git command to the queue. -} -addCommand :: String -> [CommandParam] -> [FilePath] -> Annex () -addCommand command params files = do +addCommand :: [CommandParam] -> String -> [CommandParam] -> [FilePath] -> Annex () +addCommand commonparams command params files = do q <- get store =<< flushWhenFull =<< - (Git.Queue.addCommand command params files q =<< gitRepo) + (Git.Queue.addCommand commonparams command params files q =<< gitRepo) addInternalAction :: Git.Queue.InternalActionRunner Annex -> [(RawFilePath, IO Bool)] -> Annex () addInternalAction runner files = do diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -253,7 +253,8 @@ | [c1,c2,c3] == pseudoBackslash = escapepseudo ("%":pseudoBackslash:s) cs | [c1,c2,c3] == pseudoColon = escapepseudo ("%":pseudoColon:s) cs | otherwise = escapepseudo ([c1]:s) (c2:c3:cs) - escapepseudo s cs = concat (reverse (cs:s)) + escapepseudo s (c:cs) = escapepseudo ([c]:s) cs + escapepseudo s [] = concat (reverse s) fromViewPath :: FilePath -> MetaValue fromViewPath = toMetaValue . encodeBS . deescapepseudo [] diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -64,6 +64,7 @@ , (trustLog, void $ liftAnnex trustMapLoad) , (groupLog, void $ liftAnnex groupMapLoad) , (numcopiesLog, void $ liftAnnex globalNumCopiesLoad) + , (mincopiesLog, void $ liftAnnex globalMinCopiesLoad) , (scheduleLog, void updateScheduleLog) -- Preferred and required content settings depend on most of the -- other configs, so will be reloaded whenever any configs change. diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -198,7 +198,7 @@ add largefilematcher file = ifM (liftAnnex $ checkFileMatcher largefilematcher (toRawFilePath file)) ( pendingAddChange file , do - liftAnnex $ Annex.Queue.addCommand "add" + liftAnnex $ Annex.Queue.addCommand [] "add" [Param "--force", Param "--"] [file] madeChange file AddFileChange ) diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,48 @@ +git-annex (8.20210127) upstream; urgency=medium + + * Added mincopies configuration. This is like numcopies, but is + enforced even more strictly. While numcopies can be violated in + concurrent drop situations involving special remotes that do not + support locking, mincopies cannot be. The default value has always + been 1, but now it can be set to higher values if desired. + * Behavior change: When numcopies is set to 0, git-annex used to drop + content without requiring any copies. Now to get that (highly unsafe) + behavior, mincopies also needs to be set to 0. + * Behavior change: git-annex trust now needs --force, since unconsidered + use of trusted repositories can lead to data loss. + * Behavior change: --trust and --trust-glacier options no longer overrides + trust, since that can lead to data loss, which should never be enabled + by an option other than --force. + * add: Significantly speed up adding lots of non-large files to git, + by disabling the annex smudge filter when running git add. + * add --force-small: Run git add rather than updating the index itself, + so any other smudge filters than the annex one that may be enabled will + be used. + * Fix --time-limit, which got broken in several ways by some optimisations + in version 8.20201007. + * When syncing changes back from an adjusted branch to the basis branch, + include deletions of submodules. + Thanks, Kyle Meyer for the patch. + * Bug fix: export with -J could fail when two files had the same content. + * Bug fix: Fix tilde expansion in ssh urls when the tilde is the last + character in the url. + Thanks, Grond for the patch. + * Avoid crashing when there are remotes using unparseable urls. + Including the non-standard URI form that git-remote-gcrypt uses for rsync. + * Directory special remotes with importtree=yes now avoid unncessary + hashing when inodes of files have changed, as happens whenever a FAT + filesystem gets remounted. + * Fix a bug that prevented git-annex init from working in a submodule. + * Fix a bug in view filename generation when a metadata value ended with + "/" (or ":" or "\" on Windows) + * adjust: Fix some bad behavior when unlocked files use URL keys. + * smudge: Fix some bad behavior when git add is run on an unlocked + file that used an URL key. + * Added GETGITREMOTENAME to external special remote protocol. + * Windows: Work around win32 length limits when dealing with lock files. + + -- Joey Hess Wed, 27 Jan 2021 11:09:25 -0400 + git-annex (8.20201129) upstream; urgency=medium * New borg special remote. This is a new kind of remote, that examines diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -2,7 +2,7 @@ Source: native package Files: * -Copyright: © 2010-2020 Joey Hess +Copyright: © 2010-2021 Joey Hess License: AGPL-3+ Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/* diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -81,6 +81,7 @@ import qualified Command.Uninit import qualified Command.Reinit import qualified Command.NumCopies +import qualified Command.MinCopies import qualified Command.Trust import qualified Command.Untrust import qualified Command.Semitrust @@ -157,6 +158,7 @@ , Command.PreCommit.cmd , Command.PostReceive.cmd , Command.NumCopies.cmd + , Command.MinCopies.cmd , Command.Trust.cmd , Command.Untrust.cmd , Command.Semitrust.cmd diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -1,6 +1,6 @@ {- git-annex command-line option parsing - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -11,6 +11,7 @@ import Control.Monad.Fail as Fail (MonadFail(..)) import Options.Applicative +import Data.Time.Clock.POSIX import qualified Data.Map as M import Annex.Common @@ -44,12 +45,17 @@ gitAnnexGlobalOptions = commonGlobalOptions ++ [ globalSetter setnumcopies $ option auto ( long "numcopies" <> short 'N' <> metavar paramNumber - <> help "override default number of copies" + <> help "override desired number of copies" <> hidden ) + , globalSetter setmincopies $ option auto + ( long "mincopies" <> short 'N' <> metavar paramNumber + <> help "override minimum number of copies" + <> hidden + ) , globalSetter (Remote.forceTrust Trusted) $ strOption ( long "trust" <> metavar paramRemote - <> help "override trust setting" + <> help "deprecated, does not override trust setting" <> hidden <> completeRemotes ) @@ -75,9 +81,9 @@ <> help "override default User-Agent" <> hidden ) - , globalFlag (Annex.setFlag "trustglacier") + , globalFlag (toplevelWarning False "--trust-glacier no longer has any effect") ( long "trust-glacier" - <> help "Trust Amazon Glacier inventory" + <> help "deprecated, does not trust Amazon Glacier inventory" <> hidden ) , globalFlag (setdesktopnotify mkNotifyFinish) @@ -93,6 +99,7 @@ ] where setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n } + setmincopies n = Annex.changeState $ \s -> s { Annex.forcemincopies = Just $ MinCopies n } setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v } setgitconfig v = Annex.addGitConfigOverride v setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } @@ -403,12 +410,17 @@ timeLimitOption :: [GlobalOption] timeLimitOption = - [ globalSetter Limit.addTimeLimit $ option (eitherReader parseDuration) + [ globalSetter settimelimit $ option (eitherReader parseDuration) ( long "time-limit" <> short 'T' <> metavar paramTime <> help "stop after the specified amount of time" <> hidden ) ] + where + settimelimit duration = do + start <- liftIO getPOSIXTime + let cutoff = start + durationToPOSIXTime duration + Annex.changeState $ \s -> s { Annex.timelimit = Just (duration, cutoff) } data DaemonOptions = DaemonOptions { foregroundDaemonOption :: Bool diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -4,7 +4,7 @@ - the values a user passes to a command, and prepare actions operating - on them. - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -40,15 +40,18 @@ import Annex.InodeSentinal import Annex.Concurrent 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 +import Utility.HumanTime import Control.Concurrent.Async import System.Posix.Types import Data.IORef +import Data.Time.Clock.POSIX import qualified System.FilePath.ByteString as P data AnnexedFileSeeker = AnnexedFileSeeker @@ -96,12 +99,17 @@ withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents a params = do matcher <- Limit.getMatcher - forM_ params $ \p -> do - fs <- liftIO $ get p - forM fs $ \f -> - whenM (checkmatch matcher f) $ - a f + checktimelimit <- mkCheckTimeLimit + go matcher checktimelimit params [] where + go _ _ [] [] = return () + go matcher checktimelimit (p:ps) [] = + go matcher checktimelimit ps =<< liftIO (get p) + go matcher checktimelimit ps (f:fs) = checktimelimit noop $ do + whenM (checkmatch matcher f) $ + a f + go matcher checktimelimit ps fs + get p = ifM (isDirectory <$> getFileStatus p) ( map (\f -> let f' = toRawFilePath f @@ -237,6 +245,7 @@ -- those. This significantly speeds up typical operations -- that need to look at the location log for each key. runallkeys = do + checktimelimit <- mkCheckTimeLimit keyaction <- mkkeyaction config <- Annex.getGitConfig g <- Annex.gitRepo @@ -246,9 +255,12 @@ LsTree.LsTreeRecursive Annex.Branch.fullname let getk f = fmap (,f) (locationLogFileKey config f) + let discard reader = reader >>= \case + Nothing -> noop + Just _ -> discard reader let go reader = liftIO reader >>= \case Nothing -> return () - Just ((k, f), content) -> do + Just ((k, f), content) -> checktimelimit (discard reader) $ do maybe noop (Annex.BranchState.setCache f) content keyaction (SeekInput [], k, mkActionItem k) go reader @@ -282,14 +294,17 @@ seekFiltered :: ((SeekInput, RawFilePath) -> Annex Bool) -> ((SeekInput, RawFilePath) -> CommandSeek) -> Annex ([(SeekInput, RawFilePath)], IO Bool) -> Annex () seekFiltered prefilter a listfs = do matcher <- Limit.getMatcher + checktimelimit <- mkCheckTimeLimit (fs, cleanup) <- listfs - sequence_ (map (process matcher) fs) + go matcher checktimelimit fs liftIO $ void cleanup where - process matcher v@(_si, f) = + go _ _ [] = return () + go matcher checktimelimit (v@(_si, f):rest) = checktimelimit noop $ do whenM (prefilter v) $ whenM (matcher $ MatchingFile $ FileInfo (Just f) f Nothing) $ a v + go matcher checktimelimit rest data MatcherInfo = MatcherInfo { matcherAction :: MatchInfo -> Annex Bool @@ -317,6 +332,7 @@ <*> Limit.introspect matchNeedsLocationLog config <- Annex.getGitConfig (l, cleanup) <- listfs + checktimelimit <- mkCheckTimeLimit catObjectMetaDataStream g $ \mdfeeder mdcloser mdreader -> catObjectStream g $ \ofeeder ocloser oreader -> do processertid <- liftIO . async =<< forkState @@ -327,29 +343,37 @@ then catObjectStream g $ \lfeeder lcloser lreader -> do precachertid <- liftIO . async =<< forkState (precacher mi config oreader lfeeder lcloser) - precachefinisher mi lreader + precachefinisher mi lreader checktimelimit join (liftIO (wait precachertid)) - else finisher mi oreader + else finisher mi oreader checktimelimit join (liftIO (wait mdprocessertid)) join (liftIO (wait processertid)) liftIO $ void cleanup where - finisher mi oreader = liftIO oreader >>= \case - Just ((si, f), content) -> do + finisher mi oreader checktimelimit = liftIO oreader >>= \case + Just ((si, f), content) -> checktimelimit discard $ do keyaction f mi content $ commandAction . startAction seeker si f - finisher mi oreader + finisher mi oreader checktimelimit Nothing -> return () + where + discard = oreader >>= \case + Nothing -> return () + Just _ -> discard - precachefinisher mi lreader = liftIO lreader >>= \case - Just ((logf, (si, f), k), logcontent) -> do + precachefinisher mi lreader checktimelimit = liftIO lreader >>= \case + Just ((logf, (si, f), k), logcontent) -> checktimelimit discard $ do maybe noop (Annex.BranchState.setCache logf) logcontent checkMatcherWhen mi (matcherNeedsLocationLog mi && not (matcherNeedsFileName mi)) (MatchingFile $ FileInfo (Just f) f (Just k)) (commandAction $ startAction seeker si f k) - precachefinisher mi lreader + precachefinisher mi lreader checktimelimit Nothing -> return () + where + discard = lreader >>= \case + Nothing -> return () + Just _ -> discard precacher mi config oreader lfeeder lcloser = liftIO oreader >>= \case Just ((si, f), content) -> do @@ -543,3 +567,19 @@ notSymlink :: RawFilePath -> IO Bool 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 ()) +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 + liftIO cleanup + liftIO $ exitWith $ ExitFailure 101 + else a diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -17,13 +17,10 @@ import Annex.FileMatcher import Annex.Link import Annex.Tmp -import Annex.HashObject import Messages.Progress -import Git.Types import Git.FilePath import Config.GitConfig -import qualified Git.UpdateIndex -import Utility.FileMode +import Config.Smudge import Utility.OptParse import qualified Utility.RawFilePath as R @@ -119,36 +116,26 @@ addSmall :: CheckGitIgnore -> RawFilePath -> Annex Bool addSmall ci file = do showNote "non-large file; adding content to git repository" - addFile ci file + addFile Small ci file startSmallOverridden :: AddOptions -> SeekInput -> RawFilePath -> CommandStart startSmallOverridden o si file = - starting "add" (ActionItemWorkTreeFile file) si $ - next $ addSmallOverridden o file + starting "add" (ActionItemWorkTreeFile file) si $ next $ do + showNote "adding content to git repository" + addFile Small (checkGitIgnoreOption o) file -addSmallOverridden :: AddOptions -> RawFilePath -> Annex Bool -addSmallOverridden o file = do - showNote "adding content to git repository" - s <- liftIO $ R.getSymbolicLinkStatus file - if not (isRegularFile s) - then addFile (checkGitIgnoreOption o) file - else do - -- Can't use addFile because the clean filter will - -- honor annex.largefiles and it has been overridden. - -- Instead, hash the file and add to the index. - sha <- hashFile file - let ty = if isExecutable (fileMode s) - then TreeExecutable - else TreeFile - Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.stageFile sha ty (fromRawFilePath file)) - return True +data SmallOrLarge = Small | Large -addFile :: CheckGitIgnore -> RawFilePath -> Annex Bool -addFile ci file = do +addFile :: SmallOrLarge -> CheckGitIgnore -> RawFilePath -> Annex Bool +addFile smallorlarge ci file = do ps <- gitAddParams ci - Annex.Queue.addCommand "add" (ps++[Param "--"]) [fromRawFilePath file] + Annex.Queue.addCommand cps "add" (ps++[Param "--"]) + [fromRawFilePath file] return True + where + cps = case smallorlarge of + Large -> [] + Small -> bypassSmudgeConfig start :: AddOptions -> SeekInput -> RawFilePath -> AddUnlockedMatcher -> CommandStart start o si file addunlockedmatcher = do @@ -163,7 +150,7 @@ | otherwise -> starting "add" (ActionItemWorkTreeFile file) si $ if isSymbolicLink s - then next $ addFile (checkGitIgnoreOption o) file + then next $ addFile Small (checkGitIgnoreOption o) file else perform o file addunlockedmatcher addpresent key = liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case @@ -179,7 +166,7 @@ starting "add" (ActionItemWorkTreeFile file) si $ addingExistingLink file key $ do Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) - next $ addFile (checkGitIgnoreOption o) file + next $ addFile Large (checkGitIgnoreOption o) file perform :: AddOptions -> RawFilePath -> AddUnlockedMatcher -> CommandPerform perform o file addunlockedmatcher = withOtherTmp $ \tmpdir -> do diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -84,11 +84,11 @@ start' :: DropOptions -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart start' o from key afile ai si = - checkDropAuto (autoMode o) from afile key $ \numcopies -> + checkDropAuto (autoMode o) from afile key $ \numcopies mincopies -> stopUnless want $ case from of - Nothing -> startLocal afile ai si numcopies key [] - Just remote -> startRemote afile ai si numcopies key remote + Nothing -> startLocal afile ai si numcopies mincopies key [] + Just remote -> startRemote afile ai si numcopies mincopies key remote where want | autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile @@ -97,21 +97,21 @@ startKeys :: DropOptions -> Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart startKeys o from (si, key, ai) = start' o from key (AssociatedFile Nothing) ai si -startLocal :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart -startLocal afile ai si numcopies key preverified = +startLocal :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> [VerifiedCopy] -> CommandStart +startLocal afile ai si numcopies mincopies key preverified = starting "drop" (OnlyActionOn key ai) si $ - performLocal key afile numcopies preverified + performLocal key afile numcopies mincopies preverified -startRemote :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> Key -> Remote -> CommandStart -startRemote afile ai si numcopies key remote = +startRemote :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> Remote -> CommandStart +startRemote afile ai si numcopies mincopies key remote = starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) si $ - performRemote key afile numcopies remote + performRemote key afile numcopies mincopies remote -performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform -performLocal key afile numcopies preverified = lockContentForRemoval key fallback $ \contentlock -> do +performLocal :: Key -> AssociatedFile -> NumCopies -> MinCopies -> [VerifiedCopy] -> CommandPerform +performLocal key afile numcopies mincopies preverified = lockContentForRemoval key fallback $ \contentlock -> do u <- getUUID (tocheck, verified) <- verifiableCopies key [u] - doDrop u (Just contentlock) key afile numcopies [] (preverified ++ verified) tocheck + doDrop u (Just contentlock) key afile numcopies mincopies [] (preverified ++ verified) tocheck ( \proof -> do liftIO $ debugM "drop" $ unwords [ "Dropping from here" @@ -133,12 +133,12 @@ -- to be done except for cleaning up. fallback = next $ cleanupLocal key -performRemote :: Key -> AssociatedFile -> NumCopies -> Remote -> CommandPerform -performRemote key afile numcopies remote = do +performRemote :: Key -> AssociatedFile -> NumCopies -> MinCopies -> Remote -> CommandPerform +performRemote key afile numcopies mincopies remote = do -- Filter the uuid it's being dropped from out of the lists of -- places assumed to have the key, and places to check. (tocheck, verified) <- verifiableCopies key [uuid] - doDrop uuid Nothing key afile numcopies [uuid] verified tocheck + doDrop uuid Nothing key afile numcopies mincopies [uuid] verified tocheck ( \proof -> do liftIO $ debugM "drop" $ unwords [ "Dropping from remote" @@ -178,17 +178,18 @@ -> Key -> AssociatedFile -> NumCopies + -> MinCopies -> [UUID] -> [VerifiedCopy] -> [UnVerifiedCopy] -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) -> CommandPerform -doDrop dropfrom contentlock key afile numcopies skip preverified check (dropaction, nodropaction) = +doDrop dropfrom contentlock key afile numcopies mincopies skip preverified check (dropaction, nodropaction) = ifM (Annex.getState Annex.force) ( dropaction Nothing , ifM (checkRequiredContent dropfrom key afile) ( verifyEnoughCopiesToDrop nolocmsg key - contentlock numcopies + contentlock numcopies mincopies skip preverified check (dropaction . Just) (forcehint nodropaction) @@ -216,17 +217,17 @@ {- In auto mode, only runs the action if there are enough - copies on other semitrusted repositories. -} -checkDropAuto :: Bool -> Maybe Remote -> AssociatedFile -> Key -> (NumCopies -> CommandStart) -> CommandStart +checkDropAuto :: Bool -> Maybe Remote -> AssociatedFile -> Key -> (NumCopies -> MinCopies -> CommandStart) -> CommandStart checkDropAuto automode mremote afile key a = - go =<< getAssociatedFileNumCopies afile + go =<< getAssociatedFileNumMinCopies afile where - go numcopies + go (numcopies, mincopies) | automode = do locs <- Remote.keyLocations key uuid <- getUUID let remoteuuid = fromMaybe uuid $ Remote.uuid <$> mremote locs' <- trustExclude UnTrusted $ filter (/= remoteuuid) locs if NumCopies (length locs') >= numcopies - then a numcopies + then a numcopies mincopies else stop - | otherwise = a numcopies + | otherwise = a numcopies mincopies diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -35,20 +35,21 @@ seek :: DropUnusedOptions -> CommandSeek seek o = do numcopies <- getNumCopies + mincopies <- getMinCopies from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o) - withUnusedMaps (start from numcopies) (rangesToDrop o) + withUnusedMaps (start from numcopies mincopies) (rangesToDrop o) -start :: Maybe Remote -> NumCopies -> UnusedMaps -> Int -> CommandStart -start from numcopies = startUnused "dropunused" - (perform from numcopies) +start :: Maybe Remote -> NumCopies -> MinCopies -> UnusedMaps -> Int -> CommandStart +start from numcopies mincopies = startUnused "dropunused" + (perform from numcopies mincopies) (performOther gitAnnexBadLocation) (performOther gitAnnexTmpObjectLocation) -perform :: Maybe Remote -> NumCopies -> Key -> CommandPerform -perform from numcopies key = case from of +perform :: Maybe Remote -> NumCopies -> MinCopies -> Key -> CommandPerform +perform from numcopies mincopies key = case from of Just r -> do showAction $ "from " ++ Remote.name r - Command.Drop.performRemote key (AssociatedFile Nothing) numcopies r + Command.Drop.performRemote key (AssociatedFile Nothing) numcopies mincopies r Nothing -> ifM (inAnnex key) ( droplocal , ifM (objectFileExists key) @@ -62,7 +63,7 @@ ) ) where - droplocal = Command.Drop.performLocal key (AssociatedFile Nothing) numcopies [] + droplocal = Command.Drop.performLocal key (AssociatedFile Nothing) numcopies mincopies [] performOther :: (Key -> Git.Repo -> RawFilePath) -> Key -> CommandPerform performOther filespec key = do diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -283,7 +283,11 @@ sent <- tryNonAsync $ case ek of AnnexKey k -> ifM (inAnnex k) ( notifyTransfer Upload af $ - upload' (uuid r) k af stdRetry $ \pm -> do + -- alwaysUpload because the same key + -- could be used for more than one export + -- location, and concurrently uploading + -- of the content should still be allowed. + alwaysUpload (uuid r) k af stdRetry $ \pm -> do let rollback = void $ performUnexport r db [ek] loc sendAnnex k rollback $ \f -> diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -107,5 +107,5 @@ cleanupSymlink :: FilePath -> CommandCleanup cleanupSymlink file = do - Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file] + Annex.Queue.addCommand [] "add" [Param "--force", Param "--"] [file] return True diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -97,7 +97,8 @@ link <- calcRepo $ gitAnnexLink file key createWorkTreeDirectory (parentDir file) liftIO $ R.createSymbolicLink link file - Annex.Queue.addCommand "add" [Param "--"] [fromRawFilePath file] + Annex.Queue.addCommand [] "add" [Param "--"] + [fromRawFilePath file] next $ return True ) Just k diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -117,7 +117,7 @@ start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case Nothing -> stop Just backend -> do - numcopies <- getFileNumCopies file + (numcopies, _mincopies) <- getFileNumMinCopies file case from of Nothing -> go $ perform key file backend numcopies Just r -> go $ performRemote key afile backend numcopies r diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -279,10 +279,10 @@ verifyExisting key destfile (yes, no) = do -- Look up the numcopies setting for the file that it would be -- imported to, if it were imported. - need <- getFileNumCopies destfile + (needcopies, mincopies) <- getFileNumMinCopies destfile (tocheck, preverified) <- verifiableCopies key [] - verifyEnoughCopiesToDrop [] key Nothing need [] preverified tocheck + verifyEnoughCopiesToDrop [] key Nothing needcopies mincopies [] preverified tocheck (const yes) no seekRemote :: Remote -> Branch -> Maybe TopFilePath -> Bool -> CheckGitIgnore -> CommandSeek diff --git a/Command/MinCopies.hs b/Command/MinCopies.hs new file mode 100644 --- /dev/null +++ b/Command/MinCopies.hs @@ -0,0 +1,39 @@ +{- git-annex command + - + - Copyright 2014-2021 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Command.MinCopies where + +import Command +import Annex.NumCopies +import qualified Command.NumCopies + +cmd :: Command +cmd = noMessages $ command "mincopies" SectionSetup + "configure minimum number of copies" + paramNumber (withParams seek) + +seek :: CmdParams -> CommandSeek +seek = withWords (commandAction . Command.NumCopies.start' "mincopies" startGet startSet) + +start :: [String] -> CommandStart +start = Command.NumCopies.start' "mincopies" startGet startSet + +startGet :: CommandStart +startGet = startingCustomOutput (ActionItemOther Nothing) $ next $ do + v <- getGlobalMinCopies + case v of + Just n -> liftIO $ putStrLn $ show $ fromMinCopies n + Nothing -> liftIO $ putStrLn "global mincopies is not set" + return True + +startSet :: Int -> CommandStart +startSet n = startingUsualMessages "mincopies" ai si $ do + setGlobalMinCopies $ MinCopies n + next $ return True + where + ai = ActionItemOther (Just $ show n) + si = SeekInput [show n] diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -68,8 +68,8 @@ ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key) ( Command.Move.toStart Command.Move.RemoveNever afile key ai si =<< getParsed r , do - numcopies <- getnumcopies - Command.Drop.startRemote afile ai si numcopies key =<< getParsed r + (numcopies, mincopies) <- getnummincopies + Command.Drop.startRemote afile ai si numcopies mincopies key =<< getParsed r ) FromRemote r -> checkFailedTransferDirection ai Download $ do haskey <- flip Remote.hasKey key =<< getParsed r @@ -81,11 +81,11 @@ ) Right False -> ifM (inAnnex key) ( do - numcopies <- getnumcopies - Command.Drop.startLocal afile ai si numcopies key [] + (numcopies, mincopies) <- getnummincopies + Command.Drop.startLocal afile ai si numcopies mincopies key [] , stop ) where - getnumcopies = case afile of - AssociatedFile Nothing -> getNumCopies - AssociatedFile (Just af) -> getFileNumCopies af + getnummincopies = case afile of + AssociatedFile Nothing -> (,) <$> getNumCopies <*> getMinCopies + AssociatedFile (Just af) -> getFileNumMinCopies af diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -165,10 +165,10 @@ willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case DropAllowed -> drophere setpresentremote contentlock "moved" DropCheckNumCopies -> do - numcopies <- getAssociatedFileNumCopies afile + (numcopies, mincopies) <- getAssociatedFileNumMinCopies afile (tocheck, verified) <- verifiableCopies key [srcuuid] verifyEnoughCopiesToDrop "" key (Just contentlock) - numcopies [srcuuid] verified + numcopies mincopies [srcuuid] verified (UnVerifiedRemote dest : tocheck) (drophere setpresentremote contentlock . showproof) (faileddrophere setpresentremote) @@ -244,9 +244,9 @@ willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case DropAllowed -> dropremote "moved" DropCheckNumCopies -> do - numcopies <- getAssociatedFileNumCopies afile + (numcopies, mincopies) <- getAssociatedFileNumMinCopies afile (tocheck, verified) <- verifiableCopies key [Remote.uuid src] - verifyEnoughCopiesToDrop "" key Nothing numcopies [Remote.uuid src] verified + verifyEnoughCopiesToDrop "" key Nothing numcopies mincopies [Remote.uuid src] verified tocheck (dropremote . showproof) faileddropremote DropWorse -> faileddropremote diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs --- a/Command/NumCopies.hs +++ b/Command/NumCopies.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2014 Joey Hess + - Copyright 2014-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,17 +20,20 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart -start [] = startGet -start [s] = case readish s of +start = start' "numcopies" startGet startSet + +start' :: String -> CommandStart -> (Int -> CommandStart) -> [String] -> CommandStart +start' _ startget _ [] = startget +start' setting _ startset [s] = case readish s of Nothing -> giveup $ "Bad number: " ++ s Just n - | n > 0 -> startSet n + | n > 0 -> startset n | n == 0 -> ifM (Annex.getState Annex.force) - ( startSet n - , giveup "Setting numcopies to 0 is very unsafe. You will lose data! If you really want to do that, specify --force." + ( startset n + , giveup $ "Setting " ++ setting ++ " to 0 is very unsafe. You will lose data! If you really want to do that, specify --force." ) | otherwise -> giveup "Number cannot be negative!" -start _ = giveup "Specify a single number." +start' _ _ _ _ = giveup "Specify a single number." startGet :: CommandStart startGet = startingCustomOutput (ActionItemOther Nothing) $ next $ do diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2015-2019 Joey Hess + - Copyright 2015-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -28,6 +28,7 @@ import Annex.InodeSentinal import Utility.InodeCache import Config.GitConfig +import qualified Types.Backend import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -120,28 +121,31 @@ -- Optimization for the case when the file is already -- annexed and is unmodified. case oldkey of - Nothing -> doingest oldkey + Nothing -> doingest Nothing Just ko -> ifM (isUnmodifiedCheap ko file) ( liftIO $ emitPointer ko - , doingest oldkey + , updateingest ko ) , liftIO $ L.hPut stdout b ) - doingest oldkey = do - -- Look up the backend that was used for this file - -- before, so that when git re-cleans a file its - -- backend does not change. - oldbackend <- maybe - (pure Nothing) - (maybeLookupBackendVariety . fromKey keyVariety) - oldkey + -- Use the same backend that was used before, when possible. + -- If the old key's backend does not support generating keys, + -- use the default backend. + updateingest oldkey = + maybeLookupBackendVariety (fromKey keyVariety oldkey) >>= \case + Nothing -> doingest Nothing + Just oldbackend -> case Types.Backend.genKey oldbackend of + Just _ -> doingest (Just oldbackend) + Nothing -> doingest Nothing + + doingest preferredbackend = do -- Can't restage associated files because git add -- runs this and has the index locked. let norestage = Restage False liftIO . emitPointer =<< postingest - =<< (\ld -> ingest' oldbackend nullMeterUpdate ld Nothing norestage) + =<< (\ld -> ingest' preferredbackend nullMeterUpdate ld Nothing norestage) =<< lockDown cfg (fromRawFilePath file) postingest (Just k, _) = do @@ -255,8 +259,14 @@ f <- fromRepo (fromTopFilePath topf) whenM (inAnnex k) $ do obj <- calcRepo (gitAnnexLocation k) - unlessM (isJust <$> populatePointerFile restage k obj f) $ - liftIO (isPointerFile f) >>= \case + objic <- withTSDelta (liftIO . genInodeCache obj) + populatePointerFile restage k obj f >>= \case + Just ic -> do + cs <- Database.Keys.getInodeCaches k + if null cs + then Database.Keys.addInodeCaches k (catMaybes [Just ic, objic]) + else Database.Keys.addInodeCaches k [ic] + Nothing -> liftIO (isPointerFile f) >>= \case Just k' | k' == k -> toplevelWarning False $ "unable to populate worktree file " ++ fromRawFilePath f _ -> noop diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes, DeriveFunctor #-} module Command.TestRemote where @@ -194,7 +194,7 @@ data Described t = Described { getDesc :: String , getVal :: t - } + } deriving Functor type RunAnnex = forall a. Annex a -> IO a diff --git a/Command/Trust.hs b/Command/Trust.hs --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010, 2014 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,6 +9,7 @@ import Command import qualified Remote +import qualified Annex import Types.TrustLevel import Logs.Trust import Logs.Group @@ -29,8 +30,11 @@ let name = unwords ws u <- Remote.nameToUUID name let si = SeekInput ws - starting c (ActionItemOther (Just name)) si (perform u) - perform uuid = do + starting c (ActionItemOther (Just name)) si (perform name u) + perform name uuid = do + when (level >= Trusted) $ + unlessM (Annex.getState Annex.force) $ + giveup $ trustedNeedsForce name trustSet uuid level when (level == DeadTrusted) $ groupSet uuid S.empty @@ -38,3 +42,12 @@ when (l /= level) $ warning $ "This remote's trust level is overridden to " ++ showTrustLevel l ++ "." next $ return True + +trustedNeedsForce :: String -> String +trustedNeedsForce name = unwords + [ "Trusting a repository can lead to data loss." + , "If you're sure you know what you're doing, use --force to" + , "make this take effect." + , "If you choose to do so, bear in mind that any time you drop" + , "content from " ++ name ++ ", you will risk losing data." + ] diff --git a/Config/Smudge.hs b/Config/Smudge.hs --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -60,3 +60,11 @@ filter (\l -> l `notElem` stdattr && not (null l)) ls unsetConfig (ConfigKey "filter.annex.smudge") unsetConfig (ConfigKey "filter.annex.clean") + +-- Params to pass to git to temporarily avoid using the smudge/clean +-- filters. +bypassSmudgeConfig :: [CommandParam] +bypassSmudgeConfig = map Param + [ "-c", "filter.annex.smudge=" + , "-c", "filter.annex.clean=" + ] diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -43,6 +43,7 @@ import Git.Command import Git.Types import Git.Index +import Config.Smudge import qualified Utility.RawFilePath as R import qualified Data.ByteString as S @@ -237,15 +238,14 @@ liftIO $ writeFile indexcache $ showInodeCache cur diff = - -- Avoid using external diff command, which would be slow. - -- (The -G option may make it be used otherwise.) - [ Param "-c", Param "diff.external=" -- Avoid running smudge or clean filters, since we want the -- raw output, and they would block trying to access the -- locked database. The --raw normally avoids git diff -- running them, but older versions of git need this. - , Param "-c", Param "filter.annex.smudge=" - , Param "-c", Param "filter.annex.clean=" + bypassSmudgeConfig ++ + -- Avoid using external diff command, which would be slow. + -- (The -G option may make it be used otherwise.) + [ Param "-c", Param "diff.external=" , Param "diff" , Param "--cached" , Param "--raw" diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -3,7 +3,7 @@ - This is written to be completely independant of git-annex and should be - suitable for other uses. - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -55,6 +55,7 @@ repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url +repoDescribe Repo { location = UnparseableUrl url } = url repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir @@ -63,13 +64,14 @@ {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String repoLocation Repo { location = Url url } = show url +repoLocation Repo { location = UnparseableUrl url } = url repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir repoLocation Repo { location = Unknown } = error "unknown repoLocation" {- Path to a repository. For non-bare, this is the worktree, for bare, - - it's the gitdir, and for URL repositories, is the path on the remote + - it's the gitdit, and for URL repositories, is the path on the remote - host. -} repoPath :: Repo -> RawFilePath repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u @@ -77,6 +79,7 @@ repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = error "unknown repoPath" +repoPath Repo { location = UnparseableUrl _u } = error "unknwon repoPath" repoWorkTree :: Repo -> Maybe RawFilePath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d @@ -91,6 +94,7 @@ - or bare and non-bare, these functions help with that. -} repoIsUrl :: Repo -> Bool repoIsUrl Repo { location = Url _ } = True +repoIsUrl Repo { location = UnparseableUrl _ } = True repoIsUrl _ = False repoIsSsh :: Repo -> Bool diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -1,6 +1,6 @@ {- git check-attr interface - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,8 +20,8 @@ type Attr = String -{- Starts git check-attr running to look up the specified gitattributes - - values and returns a handle. -} +{- Starts git check-attr running to look up the specified attributes + - and returns a handle. -} checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle checkAttrStart attrs repo = do currdir <- R.getCurrentDirectory @@ -38,17 +38,24 @@ checkAttrStop :: CheckAttrHandle -> IO () checkAttrStop (h, _, _) = CoProcess.stop h -{- Gets an attribute of a file. When the attribute is not specified, - - returns "" -} checkAttr :: CheckAttrHandle -> Attr -> RawFilePath -> IO String -checkAttr (h, attrs, currdir) want file = do - pairs <- CoProcess.query h send (receive "") - let vals = map snd $ filter (\(attr, _) -> attr == want) pairs - case vals of - ["unspecified"] -> return "" - [v] -> return v - _ -> error $ "unable to determine " ++ want ++ " attribute of " ++ fromRawFilePath file +checkAttr h want file = checkAttrs h [want] file >>= return . \case + (v:_) -> v + [] -> "" + +{- Gets attributes of a file. When an attribute is not specified, + - returns "" for it. -} +checkAttrs :: CheckAttrHandle -> [Attr] -> RawFilePath -> IO [String] +checkAttrs (h, attrs, currdir) want file = do + l <- CoProcess.query h send (receive "") + return (getvals l want) where + getvals _ [] = [] + getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of + ["unspecified"] -> "" : getvals l xs + [v] -> v : getvals l xs + _ -> error $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file + send to = B.hPutStr to $ file' `B.snoc` 0 receive c from = do s <- hGetSomeString from 1024 diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,6 +1,6 @@ {- Construction of Git Repo objects - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -87,24 +87,29 @@ else ret dir ) -{- Remote Repo constructor. Throws exception on invalid url. +{- Construct a Repo for a remote's url. - - Git is somewhat forgiving about urls to repositories, allowing - - eg spaces that are not normally allowed unescaped in urls. + - eg spaces that are not normally allowed unescaped in urls. Such + - characters get escaped. + - + - This will always succeed, even if the url cannot be parsed + - or is invalid, because git can also function despite remotes having + - such urls, only failing if such a remote is used. -} fromUrl :: String -> IO Repo fromUrl url - | not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url - | otherwise = fromUrlStrict url + | not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url + | otherwise = fromUrl' url -fromUrlStrict :: String -> IO Repo -fromUrlStrict url - | "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $ - unEscapeString $ uriPath u - | otherwise = pure $ newFrom $ Url u - where - u = fromMaybe bad $ parseURI url - bad = error $ "bad url " ++ url +fromUrl' :: String -> IO Repo +fromUrl' url + | "file://" `isPrefixOf` url = case parseURI url of + Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u + Nothing -> pure $ newFrom $ UnparseableUrl url + | otherwise = case parseURI url of + Just u -> pure $ newFrom $ Url u + Nothing -> pure $ newFrom $ UnparseableUrl url {- Creates a repo that has an unknown location. -} fromUnknown :: Repo @@ -116,16 +121,16 @@ localToUrl reference r | not $ repoIsUrl reference = error "internal error; reference repo not url" | repoIsUrl r = r - | otherwise = case Url.authority reference of - Nothing -> r - Just auth -> + | otherwise = case (Url.authority reference, Url.scheme reference) of + (Just auth, Just s) -> let absurl = concat - [ Url.scheme reference + [ s , "//" , auth , fromRawFilePath (repoPath r) ] in r { location = Url $ fromJust $ parseURI absurl } + _ -> r {- Calculates a list of a repo's configured remotes, by parsing its config. -} fromRemotes :: Repo -> IO [Repo] @@ -187,6 +192,7 @@ expandt True ('~':'/':cs) = do h <- myHomeDir return $ h cs + expandt True "~" = myHomeDir expandt True ('~':cs) = do let (name, rest) = findname "" cs u <- getUserEntryForName name diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -28,6 +28,7 @@ isEncrypted :: Repo -> Bool isEncrypted Repo { location = Url url } = urlPrefix `isPrefixOf` show url +isEncrypted Repo { location = UnparseableUrl url } = urlPrefix `isPrefixOf` url isEncrypted _ = False {- The first Repo is the git repository that has the second Repo @@ -36,21 +37,23 @@ - When the remote Repo uses gcrypt, returns the actual underlying - git repository that gcrypt is using to store its data. - - - Throws an exception if an url is invalid or the repo does not use - - gcrypt. + - Throws an exception if the repo does not use gcrypt. -} encryptedRemote :: Repo -> Repo -> IO Repo encryptedRemote baserepo = go where - go Repo { location = Url url } + go Repo { location = Url url } = go' (show url) + go Repo { location = UnparseableUrl url } = go' url + go _ = notencrypted + + go' u | urlPrefix `isPrefixOf` u = fromRemoteLocation (drop plen u) baserepo | otherwise = notencrypted - where - u = show url - plen = length urlPrefix - go _ = notencrypted + notencrypted = giveup "not a gcrypt encrypted repository" + + plen = length urlPrefix data ProbeResult = Decryptable | NotDecryptable | NotEncrypted diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -1,6 +1,6 @@ {- git repository command queue - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -37,8 +37,12 @@ {- A git command to run, on a list of files that can be added to - as the queue grows. -} | CommandAction - { getSubcommand :: String + { getCommonParams :: [CommandParam] + -- ^ parameters that come before the git subcommand + -- (in addition to the Repo's gitGlobalOpts. + , getSubcommand :: String , getParams :: [CommandParam] + -- ^ parameters that come after the git subcommand , getFiles :: [CommandParam] } {- An internal action to run, on a list of files that can be added @@ -55,12 +59,15 @@ InternalActionRunner s1 _ == InternalActionRunner s2 _ = s1 == s2 {- A key that can uniquely represent an action in a Map. -} -data ActionKey = UpdateIndexActionKey | CommandActionKey String | InternalActionKey String +data ActionKey + = UpdateIndexActionKey + | CommandActionKey [CommandParam] String [CommandParam] + | InternalActionKey String deriving (Eq, Ord) actionKey :: Action m -> ActionKey actionKey (UpdateIndexAction _) = UpdateIndexActionKey -actionKey CommandAction { getSubcommand = s } = CommandActionKey s +actionKey CommandAction { getCommonParams = c, getSubcommand = s, getParams = p } = CommandActionKey c s p actionKey InternalAction { getRunner = InternalActionRunner s _ } = InternalActionKey s {- A queue of actions to perform (in any order) on a git repository, @@ -92,14 +99,15 @@ - - Git commands with the same subcommand but different parameters are - assumed to be equivilant enough to perform in any order with the same - - result. + - end result. -} -addCommand :: MonadIO m => String -> [CommandParam] -> [FilePath] -> Queue m -> Repo -> m (Queue m) -addCommand subcommand params files q repo = +addCommand :: MonadIO m => [CommandParam] -> String -> [CommandParam] -> [FilePath] -> Queue m -> Repo -> m (Queue m) +addCommand commonparams subcommand params files q repo = updateQueue action different (length files) q repo where action = CommandAction - { getSubcommand = subcommand + { getCommonParams = commonparams + , getSubcommand = subcommand , getParams = params , getFiles = map File files } @@ -152,8 +160,8 @@ - the old value. So, the list append of the new value first is more - efficient. -} combineNewOld :: Action m -> Action m -> Action m -combineNewOld (CommandAction _sc1 _ps1 fs1) (CommandAction sc2 ps2 fs2) = - CommandAction sc2 ps2 (fs1++fs2) +combineNewOld (CommandAction _cps1 _sc1 _ps1 fs1) (CommandAction cps2 sc2 ps2 fs2) = + CommandAction cps2 sc2 ps2 (fs1++fs2) combineNewOld (UpdateIndexAction s1) (UpdateIndexAction s2) = UpdateIndexAction (s1++s2) combineNewOld (InternalAction _r1 fs1) (InternalAction r2 fs2) = @@ -206,7 +214,8 @@ #endif where gitparams = gitCommandLine - (Param (getSubcommand action):getParams action) repo + (getCommonParams action++Param (getSubcommand action):getParams action) + repo #ifndef mingw32_HOST_OS go p (Just h) _ _ pid = do hPutStr h $ intercalate "\0" $ toCommand $ getFiles action diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -464,14 +464,19 @@ putStrLn "Running git fsck ..." fsckresult <- findBroken False g if foundBroken fsckresult - then runRepair' removablebranch fsckresult forced Nothing g + then do + putStrLn "Fsck found problems, attempting repair." + runRepair' removablebranch fsckresult forced Nothing g else do + putStrLn "Fsck found no problems. Checking for broken branches." bad <- badBranches S.empty g if null bad then do putStrLn "No problems found." return (True, []) - else runRepair' removablebranch fsckresult forced Nothing g + else do + putStrLn "Found problems, attempting repair." + runRepair' removablebranch fsckresult forced Nothing g runRepairOf :: FsckResults -> (Ref -> Bool) -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) runRepairOf fsckresult removablebranch forced referencerepo g = do diff --git a/Git/Tree.hs b/Git/Tree.hs --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -259,7 +259,9 @@ removeset = S.fromList $ map (normalise . gitPath) removefiles removed (TreeBlob f _ _) = S.member (normalise (gitPath f)) removeset - removed _ = False + removed (TreeCommit f _ _) = S.member (normalise (gitPath f)) removeset + removed (RecordedSubTree _ _ _) = False + removed (NewSubTree _ _) = False addoldnew [] new = new addoldnew old [] = old diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -34,6 +34,7 @@ = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath } | LocalUnknown RawFilePath | Url URI + | UnparseableUrl String | Unknown deriving (Show, Eq, Ord) diff --git a/Git/Url.hs b/Git/Url.hs --- a/Git/Url.hs +++ b/Git/Url.hs @@ -1,6 +1,6 @@ {- git repository urls - - - Copyright 2010, 2011 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -18,12 +18,11 @@ import Common import Git.Types -import Git {- Scheme of an URL repo. -} -scheme :: Repo -> String -scheme Repo { location = Url u } = uriScheme u -scheme repo = notUrl repo +scheme :: Repo -> Maybe String +scheme Repo { location = Url u } = Just (uriScheme u) +scheme _ = Nothing {- Work around a bug in the real uriRegName - -} @@ -65,13 +64,9 @@ {- Applies a function to extract part of the uriAuthority of an URL repo. -} authpart :: (URIAuth -> a) -> Repo -> Maybe a authpart a Repo { location = Url u } = a <$> uriAuthority u -authpart _ repo = notUrl repo +authpart _ _ = Nothing {- Path part of an URL repo. -} -path :: Repo -> FilePath -path Repo { location = Url u } = uriPath u -path repo = notUrl repo - -notUrl :: Repo -> a -notUrl repo = error $ - "acting on local git repo " ++ repoDescribe repo ++ " not supported" +path :: Repo -> Maybe FilePath +path Repo { location = Url u } = Just (uriPath u) +path _ = Nothing diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -13,7 +13,6 @@ import qualified Remote import Annex.Content import Annex.WorkTree -import Annex.Action import Annex.UUID import Annex.Magic import Annex.Link @@ -495,25 +494,6 @@ check f matching k = not . S.null . S.filter matching . metaDataValues f <$> getCurrentMetaData k - -addTimeLimit :: Duration -> Annex () -addTimeLimit duration = do - start <- liftIO getPOSIXTime - let cutoff = start + durationToPOSIXTime duration - addLimit $ Right $ MatchFiles - { matchAction = const $ const $ do - now <- liftIO getPOSIXTime - if now > cutoff - then do - warning $ "Time limit (" ++ fromDuration duration ++ ") reached!" - shutdown True - liftIO $ exitWith $ ExitFailure 101 - else return True - , matchNeedsFileName = False - , matchNeedsFileContent = False - , matchNeedsKey = False - , matchNeedsLocationLog = False - } addAccessedWithin :: Duration -> Annex () addAccessedWithin duration = do diff --git a/Logs.hs b/Logs.hs --- a/Logs.hs +++ b/Logs.hs @@ -90,6 +90,7 @@ otherLogs :: [RawFilePath] otherLogs = [ numcopiesLog + , mincopiesLog , groupPreferredContentLog ] @@ -98,6 +99,9 @@ numcopiesLog :: RawFilePath numcopiesLog = "numcopies.log" + +mincopiesLog :: RawFilePath +mincopiesLog = "mincopies.log" configLog :: RawFilePath configLog = "config.log" diff --git a/Logs/NumCopies.hs b/Logs/NumCopies.hs --- a/Logs/NumCopies.hs +++ b/Logs/NumCopies.hs @@ -1,6 +1,6 @@ {- git-annex numcopies log - - - Copyright 2014 Joey Hess + - Copyright 2014-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,8 +9,11 @@ module Logs.NumCopies ( setGlobalNumCopies, + setGlobalMinCopies, getGlobalNumCopies, + getGlobalMinCopies, globalNumCopiesLoad, + globalMinCopiesLoad, ) where import Annex.Common @@ -23,19 +26,40 @@ serialize (NumCopies n) = encodeBS (show n) deserialize = NumCopies <$$> readish . decodeBS +instance SingleValueSerializable MinCopies where + serialize (MinCopies n) = encodeBS (show n) + deserialize = MinCopies <$$> readish . decodeBS + setGlobalNumCopies :: NumCopies -> Annex () setGlobalNumCopies new = do curr <- getGlobalNumCopies when (curr /= Just new) $ setLog numcopiesLog new +setGlobalMinCopies :: MinCopies -> Annex () +setGlobalMinCopies new = do + curr <- getGlobalMinCopies + when (curr /= Just new) $ + setLog mincopiesLog new + {- Value configured in the numcopies log. Cached for speed. -} getGlobalNumCopies :: Annex (Maybe NumCopies) getGlobalNumCopies = maybe globalNumCopiesLoad (return . Just) =<< Annex.getState Annex.globalnumcopies +{- Value configured in the mincopies log. Cached for speed. -} +getGlobalMinCopies :: Annex (Maybe MinCopies) +getGlobalMinCopies = maybe globalMinCopiesLoad (return . Just) + =<< Annex.getState Annex.globalmincopies + globalNumCopiesLoad :: Annex (Maybe NumCopies) globalNumCopiesLoad = do v <- getLog numcopiesLog Annex.changeState $ \s -> s { Annex.globalnumcopies = v } + return v + +globalMinCopiesLoad :: Annex (Maybe MinCopies) +globalMinCopiesLoad = do + v <- getLog mincopiesLog + Annex.changeState $ \s -> s { Annex.globalmincopies = v } return v diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -384,8 +384,10 @@ forceTrust :: TrustLevel -> String -> Annex () forceTrust level remotename = do u <- nameToUUID remotename - Annex.changeState $ \s -> - s { Annex.forcetrust = M.insert u level (Annex.forcetrust s) } + if level >= Trusted + then toplevelWarning False "Ignoring request to trust repository, because that can lead to data loss." + else Annex.changeState $ \s -> + s { Annex.forcetrust = M.insert u level (Annex.forcetrust s) } {- Used to log a change in a remote's having a key. The change is logged - in the local repo, not on the remote. The process of transferring the diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -1,6 +1,6 @@ {- A "remote" that is just a filesystem directory. - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -354,18 +354,21 @@ sz <- getFileSize' f st return $ Just (mkImportLocation relf, (cid, sz)) --- Make a ContentIdentifier that contains an InodeCache. +-- Make a ContentIdentifier that contains the size and mtime of the file. +-- If the file is not a regular file, this will return Nothing. -- --- The InodeCache is generated without checking a sentinal file. --- So in a case when a remount etc causes all the inodes to change, --- files may appear to be modified when they are not, which will only --- result in extra work to re-import them. +-- The inode is zeroed because often this is used for import from a +-- FAT filesystem, whose inodes change each time it's mounted, and +-- including inodes would cause repeated re-hashing of files, and +-- bloat the git-annex branch with changes to content identifier logs. -- --- If the file is not a regular file, this will return Nothing. +-- This does mean that swaps of two files with the same size and +-- mtime won't be noticed, nor will modifications to files that +-- preserve the size and mtime. Both very unlikely so acceptable. mkContentIdentifier :: RawFilePath -> FileStatus -> IO (Maybe ContentIdentifier) mkContentIdentifier f st = fmap (ContentIdentifier . encodeBS . showInodeCache) - <$> toInodeCache noTSDelta f st + <$> toInodeCache' noTSDelta f st 0 guardSameContentIdentifiers :: a -> ContentIdentifier -> Maybe ContentIdentifier -> a guardSameContentIdentifiers cont old new @@ -468,7 +471,7 @@ Nothing -> giveup "unable to generate content identifier" Just newcid -> do checkExportContent dir loc - (newcid:overwritablecids) + overwritablecids (giveup "unsafe to overwrite file") (const $ liftIO $ rename tmpf dest) return newcid diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -81,7 +81,8 @@ exportUnsupported | otherwise = do c <- parsedRemoteConfig remote rc - external <- newExternal externaltype (Just u) c (Just gc) (Just rs) + external <- newExternal externaltype (Just u) c (Just gc) + (Git.remoteName r) (Just rs) Annex.addCleanupAction (RemoteCleanup u) $ stopExternal external cst <- getCost external r gc avail <- getAvailability external r gc @@ -184,7 +185,7 @@ return c' else do pc' <- either giveup return $ parseRemoteConfig c' lenientRemoteConfigParser - external <- newExternal externaltype (Just u) pc' (Just gc) Nothing + external <- newExternal externaltype (Just u) pc' (Just gc) Nothing Nothing -- Now that we have an external, ask it to LISTCONFIGS, -- and re-parse the RemoteConfig strictly, so we can -- error out if the user provided an unexpected config. @@ -212,7 +213,7 @@ if externaltype == "readonly" then return False else checkExportSupported' - =<< newExternal externaltype Nothing c (Just gc) Nothing + =<< newExternal externaltype Nothing c (Just gc) Nothing Nothing checkExportSupported' :: External -> Annex Bool checkExportSupported' external = go `catchNonAsync` (const (return False)) @@ -458,6 +459,10 @@ Nothing -> senderror "cannot send GETUUID here" handleRemoteRequest GETGITDIR = send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir + handleRemoteRequest GETGITREMOTENAME = + case externalRemoteName external of + Just n -> send $ VALUE n + Nothing -> senderror "git remote name not known" handleRemoteRequest (SETWANTED expr) = case externalUUID external of Just u -> preferredContentSet u expr Nothing -> senderror "cannot send SETWANTED here" @@ -896,7 +901,7 @@ (Nothing, _) -> return lenientRemoteConfigParser (_, Just True) -> return lenientRemoteConfigParser (Just externaltype, _) -> do - external <- newExternal externaltype Nothing pc Nothing Nothing + external <- newExternal externaltype Nothing pc Nothing Nothing Nothing strictRemoteConfigParser external where isproposed (Accepted _) = False diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -52,6 +52,7 @@ import Types.Export import Types.Availability (Availability(..)) import Types.Key +import Git.Types import Utility.Url (URLString) import qualified Utility.SimpleProtocol as Proto @@ -69,18 +70,20 @@ , externalLastPid :: TVar PID , externalDefaultConfig :: ParsedRemoteConfig , externalGitConfig :: Maybe RemoteGitConfig + , externalRemoteName :: Maybe RemoteName , externalRemoteStateHandle :: Maybe RemoteStateHandle , externalAsync :: TMVar ExternalAsync } -newExternal :: ExternalType -> Maybe UUID -> ParsedRemoteConfig -> Maybe RemoteGitConfig -> Maybe RemoteStateHandle -> Annex External -newExternal externaltype u c gc rs = liftIO $ External +newExternal :: ExternalType -> Maybe UUID -> ParsedRemoteConfig -> Maybe RemoteGitConfig -> Maybe RemoteName -> Maybe RemoteStateHandle -> Annex External +newExternal externaltype u c gc rn rs = liftIO $ External <$> pure externaltype <*> pure u <*> atomically (newTVar []) <*> atomically (newTVar 0) <*> pure c <*> pure gc + <*> pure rn <*> pure rs <*> atomically (newTMVar UncheckedExternalAsync) @@ -102,7 +105,11 @@ deriving (Show, Monoid, Semigroup) supportedExtensionList :: ExtensionList -supportedExtensionList = ExtensionList ["INFO", asyncExtension] +supportedExtensionList = ExtensionList + [ "INFO" + , "GETGITREMOTENAME" + , asyncExtension + ] asyncExtension :: String asyncExtension = "ASYNC" @@ -304,6 +311,7 @@ | GETCREDS Setting | GETUUID | GETGITDIR + | GETGITREMOTENAME | SETWANTED PreferredContentExpression | GETWANTED | SETSTATE Key String @@ -328,6 +336,7 @@ parseCommand "GETCREDS" = Proto.parse1 GETCREDS parseCommand "GETUUID" = Proto.parse0 GETUUID parseCommand "GETGITDIR" = Proto.parse0 GETGITDIR + parseCommand "GETGITREMOTENAME" = Proto.parse0 GETGITREMOTENAME parseCommand "SETWANTED" = Proto.parse1 SETWANTED parseCommand "GETWANTED" = Proto.parse0 GETWANTED parseCommand "SETSTATE" = Proto.parse2 SETSTATE diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -67,7 +67,7 @@ remote = specialRemoteType $ RemoteType { typename = "gcrypt" -- Remote.Git takes care of enumerating gcrypt remotes too, - -- and will call our gen on them. + -- and will call our chainGen on them. , enumerate = const (return []) , generate = gen , configParser = mkRemoteConfigParser $ diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -255,14 +255,16 @@ return Nothing Just (Right hostuser) -> do let port = Git.Url.port r + let p = fromMaybe (error "unknown path") + (Git.Url.path r) -- Remove leading /~/ from path. That is added when -- converting a scp-style repository location with -- a relative path into an url, and is legal -- according to git-clone(1), but github does not -- support it. - let remotepath = if "/~/" `isPrefixOf` Git.Url.path r - then drop 3 (Git.Url.path r) - else Git.Url.path r + let remotepath = if "/~/" `isPrefixOf` p + then drop 3 p + else p let ps = LFS.sshDiscoverEndpointCommand remotepath tro -- Note that no shellEscape is done here, because -- at least github's git-lfs implementation does diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -1,6 +1,6 @@ {- Amazon Glacier remotes. - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -23,7 +23,6 @@ import qualified Remote.Helper.AWS as AWS import Creds import Utility.Metered -import qualified Annex import Annex.UUID import Utility.Env import Types.ProposedAccepted @@ -233,8 +232,7 @@ s <- liftIO $ readProcessEnv "glacier" (toCommand params) (Just e) let probablypresent = serializeKey k `elem` lines s if probablypresent - then ifM (Annex.getFlag "trustglacier") - ( return True, giveup untrusted ) + then giveup untrusted else return False params = glacierParams (config r) @@ -248,8 +246,6 @@ untrusted = unlines [ "Glacier's inventory says it has a copy." , "However, the inventory could be out of date, if it was recently removed." - , "(Use --trust-glacier if you're sure it's still in Glacier.)" - , "" ] glacierAction :: Remote -> [CommandParam] -> Annex Bool diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -1,6 +1,6 @@ {- git-annex test suite - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -224,17 +224,30 @@ testRemotes :: TestTree testRemotes = testGroup "Remote Tests" - [ testRemote "directory" - [ "directory=remotedir" - , "encryption=none" - ] - (createDirectory "remotedir") + [ testGitRemote + , testDirectoryRemote ] -testRemote :: String -> [String] -> IO () -> TestTree -testRemote remotetype config preinitremote = +testGitRemote :: TestTree +testGitRemote = testRemote False "git" $ \remotename -> do + git "clone" [".", "remotedir"] "git clone" + git "remote" ["add", remotename, "remotedir"] "git remote add" + +testDirectoryRemote :: TestTree +testDirectoryRemote = testRemote True "directory" $ \remotename -> do + createDirectory "remotedir" + git_annex "initremote" + [ remotename + , "type=directory" + , "--quiet" + , "directory=remotedir" + , "encryption=none" + ] "init" + +testRemote :: Bool -> String -> (String -> IO ()) -> TestTree +testRemote testvariants remotetype setupremote = withResource newEmptyTMVarIO (const noop) $ \getv -> - testGroup ("remote type " ++ remotetype) $ concat + testGroup ("testremote type " ++ remotetype) $ concat [ [testCase "init" (prep getv)] , go getv ] @@ -248,13 +261,7 @@ setmainrepodir d innewrepo $ do git_annex "init" [reponame, "--quiet"] "init" - preinitremote - git_annex "initremote" - ([ remotename - , "type=" ++ remotetype - , "--quiet" - ] ++ config) - "init" + setupremote remotename r <- annexeval $ either error return =<< Remote.byName' remotename cache <- Command.TestRemote.newRemoteVariantCache @@ -268,7 +275,9 @@ go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks where runannex = inmainrepo . annexeval - mkrs = Command.TestRemote.remoteVariants cache mkr basesz False + mkrs = if testvariants + then Command.TestRemote.remoteVariants cache mkr basesz False + else [fmap (fmap Just) mkr] mkr = descas (remotetype ++ " remote") (fst <$> v) mkunavailr = fst . snd <$> v mkexportr = fst . snd . snd <$> v @@ -838,9 +847,9 @@ test_trust :: Assertion test_trust = intmpclonerepo $ do - git_annex "trust" [repo] "trust" + git_annex "trust" ["--force", repo] "trust" trustcheck Logs.Trust.Trusted "trusted 1" - git_annex "trust" [repo] "trust of trusted" + git_annex "trust" ["--force", repo] "trust of trusted" trustcheck Logs.Trust.Trusted "trusted 2" git_annex "untrust" [repo] "untrust" trustcheck Logs.Trust.UnTrusted "untrusted 1" @@ -892,7 +901,7 @@ git_annex "untrust" ["origin"] "untrust of origin repo" git_annex "untrust" ["."] "untrust of current repo" fsck_should_fail "content only available in untrusted (current) repository" - git_annex "trust" ["."] "trust of current repo" + git_annex "trust" ["--force", "."] "trust of current repo" git_annex "fsck" [annexedfile] "fsck on file present in trusted repo" test_fsck_remoteuntrusted :: Assertion diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -1,6 +1,6 @@ {- git-annex numcopies types - - - Copyright 2014-2015 Joey Hess + - Copyright 2014-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -8,6 +8,8 @@ module Types.NumCopies ( NumCopies(..), fromNumCopies, + MinCopies(..), + fromMinCopies, VerifiedCopy(..), checkVerifiedCopy, invalidateVerifiedCopy, @@ -39,6 +41,12 @@ fromNumCopies :: NumCopies -> Int fromNumCopies (NumCopies n) = n +newtype MinCopies = MinCopies Int + deriving (Ord, Eq, Show) + +fromMinCopies :: MinCopies -> Int +fromMinCopies (MinCopies n) = n + -- Indicates that a key's content is exclusively -- locked locally, pending removal. newtype ContentRemovalLock = ContentRemovalLock Key @@ -130,33 +138,33 @@ - without requiring impractical amounts of locking. - - In particular, concurrent drop races may cause the number of copies - - to fall below NumCopies, but it will never fall below 1. + - to fall below NumCopies, but it will never fall below MinCopies. -} -isSafeDrop :: NumCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> Bool +isSafeDrop :: NumCopies -> MinCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> Bool {- When a ContentRemovalLock is provided, the content is being - 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 _)) = +isSafeDrop (NumCopies n) _ l (Just (ContentRemovalLock _)) = length (deDupVerifiedCopies l) >= n {- Dropping from a remote repo. - - - Unless numcopies is 0, at least one LockedCopy or TrustedCopy is required. - - A LockedCopy prevents races between concurrent drops from - - dropping the last copy, no matter what. + - To guarantee MinCopies is never violated, at least that many LockedCopy + - or TrustedCopy are required. A LockedCopy prevents races between + - concurrent drops from dropping the last copy, no matter what. - - - The other N-1 copies can be less strong verifications, like - - RecentlyVerifiedCopy. While those are subject to concurrent drop races, - - and so could be dropped all at once, causing numcopies to be violated, - - this is the best that can be done without requiring that + - The other copies required by NumCopies can be less strong verifications, + - like RecentlyVerifiedCopy. While those are subject to concurrent drop + - races, and so could be dropped all at once, causing NumCopies to be + - violated, this is the best that can be done without requiring that - all special remotes support locking. -} -isSafeDrop (NumCopies n) l Nothing - | n == 0 = True +isSafeDrop (NumCopies n) (MinCopies m) l Nothing + | n == 0 && m == 0 = True | otherwise = and [ length (deDupVerifiedCopies l) >= n - , any fullVerification l + , length (filter fullVerification l) >= m ] fullVerification :: VerifiedCopy -> Bool @@ -165,14 +173,14 @@ fullVerification (RecentlyVerifiedCopy _) = False -- A proof that it's currently safe to drop an object. -data SafeDropProof = SafeDropProof NumCopies [VerifiedCopy] (Maybe ContentRemovalLock) +data SafeDropProof = SafeDropProof NumCopies MinCopies [VerifiedCopy] (Maybe ContentRemovalLock) deriving (Show) --- Make sure that none of the VerifiedCopies have become invalidated +-- Makes sure that none of the VerifiedCopies have become invalidated -- before constructing proof. -mkSafeDropProof :: NumCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> IO (Either [VerifiedCopy] SafeDropProof) -mkSafeDropProof need have removallock = do +mkSafeDropProof :: NumCopies -> MinCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> IO (Either [VerifiedCopy] SafeDropProof) +mkSafeDropProof need mincopies have removallock = do stillhave <- filterM checkVerifiedCopy have - return $ if isSafeDrop need stillhave removallock - then Right (SafeDropProof need stillhave removallock) + return $ if isSafeDrop need mincopies stillhave removallock + then Right (SafeDropProof need mincopies stillhave removallock) else Left stillhave diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -85,7 +85,6 @@ , name :: RemoteName -- Remotes have a use cost; higher is more expensive , cost :: Cost - -- Transfers a key's contents from disk to the remote. -- The key should not appear to be present on the remote until -- all of its contents have been transferred. @@ -307,10 +306,12 @@ -- bearing in mind that the file on the remote may have changed -- since the ContentIdentifier was generated. -- + -- When it returns nothing, the file at the ImportLocation + -- not by included in the imported tree. + -- -- When the remote is thirdPartyPopulated, this should check if the -- file stored on the remote is the content of an annex object, - -- and return its Key, or Nothing if it is not. Should not - -- otherwise return Nothing. + -- and return its Key, or Nothing if it is not. -- -- Throws exception on failure to access the remote. , importKey :: Maybe (ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> a (Maybe Key)) diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -100,7 +100,7 @@ <$> calcRepo (gitAnnexLink (toRawFilePath f) k) liftIO $ removeFile f liftIO $ createSymbolicLink link f - Annex.Queue.addCommand "add" [Param "--"] [f] + Annex.Queue.addCommand [] "add" [Param "--"] [f] moveLocationLogs :: Annex () moveLocationLogs = do @@ -127,9 +127,9 @@ old <- liftIO $ readLog1 f new <- liftIO $ readLog1 dest liftIO $ writeLog1 dest (old++new) - Annex.Queue.addCommand "add" [Param "--"] [dest] - Annex.Queue.addCommand "add" [Param "--"] [f] - Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] [f] + Annex.Queue.addCommand [] "add" [Param "--"] [dest] + Annex.Queue.addCommand [] "add" [Param "--"] [f] + Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] [f] oldlog2key :: FilePath -> Maybe (FilePath, Key) oldlog2key l diff --git a/Utility/Exception.hs b/Utility/Exception.hs --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -39,7 +39,7 @@ {- Like error, this throws an exception. Unlike error, if this exception - is not caught, it won't generate a backtrace. So use this for situations - - where there's a problem that the user is expeected to see in some + - where there's a problem that the user is expected to see in some - circumstances. -} giveup :: [Char] -> a giveup = errorWithoutStackTrace diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -24,6 +24,7 @@ showInodeCache, genInodeCache, toInodeCache, + toInodeCache', InodeCacheKey, inodeCacheToKey, @@ -189,7 +190,10 @@ toInodeCache delta f =<< R.getFileStatus f toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache) -toInodeCache (TSDelta getdelta) f s +toInodeCache d f s = toInodeCache' d f s (fileID s) + +toInodeCache' :: TSDelta -> RawFilePath -> FileStatus -> FileID -> IO (Maybe InodeCache) +toInodeCache' (TSDelta getdelta) f s inode | isRegularFile s = do delta <- getdelta sz <- getFileSize' f s @@ -198,7 +202,7 @@ #else let mtime = modificationTimeHiRes s #endif - return $ Just $ InodeCache $ InodeCachePrim (fileID s) sz (MTimeHighRes (mtime + highResTime delta)) + return $ Just $ InodeCache $ InodeCachePrim inode sz (MTimeHighRes (mtime + highResTime delta)) | otherwise = pure Nothing {- Some filesystem get new random inodes each time they are mounted. diff --git a/Utility/LockFile/Windows.hs b/Utility/LockFile/Windows.hs --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -1,10 +1,12 @@ {- Windows lock files - - - Copyright 2014 Joey Hess + - Copyright 2014,2021 Joey Hess - - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} + module Utility.LockFile.Windows ( lockShared, lockExclusive, @@ -16,8 +18,12 @@ import System.Win32.Types import System.Win32.File import Control.Concurrent +import qualified Data.ByteString as B +import qualified System.FilePath.Windows.ByteString as P import Utility.FileSystemEncoding +import Utility.Split +import Utility.Path.AbsRel type LockFile = RawFilePath @@ -53,7 +59,8 @@ -} openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle) openLock sharemode f = do - h <- withTString (fromRawFilePath f) $ \c_f -> + f' <- convertToNativeNamespace f + h <- withTString (fromRawFilePath f') $ \c_f -> c_CreateFile c_f gENERIC_READ sharemode security_attributes oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing) return $ if h == iNVALID_HANDLE_VALUE @@ -61,6 +68,32 @@ else Just h where security_attributes = maybePtr Nothing + +{- Convert a filepath to use Windows's native namespace. + - This avoids filesystem length limits. + - + - This is similar to the way base converts filenames on windows, + - but as that is implemented in C (create_device_name) and not + - exported, it cannot be used here. Several edge cases are not handled, + - including network shares and dos short paths. + -} +convertToNativeNamespace :: RawFilePath -> IO RawFilePath +convertToNativeNamespace f + | win32_dev_namespace `B.isPrefixOf` f = return f + | win32_file_namespace `B.isPrefixOf` f = return f + | nt_device_namespace `B.isPrefixOf` f = return f + | otherwise = do + -- Make absolute because any '.' and '..' in the path + -- will not be resolved once it's converted. + p <- absPath f + -- Normalize slashes. + let p' = P.normalise p + return (win32_file_namespace <> p') + where + + win32_dev_namespace = "\\\\.\\" + win32_file_namespace = "\\\\?\\" + nt_device_namespace = "\\Device\\" dropLock :: LockHandle -> IO () dropLock = closeHandle diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -189,8 +189,7 @@ (base, ext) = splitExtension f len = B.length ext -{- This requires the first path to be absolute, and the - - second path cannot contain ../ or ./ +{- This requires both paths to be absolute and normalized. - - On Windows, if the paths are on different drives, - a relative path is not possible and the path is simply diff --git a/Utility/Path/Tests.hs b/Utility/Path/Tests.hs --- a/Utility/Path/Tests.hs +++ b/Utility/Path/Tests.hs @@ -1,7 +1,7 @@ {- Tests for Utility.Path. Split into a separate module to avoid it needing - QuickCheck. - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - License: BSD-2-clause -} @@ -20,6 +20,7 @@ import qualified Data.ByteString as B import Data.List import Data.Maybe +import Data.Char import Control.Applicative import Prelude @@ -35,16 +36,21 @@ p = fromRawFilePath <$> upFrom (toRawFilePath dir) dir = fromTestableFilePath tdir -prop_relPathDirToFileAbs_basics :: TestableFilePath -> TestableFilePath -> Bool -prop_relPathDirToFileAbs_basics fromt tot - | from == to = null r - | otherwise = not (null r) +prop_relPathDirToFileAbs_basics :: TestableFilePath -> Bool +prop_relPathDirToFileAbs_basics pt = and + [ relPathDirToFileAbs p (p "bar") == "bar" + , relPathDirToFileAbs (p "bar") p == ".." + , relPathDirToFileAbs p p == "" + ] where - from = fromTestableFilePath fromt - to = fromTestableFilePath tot - r = fromRawFilePath $ relPathDirToFileAbs - (toRawFilePath from) - (toRawFilePath to) + -- relPathDirToFileAbs needs absolute paths, so make the path + -- absolute by adding a path separator to the front. + p = pathSeparator `B.cons` relf + -- Make the input a relative path. On windows, make sure it does + -- not contain anything that looks like a drive letter. + relf = B.filter (not . skipchar) $ B.dropWhile isPathSeparator $ + toRawFilePath (fromTestableFilePath pt) + skipchar b = b == (fromIntegral (ord ':')) prop_relPathDirToFileAbs_regressionTest :: Bool prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -12,8 +12,7 @@ ( module X , TestableString , fromTestableString - , TestableFilePath - , fromTestableFilePath + , TestableFilePath(..) , nonNegative , positive ) where diff --git a/doc/git-annex-add.mdwn b/doc/git-annex-add.mdwn --- a/doc/git-annex-add.mdwn +++ b/doc/git-annex-add.mdwn @@ -20,6 +20,8 @@ non-large file directly to the git repository, instead of to the annex. (By default dotfiles are assumed to not be large, and are added directly to git, but annex.dotfiles can be configured to annex those too.) +See the git-annex manpage for documentation of these and other +configuration settings. Large files are added to the annex in locked form, which prevents further modification of their content unless unlocked by [[git-annex-unlock]](1). diff --git a/doc/git-annex-numcopies.mdwn b/doc/git-annex-numcopies.mdwn --- a/doc/git-annex-numcopies.mdwn +++ b/doc/git-annex-numcopies.mdwn @@ -14,18 +14,24 @@ Run without a number to get the current value. This configuration is stored in the git-annex branch, so it will be seen -by all clones of the repository. +by all clones of the repository. It can be overridden on a per-file basis +by the annex.numcopies setting in .gitattributes files, or can be +overridden temporarily with the --numcopies option. When git-annex is asked to drop a file, it first verifies that the -required number of copies can be satisfied among all the other +number of copies can be satisfied among all the other repositories that have a copy of the file. - -This can be overridden on a per-file basis by the annex.numcopies setting -in .gitattributes files. +In unusual situations, involving special remotes that do not support +locking, and concurrent drops of the same content from multiple +repositories, git-annex may violate the numcopies setting. It still +guarantees at least 1 copy is preserved. This can be configured by +using [[git-annex-mincopies]](1) + # SEE ALSO [[git-annex]](1) +[[git-annex-mincopies]](1) # AUTHOR diff --git a/doc/git-annex-trust.mdwn b/doc/git-annex-trust.mdwn --- a/doc/git-annex-trust.mdwn +++ b/doc/git-annex-trust.mdwn @@ -14,6 +14,13 @@ Repositories can be specified using their remote name, their description, or their UUID. To trust the current repository, use "here". +Before trusting a repository, consider this scenario. Repository A +is trusted and B is not; both contain the same content. `git-annex drop` +is run on repository A, which checks that B still contains the content, +and so the drop proceeds. Then `git-annex drop` is run on repository B, +which trusts A to still contain the content, so the drop succeeds. Now +the content has been lost. + # SEE ALSO [[git-annex]](1) diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -241,6 +241,12 @@ See [[git-annex-numcopies]](1) for details. +* `mincopies [N]` + + Configure minimum number of copies. + + See [[git-annex-mincopies]](1) for details. + * `trust [repository ...]` Records that a repository is trusted to not unexpectedly lose @@ -770,11 +776,16 @@ * `--numcopies=n` - Overrides the numcopies setting, forcing git-annex to ensure the - specified number of copies exist. + Overrides the numcopies setting. Note that setting numcopies to 0 is very unsafe. +* `--mincopies=n` + + Overrides the mincopies setting. + + Note that setting numcopies to 0 is very unsafe. + * `--time-limit=time` Limits how long a git-annex command runs. The time can be something @@ -786,7 +797,6 @@ Also, note that if the time limit prevents git-annex from doing all it was asked to, it will exit with a special code, 101. -* `--trust=repository` * `--semitrust=repository` * `--untrust=repository` @@ -795,17 +805,18 @@ The repository should be specified using the name of a configured remote, or the UUID or description of a repository. -* `--trust-glacier` +* `--trust=repository` - Amazon Glacier inventories take hours to retrieve, and may not represent - the current state of a repository. So git-annex does not trust that - files that the inventory claims are in Glacier are really there. - This switch can be used to allow it to trust the inventory. + This used to override trust settings for a repository, but now will + not do so, because trusting a repository can lead to data loss, + and data loss is now only enabled when using the `--force` option. - Be careful using this, especially if you or someone else might have recently - removed a file from Glacier. If you try to drop the only other copy of the - file, and this switch is enabled, you could lose data! +* `--trust-glacier` + This used to override trust settings for Glacier special remotes, + but now will not do so, because it could lead to data loss, + and data loss is now only enabled when using the `--force` option. + * `--backend=name` Specifies which key-value backend to use. This can be used when @@ -919,7 +930,7 @@ 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)`" + "`include=*.mp3 or largerthan=500kb`" See [[git-annex-matching-expression]](1) for details on the syntax. Overrides any annex.largefiles attributes in `.gitattributes` files. @@ -1842,22 +1853,23 @@ way to configure it across all clones of the repository. See [[git-annex-matching-expression]](1) for details on the syntax. -The numcopies setting can also be configured on a per-file-type basis via -the `annex.numcopies` attribute in `.gitattributes` files. This overrides -other numcopies settings. +The numcopies and mincopies settings can also be configured on a +per-file-type basis via the `annex.numcopies` and `annex.mincopies` +attributes in `.gitattributes` files. This overrides other settings. For example, this makes two copies be needed for wav files and 3 copies for flac files: *.wav annex.numcopies=2 *.flac annex.numcopies=3 -Note that setting numcopies to 0 is very unsafe. +Note that setting numcopies and 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 keys to operate on, git-annex is operating on keys and not files, so will not honor the settings from .gitattributes. For this reason, the `git annex -numcopies` command is useful to configure a global default for numcopies. +numcopies` and `git annex mincopies` commands are useful to configure a +global default. Also note that when using views, only the toplevel .gitattributes file is preserved in the view, so other settings in other files won't have any diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,11 +1,11 @@ Name: git-annex -Version: 8.20201129 +Version: 8.20210127 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess Author: Joey Hess Stability: Stable -Copyright: 2010-2020 Joey Hess +Copyright: 2010-2021 Joey Hess License-File: COPYRIGHT Homepage: http://git-annex.branchable.com/ Build-type: Custom @@ -767,6 +767,7 @@ Command.Multicast Command.NotifyChanges Command.NumCopies + Command.MinCopies Command.P2P Command.P2PStdIO Command.PostReceive