diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -1,6 +1,6 @@ {- git-annex monad - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -28,7 +28,7 @@ fromRepo, calcRepo, getGitConfig, - changeGitConfig, + overrideGitConfig, changeGitRepo, adjustGitRepo, getRemoteGitConfig, @@ -104,6 +104,7 @@ { repo :: Git.Repo , repoadjustment :: (Git.Repo -> IO Git.Repo) , gitconfig :: GitConfig + , gitconfigadjustment :: (GitConfig -> GitConfig) , gitremotes :: Maybe [Git.Repo] , backend :: Maybe (BackendA Annex) , remotes :: [Types.Remote.RemoteA Annex] @@ -161,6 +162,7 @@ { repo = r , repoadjustment = return , gitconfig = c + , gitconfigadjustment = id , gitremotes = Nothing , backend = Nothing , remotes = [] @@ -314,19 +316,13 @@ getGitConfig :: Annex GitConfig getGitConfig = getState gitconfig -{- Modifies a GitConfig setting. -} -changeGitConfig :: (GitConfig -> GitConfig) -> Annex () -changeGitConfig a = changeState $ \s -> s { gitconfig = a (gitconfig s) } - -{- Changing the git Repo data also involves re-extracting its GitConfig. -} -changeGitRepo :: Git.Repo -> Annex () -changeGitRepo r = do - adjuster <- getState repoadjustment - r' <- liftIO $ adjuster r - changeState $ \s -> s - { repo = r' - , gitconfig = extractGitConfig FromGitConfig r' - } +{- Overrides a GitConfig setting. The modification persists across + - reloads of the repo's config. -} +overrideGitConfig :: (GitConfig -> GitConfig) -> Annex () +overrideGitConfig f = changeState $ \s -> s + { gitconfigadjustment = gitconfigadjustment s . f + , gitconfig = f (gitconfig s) + } {- Adds an adjustment to the Repo data. Adjustments persist across reloads - of the repo's config. -} @@ -334,6 +330,18 @@ adjustGitRepo a = do changeState $ \s -> s { repoadjustment = \r -> repoadjustment s r >>= a } changeGitRepo =<< gitRepo + +{- Changing the git Repo data also involves re-extracting its GitConfig. -} +changeGitRepo :: Git.Repo -> Annex () +changeGitRepo r = do + repoadjuster <- getState repoadjustment + gitconfigadjuster <- getState gitconfigadjustment + r' <- liftIO $ repoadjuster r + changeState $ \s -> s + { repo = r' + , gitconfig = gitconfigadjuster $ + extractGitConfig FromGitConfig r' + } {- Gets the RemoteGitConfig from a remote, given the Git.Repo for that - remote. -} diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -57,6 +57,7 @@ import Annex.GitOverlay import Utility.Tmp.Dir import Utility.CopyFile +import Utility.Directory import qualified Database.Keys import Config @@ -375,10 +376,10 @@ - index file is currently locked.) -} changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do - tmpwt <- fromRepo gitAnnexMergeDir git_dir <- fromRawFilePath <$> fromRepo Git.localGitDir + tmpwt <- fromRepo gitAnnexMergeDir withTmpDirIn othertmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ - withemptydir tmpwt $ withWorkTree tmpwt $ do + withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do liftIO $ writeFile (tmpgit "HEAD") (fromRef updatedorig) -- Copy in refs and packed-refs, to work -- around bug in git 2.13.0, which @@ -390,7 +391,7 @@ whenM (doesFileExist src) $ do dest <- relPathDirToFile git_dir src let dest' = tmpgit dest - createDirectoryIfMissing True (takeDirectory dest') + createDirectoryUnder git_dir (takeDirectory dest') void $ createLinkOrCopy src dest' -- This reset makes git merge not care -- that the work tree is empty; otherwise @@ -411,12 +412,12 @@ else return $ return False changestomerge Nothing = return $ return False - withemptydir d a = bracketIO setup cleanup (const a) + withemptydir git_dir d a = bracketIO setup cleanup (const a) where setup = do whenM (doesDirectoryExist d) $ removeDirectoryRecursive d - createDirectoryIfMissing True d + createDirectoryUnder git_dir d cleanup _ = removeDirectoryRecursive d {- A merge commit has been made between the basisbranch and diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -208,7 +208,7 @@ stageSymlink dest' =<< hashSymlink l replacewithsymlink dest link = withworktree dest $ \f -> - replaceFile f $ makeGitLink link . toRawFilePath + replaceWorkTreeFile f $ makeGitLink link . toRawFilePath makepointer key dest destmode = do unless inoverlay $ @@ -256,7 +256,7 @@ , case selectwant' (LsFiles.unmergedSha u) of Nothing -> noop Just sha -> withworktree item $ \f -> - replaceFile f $ \tmp -> do + replaceWorkTreeFile f $ \tmp -> do c <- catObject sha liftIO $ L.writeFile tmp c ) diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs --- a/Annex/ChangedRefs.hs +++ b/Annex/ChangedRefs.hs @@ -76,8 +76,9 @@ chan <- liftIO $ newTBMChanIO 100 g <- gitRepo - let refdir = fromRawFilePath (Git.localGitDir g) "refs" - liftIO $ createDirectoryIfMissing True refdir + let gittop = fromRawFilePath (Git.localGitDir g) + let refdir = gittop "refs" + liftIO $ createDirectoryUnder gittop refdir let notifyhook = Just $ notifyHook chan let hooks = mkWatchHooks diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -879,8 +879,7 @@ liftIO $ writeFile obj "" setAnnexFilePerm obj let tmpdir = gitAnnexTmpWorkDir obj - liftIO $ createDirectoryIfMissing True tmpdir - setAnnexDirPerm tmpdir + createAnnexDirectory tmpdir res <- action tmpdir case res of Just _ -> liftIO $ removeDirectoryRecursive tmpdir diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -39,7 +39,7 @@ let f' = fromRawFilePath f destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f' liftIO $ nukeFile f' - (ic, populated) <- replaceFile f' $ \tmp -> do + (ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do let tmp' = toRawFilePath tmp ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case Just _ -> thawContent tmp >> return True @@ -62,7 +62,7 @@ let mode = fmap fileMode st secureErase file' liftIO $ nukeFile file' - ic <- replaceFile file' $ \tmp -> do + ic <- replaceWorkTreeFile file' $ \tmp -> do liftIO $ writePointerFile (toRawFilePath tmp) key mode #if ! defined(mingw32_HOST_OS) -- Don't advance mtime; this avoids unncessary re-smudging diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -1,6 +1,6 @@ {- git-annex repository fixups - - - Copyright 2013-2019 Joey Hess + - Copyright 2013-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,8 +12,6 @@ import Git.Types import Git.Config import Types.GitConfig -import Config.Files -import qualified Git import Utility.Path import Utility.SafeCommand import Utility.Directory @@ -83,27 +81,24 @@ - also converted to a symlink so links to .git/annex will work. - - When the filesystem doesn't support symlinks, we cannot make .git - - into a symlink. But we don't need too, since the repo will use direct - - mode. + - into a symlink. But we don't need too, since the repo will use adjusted + - unlocked branches. - - - Before making any changes, check if there's a .noannex file - - in the repo. If that file will prevent git-annex from being used, - - there's no need to fix up the repository. + - Don't do any of this if the repo has not been initialized for git-annex + - use yet. -} fixupUnusualRepos :: Repo -> GitConfig -> IO Repo fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d }) }) c - | needsSubmoduleFixup r = ifM notnoannex - ( do - when (coreSymlinks c) $ - (replacedotgit >> unsetcoreworktree) - `catchNonAsync` \_e -> hPutStrLn stderr - "warning: unable to convert submodule to form that will work with git-annex" - return $ r' - { config = M.delete "core.worktree" (config r) - } - , return r - ) - | otherwise = ifM (needsGitLinkFixup r <&&> notnoannex) + | isNothing (annexVersion c) = return r + | 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" + return $ r' + { config = M.delete "core.worktree" (config r) + } + | otherwise = ifM (needsGitLinkFixup r) ( do when (coreSymlinks c) $ (replacedotgit >> worktreefixup) @@ -144,8 +139,6 @@ r' | coreSymlinks c = r { location = l { gitdir = dotgit } } | otherwise = r - - notnoannex = isNothing <$> noAnnexFileContent (fmap fromRawFilePath (Git.repoWorkTree r)) fixupUnusualRepos r _ = return r needsSubmoduleFixup :: Repo -> Bool diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -274,7 +274,7 @@ makeLink :: FilePath -> Key -> Maybe InodeCache -> Annex String makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do l <- calcRepo $ gitAnnexLink file key - replaceFile file $ makeAnnexLink l . toRawFilePath + replaceWorkTreeFile file $ makeAnnexLink l . toRawFilePath -- touch symlink to have same time as the original file, -- as provided in the InodeCache diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -34,6 +34,7 @@ import Annex.Difference import Annex.UUID import Annex.WorkTree +import Annex.Fixup import Config import Config.Files import Config.Smudge @@ -129,6 +130,7 @@ ) propigateSecureHashesOnly createInodeSentinalFile False + fixupUnusualReposAfterInit uninitialize :: Annex () uninitialize = do @@ -280,3 +282,8 @@ propigateSecureHashesOnly = maybe noop (setConfig "annex.securehashesonly" . fromConfigValue) =<< getGlobalConfig "annex.securehashesonly" + +fixupUnusualReposAfterInit :: Annex () +fixupUnusualReposAfterInit = do + gc <- Annex.getGitConfig + void $ inRepo $ \r -> fixupUnusualRepos r gc diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -1,6 +1,6 @@ {- git-annex file permissions - - - Copyright 2012 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -11,6 +11,7 @@ setAnnexDirPerm, annexFileMode, createAnnexDirectory, + createWorkTreeDirectory, noUmask, freezeContent, isContentWritePermOk, @@ -25,6 +26,7 @@ import Annex.Common import Utility.FileMode +import Git import Git.ConfigTypes import qualified Annex import Config @@ -65,22 +67,31 @@ go _ = stdFileMode sharedmode = combineModes groupSharedModes -{- Creates a directory inside the gitAnnexDir, including any parent - - directories. Makes directories with appropriate permissions. -} +{- Creates a directory inside the gitAnnexDir, creating any parent + - directories up to and including the gitAnnexDir. + - Makes directories with appropriate permissions. -} createAnnexDirectory :: FilePath -> Annex () -createAnnexDirectory dir = walk dir [] =<< top +createAnnexDirectory dir = do + top <- parentDir . fromRawFilePath <$> fromRepo gitAnnexDir + createDirectoryUnder' top dir createdir where - top = parentDir . fromRawFilePath <$> fromRepo gitAnnexDir - walk d below stop - | d `equalFilePath` stop = done - | otherwise = ifM (liftIO $ doesDirectoryExist d) - ( done - , walk (parentDir d) (d:below) stop - ) - where - done = forM_ below $ \p -> do - liftIO $ createDirectoryIfMissing True p - setAnnexDirPerm p + createdir p = do + liftIO $ createDirectory p + setAnnexDirPerm p + +{- Create a directory in the git work tree, creating any parent + - directories up to the top of the work tree. + - + - Uses default permissions. + -} +createWorkTreeDirectory :: FilePath -> Annex () +createWorkTreeDirectory dir = do + fromRepo repoWorkTree >>= liftIO . \case + Just wt -> createDirectoryUnder (fromRawFilePath wt) dir + -- Should never happen, but let whatever tries to write + -- to the directory be what throws an exception, as that + -- will be clearer than an exception from here. + Nothing -> noop {- Normally, blocks writing to an annexed file, and modifies file - permissions to allow reading it. diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -1,21 +1,42 @@ {- git-annex file replacing - - - Copyright 2013-2015 Joey Hess + - Copyright 2013-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} -module Annex.ReplaceFile where +module Annex.ReplaceFile ( + replaceGitAnnexDirFile, + replaceGitDirFile, + replaceWorkTreeFile, + replaceFile, +) where import Annex.Common import Annex.Tmp +import Annex.Perms +import Git import Utility.Tmp.Dir #ifndef mingw32_HOST_OS import Utility.Path.Max #endif +{- replaceFile on a file located inside the gitAnnexDir. -} +replaceGitAnnexDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a +replaceGitAnnexDirFile = replaceFile createAnnexDirectory + +{- replaceFile on a file located inside the .git directory. -} +replaceGitDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a +replaceGitDirFile = replaceFile $ \dir -> do + top <- fromRawFilePath <$> fromRepo localGitDir + liftIO $ createDirectoryUnder top dir + +{- replaceFile on a worktree file. -} +replaceWorkTreeFile :: FilePath -> (FilePath -> Annex a) -> Annex a +replaceWorkTreeFile = replaceFile createWorkTreeDirectory + {- Replaces a possibly already existing file with a new version, - atomically, by running an action. - @@ -27,9 +48,12 @@ - will be deleted, and the existing file will be preserved. - - Throws an IO exception when it was unable to replace the file. + - + - The createdirectory action is only run when moving the file into place + - fails, and can create any parent directory structure needed. -} -replaceFile :: FilePath -> (FilePath -> Annex a) -> Annex a -replaceFile file action = withOtherTmp $ \othertmpdir -> do +replaceFile :: (FilePath -> Annex ()) -> FilePath -> (FilePath -> Annex a) -> Annex a +replaceFile createdirectory file action = withOtherTmp $ \othertmpdir -> do #ifndef mingw32_HOST_OS -- Use part of the filename as the template for the temp -- directory. This does not need to be unique, but it @@ -44,13 +68,13 @@ withTmpDirIn othertmpdir basetmp $ \tmpdir -> do let tmpfile = tmpdir basetmp r <- action tmpfile - liftIO $ replaceFileFrom tmpfile file + replaceFileFrom tmpfile file createdirectory return r -replaceFileFrom :: FilePath -> FilePath -> IO () -replaceFileFrom src dest = go `catchIO` fallback +replaceFileFrom :: FilePath -> FilePath -> (FilePath -> Annex ()) -> Annex () +replaceFileFrom src dest createdirectory = go `catchIO` fallback where - go = moveFile src dest + go = liftIO $ moveFile src dest fallback _ = do - createDirectoryIfMissing True $ parentDir dest + createdirectory (parentDir dest) go diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -16,7 +16,7 @@ import Types.UUID import Types.ProposedAccepted import Types.RemoteConfig -import Config +import Types.GitConfig import qualified Git.Config import qualified Data.Map as M @@ -234,8 +234,12 @@ p Nothing _c = Right Nothing yesNoParser :: RemoteConfigField -> Bool -> FieldDesc -> RemoteConfigFieldParser -yesNoParser f v fd = genParser yesNo f v fd +yesNoParser f v fd = genParser yesno f v fd (Just (ValueDesc "yes or no")) + where + yesno "yes" = Just True + yesno "no" = Just False + yesno _ = Nothing trueFalseParser :: RemoteConfigField -> Bool -> FieldDesc -> RemoteConfigFieldParser trueFalseParser f v fd = genParser Git.Config.isTrueFalse f v fd diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -154,8 +154,11 @@ sshSocketDirEnv :: String sshSocketDirEnv = "GIT_ANNEX_SSH_SOCKET_DIR" -{- ssh connection caching creates sockets, so will not work on a - - crippled filesystem. -} +{- Returns the directory where ssh connection caching sockets can be + - stored. + - + - The directory will be created if it does not exist. + -} sshCacheDir :: Annex (Maybe FilePath) sshCacheDir = eitherToMaybe <$> sshCacheDir' @@ -169,7 +172,10 @@ Just tmpdir -> liftIO $ catchMsgIO $ usetmpdir tmpdir - , Right <$> fromRepo gitAnnexSshDir + , do + d <- fromRepo gitAnnexSshDir + createAnnexDirectory d + return (Right d) ) , return (Left "annex.sshcaching is not set to true") ) @@ -221,7 +227,6 @@ -- Cleanup at shutdown. Annex.addCleanup SshCachingCleanup sshCleanup - liftIO $ createDirectoryIfMissing True $ parentDir socketfile let socketlock = socket2lock socketfile Annex.getState Annex.concurrency >>= \case diff --git a/Annex/UUID.hs b/Annex/UUID.hs --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -102,9 +102,7 @@ storeUUID =<< liftIO genUUID storeUUID :: UUID -> Annex () -storeUUID u = do - Annex.changeGitConfig $ \c -> c { annexUUID = u } - storeUUIDIn configkeyUUID u +storeUUID = storeUUIDIn configkeyUUID storeUUIDIn :: ConfigKey -> UUID -> Annex () storeUUIDIn configfield = setConfig configfield . fromUUID diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -100,7 +100,7 @@ Just k' | k' == k -> do destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f - ic <- replaceFile (fromRawFilePath f) $ \tmp -> do + ic <- replaceWorkTreeFile (fromRawFilePath f) $ \tmp -> do let tmp' = toRawFilePath tmp linkFromAnnex k tmp destmode >>= \case LinkAnnexOk -> diff --git a/Assistant.hs b/Assistant.hs --- a/Assistant.hs +++ b/Assistant.hs @@ -75,6 +75,7 @@ pidfile <- fromRepo gitAnnexPidFile logfile <- fromRepo gitAnnexLogFile liftIO $ debugM desc $ "logging to " ++ logfile + createAnnexDirectory (parentDir pidfile) #ifndef mingw32_HOST_OS createAnnexDirectory (parentDir logfile) logfd <- liftIO $ handleToFd =<< openLog logfile diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -26,8 +26,9 @@ mergeThread :: NamedThread mergeThread = namedThread "Merger" $ do g <- liftAnnex gitRepo - let dir = fromRawFilePath (Git.localGitDir g) "refs" - liftIO $ createDirectoryIfMissing True dir + let gitd = fromRawFilePath (Git.localGitDir g) + let dir = gitd "refs" + liftIO $ createDirectoryUnder gitd dir let hook a = Just <$> asIO2 (runHandler a) changehook <- hook onChange errhook <- hook onErr diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -15,6 +15,7 @@ import Utility.DirWatcher import Utility.DirWatcher.Types import qualified Remote +import Annex.Perms import Control.Concurrent import qualified Data.Map as M @@ -24,7 +25,7 @@ transferWatcherThread :: NamedThread transferWatcherThread = namedThread "TransferWatcher" $ do dir <- liftAnnex $ gitAnnexTransferDir <$> gitRepo - liftIO $ createDirectoryIfMissing True dir + liftAnnex $ createAnnexDirectory dir let hook a = Just <$> asIO2 (runHandler a) addhook <- hook onAdd delhook <- hook onDel diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -300,7 +300,7 @@ if linktarget == Just link then ensurestaged (Just link) =<< getDaemonStatus else do - liftAnnex $ replaceFile file $ + liftAnnex $ replaceWorkTreeFile file $ makeAnnexLink link . toRawFilePath addLink file link (Just key) -- other symlink, not git-annex diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -41,6 +41,7 @@ import Types.Crypto import Utility.Gpg import Annex.UUID +import Annex.Perms import Assistant.Ssh import Config import Config.GitConfig @@ -246,9 +247,9 @@ repoconfig <- M.lookup (Remote.uuid r) <$> readRemoteLog case repoGroup cfg of RepoGroupStandard gr -> case associatedDirectory repoconfig gr of - Just d -> inRepo $ \g -> - createDirectoryIfMissing True $ - fromRawFilePath (Git.repoPath g) d + Just d -> do + top <- fromRawFilePath <$> fromRepo Git.repoPath + createWorkTreeDirectory (top d) Nothing -> noop _ -> noop diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,36 @@ +git-annex (8.20200309) upstream; urgency=medium + + * Fix bug that caused unlocked annexed dotfiles to be added to git by the + smudge filter when annex.dotfiles was not set. + * Upgrade other repos than the current one by running git-annex upgrade + inside them, which avoids problems with upgrade code making assumptions + that the cwd will be inside the repo being upgraded. In particular, + this fixes a problem where upgrading a v7 repo to v8 caused an ugly + git error message. + * Fix upgrade failure when a file has been deleted from the working tree. + * Fix regression 1 month ago that prevented external special remotes from + using GETCONFIG to query values like "name". + * Improve behavior when a directory git-annex is writing to gets + unmounted. Previously it could in some cases re-create the mount point + and directory tree, and even write object contents to the wrong disk. + * Don't ignore --debug when it is followed by -c. + * whereis: If a remote fails to report on urls where a key + is located, display a warning, rather than giving up and not displaying + any information. + * When external special remotes fail but neglect to provide an error + message, say what request failed, which is better than displaying an + empty error message to the user. + * git-annex config: Only allow configs be set that are ones git-annex + actually supports reading from repo-global config, to avoid confusion. + * Avoid converting .git file in a worktree or submodule to a symlink + when the repository is not a git-annex repository. + * Linux standalone: Use md5sum to shorten paths in .cache/git-annex/locales + * Fix build with ghc 8.8 (MonadFail) + Thanks, Peter Simons + * stack.yaml: Updated to lts-14.27. + + -- Joey Hess Mon, 09 Mar 2020 17:04:08 -0400 + git-annex (8.20200226) upstream; urgency=medium * New v8 repository version. @@ -42,6 +75,7 @@ on those remotes without encrypting it. If your remotes are affected, you will want to make sure to delete any content that git-annex has stored on them that is not encrypted! + * initremote: Fix regression in parsing the exporttree= parameter. * info: Fix display of the encryption value. (Some debugging junk had crept in.) * Bugfix to getting content from an export remote with -J, when the diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -9,6 +9,7 @@ module CmdLine.GitAnnex.Options where +import Control.Monad.Fail as Fail (MonadFail(..)) import Options.Applicative import qualified Data.Map as M @@ -215,8 +216,8 @@ <> help "operate on all versions of all files" ) -parseKey :: Monad m => String -> m Key -parseKey = maybe (fail "invalid key") return . deserializeKey +parseKey :: MonadFail m => String -> m Key +parseKey = maybe (Fail.fail "invalid key") return . deserializeKey -- Options to match properties of annexed files. annexedMatchingOptions :: [GlobalOption] diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -59,5 +59,5 @@ setforce v = Annex.changeState $ \s -> s { Annex.force = v } setfast v = Annex.changeState $ \s -> s { Annex.fast = v } setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } - setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True } - unsetdebug = Annex.changeGitConfig $ \c -> c { annexDebug = False } + setdebug = Annex.overrideGitConfig $ \c -> c { annexDebug = True } + unsetdebug = Annex.overrideGitConfig $ \c -> c { annexDebug = False } diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -20,6 +20,7 @@ import Annex.Content import Annex.Ingest import Annex.CheckIgnore +import Annex.Perms import Annex.UUID import Annex.YoutubeDl import Logs.Web @@ -168,7 +169,7 @@ downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key) downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd file $ do let urlkey = Backend.URL.fromUrl uri sz - liftIO $ createDirectoryIfMissing True (parentDir file) + createWorkTreeDirectory (parentDir file) ifM (Annex.getState Annex.fast <||> pure (relaxedOption o)) ( do addWorkTree addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing @@ -271,7 +272,7 @@ ) normalfinish tmp = checkCanAdd file $ do showDestinationFile file - liftIO $ createDirectoryIfMissing True (parentDir file) + createWorkTreeDirectory (parentDir file) finishDownloadWith addunlockedmatcher tmp webUUID url file tryyoutubedl tmp -- Ask youtube-dl what filename it will download @@ -357,7 +358,7 @@ tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey ok <- Transfer.notifyTransfer Transfer.Download url $ Transfer.download u dummykey afile Transfer.stdRetry $ \p -> do - liftIO $ createDirectoryIfMissing True (parentDir tmp) + createAnnexDirectory (parentDir tmp) downloader tmp p if ok then return (Just tmp) @@ -389,9 +390,9 @@ Nothing -> go Just tmp -> do -- Move to final location for large file check. - pruneTmpWorkDirBefore tmp $ \_ -> liftIO $ do - createDirectoryIfMissing True (takeDirectory file) - renameFile tmp file + pruneTmpWorkDirBefore tmp $ \_ -> do + createWorkTreeDirectory (takeDirectory file) + liftIO $ renameFile tmp file largematcher <- largeFilesMatcher large <- checkFileMatcher largematcher file if large @@ -438,7 +439,7 @@ nodownloadWeb' :: AddUnlockedMatcher -> URLString -> Key -> FilePath -> Annex (Maybe Key) nodownloadWeb' addunlockedmatcher url key file = checkCanAdd file $ do showDestinationFile file - liftIO $ createDirectoryIfMissing True (parentDir file) + createWorkTreeDirectory (parentDir file) addWorkTree addunlockedmatcher webUUID url file key Nothing return (Just key) diff --git a/Command/Config.hs b/Command/Config.hs --- a/Command/Config.hs +++ b/Command/Config.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2017 Joey Hess + - Copyright 2017-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,6 +12,7 @@ import Command import Logs.Config import Config +import Types.GitConfig (globalConfigs) import Git.Types (ConfigKey(..), fromConfigValue) import qualified Data.ByteString.Char8 as S8 @@ -53,24 +54,29 @@ ) seek :: Action -> CommandSeek -seek (SetConfig ck@(ConfigKey name) val) = commandAction $ +seek (SetConfig ck@(ConfigKey name) val) = checkIsGlobalConfig ck $ commandAction $ startingUsualMessages (decodeBS' name) (ActionItemOther (Just (fromConfigValue val))) $ do setGlobalConfig ck val when (needLocalUpdate ck) $ setConfig ck (fromConfigValue val) next $ return True -seek (UnsetConfig ck@(ConfigKey name)) = commandAction $ +seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction $ startingUsualMessages (decodeBS' name) (ActionItemOther (Just "unset")) $do unsetGlobalConfig ck when (needLocalUpdate ck) $ unsetConfig ck next $ return True -seek (GetConfig ck) = commandAction $ +seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $ startingCustomOutput (ActionItemOther Nothing) $ do getGlobalConfig ck >>= \case Nothing -> return () Just (ConfigValue v) -> liftIO $ S8.putStrLn v next $ return True + +checkIsGlobalConfig :: ConfigKey -> Annex a -> Annex a +checkIsGlobalConfig ck@(ConfigKey name) a + | elem ck globalConfigs = a + | otherwise = giveup $ decodeBS name ++ " is not a configuration setting that can be stored in the git-annex branch" needLocalUpdate :: ConfigKey -> Bool needLocalUpdate (ConfigKey "annex.securehashesonly") = True diff --git a/Command/Expire.hs b/Command/Expire.hs --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -17,6 +17,7 @@ import qualified Remote import Utility.HumanTime +import Control.Monad.Fail as Fail (MonadFail(..)) import Data.Time.Clock.POSIX import qualified Data.Map as M @@ -105,9 +106,9 @@ Nothing -> giveup $ "bad expire time: " ++ s Just d -> Just (now - durationToPOSIXTime d) -parseActivity :: Monad m => String -> m Activity +parseActivity :: MonadFail m => String -> m Activity parseActivity s = case readish s of - Nothing -> fail $ "Unknown activity. Choose from: " ++ + Nothing -> Fail.fail $ "Unknown activity. Choose from: " ++ unwords (map show [minBound..maxBound :: Activity]) Just v -> return v diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -67,7 +67,7 @@ breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform breakHardLink file key obj = do - replaceFile (fromRawFilePath file) $ \tmp -> do + replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file let obj' = fromRawFilePath obj unlessM (checkedCopyFile key obj' tmp mode) $ @@ -79,7 +79,7 @@ makeHardLink :: RawFilePath -> Key -> CommandPerform makeHardLink file key = do - replaceFile (fromRawFilePath file) $ \tmp -> do + replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file linkFromAnnex key tmp mode >>= \case LinkAnnexFailed -> error "unable to make hard link" @@ -88,17 +88,16 @@ fixSymlink :: FilePath -> FilePath -> CommandPerform fixSymlink file link = do - liftIO $ do #if ! defined(mingw32_HOST_OS) - -- preserve mtime of symlink - mtime <- catchMaybeIO $ modificationTimeHiRes - <$> getSymbolicLinkStatus file + -- preserve mtime of symlink + mtime <- liftIO $ catchMaybeIO $ modificationTimeHiRes + <$> getSymbolicLinkStatus file #endif - createDirectoryIfMissing True (parentDir file) - removeFile file - createSymbolicLink link file + createWorkTreeDirectory (parentDir file) + liftIO $ removeFile file + liftIO $ createSymbolicLink link file #if ! defined(mingw32_HOST_OS) - maybe noop (\t -> touch file t False) mtime + liftIO $ maybe noop (\t -> touch file t False) mtime #endif next $ cleanupSymlink file diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -13,6 +13,7 @@ import qualified Annex.Queue import Annex.Content import Annex.WorkTree +import Annex.Perms import qualified Annex import qualified Backend.URL @@ -85,7 +86,7 @@ ( hasothercontent , do link <- calcRepo $ gitAnnexLink file key - liftIO $ createDirectoryIfMissing True (parentDir file) + createWorkTreeDirectory (parentDir file) liftIO $ createSymbolicLink link file Annex.Queue.addCommand "add" [Param "--"] [file] next $ return True diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -219,7 +219,7 @@ go want have | want /= fromRawFilePath (fromInternalGitPath have) = do showNote "fixing link" - liftIO $ createDirectoryIfMissing True (parentDir (fromRawFilePath file)) + createWorkTreeDirectory (parentDir (fromRawFilePath file)) liftIO $ removeFile (fromRawFilePath file) addAnnexLink want file | otherwise = noop @@ -332,7 +332,7 @@ case mk of Just k | k == key -> whenM (inAnnex key) $ do showNote "fixing worktree content" - replaceFile (fromRawFilePath file) $ \tmp -> do + replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file ifM (annexThin <$> Annex.getGitConfig) ( void $ linkFromAnnex key tmp mode diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -13,6 +13,7 @@ import qualified Annex import qualified Git.Config import Config +import Annex.Perms import Utility.ThreadScheduler import Utility.DiskFree import Git.Types (fromConfigKey) @@ -172,10 +173,10 @@ ] runFuzzAction :: FuzzAction -> Annex () -runFuzzAction (FuzzAdd (FuzzFile f)) = liftIO $ do - createDirectoryIfMissing True $ parentDir f - n <- getStdRandom random :: IO Int - writeFile f $ show n ++ "\n" +runFuzzAction (FuzzAdd (FuzzFile f)) = do + createWorkTreeDirectory (parentDir f) + n <- liftIO (getStdRandom random :: IO Int) + liftIO $ writeFile f $ show n ++ "\n" runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ rename src dest diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -25,6 +25,7 @@ import Annex.Ingest import Annex.InodeSentinal import Annex.Import +import Annex.Perms import Annex.RemoteTrackingBranch import Utility.InodeCache import Logs.Location @@ -176,12 +177,12 @@ importfilechecked ld k = do -- Move or copy the src file to the dest file. -- The dest file is what will be ingested. - liftIO $ createDirectoryIfMissing True (parentDir destfile) + createWorkTreeDirectory (parentDir destfile) liftIO $ if mode == Duplicate || mode == SkipDuplicates then void $ copyFileExternal CopyAllMetaData srcfile destfile else moveFile srcfile destfile -- Get the inode cache of the dest file. It should be - -- weakly the same as the origianlly locked down file's + -- weakly the same as the originally locked down file's -- inode cache. (Since the file may have been copied, -- its inodes may not be the same.) newcache <- withTSDelta $ liftIO . genInodeCache destfile' diff --git a/Command/Init.hs b/Command/Init.hs --- a/Command/Init.hs +++ b/Command/Init.hs @@ -13,6 +13,7 @@ import Types.RepoVersion import qualified Annex.SpecialRemote +import Control.Monad.Fail as Fail (MonadFail(..)) import qualified Data.Map as M cmd :: Command @@ -33,14 +34,14 @@ <> help "Override default annex.version" )) -parseRepoVersion :: Monad m => String -> m RepoVersion +parseRepoVersion :: MonadFail m => String -> m RepoVersion parseRepoVersion s = case RepoVersion <$> readish s of - Nothing -> fail $ "version parse error" + Nothing -> Fail.fail $ "version parse error" Just v | v `elem` supportedVersions -> return v | otherwise -> case M.lookup v autoUpgradeableVersions of Just v' -> return v' - Nothing -> fail $ s ++ " is not a currently supported repository version" + Nothing -> Fail.fail $ s ++ " is not a currently supported repository version" seek :: InitOptions -> CommandSeek seek = commandAction . start diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -74,7 +74,7 @@ mfc <- withTSDelta (liftIO . genInodeCache file) unlessM (sameInodeCache obj (maybeToList mfc)) $ do let obj' = fromRawFilePath obj - modifyContent obj' $ replaceFile obj' $ \tmp -> do + modifyContent obj' $ replaceGitAnnexDirFile obj' $ \tmp -> do unlessM (checkedCopyFile key obj' tmp Nothing) $ giveup "unable to lock file" Database.Keys.storeInodeCaches key [obj] diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -93,7 +93,7 @@ st <- liftIO $ R.getFileStatus file when (linkCount st > 1) $ do freezeContent oldobj - replaceFile (fromRawFilePath file) $ \tmp -> do + replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $ error "can't lock old key" thawContent tmp diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -176,7 +176,7 @@ checkmatcher d | dotfile file = ifM (getGitConfigVal annexDotFiles) ( go - , return False + , d ) | otherwise = go where diff --git a/Command/Unlock.hs b/Command/Unlock.hs --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -29,9 +29,6 @@ seek :: CmdParams -> CommandSeek seek ps = withFilesInGit (commandAction . whenAnnexed start) =<< workTreeItems ps -{- Before v6, the unlock subcommand replaces the symlink with a copy of - - the file's content. In v6 and above, it converts the file from a symlink - - to a pointer. -} start :: RawFilePath -> Key -> CommandStart start file key = ifM (isJust <$> isAnnexLink file) ( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $ @@ -42,7 +39,7 @@ perform :: RawFilePath -> Key -> CommandPerform perform dest key = do destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus dest - replaceFile (fromRawFilePath dest) $ \tmp -> + replaceWorkTreeFile (fromRawFilePath dest) $ \tmp -> ifM (inAnnex key) ( do r <- linkFromAnnex key tmp destmode diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2011 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,13 +20,28 @@ noDaemonRunning $ -- ^ avoid upgrading repo out from under daemon command "upgrade" SectionMaintenance "upgrade repository" - paramNothing (withParams seek) + paramNothing (seek <$$> optParser) -seek :: CmdParams -> CommandSeek -seek = withNothing (commandAction start) +data UpgradeOptions = UpgradeOptions + { autoOnly :: Bool + } -start :: CommandStart -start = starting "upgrade" (ActionItemOther Nothing) $ do +optParser :: CmdParamsDesc -> Parser UpgradeOptions +optParser _ = UpgradeOptions + <$> switch + ( long "autoonly" + <> help "only do automatic upgrades" + ) + +seek :: UpgradeOptions -> CommandSeek +seek o = commandAction (start o) + +start :: UpgradeOptions -> CommandStart +start (UpgradeOptions { autoOnly = True }) = do + starting "upgrade" (ActionItemOther Nothing) $ do + getVersion >>= maybe noop checkUpgrade + next $ return True +start _ = starting "upgrade" (ActionItemOther Nothing) $ do whenM (isNothing <$> getVersion) $ do initialize Nothing Nothing r <- upgrade False latestVersion diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -92,7 +92,18 @@ <$> askremote <*> claimedurls where - askremote = maybe (pure []) (flip id key) (whereisKey remote) + askremote = case whereisKey remote of + Nothing -> pure [] + Just w -> tryNonAsync (w key) >>= \case + Right l -> pure l + Left e -> do + warning $ unwords + [ "unable to query remote" + , name remote + , "for urls:" + , show e + ] + return [] claimedurls = do us <- map fst . filter (\(_, d) -> d == OtherDownloader) diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -5,10 +5,14 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -module Config where +module Config ( + module Config, + annexConfig, + remoteAnnexConfig, + remoteConfig, +) where import Annex.Common import qualified Git @@ -18,13 +22,9 @@ import Config.Cost import Config.DynamicConfig import Types.Availability +import Types.GitConfig import Git.Types -import qualified Types.Remote as Remote -import qualified Data.ByteString as S - -type UnqualifiedConfigKey = S.ByteString - {- Looks up a setting in git config. This is not as efficient as using the - GitConfig type. -} getConfig :: ConfigKey -> ConfigValue -> Annex ConfigValue @@ -50,31 +50,6 @@ unsetConfig :: ConfigKey -> Annex () unsetConfig key = void $ inRepo $ Git.Config.unset key -class RemoteNameable r where - getRemoteName :: r -> RemoteName - -instance RemoteNameable Git.Repo where - getRemoteName r = fromMaybe "" (Git.remoteName r) - -instance RemoteNameable RemoteName where - getRemoteName = id - -instance RemoteNameable Remote where - getRemoteName = Remote.name - -{- A per-remote config setting in git config. -} -remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey -remoteConfig r key = ConfigKey $ - "remote." <> encodeBS' (getRemoteName r) <> "." <> key - -{- A per-remote config annex setting in git config. -} -remoteAnnexConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey -remoteAnnexConfig r key = remoteConfig r ("annex-" <> key) - -{- A global annex setting in git config. -} -annexConfig :: UnqualifiedConfigKey -> ConfigKey -annexConfig key = ConfigKey ("annex." <> key) - {- Calculates cost for a remote. Either the specific default, or as configured - by remote..annex-cost, or if remote..annex-cost-command - is set and prints a number, that is used. -} @@ -106,11 +81,5 @@ crippledFileSystem = annexCrippledFileSystem <$> Annex.getGitConfig setCrippledFileSystem :: Bool -> Annex () -setCrippledFileSystem b = do +setCrippledFileSystem b = setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) - Annex.changeGitConfig $ \c -> c { annexCrippledFileSystem = b } - -yesNo :: String -> Maybe Bool -yesNo "yes" = Just True -yesNo "no" = Just False -yesNo _ = Nothing diff --git a/Config/GitConfig.hs b/Config/GitConfig.hs --- a/Config/GitConfig.hs +++ b/Config/GitConfig.hs @@ -17,7 +17,8 @@ - repository-global defaults when the GitConfig does not yet - have a value. - - - Note: Be sure to add the config value to mergeGitConfig. + - Note: Be sure to add the config to mergeGitConfig and to + - globalConfigs. -} getGitConfigVal :: (GitConfig -> Configurable a) -> Annex a getGitConfigVal f = getGitConfigVal' f >>= \case @@ -35,6 +36,6 @@ -- config makes all repository-global default -- values populate the GitConfig with HasGlobalConfig -- values, so it will only need to be done once. - Annex.changeGitConfig (\gc -> mergeGitConfig gc globalgc) + Annex.overrideGitConfig (\gc -> mergeGitConfig gc globalgc) f <$> Annex.getGitConfig c -> return c diff --git a/Config/Smudge.hs b/Config/Smudge.hs --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -33,8 +33,9 @@ gf <- Annex.fromRepo Git.attributes lfs <- readattr lf gfs <- readattr gf + gittop <- fromRawFilePath . Git.localGitDir <$> gitRepo liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do - createDirectoryIfMissing True (takeDirectory lf) + createDirectoryUnder gittop (takeDirectory lf) writeFile lf (lfs ++ "\n" ++ unlines stdattr) where readattr = liftIO . catchDefaultIO "" . readFileStrict diff --git a/Database/Init.hs b/Database/Init.hs --- a/Database/Init.hs +++ b/Database/Init.hs @@ -1,6 +1,6 @@ {- Persistent sqlite database initialization - - - Copyright 2015-2018 Joey Hess + - Copyright 2015-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -29,9 +29,10 @@ let dbdir = takeDirectory db let tmpdbdir = dbdir ++ ".tmp" let tmpdb = tmpdbdir "db" - let tdb = T.pack tmpdb + let tdb = T.pack tmpdb + top <- parentDir . fromRawFilePath <$> fromRepo gitAnnexDir liftIO $ do - createDirectoryIfMissing True tmpdbdir + createDirectoryUnder top tmpdbdir runSqliteInfo (enableWAL tdb) migration setAnnexDirPerm tmpdbdir -- Work around sqlite bug that prevents it from honoring diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -40,12 +40,36 @@ import qualified Data.Map as M import qualified Data.ByteString.Lazy as L -{- Scans for files that are checked into git's index at the specified locations. -} +{- It's only safe to use git ls-files on the current repo, not on a remote. + - + - Git has some strange behavior when git ls-files is used with repos + - that are not the one that the cwd is in: + - git --git-dir=../foo/.git --worktree=../foo ../foo fails saying + - "../foo is outside repository". + - That does not happen when an absolute path is provided. + - + - Also, the files output by ls-files are relative to the cwd. + - Unless it's run on remote. Then it's relative to the top of the remote + - repo. + - + - So, best to avoid that class of problems. + -} +safeForLsFiles :: Repo -> Bool +safeForLsFiles r = isNothing (remoteName r) + +guardSafeForLsFiles :: Repo -> IO a -> IO a +guardSafeForLsFiles r a + | safeForLsFiles r = a + | otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r + +{- Lists files that are checked into git's index at the specified paths. + - With no paths, all files are listed. + -} inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) inRepo = inRepo' [] inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepo' ps l repo = pipeNullSplit' params repo +inRepo' ps l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -64,7 +88,8 @@ notInRepo = notInRepo' [] notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -notInRepo' ps include_ignored l repo = pipeNullSplit' params repo +notInRepo' ps include_ignored l repo = guardSafeForLsFiles repo $ + pipeNullSplit' params repo where params = concat [ [ Param "ls-files", Param "--others"] @@ -85,18 +110,20 @@ {- Finds all files in the specified locations, whether checked into git or - not. -} allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -allFiles l = pipeNullSplit' $ - Param "ls-files" : - Param "--cached" : - Param "--others" : - Param "-z" : - Param "--" : - map (File . fromRawFilePath) l +allFiles l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo + where + params = + Param "ls-files" : + Param "--cached" : + Param "--others" : + Param "-z" : + Param "--" : + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - deleted. -} deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -deleted l repo = pipeNullSplit' params repo +deleted l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -108,7 +135,7 @@ {- Returns a list of files in the specified locations that have been - modified. -} modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -modified l repo = pipeNullSplit' params repo +modified l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -120,7 +147,7 @@ {- Files that have been modified or are not checked into git (and are not - ignored). -} modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -modifiedOthers l repo = pipeNullSplit' params repo +modifiedOthers l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -141,7 +168,8 @@ stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo +staged' ps l repo = guardSafeForLsFiles repo $ + pipeNullSplit' (prefix ++ ps ++ suffix) repo where prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] suffix = Param "--" : map (File . fromRawFilePath) l @@ -160,7 +188,7 @@ {- Gets details about staged files, including the Sha of their staged - contents. -} stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) -stagedDetails' ps l repo = do +stagedDetails' ps l repo = guardSafeForLsFiles repo $ do (ls, cleanup) <- pipeNullSplit params repo return (map parseStagedDetails ls, cleanup) where @@ -188,7 +216,7 @@ typeChanged = typeChanged' [] typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -typeChanged' ps l repo = do +typeChanged' ps l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. @@ -228,7 +256,7 @@ - If a line is omitted, that side removed the file. -} unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) -unmerged l repo = do +unmerged l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit params repo return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup) where @@ -292,7 +320,7 @@ - point in the future. If the output is not as expected, will use Nothing. -} inodeCaches :: [RawFilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool) -inodeCaches locs repo = do +inodeCaches locs repo = guardSafeForLsFiles repo $ do (ls, cleanup) <- pipeNullSplit params repo return (parse Nothing (map decodeBL ls), cleanup) where diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -245,8 +245,9 @@ nukeFile f where makeref (sha, ref) = do - let dest = fromRawFilePath (localGitDir r) fromRef ref - createDirectoryIfMissing True (parentDir dest) + let gitd = fromRawFilePath (localGitDir r) + let dest = gitd fromRef ref + createDirectoryUnder gitd (parentDir dest) unlessM (doesFileExist dest) $ writeFile dest (fromRef sha) diff --git a/Logs/File.hs b/Logs/File.hs --- a/Logs/File.hs +++ b/Logs/File.hs @@ -29,7 +29,7 @@ withLogHandle :: FilePath -> (Handle -> Annex a) -> Annex a withLogHandle f a = do createAnnexDirectory (parentDir f) - replaceFile f $ \tmp -> + replaceGitAnnexDirFile f $ \tmp -> bracket (setup tmp) cleanup a where setup tmp = do diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -170,13 +170,13 @@ store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex Bool store d chunkconfig k b p = liftIO $ do - void $ tryIO $ createDirectoryIfMissing True tmpdir + void $ tryIO $ createDirectoryUnder d tmpdir case chunkconfig of - LegacyChunks chunksize -> Legacy.store chunksize finalizeStoreGeneric k b p tmpdir destdir + LegacyChunks chunksize -> Legacy.store d chunksize (finalizeStoreGeneric d) k b p tmpdir destdir _ -> do let tmpf = tmpdir kf meteredWriteFile p tmpf b - finalizeStoreGeneric tmpdir destdir + finalizeStoreGeneric d tmpdir destdir return True where tmpdir = addTrailingPathSeparator $ d "tmp" kf @@ -187,11 +187,11 @@ - in the dest directory, moves it into place. Anything already existing - in the dest directory will be deleted. File permissions will be locked - down. -} -finalizeStoreGeneric :: FilePath -> FilePath -> IO () -finalizeStoreGeneric tmp dest = do +finalizeStoreGeneric :: FilePath -> FilePath -> FilePath -> IO () +finalizeStoreGeneric d tmp dest = do void $ tryIO $ allowWrite dest -- may already exist void $ tryIO $ removeDirectoryRecursive dest -- or not exist - createDirectoryIfMissing True (parentDir dest) + createDirectoryUnder d (parentDir dest) renameDirectory tmp dest -- may fail on some filesystems void $ tryIO $ do @@ -267,7 +267,7 @@ storeExportM :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportM d src _k loc p = liftIO $ catchBoolIO $ do - createDirectoryIfMissing True (takeDirectory dest) + createDirectoryUnder d (takeDirectory dest) -- Write via temp file so that checkPresentGeneric will not -- see it until it's fully stored. viaTmp (\tmp () -> withMeteredFile src p (L.writeFile tmp)) dest () @@ -298,7 +298,7 @@ renameExportM d _k oldloc newloc = liftIO $ Just <$> go where go = catchBoolIO $ do - createDirectoryIfMissing True (takeDirectory dest) + createDirectoryUnder d (takeDirectory dest) renameFile src dest removeExportLocation d oldloc return True @@ -413,7 +413,7 @@ catchIO go (return . Left . show) where go = do - liftIO $ createDirectoryIfMissing True destdir + liftIO $ createDirectoryUnder dir destdir withTmpFileIn destdir template $ \tmpf tmph -> do liftIO $ withMeteredFile src p (L.hPut tmph) liftIO $ hFlush tmph diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -70,9 +70,9 @@ feed bytes' (sz - s) ls h else return (l:ls) -storeHelper :: (FilePath -> FilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO Bool -storeHelper finalizer key storer tmpdir destdir = do - void $ liftIO $ tryIO $ createDirectoryIfMissing True tmpdir +storeHelper :: FilePath -> (FilePath -> FilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO Bool +storeHelper repotop finalizer key storer tmpdir destdir = do + void $ liftIO $ tryIO $ createDirectoryUnder repotop tmpdir Legacy.storeChunks key tmpdir destdir storer recorder finalizer where recorder f s = do @@ -80,8 +80,8 @@ writeFile f s void $ tryIO $ preventWrite f -store :: ChunkSize -> (FilePath -> FilePath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO Bool -store chunksize finalizer k b p = storeHelper finalizer k $ \dests -> +store :: FilePath -> ChunkSize -> (FilePath -> FilePath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO Bool +store repotop chunksize finalizer k b p = storeHelper repotop finalizer k $ \dests -> storeLegacyChunked p chunksize dests b {- Need to get a single ByteString containing every chunk. diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -183,7 +183,8 @@ =<< strictRemoteConfigParser external handleRequest external INITREMOTE Nothing $ \resp -> case resp of INITREMOTE_SUCCESS -> result () - INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg + INITREMOTE_FAILURE errmsg -> Just $ giveup $ + respErrorMessage "INITREMOTE" errmsg _ -> Nothing -- Any config changes the external made before -- responding to INITREMOTE need to be applied to @@ -218,7 +219,7 @@ TRANSFER_SUCCESS Upload k' | k == k' -> result True TRANSFER_FAILURE Upload k' errmsg | k == k' -> Just $ do - warning errmsg + warning $ respErrorMessage "TRANSFER" errmsg return (Result False) _ -> Nothing @@ -229,7 +230,8 @@ TRANSFER_SUCCESS Download k' | k == k' -> result () TRANSFER_FAILURE Download k' errmsg - | k == k' -> Just $ giveup errmsg + | k == k' -> Just $ giveup $ + respErrorMessage "TRANSFER" errmsg _ -> Nothing removeKeyM :: External -> Remover @@ -240,7 +242,7 @@ | k == k' -> result True REMOVE_FAILURE k' errmsg | k == k' -> Just $ do - warning errmsg + warning $ respErrorMessage "REMOVE" errmsg return (Result False) _ -> Nothing @@ -254,7 +256,8 @@ CHECKPRESENT_FAILURE k' | k' == k -> result $ Right False CHECKPRESENT_UNKNOWN k' errmsg - | k' == k -> result $ Left errmsg + | k' == k -> result $ Left $ + respErrorMessage "CHECKPRESENT" errmsg _ -> Nothing whereisKeyM :: External -> Key -> Annex [String] @@ -270,7 +273,7 @@ TRANSFER_SUCCESS Upload k' | k == k' -> result True TRANSFER_FAILURE Upload k' errmsg | k == k' -> Just $ do - warning errmsg + warning $ respErrorMessage "TRANSFER" errmsg return (Result False) UNSUPPORTED_REQUEST -> Just $ do warning "TRANSFEREXPORT not implemented by external special remote" @@ -286,7 +289,7 @@ | k == k' -> result True TRANSFER_FAILURE Download k' errmsg | k == k' -> Just $ do - warning errmsg + warning $ respErrorMessage "TRANSFER" errmsg return (Result False) UNSUPPORTED_REQUEST -> Just $ do warning "TRANSFEREXPORT not implemented by external special remote" @@ -304,7 +307,8 @@ CHECKPRESENT_FAILURE k' | k' == k -> result $ Right False CHECKPRESENT_UNKNOWN k' errmsg - | k' == k -> result $ Left errmsg + | k' == k -> result $ Left $ + respErrorMessage "CHECKPRESENT" errmsg UNSUPPORTED_REQUEST -> result $ Left "CHECKPRESENTEXPORT not implemented by external special remote" _ -> Nothing @@ -316,7 +320,7 @@ | k == k' -> result True REMOVE_FAILURE k' errmsg | k == k' -> Just $ do - warning errmsg + warning $ respErrorMessage "REMOVE" errmsg return (Result False) UNSUPPORTED_REQUEST -> Just $ do warning "REMOVEEXPORT not implemented by external special remote" @@ -420,9 +424,9 @@ modifyTVar' (externalConfigChanges st) $ \f -> f . M.insert (Accepted setting) (Accepted value) handleRemoteRequest (GETCONFIG setting) = do - value <- fromMaybe "" + value <- maybe "" fromProposedAccepted . (M.lookup (Accepted setting)) - . getRemoteConfigPassedThrough + . unparsedRemoteConfig <$> liftIO (atomically $ readTVar $ externalConfig st) send $ VALUE value handleRemoteRequest (SETCREDS setting login password) = case (externalUUID external, externalGitConfig external) of @@ -684,13 +688,19 @@ setprepared Prepared return (Result ()) PREPARE_FAILURE errmsg -> Just $ do - setprepared $ FailedPrepare errmsg - giveup errmsg + let errmsg' = respErrorMessage "PREPARE" errmsg + setprepared $ FailedPrepare errmsg' + giveup errmsg' _ -> Nothing where setprepared status = liftIO $ atomically $ void $ swapTVar (externalPrepared st) status +respErrorMessage :: String -> String -> String +respErrorMessage req err + | null err = req ++ " failed with no reason given" + | otherwise = err + {- Caches the cost in the git config to avoid needing to start up an - external special remote every time time just to ask it what its - cost is. -} @@ -743,7 +753,8 @@ CHECKURL_CONTENTS sz f -> result $ UrlContents sz $ if null f then Nothing else Just $ mkSafeFilePath f CHECKURL_MULTI l -> result $ UrlMulti $ map mkmulti l - CHECKURL_FAILURE errmsg -> Just $ giveup errmsg + CHECKURL_FAILURE errmsg -> Just $ giveup $ + respErrorMessage "CHECKURL" errmsg UNSUPPORTED_REQUEST -> giveup "CHECKURL not implemented by external special remote" _ -> Nothing where diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -49,6 +49,7 @@ import Utility.Metered import Annex.UUID import Annex.Ssh +import Annex.Perms import qualified Remote.Rsync import qualified Remote.Directory import Utility.Rsync @@ -283,7 +284,7 @@ - which is needed for direct rsync of objects to work. -} rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do - liftIO $ createDirectoryIfMissing True $ tmp objectDir + createAnnexDirectory (tmp objectDir) dummycfg <- liftIO dummyRemoteGitConfig (rsynctransport, rsyncurl, _) <- rsyncTransport r dummycfg let tmpconfig = tmp "config" @@ -368,11 +369,11 @@ | not $ Git.repoIsUrl repo = byteStorer $ \k b p -> guardUsable repo (return False) $ liftIO $ do let tmpdir = Git.repoLocation repo "tmp" fromRawFilePath (keyFile k) - void $ tryIO $ createDirectoryIfMissing True tmpdir + void $ tryIO $ createDirectoryUnder (Git.repoLocation repo) tmpdir let tmpf = tmpdir fromRawFilePath (keyFile k) meteredWriteFile p tmpf b let destdir = parentDir $ gCryptLocation repo k - Remote.Directory.finalizeStoreGeneric tmpdir destdir + Remote.Directory.finalizeStoreGeneric (Git.repoLocation repo) tmpdir destdir return True | Git.repoIsSsh repo = if accessShell r then fileStorer $ \k f p -> do diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -167,7 +167,7 @@ -- (so it's also usable by git as a non-special remote), -- and set remote.name.annex-git-lfs = true gitConfigSpecialRemote u c' [("git-lfs", "true")] - setConfig (remoteConfig (getRemoteName c) "url") url + setConfig (remoteConfig c "url") url return (c', u) where url = maybe (giveup "Specify url=") fromProposedAccepted diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -48,7 +48,7 @@ dir <- fromRepo gitAnnexRemotesDir let lck = dir remoteid ++ ".lck" whenM (notElem lck . M.keys <$> getLockCache) $ do - liftIO $ createDirectoryIfMissing True dir + createAnnexDirectory dir firstrun lck a where diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -27,6 +27,7 @@ import Annex.Content import Annex.UUID import Annex.Ssh +import Annex.Perms import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.ExportImport @@ -218,7 +219,7 @@ storeGeneric :: RsyncOpts -> MeterUpdate -> FilePath -> (FilePath -> Annex Bool) -> Annex Bool storeGeneric o meterupdate basedest populatedest = withRsyncScratchDir $ \tmp -> do let dest = tmp basedest - liftIO $ createDirectoryIfMissing True $ parentDir dest + createAnnexDirectory (parentDir dest) ok <- populatedest dest ps <- sendParams if ok diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -161,7 +161,7 @@ | otherwise = Nothing properties :: TestTree -properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" +properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $ [ testProperty "prop_encode_decode_roundtrip" Git.Filename.prop_encode_decode_roundtrip , testProperty "prop_encode_c_decode_c_roundtrip" Utility.Format.prop_encode_c_decode_c_roundtrip , testProperty "prop_isomorphic_key_encode" Key.prop_isomorphic_key_encode @@ -185,8 +185,6 @@ , testProperty "prop_parse_build_contentidentifier_log" Logs.ContentIdentifier.prop_parse_build_contentidentifier_log , testProperty "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel , testProperty "prop_parse_build_TrustLevelLog" Logs.Trust.prop_parse_build_TrustLevelLog - , testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable - , testProperty "prop_mac_stable" Utility.Hash.prop_mac_stable , testProperty "prop_schedule_roundtrips" Utility.Scheduled.QuickCheck.prop_schedule_roundtrips , testProperty "prop_past_sane" Utility.Scheduled.prop_past_sane , testProperty "prop_duration_roundtrips" Utility.HumanTime.prop_duration_roundtrips @@ -198,7 +196,12 @@ , testProperty "prop_viewedFile_rountrips" Annex.View.ViewedFile.prop_viewedFile_roundtrips , testProperty "prop_b64_roundtrips" Utility.Base64.prop_b64_roundtrips , testProperty "prop_standardGroups_parse" Logs.PreferredContent.prop_standardGroups_parse - ] + ] ++ map (uncurry testProperty) combos + where + combos = concat + [ Utility.Hash.props_hashes_stable + , Utility.Hash.props_macs_stable + ] {- These tests set up the test environment, but also test some basic parts - of git-annex. They are always run before the unitTests. -} diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -1,10 +1,11 @@ {- git-annex configuration - - - Copyright 2012-2019 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Types.GitConfig ( @@ -13,9 +14,14 @@ GitConfig(..), extractGitConfig, mergeGitConfig, + globalConfigs, RemoteGitConfig(..), extractRemoteGitConfig, dummyRemoteGitConfig, + annexConfig, + RemoteNameable(..), + remoteAnnexConfig, + remoteConfig, ) where import Common @@ -43,6 +49,7 @@ import Control.Concurrent.STM import qualified Data.Set as S +import qualified Data.ByteString as B -- | A configurable value, that may not be fully determined yet because -- the global git config has not yet been loaded. @@ -125,84 +132,86 @@ extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig extractGitConfig configsource r = GitConfig - { annexVersion = RepoVersion <$> getmayberead (annex "version") - , annexUUID = maybe NoUUID toUUID $ getmaybe (annex "uuid") - , annexNumCopies = NumCopies <$> getmayberead (annex "numcopies") + { annexVersion = RepoVersion <$> getmayberead (annexConfig "version") + , annexUUID = maybe NoUUID toUUID $ getmaybe (annexConfig "uuid") + , annexNumCopies = NumCopies <$> getmayberead (annexConfig "numcopies") , annexDiskReserve = fromMaybe onemegabyte $ - readSize dataUnits =<< getmaybe (annex "diskreserve") - , annexDirect = getbool (annex "direct") False + readSize dataUnits =<< getmaybe (annexConfig "diskreserve") + , annexDirect = getbool (annexConfig "direct") False , annexBackend = maybe -- annex.backends is the old name of the option, still used -- when annex.backend is not set. - (headMaybe $ getwords (annex "backends")) + (headMaybe $ getwords (annexConfig "backends")) Just - (getmaybe (annex "backend")) - , annexQueueSize = getmayberead (annex "queuesize") - , annexBloomCapacity = getmayberead (annex "bloomcapacity") - , annexBloomAccuracy = getmayberead (annex "bloomaccuracy") - , annexSshCaching = getmaybebool (annex "sshcaching") - , annexAlwaysCommit = getbool (annex "alwayscommit") True - , annexCommitMessage = getmaybe (annex "commitmessage") - , annexMergeAnnexBranches = getbool (annex "merge-annex-branches") True - , annexDelayAdd = getmayberead (annex "delayadd") - , annexHttpHeaders = getlist (annex "http-headers") - , annexHttpHeadersCommand = getmaybe (annex "http-headers-command") + (getmaybe (annexConfig "backend")) + , annexQueueSize = getmayberead (annexConfig "queuesize") + , annexBloomCapacity = getmayberead (annexConfig "bloomcapacity") + , annexBloomAccuracy = getmayberead (annexConfig "bloomaccuracy") + , annexSshCaching = getmaybebool (annexConfig "sshcaching") + , annexAlwaysCommit = getbool (annexConfig "alwayscommit") True + , annexCommitMessage = getmaybe (annexConfig "commitmessage") + , annexMergeAnnexBranches = getbool (annexConfig "merge-annex-branches") True + , annexDelayAdd = getmayberead (annexConfig "delayadd") + , annexHttpHeaders = getlist (annexConfig "http-headers") + , annexHttpHeadersCommand = getmaybe (annexConfig "http-headers-command") , annexAutoCommit = configurable True $ - getmaybebool (annex "autocommit") + getmaybebool (annexConfig "autocommit") , annexResolveMerge = configurable True $ - getmaybebool (annex "resolvemerge") + getmaybebool (annexConfig "resolvemerge") , annexSyncContent = configurable False $ - getmaybebool (annex "synccontent") + getmaybebool (annexConfig "synccontent") , annexSyncOnlyAnnex = configurable False $ - getmaybebool (annex "synconlyannex") - , annexDebug = getbool (annex "debug") False - , annexWebOptions = getwords (annex "web-options") - , annexYoutubeDlOptions = getwords (annex "youtube-dl-options") - , annexAriaTorrentOptions = getwords (annex "aria-torrent-options") - , annexCrippledFileSystem = getbool (annex "crippledfilesystem") False + getmaybebool (annexConfig "synconlyannex") + , annexDebug = getbool (annexConfig "debug") False + , annexWebOptions = getwords (annexConfig "web-options") + , annexYoutubeDlOptions = getwords (annexConfig "youtube-dl-options") + , annexAriaTorrentOptions = getwords (annexConfig "aria-torrent-options") + , annexCrippledFileSystem = getbool (annexConfig "crippledfilesystem") False , annexLargeFiles = configurable Nothing $ - fmap Just $ getmaybe (annex "largefiles") - , annexDotFiles = configurable False $ getmaybebool (annex "dotfiles") - , annexGitAddToAnnex = getbool (annex "gitaddtoannex") True - , annexAddSmallFiles = getbool (annex "addsmallfiles") True - , annexFsckNudge = getbool (annex "fscknudge") True - , annexAutoUpgrade = toAutoUpgrade $ getmaybe (annex "autoupgrade") + fmap Just $ getmaybe (annexConfig "largefiles") + , annexDotFiles = configurable False $ + getmaybebool (annexConfig "dotfiles") + , annexGitAddToAnnex = getbool (annexConfig "gitaddtoannex") True + , annexAddSmallFiles = getbool (annexConfig "addsmallfiles") True + , annexFsckNudge = getbool (annexConfig "fscknudge") True + , annexAutoUpgrade = toAutoUpgrade $ + getmaybe (annexConfig "autoupgrade") , annexExpireUnused = maybe Nothing Just . parseDuration - <$> getmaybe (annex "expireunused") - , annexSecureEraseCommand = getmaybe (annex "secure-erase-command") - , annexGenMetaData = getbool (annex "genmetadata") False - , annexListen = getmaybe (annex "listen") - , annexStartupScan = getbool (annex "startupscan") True - , annexHardLink = getbool (annex "hardlink") False - , annexThin = getbool (annex "thin") False + <$> getmaybe (annexConfig "expireunused") + , annexSecureEraseCommand = getmaybe (annexConfig "secure-erase-command") + , annexGenMetaData = getbool (annexConfig "genmetadata") False + , annexListen = getmaybe (annexConfig "listen") + , annexStartupScan = getbool (annexConfig "startupscan") True + , annexHardLink = getbool (annexConfig "hardlink") False + , annexThin = getbool (annexConfig "thin") False , annexDifferences = getDifferences r , annexUsedRefSpec = either (const Nothing) Just . parseRefSpec - =<< getmaybe (annex "used-refspec") - , annexVerify = getbool (annex "verify") True - , annexPidLock = getbool (annex "pidlock") False + =<< getmaybe (annexConfig "used-refspec") + , annexVerify = getbool (annexConfig "verify") True + , annexPidLock = getbool (annexConfig "pidlock") False , annexPidLockTimeout = Seconds $ fromMaybe 300 $ - getmayberead (annex "pidlocktimeout") + getmayberead (annexConfig "pidlocktimeout") , annexAddUnlocked = configurable Nothing $ - fmap Just $ getmaybe (annex "addunlocked") - , annexSecureHashesOnly = getbool (annex "securehashesonly") False - , annexRetry = getmayberead (annex "retry") + fmap Just $ getmaybe (annexConfig "addunlocked") + , annexSecureHashesOnly = getbool (annexConfig "securehashesonly") False + , annexRetry = getmayberead (annexConfig "retry") , annexRetryDelay = Seconds - <$> getmayberead (annex "retrydelay") + <$> getmayberead (annexConfig "retrydelay") , annexAllowedUrlSchemes = S.fromList $ map mkScheme $ maybe ["http", "https", "ftp"] words $ - getmaybe (annex "security.allowed-url-schemes") + getmaybe (annexConfig "security.allowed-url-schemes") , annexAllowedIPAddresses = fromMaybe "" $ - getmaybe (annex "security.allowed-ip-addresses") + getmaybe (annexConfig "security.allowed-ip-addresses") <|> - getmaybe (annex "security.allowed-http-addresses") -- old name + getmaybe (annexConfig "security.allowed-http-addresses") -- old name , annexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ - getmaybe (annex "security.allow-unverified-downloads") - , annexMaxExtensionLength = getmayberead (annex "maxextensionlength") + getmaybe (annexConfig "security.allow-unverified-downloads") + , annexMaxExtensionLength = getmayberead (annexConfig "maxextensionlength") , annexJobs = fromMaybe NonConcurrent $ - parseConcurrency =<< getmaybe (annex "jobs") - , annexCacheCreds = getbool (annex "cachecreds") True - , annexAutoUpgradeRepository = getbool (annex "autoupgraderepository") True - , annexCommitMode = if getbool (annex "allowsign") False + parseConcurrency =<< getmaybe (annexConfig "jobs") + , annexCacheCreds = getbool (annexConfig "cachecreds") True + , annexAutoUpgradeRepository = getbool (annexConfig "autoupgraderepository") True + , annexCommitMode = if getbool (annexConfig "allowsign") False then ManualCommit else AutomaticCommit , coreSymlinks = getbool "core.symlinks" True @@ -225,8 +234,6 @@ FromGitConfig -> HasGitConfig v FromGlobalConfig -> HasGlobalConfig v - annex k = ConfigKey $ "annex." <> k - onemegabyte = 1000000 {- Merge a GitConfig that comes from git-config with one containing @@ -249,6 +256,18 @@ _ -> HasGitConfig d HasGlobalConfig v -> HasGlobalConfig v +{- Configs that can be set repository-global. -} +globalConfigs :: [ConfigKey] +globalConfigs = + [ annexConfig "autocommit" + , annexConfig "synccontent" + , annexConfig "synconlyannex" + , annexConfig "resolvemerge" + , annexConfig "largefiles" + , annexConfig "dotfiles" + , annexConfig "addunlocked" + ] + {- Per-remote git-annex settings. Each setting corresponds to a git-config - key such as .annex-foo, or if that is not set, a default from - annex.foo. @@ -366,14 +385,10 @@ getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k getmayberead k = readish =<< getmaybe k getmaybe = fmap fromConfigValue . getmaybe' - getmaybe' k = mplus (Git.Config.getMaybe (key k) r) - (Git.Config.getMaybe (remotekey k) r) + getmaybe' k = mplus (Git.Config.getMaybe (annexConfig k) r) + (Git.Config.getMaybe (remoteAnnexConfig remotename k) r) getoptions k = fromMaybe [] $ words <$> getmaybe k - key k = ConfigKey $ "annex." <> k - remotekey k = ConfigKey $ - "remote." <> encodeBS' remotename <> ".annex-" <> k - notempty :: Maybe String -> Maybe String notempty Nothing = Nothing notempty (Just "") = Nothing @@ -382,3 +397,27 @@ dummyRemoteGitConfig :: IO RemoteGitConfig dummyRemoteGitConfig = atomically $ extractRemoteGitConfig Git.Construct.fromUnknown "dummy" + +type UnqualifiedConfigKey = B.ByteString + +{- A global annex setting in git config. -} +annexConfig :: UnqualifiedConfigKey -> ConfigKey +annexConfig key = ConfigKey ("annex." <> key) + +class RemoteNameable r where + getRemoteName :: r -> RemoteName + +instance RemoteNameable Git.Repo where + getRemoteName r = fromMaybe "" (Git.remoteName r) + +instance RemoteNameable RemoteName where + getRemoteName = id + +{- A per-remote annex setting in git config. -} +remoteAnnexConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey +remoteAnnexConfig r key = remoteConfig r ("annex-" <> key) + +{- A per-remote setting in git config. -} +remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey +remoteConfig r key = ConfigKey $ + "remote." <> encodeBS' (getRemoteName r) <> "." <> key diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -153,6 +153,9 @@ , remoteStateHandle :: RemoteStateHandle } +instance RemoteNameable (RemoteA a) where + getRemoteName = name + instance Show (RemoteA a) where show remote = "Remote { name =\"" ++ name remote ++ "\" }" diff --git a/Types/RemoteConfig.hs b/Types/RemoteConfig.hs --- a/Types/RemoteConfig.hs +++ b/Types/RemoteConfig.hs @@ -23,8 +23,9 @@ {- Before being used a RemoteConfig has to be parsed. -} data ParsedRemoteConfig = ParsedRemoteConfig - (M.Map RemoteConfigField RemoteConfigValue) - RemoteConfig + { parsedRemoteConfigMap :: M.Map RemoteConfigField RemoteConfigValue + , unparsedRemoteConfig :: RemoteConfig + } {- Remotes can have configuration values of many types, so use Typeable - to let them all be stored in here. -} diff --git a/Upgrade.hs b/Upgrade.hs --- a/Upgrade.hs +++ b/Upgrade.hs @@ -1,6 +1,6 @@ {- git-annex upgrade support - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,6 +12,8 @@ import Annex.Common import qualified Annex import qualified Git +import Config +import Config.Files import Annex.Version import Types.RepoVersion #ifndef mingw32_HOST_OS @@ -61,18 +63,26 @@ upgrade :: Bool -> RepoVersion -> Annex Bool upgrade automatic destversion = do upgraded <- go =<< getVersion - when upgraded $ - setVersion destversion + when upgraded + postupgrade return upgraded where go (Just v) | v >= destversion = return True - | otherwise = ifM (up v) - ( go (Just (RepoVersion (fromRepoVersion v + 1))) - , return False + | otherwise = ifM upgradingRemote + ( upgraderemote + , ifM (up v) + ( go (Just (RepoVersion (fromRepoVersion v + 1))) + , return False + ) ) go _ = return True + postupgrade = ifM upgradingRemote + ( reloadConfig + , setVersion destversion + ) + #ifndef mingw32_HOST_OS up (RepoVersion 0) = Upgrade.V0.upgrade up (RepoVersion 1) = Upgrade.V1.upgrade @@ -87,3 +97,19 @@ up (RepoVersion 6) = Upgrade.V6.upgrade automatic up (RepoVersion 7) = Upgrade.V7.upgrade automatic up _ = return True + + -- Upgrade local remotes by running git-annex upgrade in them. + -- This avoids complicating the upgrade code by needing to handle + -- upgrading a git repo other than the current repo. + upgraderemote = do + rp <- fromRawFilePath <$> fromRepo Git.repoPath + cmd <- liftIO readProgramFile + liftIO $ boolSystem' cmd + [ Param "upgrade" + , Param "--quiet" + , Param "--autoonly" + ] + (\p -> p { cwd = Just rp }) + +upgradingRemote :: Annex Bool +upgradingRemote = isJust <$> fromRepo Git.remoteName diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -17,6 +17,7 @@ import Annex.Common import Annex.Content import Annex.Link +import Annex.Perms import Types.Key import Logs.Presence import qualified Annex.Queue @@ -115,7 +116,7 @@ dest <- fromRepo $ logFile2 k dir <- fromRepo Upgrade.V2.gitStateDir let f = dir l - liftIO $ createDirectoryIfMissing True (parentDir dest) + createWorkTreeDirectory (parentDir dest) -- could just git mv, but this way deals with -- log files that are not checked into git, -- as well as merging with already upgraded diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -10,7 +10,6 @@ module Upgrade.V5 where import Annex.Common -import qualified Annex import Config import Config.Smudge import Annex.InodeSentinal @@ -84,7 +83,6 @@ - space, with less preservation of old versions of files - as does annex.thin. -} setConfig (annexConfig "thin") (boolConfig True) - Annex.changeGitConfig $ \c -> c { annexThin = True } Direct.setIndirect cur <- fromMaybe (error "Somehow no branch is checked out") <$> inRepo Git.Branch.current diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -19,7 +19,6 @@ ) where import Annex.Common -import qualified Annex import qualified Git import qualified Git.Config import qualified Git.Ref @@ -35,7 +34,6 @@ setbare switchHEADBack setConfig (annexConfig "direct") val - Annex.changeGitConfig $ \c -> c { annexDirect = False } where val = Git.Config.boolConfig False coreworktree = ConfigKey "core.worktree" diff --git a/Upgrade/V7.hs b/Upgrade/V7.hs --- a/Upgrade/V7.hs +++ b/Upgrade/V7.hs @@ -101,7 +101,7 @@ (l, cleanup) <- inRepo $ LsFiles.inodeCaches [top] forM_ l $ \case (_f, Nothing) -> giveup "Unable to parse git ls-files --debug output while upgrading git-annex sqlite databases." - (f, Just ic) -> unlessM (liftIO $ isSymbolicLink <$> getSymbolicLinkStatus f) $ do + (f, Just ic) -> unlessM (liftIO $ catchBoolIO $ isSymbolicLink <$> getSymbolicLinkStatus f) $ do catKeyFile (toRawFilePath f) >>= \case Nothing -> noop Just k -> do diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -90,7 +90,6 @@ - Fails if the pid file is already locked by another process. -} lockPidFile :: FilePath -> IO () lockPidFile pidfile = do - createDirectoryIfMissing True (parentDir pidfile) #ifndef mingw32_HOST_OS fd <- openFd pidfile ReadWrite (Just stdFileMode) defaultFileFlags locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,11 +1,12 @@ {- directory traversal and manipulation - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2020 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory ( @@ -18,7 +19,9 @@ import System.FilePath import System.PosixCompat.Files import Control.Applicative +import Control.Monad.IO.Class import System.IO.Unsafe (unsafeInterleaveIO) +import System.IO.Error import Data.Maybe import Prelude @@ -28,10 +31,12 @@ #endif import Utility.SystemDirectory +import Utility.Path import Utility.Tmp import Utility.Exception import Utility.Monad import Utility.Applicative +import Utility.PartialPrelude dirCruft :: FilePath -> Bool dirCruft "." = True @@ -154,3 +159,74 @@ #else go = removeFile file #endif + +{- Like createDirectoryIfMissing True, but it will only create + - missing parent directories up to but not including the directory + - in the first parameter. + - + - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz" + - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist, + - it will throw an exception. + - + - The exception thrown is the same that createDirectory throws if the + - parent directory does not exist. + - + - If the second FilePath is not under the first + - FilePath (or the same as it), it will fail with an exception + - even if the second FilePath's parent directory already exists. + - + - Either or both of the FilePaths can be relative, or absolute. + - They will be normalized as necessary. + - + - Note that, the second FilePath, if relative, is relative to the current + - working directory, not to the first FilePath. + -} +createDirectoryUnder :: FilePath -> FilePath -> IO () +createDirectoryUnder topdir dir = + createDirectoryUnder' topdir dir createDirectory + +createDirectoryUnder' + :: (MonadIO m, MonadCatch m) + => FilePath + -> FilePath + -> (FilePath -> m ()) + -> m () +createDirectoryUnder' topdir dir0 mkdir = do + p <- liftIO $ relPathDirToFile topdir dir0 + let dirs = splitDirectories p + -- Catch cases where the dir is not beneath the topdir. + -- If the relative path between them starts with "..", + -- it's not. And on Windows, if they are on different drives, + -- the path will not be relative. + if headMaybe dirs == Just ".." || isAbsolute p + then liftIO $ ioError $ customerror userErrorType + ("createDirectoryFrom: not located in " ++ topdir) + -- If dir0 is the same as the topdir, don't try to create + -- it, but make sure it does exist. + else if null dirs + then liftIO $ unlessM (doesDirectoryExist topdir) $ + ioError $ customerror doesNotExistErrorType + "createDirectoryFrom: does not exist" + else createdirs $ + map (topdir ) (reverse (scanl1 () dirs)) + where + customerror t s = mkIOError t s Nothing (Just dir0) + + createdirs [] = pure () + createdirs (dir:[]) = createdir dir (liftIO . ioError) + createdirs (dir:dirs) = createdir dir $ \_ -> do + createdirs dirs + createdir dir (liftIO . ioError) + + -- This is the same method used by createDirectoryIfMissing, + -- in particular the handling of errors that occur when the + -- directory already exists. See its source for explanation + -- of several subtleties. + createdir dir notexisthandler = tryIO (mkdir dir) >>= \case + Right () -> pure () + Left e + | isDoesNotExistError e -> notexisthandler e + | isAlreadyExistsError e || isPermissionError e -> + liftIO $ unlessM (doesDirectoryExist dir) $ + ioError e + | otherwise -> liftIO $ ioError e diff --git a/Utility/Hash.hs b/Utility/Hash.hs --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -25,10 +25,10 @@ blake2bp_512, md5, md5s, - prop_hashes_stable, + props_hashes_stable, Mac(..), calcMac, - prop_mac_stable, + props_macs_stable, ) where import qualified Data.ByteString as S @@ -111,31 +111,31 @@ md5s = hash {- Check that all the hashes continue to hash the same. -} -prop_hashes_stable :: Bool -prop_hashes_stable = all (\(hasher, result) -> hasher foo == result) - [ (show . sha1, "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33") - , (show . sha2_224, "0808f64e60d58979fcb676c96ec938270dea42445aeefcd3a4e6f8db") - , (show . sha2_256, "2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae") - , (show . sha2_384, "98c11ffdfdd540676b1a137cb1a22b2a70350c9a44171d6b1180c6be5cbb2ee3f79d532c8a1dd9ef2e8e08e752a3babb") - , (show . sha2_512, "f7fbba6e0636f890e56fbbf3283e524c6fa3204ae298382d624741d0dc6638326e282c41be5e4254d8820772c5518a2c5a8c0c7f7eda19594a7eb539453e1ed7") - , (show . skein256, "a04efd9a0aeed6ede40fe5ce0d9361ae7b7d88b524aa19917b9315f1ecf00d33") - , (show . skein512, "fd8956898113510180aa4658e6c0ac85bd74fb47f4a4ba264a6b705d7a8e8526756e75aecda12cff4f1aca1a4c2830fbf57f458012a66b2b15a3dd7d251690a7") - , (show . sha3_224, "f4f6779e153c391bbd29c95e72b0708e39d9166c7cea51d1f10ef58a") - , (show . sha3_256, "76d3bc41c9f588f7fcd0d5bf4718f8f84b1c41b20882703100b9eb9413807c01") - , (show . sha3_384, "665551928d13b7d84ee02734502b018d896a0fb87eed5adb4c87ba91bbd6489410e11b0fbcc06ed7d0ebad559e5d3bb5") - , (show . sha3_512, "4bca2b137edc580fe50a88983ef860ebaca36c857b1f492839d6d7392452a63c82cbebc68e3b70a2a1480b4bb5d437a7cba6ecf9d89f9ff3ccd14cd6146ea7e7") - , (show . blake2s_160, "52fb63154f958a5c56864597273ea759e52c6f00") - , (show . blake2s_224, "9466668503ac415d87b8e1dfd7f348ab273ac1d5e4f774fced5fdb55") - , (show . blake2s_256, "08d6cad88075de8f192db097573d0e829411cd91eb6ec65e8fc16c017edfdb74") - , (show . blake2sp_224, "8492d356fbac99f046f55e114301f7596649cb590e5b083d1a19dcdb") - , (show . blake2sp_256, "050dc5786037ea72cb9ed9d0324afcab03c97ec02e8c47368fc5dfb4cf49d8c9") - , (show . blake2b_160, "983ceba2afea8694cc933336b27b907f90c53a88") - , (show . blake2b_224, "853986b3fe231d795261b4fb530e1a9188db41e460ec4ca59aafef78") - , (show . blake2b_256, "b8fe9f7f6255a6fa08f668ab632a8d081ad87983c77cd274e48ce450f0b349fd") - , (show . blake2b_384, "e629ee880953d32c8877e479e3b4cb0a4c9d5805e2b34c675b5a5863c4ad7d64bb2a9b8257fac9d82d289b3d39eb9cc2") - , (show . blake2b_512, "ca002330e69d3e6b84a46a56a6533fd79d51d97a3bb7cad6c2ff43b354185d6dc1e723fb3db4ae0737e120378424c714bb982d9dc5bbd7a0ab318240ddd18f8d") - , (show . blake2bp_512, "8ca9ccee7946afcb686fe7556628b5ba1bf9a691da37ca58cd049354d99f37042c007427e5f219b9ab5063707ec6823872dee413ee014b4d02f2ebb6abb5f643") - , (show . md5, "acbd18db4cc2f85cedef654fccc4a4d8") +props_hashes_stable :: [(String, Bool)] +props_hashes_stable = map (\(desc, hasher, result) -> (desc ++ " stable", hasher foo == result)) + [ ("sha1", show . sha1, "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33") + , ("sha2_224", show . sha2_224, "0808f64e60d58979fcb676c96ec938270dea42445aeefcd3a4e6f8db") + , ("sha2_256", show . sha2_256, "2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae") + , ("sha2_384", show . sha2_384, "98c11ffdfdd540676b1a137cb1a22b2a70350c9a44171d6b1180c6be5cbb2ee3f79d532c8a1dd9ef2e8e08e752a3babb") + , ("sha2_512", show . sha2_512, "f7fbba6e0636f890e56fbbf3283e524c6fa3204ae298382d624741d0dc6638326e282c41be5e4254d8820772c5518a2c5a8c0c7f7eda19594a7eb539453e1ed7") + , ("skein256", show . skein256, "a04efd9a0aeed6ede40fe5ce0d9361ae7b7d88b524aa19917b9315f1ecf00d33") + , ("skein512", show . skein512, "fd8956898113510180aa4658e6c0ac85bd74fb47f4a4ba264a6b705d7a8e8526756e75aecda12cff4f1aca1a4c2830fbf57f458012a66b2b15a3dd7d251690a7") + , ("sha3_224", show . sha3_224, "f4f6779e153c391bbd29c95e72b0708e39d9166c7cea51d1f10ef58a") + , ("sha3_256", show . sha3_256, "76d3bc41c9f588f7fcd0d5bf4718f8f84b1c41b20882703100b9eb9413807c01") + , ("sha3_384", show . sha3_384, "665551928d13b7d84ee02734502b018d896a0fb87eed5adb4c87ba91bbd6489410e11b0fbcc06ed7d0ebad559e5d3bb5") + , ("sha3_512", show . sha3_512, "4bca2b137edc580fe50a88983ef860ebaca36c857b1f492839d6d7392452a63c82cbebc68e3b70a2a1480b4bb5d437a7cba6ecf9d89f9ff3ccd14cd6146ea7e7") + , ("blake2s_160", show . blake2s_160, "52fb63154f958a5c56864597273ea759e52c6f00") + , ("blake2s_224", show . blake2s_224, "9466668503ac415d87b8e1dfd7f348ab273ac1d5e4f774fced5fdb55") + , ("blake2s_256", show . blake2s_256, "08d6cad88075de8f192db097573d0e829411cd91eb6ec65e8fc16c017edfdb74") + , ("blake2sp_224", show . blake2sp_224, "8492d356fbac99f046f55e114301f7596649cb590e5b083d1a19dcdb") + , ("blake2sp_256", show . blake2sp_256, "050dc5786037ea72cb9ed9d0324afcab03c97ec02e8c47368fc5dfb4cf49d8c9") + , ("blake2b_160", show . blake2b_160, "983ceba2afea8694cc933336b27b907f90c53a88") + , ("blake2b_224", show . blake2b_224, "853986b3fe231d795261b4fb530e1a9188db41e460ec4ca59aafef78") + , ("blake2b_256", show . blake2b_256, "b8fe9f7f6255a6fa08f668ab632a8d081ad87983c77cd274e48ce450f0b349fd") + , ("blake2b_384", show . blake2b_384, "e629ee880953d32c8877e479e3b4cb0a4c9d5805e2b34c675b5a5863c4ad7d64bb2a9b8257fac9d82d289b3d39eb9cc2") + , ("blake2b_512", show . blake2b_512, "ca002330e69d3e6b84a46a56a6533fd79d51d97a3bb7cad6c2ff43b354185d6dc1e723fb3db4ae0737e120378424c714bb982d9dc5bbd7a0ab318240ddd18f8d") + , ("blake2bp_512", show . blake2bp_512, "8ca9ccee7946afcb686fe7556628b5ba1bf9a691da37ca58cd049354d99f37042c007427e5f219b9ab5063707ec6823872dee413ee014b4d02f2ebb6abb5f643") + , ("md5", show . md5, "acbd18db4cc2f85cedef654fccc4a4d8") ] where foo = L.fromChunks [T.encodeUtf8 $ T.pack "foo"] @@ -165,13 +165,13 @@ hmacWitnessAlg _ = hmac -- Check that all the MACs continue to produce the same. -prop_mac_stable :: Bool -prop_mac_stable = all (\(mac, result) -> calcMac mac key msg == result) - [ (HmacSha1, "46b4ec586117154dacd49d664e5d63fdc88efb51") - , (HmacSha224, "4c1f774863acb63b7f6e9daa9b5c543fa0d5eccf61e3ffc3698eacdd") - , (HmacSha256, "f9320baf0249169e73850cd6156ded0106e2bb6ad8cab01b7bbbebe6d1065317") - , (HmacSha384, "3d10d391bee2364df2c55cf605759373e1b5a4ca9355d8f3fe42970471eca2e422a79271a0e857a69923839015877fc6") - , (HmacSha512, "114682914c5d017dfe59fdc804118b56a3a652a0b8870759cf9e792ed7426b08197076bf7d01640b1b0684df79e4b67e37485669e8ce98dbab60445f0db94fce") +props_macs_stable :: [(String, Bool)] +props_macs_stable = map (\(desc, mac, result) -> (desc ++ " stable", calcMac mac key msg == result)) + [ ("HmacSha1", HmacSha1, "46b4ec586117154dacd49d664e5d63fdc88efb51") + , ("HmacSha224", HmacSha224, "4c1f774863acb63b7f6e9daa9b5c543fa0d5eccf61e3ffc3698eacdd") + , ("HmacSha256", HmacSha256, "f9320baf0249169e73850cd6156ded0106e2bb6ad8cab01b7bbbebe6d1065317") + , ("HmacSha384", HmacSha384, "3d10d391bee2364df2c55cf605759373e1b5a4ca9355d8f3fe42970471eca2e422a79271a0e857a69923839015877fc6") + , ("HmacSha512", HmacSha512, "114682914c5d017dfe59fdc804118b56a3a652a0b8870759cf9e792ed7426b08197076bf7d01640b1b0684df79e4b67e37485669e8ce98dbab60445f0db94fce") ] where key = T.encodeUtf8 $ T.pack "foo" diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -19,6 +19,7 @@ import Utility.PartialPrelude import Utility.QuickCheck +import Control.Monad.Fail as Fail (MonadFail(..)) import qualified Data.Map as M import Data.Time.Clock import Data.Time.Clock.POSIX (POSIXTime) @@ -44,7 +45,7 @@ daysToDuration i = Duration $ i * dsecs {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} -parseDuration :: Monad m => String -> m Duration +parseDuration :: MonadFail m => String -> m Duration parseDuration = maybe parsefail (return . Duration) . go 0 where go n [] = return n @@ -55,7 +56,7 @@ u <- M.lookup c unitmap go (n + num * u) rest _ -> return $ n + num - parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\"" + parsefail = Fail.fail "duration parse error; expected eg \"5m\" or \"1h5m\"" fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -41,7 +41,7 @@ import Utility.Monad import Utility.UserInfo -import Utility.Directory +import Utility.SystemDirectory import Utility.Split import Utility.FileSystemEncoding @@ -74,6 +74,8 @@ {- Makes a path absolute. - + - Also simplifies it using simplifyPath. + - - The first parameter is a base directory (ie, the cwd) to use if the path - is not already absolute, and should itsef be absolute. - @@ -124,12 +126,19 @@ {- Converts a filename into an absolute path. - + - Also simplifies it using simplifyPath. + - - Unlike Directory.canonicalizePath, this does not require the path - already exists. -} absPath :: FilePath -> IO FilePath -absPath file = do - cwd <- getCurrentDirectory - return $ absPathFrom cwd file +absPath file + -- Avoid unncessarily getting the current directory when the path + -- is already absolute. absPathFrom uses simplifyPath + -- so also used here for consistency. + | isAbsolute file = return $ simplifyPath file + | otherwise = do + cwd <- getCurrentDirectory + return $ absPathFrom cwd file {- Constructs a relative path from the CWD to a file. - diff --git a/doc/git-annex-upgrade.mdwn b/doc/git-annex-upgrade.mdwn --- a/doc/git-annex-upgrade.mdwn +++ b/doc/git-annex-upgrade.mdwn @@ -8,7 +8,7 @@ # DESCRIPTION -Upgrades the repository. +Upgrades the repository to the latest version. Each git-annex repository has an annex.version in its git configuration, that indicates the repository version. When an old repository version @@ -23,6 +23,13 @@ was only used by its author. It's expected that git-annex will always support upgrading from all past repository versions -- this is necessary to allow archives to be taken offline for years and later used. + +# OPTIONS + +* --autoonly + + Only do whatever automatic upgrade can be done, don't necessarily + upgrade to the latest version. This is used internally by git-annex. # SEE ALSO diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 8.20200226 +Version: 8.20200309 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -15,16 +15,13 @@ packages: - '.' extra-deps: -- IfElse-0.85 -- aws-0.21.1 -- bloomfilter-2.0.1.0 -- tasty-1.1.0.4 -- tasty-rerun-1.1.13 -- torrent-10000.1.1 -- sandi-0.5 -- http-client-0.5.14 -- silently-1.2.5.1 -- filepath-bytestring-1.4.2.1.1 + - IfElse-0.85 + - aws-0.21.1 + - bloomfilter-2.0.1.0 + - filepath-bytestring-1.4.2.1.6 + - sandi-0.5 + - tasty-rerun-1.1.17 + - torrent-10000.1.1 explicit-setup-deps: git-annex: true -resolver: lts-13.29 +resolver: lts-14.27