diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns, PackageImports #-} module Annex ( Annex, diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -162,7 +162,7 @@ -- Avoid catting large files, that cannot be symlinks or -- pointer files, which would require buffering their -- content in memory, as well as a lot of IO. - | sz <= maxPointerSz = + | sz <= fromIntegral maxPointerSz = parseLinkTargetOrPointer . L.toStrict <$> catObject ref catKey' _ _ = return Nothing diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -598,6 +598,14 @@ cleanObjectLoc key cleaner = do file <- calcRepo (gitAnnexLocation key) void $ tryIO $ thawContentDir file + {- Thawing is not necessary when the file was frozen only + - by removing write perms. But if there is a thaw hook, it may do + - something else that is necessary to allow the file to be + - deleted. + -} + whenM hasThawHook $ + void $ tryIO $ thawContent file + cleaner liftIO $ cleanObjectDirs file @@ -623,15 +631,16 @@ where -- Check associated pointer file for modifications, and reset if -- it's unmodified. - resetpointer file = ifM (isUnmodified key file) - ( adjustedBranchRefresh (AssociatedFile (Just file)) $ - depopulatePointerFile key file - -- Modified file, so leave it alone. - -- If it was a hard link to the annex object, - -- that object might have been frozen as part of the - -- removal process, so thaw it. - , void $ tryIO $ thawContent file - ) + resetpointer file = unlessM (liftIO $ isSymbolicLink <$> getSymbolicLinkStatus (fromRawFilePath file)) $ + ifM (isUnmodified key file) + ( adjustedBranchRefresh (AssociatedFile (Just file)) $ + depopulatePointerFile key file + -- Modified file, so leave it alone. + -- If it was a hard link to the annex object, + -- that object might have been frozen as part of the + -- removal process, so thaw it. + , void $ tryIO $ thawContent file + ) {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and - returns the file it was moved to. -} diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -251,6 +251,7 @@ (r, warnings) <- probeCrippledFileSystem' tmp (Just (freezeContent' UnShared)) (Just (thawContent' UnShared)) + =<< hasFreezeHook mapM_ warning warnings return r @@ -259,11 +260,12 @@ => RawFilePath -> Maybe (RawFilePath -> m ()) -> Maybe (RawFilePath -> m ()) + -> Bool -> m (Bool, [String]) #ifdef mingw32_HOST_OS -probeCrippledFileSystem' _ _ _ = return (True, []) +probeCrippledFileSystem' _ _ _ _ = return (True, []) #else -probeCrippledFileSystem' tmp freezecontent thawcontent = do +probeCrippledFileSystem' tmp freezecontent thawcontent hasfreezehook = do let f = tmp P. "gaprobe" let f' = fromRawFilePath f liftIO $ writeFile f' "" @@ -282,7 +284,7 @@ -- running as root). But some crippled -- filesystems ignore write bit removals or ignore -- permissions entirely. - ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f) Nothing)) + ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f) Nothing hasfreezehook)) ( return (True, ["Filesystem does not allow removing write bit from files."]) , liftIO $ ifM ((== 0) <$> getRealUserID) ( return (False, []) diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -7,7 +7,7 @@ - - Pointer files are used instead of symlinks for unlocked files. - - - Copyright 2013-2021 Joey Hess + - Copyright 2013-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -82,10 +82,10 @@ probesymlink = R.readSymbolicLink file probefilecontent = withFile (fromRawFilePath file) ReadMode $ \h -> do - s <- S.hGet h unpaddedMaxPointerSz + s <- S.hGet h maxSymlinkSz -- If we got the full amount, the file is too large -- to be a symlink target. - return $ if S.length s == unpaddedMaxPointerSz + return $ if S.length s == maxSymlinkSz then mempty else -- If there are any NUL or newline @@ -295,33 +295,70 @@ , "git update-index -q --refresh " ++ fromMaybe "" mf ] -{- Parses a symlink target or a pointer file to a Key. -} +{- Parses a symlink target or a pointer file to a Key. + - + - Makes sure that the pointer file is valid, including not being longer + - than the maximum allowed size of a valid pointer file, and that any + - subsequent lines after the first contain the validPointerLineTag. + - If a valid pointer file gets some other data appended to it, it should + - never be considered valid, unless that data happened to itself be a + - valid pointer file. + -} parseLinkTargetOrPointer :: S.ByteString -> Maybe Key -parseLinkTargetOrPointer = parseLinkTarget . S8.takeWhile (not . lineend) - where - lineend '\n' = True - lineend '\r' = True - lineend _ = False +parseLinkTargetOrPointer = either (const Nothing) id + . parseLinkTargetOrPointer' -{- Avoid looking at more of the lazy ByteString than necessary since it - - could be reading from a large file that is not a pointer file. -} -parseLinkTargetOrPointerLazy :: L.ByteString -> Maybe Key -parseLinkTargetOrPointerLazy b = - let b' = L.take (fromIntegral maxPointerSz) b - in parseLinkTargetOrPointer (L.toStrict b') +data InvalidAppendedPointerFile = InvalidAppendedPointerFile -{- Parses a symlink target to a Key. -} -parseLinkTarget :: S.ByteString -> Maybe Key -parseLinkTarget l - | isLinkToAnnex l = fileKey $ snd $ S8.breakEnd pathsep l - | otherwise = Nothing +parseLinkTargetOrPointer' :: S.ByteString -> Either InvalidAppendedPointerFile (Maybe Key) +parseLinkTargetOrPointer' b = + let (firstline, rest) = S8.span (/= '\n') b + in case parsekey $ droptrailing '\r' firstline of + Just k + | S.length b > maxValidPointerSz -> Left InvalidAppendedPointerFile + | restvalid (dropleading '\n' rest) -> Right (Just k) + | otherwise -> Left InvalidAppendedPointerFile + Nothing -> Right Nothing where + parsekey l + | isLinkToAnnex l = fileKey $ snd $ S8.breakEnd pathsep l + | otherwise = Nothing + + restvalid r + | S.null r = True + | otherwise = + let (l, r') = S8.span (/= '\n') r + in validPointerLineTag `S.isInfixOf` l + && (not (S8.null r') && S8.head r' == '\n') + && restvalid (S8.tail r') + + dropleading c l + | S.null l = l + | S8.head l == c = S8.tail l + | otherwise = l + + droptrailing c l + | S.null l = l + | S8.last l == c = S8.init l + | otherwise = l + pathsep '/' = True #ifdef mingw32_HOST_OS pathsep '\\' = True #endif pathsep _ = False +{- Avoid looking at more of the lazy ByteString than necessary since it + - could be reading from a large file that is not a pointer file. -} +parseLinkTargetOrPointerLazy :: L.ByteString -> Maybe Key +parseLinkTargetOrPointerLazy = either (const Nothing) id + . parseLinkTargetOrPointerLazy' + +parseLinkTargetOrPointerLazy' :: L.ByteString -> Either InvalidAppendedPointerFile (Maybe Key) +parseLinkTargetOrPointerLazy' b = + let b' = L.take (fromIntegral maxPointerSz) b + in parseLinkTargetOrPointer' (L.toStrict b') + formatPointer :: Key -> S.ByteString formatPointer k = prefix <> keyFile k <> nl where @@ -333,14 +370,22 @@ - memory when reading files that may be pointers. - - 8192 bytes is plenty for a pointer to a key. This adds some additional - - padding to allow for any pointer files that might have - - lines after the key explaining what the file is used for. -} -maxPointerSz :: Integer -maxPointerSz = 81920 + - padding to allow for pointer files that have lines of additional data + - after the key. + - + - One additional byte is used to detect when a valid pointer file + - got something else appended to it. + -} +maxPointerSz :: Int +maxPointerSz = maxValidPointerSz + 1 -unpaddedMaxPointerSz :: Int -unpaddedMaxPointerSz = 8192 +{- Maximum size of a valid pointer files is 32kb. -} +maxValidPointerSz :: Int +maxValidPointerSz = 32768 +maxSymlinkSz :: Int +maxSymlinkSz = 8192 + {- Checks if a worktree file is a pointer to a key. - - Unlocked files whose content is present are not detected by this. @@ -369,7 +414,7 @@ where checkcontentfollowssymlinks = withFile (fromRawFilePath f) ReadMode readhandle - readhandle h = parseLinkTargetOrPointer <$> S.hGet h unpaddedMaxPointerSz + readhandle h = parseLinkTargetOrPointer <$> S.hGet h maxPointerSz {- Checks a symlink target or pointer file first line to see if it - appears to point to annexed content. @@ -389,3 +434,7 @@ #ifdef mingw32_HOST_OS p' = toInternalGitPath p #endif + +{- String that must appear on every line of a valid pointer file. -} +validPointerLineTag :: S.ByteString +validPointerLineTag = "/annex/" diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Perms ( FileMode, setAnnexFilePerm, @@ -26,6 +28,8 @@ thawContentDir, modifyContent, withShared, + hasFreezeHook, + hasThawHook, ) where import Annex.Common @@ -154,6 +158,7 @@ freezeContent'' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Annex () freezeContent'' sr file rv = do + fastDebug "Annex.Perms" ("freezing content " ++ fromRawFilePath file) go sr freezeHook file where @@ -183,26 +188,35 @@ - permissions of a file owned by another user. So if the permissions seem - wrong, but the repository is shared, returns Nothing. If the permissions - are wrong otherwise, returns Just False. + - + - When there is a freeze hook, it may prevent write in some way other than + - permissions. One use of a freeze hook is when the filesystem does not + - support removing write permissions, so when there is such a hook + - write permissions are ignored. -} checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool) checkContentWritePerm file = ifM crippledFileSystem ( return (Just True) , do rv <- getVersion - withShared (\sr -> liftIO (checkContentWritePerm' sr file rv)) + hasfreezehook <- hasFreezeHook + withShared $ \sr -> liftIO $ + checkContentWritePerm' sr file rv hasfreezehook ) -checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> IO (Maybe Bool) -checkContentWritePerm' sr file rv = case sr of - GroupShared - | versionNeedsWritableContentFiles rv -> want sharedret - (includemodes [ownerWriteMode, groupWriteMode]) - | otherwise -> want sharedret (excludemodes writeModes) - AllShared - | versionNeedsWritableContentFiles rv -> - want sharedret (includemodes writeModes) - | otherwise -> want sharedret (excludemodes writeModes) - _ -> want Just (excludemodes writeModes) +checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool) +checkContentWritePerm' sr file rv hasfreezehook + | hasfreezehook = return (Just True) + | otherwise = case sr of + GroupShared + | versionNeedsWritableContentFiles rv -> want sharedret + (includemodes [ownerWriteMode, groupWriteMode]) + | otherwise -> want sharedret (excludemodes writeModes) + AllShared + | versionNeedsWritableContentFiles rv -> + want sharedret (includemodes writeModes) + | otherwise -> want sharedret (excludemodes writeModes) + _ -> want Just (excludemodes writeModes) where want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file) >>= return . \case @@ -221,7 +235,9 @@ thawContent file = withShared $ \sr -> thawContent' sr file thawContent' :: SharedRepository -> RawFilePath -> Annex () -thawContent' sr file = thawPerms (go sr) (thawHook file) +thawContent' sr file = do + fastDebug "Annex.Perms" ("thawing content " ++ fromRawFilePath file) + thawPerms (go sr) (thawHook file) where go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file go AllShared = liftIO $ void $ tryIO $ groupWriteRead file @@ -244,6 +260,7 @@ -} freezeContentDir :: RawFilePath -> Annex () freezeContentDir file = unlessM crippledFileSystem $ do + fastDebug "Annex.Perms" ("freezing content directory " ++ fromRawFilePath dir) withShared go freezeHook dir where @@ -253,7 +270,9 @@ go _ = liftIO $ preventWrite dir thawContentDir :: RawFilePath -> Annex () -thawContentDir file = thawPerms (liftIO $ allowWrite dir) (thawHook dir) +thawContentDir file = do + fastDebug "Annex.Perms" ("thawing content directory " ++ fromRawFilePath dir) + thawPerms (liftIO $ allowWrite dir) (thawHook dir) where dir = parentDir file @@ -279,6 +298,12 @@ v <- tryNonAsync a freezeContentDir f either throwM return v + +hasFreezeHook :: Annex Bool +hasFreezeHook = isJust . annexFreezeContentCommand <$> Annex.getGitConfig + +hasThawHook :: Annex Bool +hasThawHook = isJust . annexThawContentCommand <$> Annex.getGitConfig freezeHook :: RawFilePath -> Annex () freezeHook p = maybe noop go =<< annexFreezeContentCommand <$> Annex.getGitConfig diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -6,8 +6,6 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Annex.Url ( withUrlOptions, withUrlOptionsPromptingCreds, @@ -36,11 +34,7 @@ import qualified Utility.Url as U import Utility.Hash (IncrementalVerifier) import Utility.IPAddress -#ifdef WITH_HTTP_CLIENT_RESTRICTED import Network.HTTP.Client.Restricted -#else -import Utility.HttpManagerRestricted -#endif import Utility.Metered import Git.Credential import qualified BuildInfo diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, PackageImports #-} module Annex.View where diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE PackageImports #-} module Assistant.Monad ( Assistant, diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -265,7 +265,7 @@ case linktarget of Nothing -> a Just lt -> do - case parseLinkTarget lt of + case parseLinkTargetOrPointer lt of Nothing -> noop Just key -> liftAnnex $ addassociatedfile key file diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,46 @@ +git-annex (10.20220322) upstream; urgency=medium + + * Directory special remotes with importtree=yes have changed to once more + take inodes into account. This will cause extra work when importing + from a directory on a FAT filesystem that changes inodes on every + mount. To avoid that extra work, set ignoreinodes=yes when initializing + a new directory special remote, or change the configuration of your + existing remote: + git-annex enableremote foo ignoreinodes=yes + * add: Avoid unncessarily converting a newly unlocked file to be stored + in git when it is not modified, even when annex.largefiles does not + match it. + * The above change to add fixes a reversion in version 10.20220222, + where git-annex unlock followed by git-annex add, followed by git + commit file could result in git thinking the file was modified + after the commit. + * Detect when an unlocked file whose content is not present has gotten + some other content appended to it, and avoid treating it as a pointer + file, so that appended content will not be checked into git, but will + be annexed like any other file. + * smudge: Warn when encountering a pointer file that has other content + appended to it. + * When annex.freezecontent-command is set, and the filesystem does not + support removing write bits, avoid treating it as a crippled + filesystem. + * Run annex.thawcontent-command before deleting an object file, + in case annex.freezecontent-command did something that would prevent + deletion. + * Fix propagation of nonzero exit status from git ls-files when a specified + file does not exist, or a specified directory does not contain + any files checked into git. + * Fix build with aeson 2.0. + Thanks, sternenseemann for the patch. + * Avoid git-annex test being very slow when run from within the + standalone linux tarball or OSX app. + * test: Runs tests in parallel to speed up the test suite. + * test: Added --jobs option. + * Removed vendored copy of http-client-restricted, and removed the + HttpClientRestricted build flag that avoided that dependency. + * Removed the NetworkBSD build flag. + + -- Joey Hess Tue, 22 Mar 2022 13:56:12 -0400 + git-annex (10.20220222) upstream; urgency=medium * annex.skipunknown now defaults to false, so commands like diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -38,11 +38,6 @@ 2012, 2013 Joey Hess License: BSD-2-clause -Files: Utility/HttpManagerRestricted.hs -Copyright: 2018 Joey Hess - 2013 Michael Snoyman -License: Expat - Files: Utility/Attoparsec.hs Copyright: 2019 Joey Hess 2007-2015 Bryan O'Sullivan diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -77,13 +77,13 @@ (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p] r <- case fs of [f] -> do - void $ liftIO $ cleanup + propagateLsFilesError cleanup fst <$> getfiles ((SeekInput [p], f):c) ps [] -> do - void $ liftIO $ cleanup + propagateLsFilesError cleanup fst <$> getfiles c ps _ -> do - void $ liftIO $ cleanup + propagateLsFilesError cleanup giveup needforce return (r, pure True) withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop @@ -321,7 +321,7 @@ checktimelimit <- mkCheckTimeLimit (fs, cleanup) <- listfs go matcher checktimelimit fs - liftIO $ void cleanup + propagateLsFilesError cleanup where go _ _ [] = return () go matcher checktimelimit (v@(_si, f):rest) = checktimelimit noop $ do @@ -373,7 +373,7 @@ ) join (liftIO (wait mdprocessertid)) join (liftIO (wait processertid)) - liftIO $ void cleanup + propagateLsFilesError cleanup where finisher mi oreader checktimelimit = liftIO oreader >>= \case Just ((si, f), content) -> checktimelimit (liftIO discard) $ do @@ -464,7 +464,7 @@ mdprocess mi mdreader ofeeder ocloser = liftIO mdreader >>= \case Just ((si, f), Just (sha, size, _type)) - | size < maxPointerSz -> do + | size < fromIntegral maxPointerSz -> do feedmatches mi ofeeder si f sha mdprocess mi mdreader ofeeder ocloser Just _ -> mdprocess mi mdreader ofeeder ocloser @@ -618,3 +618,8 @@ cleanup liftIO $ exitWith $ ExitFailure 101 else a + +propagateLsFilesError :: IO Bool -> Annex () +propagateLsFilesError cleanup = + unlessM (liftIO cleanup) $ + Annex.incError diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -78,16 +78,18 @@ largematcher <- largeFilesMatcher addunlockedmatcher <- addUnlockedMatcher annexdotfiles <- getGitConfigVal annexDotFiles - let gofile (si, file) = case largeFilesOverride o of + let gofile includingsmall (si, file) = case largeFilesOverride o of Nothing -> ifM (pure (annexdotfiles || not (dotfile file)) <&&> (checkFileMatcher largematcher file <||> Annex.getState Annex.force)) ( start o si file addunlockedmatcher - , ifM (annexAddSmallFiles <$> Annex.getGitConfig) - ( startSmall o si file - , stop - ) + , if includingsmall + then ifM (annexAddSmallFiles <$> Annex.getGitConfig) + ( startSmall o si file + , stop + ) + else stop ) Just True -> start o si file addunlockedmatcher Just False -> startSmallOverridden o si file @@ -96,7 +98,7 @@ | updateOnly o -> giveup "--update --batch is not supported" | otherwise -> batchOnly Nothing (addThese o) $ - batchFiles fmt gofile + batchFiles fmt (gofile True) NoBatch -> do -- Avoid git ls-files complaining about files that -- are not known to git yet, since this will add @@ -104,11 +106,14 @@ -- problems, like files that don't exist. let ww = WarnUnmatchWorkTreeItems l <- workTreeItems ww (addThese o) - let go a = a ww (commandAction . gofile) l + let go b a = a ww (commandAction . gofile b) l unless (updateOnly o) $ - go (withFilesNotInGit (checkGitIgnoreOption o)) - go withFilesMaybeModified - go withUnmodifiedUnlockedPointers + go True (withFilesNotInGit (checkGitIgnoreOption o)) + go True withFilesMaybeModified + -- Convert newly unlocked files back to locked files, + -- same as a modified unlocked file would get + -- locked when added. + go False withUnmodifiedUnlockedPointers {- Pass file off to git-add. -} startSmall :: AddOptions -> SeekInput -> RawFilePath -> CommandStart diff --git a/Command/FilterProcess.hs b/Command/FilterProcess.hs --- a/Command/FilterProcess.hs +++ b/Command/FilterProcess.hs @@ -62,7 +62,7 @@ let conv b l = (B.concat (map pktLineToByteString l), b) (b, readcomplete) <- either (conv False) (conv True) - <$> liftIO (readUntilFlushPktOrSize unpaddedMaxPointerSz) + <$> liftIO (readUntilFlushPktOrSize maxPointerSz) let passthrough | readcomplete = liftIO $ respondFilterRequest b @@ -83,7 +83,7 @@ -- hash the content provided by git, but Backend does not currently -- have an interface to do so. Command.Smudge.clean' (toRawFilePath file) - (parseLinkTargetOrPointer b) + (parseLinkTargetOrPointer' b) passthrough discardreststdin emitpointer diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns, DeriveDataTypeable, PackageImports, OverloadedStrings #-} module Command.Info where @@ -446,7 +446,7 @@ , maybe (fromUUID $ transferUUID t) Remote.name $ M.lookup (transferUUID t) uuidmap ] - jsonify t i = object $ map (\(k, v) -> (packString k, v)) $ + jsonify t i = object $ map (\(k, v) -> (textKey (packString k), v)) $ [ ("transfer", toJSON' (formatDirection (transferDirection t))) , ("key", toJSON' (transferKey t)) , ("file", toJSON' (fromRawFilePath <$> afile)) 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-2021 Joey Hess + - Copyright 2015-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -105,7 +105,7 @@ then L.length b `seq` return () else liftIO $ hClose stdin let emitpointer = liftIO . S.hPut stdout . formatPointer - clean' file (parseLinkTargetOrPointerLazy b) + clean' file (parseLinkTargetOrPointerLazy' b) passthrough discardreststdin emitpointer @@ -115,7 +115,7 @@ -- Handles everything except the IO of the file content. clean' :: RawFilePath - -> Maybe Key + -> Either InvalidAppendedPointerFile (Maybe Key) -- ^ If the content provided by git is an annex pointer, -- this is the key it points to. -> Annex () @@ -135,19 +135,26 @@ where go = case mk of - Just k -> do + Right (Just k) -> do addingExistingLink file k $ do getMoveRaceRecovery k file passthrough - Nothing -> inRepo (Git.Ref.fileRef file) >>= \case - Just fileref -> do - indexmeta <- catObjectMetaData fileref - oldkey <- case indexmeta of - Just (_, sz, _) -> catKey' fileref sz - Nothing -> return Nothing - go' indexmeta oldkey - Nothing -> passthrough - go' indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey) + Right Nothing -> notpointer + Left InvalidAppendedPointerFile -> do + toplevelWarning False $ + "The file \"" ++ fromRawFilePath file ++ "\" looks like git-annex pointer file that has had other content appended to it" + notpointer + + notpointer = inRepo (Git.Ref.fileRef file) >>= \case + Just fileref -> do + indexmeta <- catObjectMetaData fileref + oldkey <- case indexmeta of + Just (_, sz, _) -> catKey' fileref sz + Nothing -> return Nothing + notpointer' indexmeta oldkey + Nothing -> passthrough + + notpointer' indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey) ( do discardreststdin 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, DeriveFunctor #-} +{-# LANGUAGE RankNTypes, DeriveFunctor, PackageImports #-} module Command.TestRemote where diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -447,7 +447,7 @@ where procthread mdreader catfeeder = mdreader >>= \case Just (ka, Just (sha, size, _type)) - | size < maxPointerSz -> do + | size <= fromIntegral maxPointerSz -> do () <- catfeeder (ka, sha) procthread mdreader catfeeder Just _ -> procthread mdreader catfeeder diff --git a/Messages/JSON.hs b/Messages/JSON.hs --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings, GADTs #-} +{-# LANGUAGE OverloadedStrings, GADTs, CPP #-} module Messages.JSON ( JSONBuilder, @@ -33,7 +33,11 @@ import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.ByteString.Lazy as L +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as HM +#else import qualified Data.HashMap.Strict as HM +#endif import System.IO import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent @@ -94,7 +98,7 @@ addErrorMessage :: [String] -> Object -> Object addErrorMessage msg o = - HM.insertWith combinearray "error-messages" v o + HM.unionWith combinearray (HM.singleton "error-messages" v) o where combinearray (Array new) (Array old) = Array (old <> new) combinearray new _old = new @@ -102,7 +106,7 @@ note :: String -> JSONBuilder note _ Nothing = Nothing -note s (Just (o, e)) = Just (HM.insertWith combinelines "note" (toJSON' s) o, e) +note s (Just (o, e)) = Just (HM.unionWith combinelines (HM.singleton "note" (toJSON' s)) o, e) where combinelines (String new) (String old) = String (old <> "\n" <> new) @@ -127,7 +131,7 @@ j = case v of AesonObject ao -> Object ao JSONChunk l -> object $ map mkPair l - mkPair (s, d) = (packString s, toJSON' d) + mkPair (s, d) = (textKey (packString s), toJSON' d) add _ Nothing = Nothing complete :: JSONChunk v -> JSONBuilder @@ -173,7 +177,7 @@ instance ToJSON' a => ToJSON' (ObjectMap a) where toJSON' (ObjectMap m) = object $ map go $ M.toList m where - go (k, v) = (packString k, toJSON' v) + go (k, v) = (textKey (packString k), toJSON' v) -- An item that a git-annex command acts on, and displays a JSON object about. data JSONActionItem a = JSONActionItem diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -239,11 +239,12 @@ Nothing -> s Just val -> val ++ ": " ++ s jsonify hereu (u, optval) = object $ catMaybes - [ Just (packString "uuid", toJSON' (fromUUID u :: String)) - , Just (packString "description", toJSON' $ finddescription u) - , Just (packString "here", toJSON' $ hereu == u) + [ Just ("uuid", toJSON' (fromUUID u :: String)) + , Just ("description", toJSON' $ finddescription u) + , Just ("here", toJSON' $ hereu == u) , case (optfield, optval) of - (Just field, Just val) -> Just (packString field, toJSON' val) + (Just field, Just val) -> Just + (textKey (packString field), toJSON' val) _ -> Nothing ] 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-2021 Joey Hess + - Copyright 2011-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -54,6 +54,8 @@ , configParser = mkRemoteConfigParser [ optionalStringParser directoryField (FieldDesc "(required) where the special remote stores data") + , yesNoParser ignoreinodesField (Just False) + (FieldDesc "ignore inodes when importing/exporting") ] , setup = directorySetup , exportSupported = exportIsSupported @@ -64,12 +66,17 @@ directoryField :: RemoteConfigField directoryField = Accepted "directory" +ignoreinodesField :: RemoteConfigField +ignoreinodesField = Accepted "ignoreinodes" + gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do c <- parsedRemoteConfig remote rc cst <- remoteCost gc cheapRemoteCost let chunkconfig = getChunkConfig c cow <- liftIO newCopyCoWTried + let ii = IgnoreInodes $ fromMaybe True $ + getRemoteConfigValue ignoreinodesField c return $ Just $ specialRemote c (storeKeyM dir chunkconfig cow) (retrieveKeyFileM dir chunkconfig cow) @@ -99,15 +106,15 @@ , renameExport = renameExportM dir } , importActions = ImportActions - { listImportableContents = listImportableContentsM dir - , importKey = Just (importKeyM dir) - , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM dir cow - , storeExportWithContentIdentifier = storeExportWithContentIdentifierM dir cow - , removeExportWithContentIdentifier = removeExportWithContentIdentifierM dir + { listImportableContents = listImportableContentsM ii dir + , importKey = Just (importKeyM ii dir) + , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM ii dir cow + , storeExportWithContentIdentifier = storeExportWithContentIdentifierM ii dir cow + , removeExportWithContentIdentifier = removeExportWithContentIdentifierM ii dir -- Not needed because removeExportWithContentIdentifier -- auto-removes empty directories. , removeExportDirectoryWhenEmpty = Nothing - , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM dir + , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM ii dir } , whereisKey = Nothing , remoteFsck = Nothing @@ -351,8 +358,8 @@ mkExportLocation loc' in go (upFrom loc') =<< tryIO (removeDirectory p) -listImportableContentsM :: RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) -listImportableContentsM dir = liftIO $ do +listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) +listImportableContentsM ii dir = liftIO $ do l <- dirContentsRecursive (fromRawFilePath dir) l' <- mapM (go . toRawFilePath) l return $ Just $ ImportableContentsComplete $ @@ -360,41 +367,38 @@ where go f = do st <- R.getFileStatus f - mkContentIdentifier f st >>= \case + mkContentIdentifier ii f st >>= \case Nothing -> return Nothing Just cid -> do relf <- relPathDirToFile dir f sz <- getFileSize' f st return $ Just (mkImportLocation relf, (cid, sz)) --- 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 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. +newtype IgnoreInodes = IgnoreInodes Bool + +-- Make a ContentIdentifier that contains the size and mtime of the file, +-- and also normally the inode, unless ignoreinodes=yes. -- --- 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 0 +-- If the file is not a regular file, this will return Nothing. +mkContentIdentifier :: IgnoreInodes -> RawFilePath -> FileStatus -> IO (Maybe ContentIdentifier) +mkContentIdentifier (IgnoreInodes ii) f st = + liftIO $ fmap (ContentIdentifier . encodeBS . showInodeCache) + <$> if ii + then toInodeCache' noTSDelta f st 0 + else toInodeCache noTSDelta f st guardSameContentIdentifiers :: a -> ContentIdentifier -> Maybe ContentIdentifier -> a guardSameContentIdentifiers cont old new | new == Just old = cont | otherwise = giveup "file content has changed" -importKeyM :: RawFilePath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) -importKeyM dir loc cid sz p = do +importKeyM :: IgnoreInodes -> RawFilePath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) +importKeyM ii dir loc cid sz p = do backend <- chooseBackend f unsizedk <- fst <$> genKey ks p backend let k = alterKey unsizedk $ \kd -> kd { keySize = keySize kd <|> Just sz } - currcid <- liftIO $ mkContentIdentifier absf + currcid <- liftIO $ mkContentIdentifier ii absf =<< R.getFileStatus absf guardSameContentIdentifiers (return (Just k)) cid currcid where @@ -406,8 +410,8 @@ , inodeCache = Nothing } -retrieveExportWithContentIdentifierM :: RawFilePath -> CopyCoWTried -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key -retrieveExportWithContentIdentifierM dir cow loc cid dest mkkey p = +retrieveExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key +retrieveExportWithContentIdentifierM ii dir cow loc cid dest mkkey p = precheck docopy where f = exportPath dir loc @@ -449,7 +453,7 @@ -- Check before copy, to avoid expensive copy of wrong file -- content. precheck cont = guardSameContentIdentifiers cont cid - =<< liftIO . mkContentIdentifier f + =<< liftIO . mkContentIdentifier ii f =<< liftIO (R.getFileStatus f) -- Check after copy, in case the file was changed while it was @@ -470,7 +474,7 @@ #else postchecknoncow cont = do #endif - currcid <- liftIO $ mkContentIdentifier f + currcid <- liftIO $ mkContentIdentifier ii f #ifndef mingw32_HOST_OS =<< getFdStatus fd #else @@ -484,22 +488,22 @@ -- the modified version was copied CoW, and then the file was -- restored to the original content before this check. postcheckcow cont = do - currcid <- liftIO $ mkContentIdentifier f + currcid <- liftIO $ mkContentIdentifier ii f =<< R.getFileStatus f guardSameContentIdentifiers cont cid currcid -storeExportWithContentIdentifierM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier -storeExportWithContentIdentifierM dir cow src _k loc overwritablecids p = do +storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier +storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do liftIO $ createDirectoryUnder dir (toRawFilePath destdir) withTmpFileIn destdir template $ \tmpf tmph -> do liftIO $ hClose tmph void $ fileCopier cow src tmpf p Nothing let tmpf' = toRawFilePath tmpf resetAnnexFilePerm tmpf' - liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf' >>= \case + liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier ii tmpf' >>= \case Nothing -> giveup "unable to generate content identifier" Just newcid -> do - checkExportContent dir loc + checkExportContent ii dir loc overwritablecids (giveup "unsafe to overwrite file") (const $ liftIO $ rename tmpf dest) @@ -509,16 +513,16 @@ (destdir, base) = splitFileName dest template = relatedTemplate (base ++ ".tmp") -removeExportWithContentIdentifierM :: RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex () -removeExportWithContentIdentifierM dir k loc removeablecids = - checkExportContent dir loc removeablecids (giveup "unsafe to remove modified file") $ \case +removeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex () +removeExportWithContentIdentifierM ii dir k loc removeablecids = + checkExportContent ii dir loc removeablecids (giveup "unsafe to remove modified file") $ \case DoesNotExist -> return () KnownContentIdentifier -> removeExportM dir k loc -checkPresentExportWithContentIdentifierM :: RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool -checkPresentExportWithContentIdentifierM dir _k loc knowncids = +checkPresentExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +checkPresentExportWithContentIdentifierM ii dir _k loc knowncids = checkPresentGeneric' dir $ - checkExportContent dir loc knowncids (return False) $ \case + checkExportContent ii dir loc knowncids (return False) $ \case DoesNotExist -> return False KnownContentIdentifier -> return True @@ -539,12 +543,12 @@ -- -- So, it suffices to check if the destination file's current -- content is known, and immediately run the callback. -checkExportContent :: RawFilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a -checkExportContent dir loc knowncids unsafe callback = +checkExportContent :: IgnoreInodes -> RawFilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a +checkExportContent ii dir loc knowncids unsafe callback = tryWhenExists (liftIO $ R.getFileStatus dest) >>= \case Just destst | not (isRegularFile destst) -> unsafe - | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier dest destst) >>= \case + | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier ii dest destst) >>= \case Just destcid | destcid `elem` knowncids -> callback KnownContentIdentifier -- dest exists with other content diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, PackageImports #-} module Remote.Helper.Encryptable ( EncryptionIsSetup, diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -11,20 +11,17 @@ import Types.Test import Types.RepoVersion +import Types.Concurrency import Test.Framework import Options.Applicative.Types import Test.Tasty -import Test.Tasty.Runners import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import Test.Tasty.Ingredients.Rerun -import Test.Tasty.Options -import Options.Applicative (switch, long, help, internal) +import Options.Applicative (switch, long, short, help, internal, maybeReader, option) import qualified Data.Map as M import qualified Data.ByteString.Lazy.UTF8 as BU8 -import System.Environment import Control.Concurrent.STM hiding (check) import Common @@ -60,12 +57,9 @@ import qualified Crypto import qualified Database.Keys import qualified Annex.WorkTree -import qualified Annex.Init import qualified Annex.CatFile -import qualified Annex.Path import qualified Annex.VectorClock import qualified Annex.VariantFile -import qualified Annex.AdjustedBranch import qualified Annex.View import qualified Annex.View.ViewedFile import qualified Logs.View @@ -78,8 +72,6 @@ import qualified Utility.Process import qualified Utility.Misc import qualified Utility.InodeCache -import qualified Utility.Env -import qualified Utility.Env.Set import qualified Utility.Matcher import qualified Utility.Hash import qualified Utility.Scheduled @@ -99,7 +91,7 @@ optParser :: Parser TestOptions optParser = TestOptions - <$> snd tastyParser + <$> snd (tastyParser (tests 1 False True (TestOptions mempty False False Nothing mempty))) <*> switch ( long "keep-failures" <> help "preserve repositories on test failure" @@ -108,66 +100,21 @@ ( long "fakessh" <> internal ) + <*> optional (option (maybeReader parseConcurrency) + ( long "jobs" + <> short 'J' + <> help "number of concurrent jobs" + )) <*> cmdParams "non-options are for internal use only" -tastyParser :: ([String], Parser Test.Tasty.Options.OptionSet) -#if MIN_VERSION_tasty(1,3,0) -tastyParser = go -#else -tastyParser = ([], go) -#endif - where - go = suiteOptionParser ingredients (tests False True mempty) - runner :: TestOptions -> IO () -runner opts - | fakeSsh opts = runFakeSsh (internalData opts) - | otherwise = runsubprocesstests =<< Utility.Env.getEnv subenv - where - -- Run git-annex test in a subprocess, so that any files - -- it may open will be closed before running finalCleanup. - -- This should prevent most failures to clean up after the test - -- suite. - subenv = "GIT_ANNEX_TEST_SUBPROCESS" - runsubprocesstests Nothing = do - let warnings = fst tastyParser - unless (null warnings) $ do - hPutStrLn stderr "warnings from tasty:" - mapM_ (hPutStrLn stderr) warnings - pp <- Annex.Path.programPath - Utility.Env.Set.setEnv subenv "1" True - ps <- getArgs - exitcode <- withCreateProcess (proc pp ps) $ - \_ _ _ pid -> waitForProcess pid - unless (keepFailuresOption opts) finalCleanup - exitWith exitcode - runsubprocesstests (Just _) = isolateGitConfig $ do - ensuretmpdir - crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' - (toRawFilePath tmpdir) - Nothing Nothing - adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported - case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of - Nothing -> error "No tests found!?" - Just act -> ifM act - ( exitSuccess - , do - putStrLn " (Failures above could be due to a bug in git-annex, or an incompatibility" - putStrLn " with utilities, such as git, installed on this system.)" - exitFailure - ) - -ingredients :: [Ingredient] -ingredients = - [ listingTests - , rerunningTests [consoleTestReporter] - ] +runner opts = parallelTestRunner opts tests -tests :: Bool -> Bool -> TestOptions -> TestTree -tests crippledfilesystem adjustedbranchok opts = - testGroup "Tests" $ properties - : withTestMode remotetestmode Nothing testRemotes - : map (\(d, te) -> withTestMode te (Just initTests) (unitTests d)) testmodes +tests :: Int -> Bool -> Bool -> TestOptions -> [TestTree] +tests n crippledfilesystem adjustedbranchok opts = + properties + : withTestMode remotetestmode testRemotes + : concatMap mkrepotests testmodes where testmodes = catMaybes [ canadjust ("v8 adjusted unlocked branch", (testMode opts (RepoVersion 8)) { adjustedUnlockedBranch = True }) @@ -181,6 +128,9 @@ canadjust v | adjustedbranchok = Just v | otherwise = Nothing + mkrepotests (d, te) = map + (\uts -> withTestMode te uts) + (repoTests d n) properties :: TestTree properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $ @@ -253,7 +203,7 @@ , "directory=remotedir" , "encryption=none" ] "init" - + testRemote :: Bool -> String -> (String -> IO ()) -> TestTree testRemote testvariants remotetype setupremote = withResource newEmptyTMVarIO (const noop) $ \getv -> @@ -300,15 +250,15 @@ desckeysize sz = descas ("key size " ++ show sz) {- These tests set up the test environment, but also test some basic parts - - of git-annex. They are always run before the unitTests. -} + - of git-annex. They are always run before the repoTests. -} initTests :: TestTree initTests = testGroup "Init Tests" [ testCase "init" test_init , testCase "add" test_add ] -unitTests :: String -> TestTree -unitTests note = testGroup ("Unit Tests " ++ note) +repoTests :: String -> Int -> [TestTree] +repoTests note numparts = map mk $ sep [ testCase "add dup" test_add_dup , testCase "add extras" test_add_extras , testCase "readonly remote" test_readonly_remote @@ -387,6 +337,14 @@ , testCase "add subdirs" test_add_subdirs , testCase "addurl" test_addurl ] + where + mk l = testGroup groupname (initTests : map adddep l) + adddep = Test.Tasty.after AllSucceed (groupname ++ ".Init Tests") + groupname = "Repo Tests " ++ note + sep = sep' (replicate numparts []) + sep' (p:ps) (l:ls) = sep' (ps++[l:p]) ls + sep' ps [] = ps + sep' [] _ = [] -- this test case creates the main repo test_init :: Assertion @@ -597,8 +555,6 @@ annexed_present annexedfile git_annex "unannex" [annexedfile, sha1annexedfile] "unannex" unannexed annexedfile - git_annex "unannex" [annexedfile] "unannex on non-annexed file" - unannexed annexedfile git_annex "unannex" [ingitfile] "unannex ingitfile should be no-op" unannexed ingitfile @@ -1230,11 +1186,11 @@ withtmpclonerepo $ \r3 -> do forM_ [r1, r2, r3] $ \r -> indir r $ do when (r /= r1) $ - git "remote" ["add", "r1", "../../" ++ r1] "remote add" + git "remote" ["add", "r1", "../" ++ r1] "remote add" when (r /= r2) $ - git "remote" ["add", "r2", "../../" ++ r2] "remote add" + git "remote" ["add", "r2", "../" ++ r2] "remote add" when (r /= r3) $ - git "remote" ["add", "r3", "../../" ++ r3] "remote add" + git "remote" ["add", "r3", "../" ++ r3] "remote add" git_annex "get" [annexedfile] "get" git "remote" ["rm", "origin"] "remote rm" forM_ [r3, r2, r1] $ \r -> indir r $ diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -1,6 +1,6 @@ {- git-annex test suite framework - - - Copyright 2010-2021 Joey Hess + - Copyright 2010-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,10 +12,22 @@ import Test.Tasty import Test.Tasty.Runners import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Test.Tasty.Options +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.Ingredients.ConsoleReporter +import Options.Applicative.Types import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import System.Environment (getArgs) +import System.Console.Concurrent +import System.Console.ANSI +import GHC.Conc import Common import Types.Test +import Types.Concurrency import qualified Annex import qualified Annex.UUID @@ -39,6 +51,7 @@ import qualified Annex.Path import qualified Annex.Action import qualified Annex.AdjustedBranch +import qualified Annex.Init import qualified Utility.Process import qualified Utility.Process.Transcript import qualified Utility.Env @@ -166,7 +179,7 @@ -- any type of error and change back to currdir before -- rethrowing. r <- bracket_ - (changeToTmpDir dir) + (changeToTopDir dir) (setCurrentDirectory currdir) (tryNonAsync a) case r of @@ -179,7 +192,6 @@ setuprepo :: FilePath -> IO FilePath setuprepo dir = do cleanup dir - ensuretmpdir git "init" ["-q", dir] "git init" configrepo dir return dir @@ -199,7 +211,6 @@ clonerepo :: FilePath -> FilePath -> CloneRepoConfig -> IO FilePath clonerepo old new cfg = do cleanup new - ensuretmpdir let cloneparams = catMaybes [ Just "-q" , if bareClone cfg then Just "--bare" else Nothing @@ -236,11 +247,11 @@ git "config" ["annex.largefiles", "exclude=" ++ ingitfile] "git config annex.largefiles" -ensuretmpdir :: IO () -ensuretmpdir = do - e <- doesDirectoryExist tmpdir +ensuredir :: FilePath -> IO () +ensuredir d = do + e <- doesDirectoryExist d unless e $ - createDirectory tmpdir + createDirectory d {- Prevent global git configs from affecting the test suite. -} isolateGitConfig :: IO a -> IO a @@ -449,29 +460,24 @@ hasUnlockedFiles :: TestMode -> Bool hasUnlockedFiles m = unlockedFiles m || adjustedUnlockedBranch m -withTestMode :: TestMode -> Maybe TestTree -> TestTree -> TestTree -withTestMode testmode minittests = withResource prepare release . const +withTestMode :: TestMode -> TestTree -> TestTree +withTestMode testmode = withResource prepare release . const where prepare = do setTestMode testmode setmainrepodir =<< newmainrepodir - case minittests of - Just inittests -> - case tryIngredients [consoleTestReporter] mempty inittests of - Nothing -> error "No tests found!?" - Just act -> unlessM act $ - error "init tests failed! cannot continue" - Nothing -> return () release _ = noop setTestMode :: TestMode -> IO () setTestMode testmode = do currdir <- getCurrentDirectory p <- Utility.Env.getEnvDefault "PATH" "" + pp <- Annex.Path.programPath mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True) - -- Ensure that the just-built git annex is used. - [ ("PATH", currdir ++ [searchPathSeparator] ++ p) + -- Ensure that the same git-annex binary that is running + -- git-annex test is at the front of the PATH. + [ ("PATH", takeDirectory pp ++ [searchPathSeparator] ++ p) , ("TOPDIR", currdir) -- Avoid git complaining if it cannot determine the user's -- email address, or exploding if it doesn't know the user's @@ -488,7 +494,7 @@ , ("GIT_ANNEX_USE_GIT_SSH", "1") , ("TESTMODE", show testmode) ] - + runFakeSsh :: [String] -> IO () runFakeSsh ("-n":ps) = runFakeSsh ps runFakeSsh (_host:cmd:[]) = @@ -506,8 +512,8 @@ git "commit" ["--allow-empty", "-m", "empty"] "git commit failed" git_annex "adjust" ["--unlock"] "git annex adjust failed" -changeToTmpDir :: FilePath -> IO () -changeToTmpDir t = do +changeToTopDir :: FilePath -> IO () +changeToTopDir t = do topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set") setCurrentDirectory $ topdir ++ "/" ++ t @@ -525,7 +531,7 @@ newmainrepodir = go (0 :: Int) where go n = do - let d = tmpdir "main" ++ show n + let d = "main" ++ show n ifM (doesDirectoryExist d) ( go $ n + 1 , do @@ -537,7 +543,7 @@ tmprepodir = go (0 :: Int) where go n = do - let d = tmpdir "tmprepo" ++ show n + let d = "tmprepo" ++ show n ifM (doesDirectoryExist d) ( go $ n + 1 , return d @@ -636,9 +642,9 @@ pair :: FilePath -> FilePath -> Assertion pair r1 r2 = forM_ [r1, r2] $ \r -> indir r $ do when (r /= r1) $ - git "remote" ["add", "r1", "../../" ++ r1] "remote add" + git "remote" ["add", "r1", "../" ++ r1] "remote add" when (r /= r2) $ - git "remote" ["add", "r2", "../../" ++ r2] "remote add" + git "remote" ["add", "r2", "../" ++ r2] "remote add" {- Runs a query in the current repository, but first makes the repository @@ -661,3 +667,128 @@ make_writeable d = void $ Utility.Process.Transcript.processTranscript "chmod" ["-R", "u+w", d] Nothing + +{- Tests each TestTree in parallel, and exits with succcess/failure. + - + - Tasty supports parallel tests, but this does not use it, because + - many tests need to be run in test repos, and chdir would not be + - thread safe. Instead, this starts one child process for each TestTree. + - + - An added benefit of using child processes is that any files they may + - leave open are closed before finalCleanup is run at the end. This + - prevents some failures to clean up after the test suite. + -} +parallelTestRunner :: TestOptions -> (Int -> Bool -> Bool -> TestOptions -> [TestTree]) -> IO () +parallelTestRunner opts mkts = do + numjobs <- case concurrentJobs opts of + Just NonConcurrent -> pure 1 + Just (Concurrent n) -> pure n + Just ConcurrentPerCpu -> getNumProcessors + Nothing -> getNumProcessors + parallelTestRunner' numjobs opts mkts + +parallelTestRunner' :: Int -> TestOptions -> (Int -> Bool -> Bool -> TestOptions -> [TestTree]) -> IO () +parallelTestRunner' numjobs opts mkts + | fakeSsh opts = runFakeSsh (internalData opts) + | otherwise = go =<< Utility.Env.getEnv subenv + where + subenv = "GIT_ANNEX_TEST_SUBPROCESS" + -- Make more parts than there are jobs, because some parts + -- are larger, and this allows the smaller parts to be packed + -- in more efficiently, speeding up the test suite overall. + numparts = numjobs * 2 + worker rs nvar a = do + (n, m) <- atomically $ do + (n, m) <- readTVar nvar + writeTVar nvar (n+1, m) + return (n, m) + if n > m + then return rs + else do + r <- a n + worker (r:rs) nvar a + go Nothing = withConcurrentOutput $ do + ensuredir tmpdir + crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' + (toRawFilePath tmpdir) + Nothing Nothing False + adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported + let ts = mkts numparts crippledfilesystem adjustedbranchok opts + let warnings = fst (tastyParser ts) + unless (null warnings) $ do + hPutStrLn stderr "warnings from tasty:" + mapM_ (hPutStrLn stderr) warnings + environ <- Utility.Env.getEnvironment + args <- getArgs + pp <- Annex.Path.programPath + termcolor <- hSupportsANSIColor stdout + let ps = if useColor (lookupOption (tastyOptionSet opts)) termcolor + then "--color=always":args + else "--color=never":args + let runone n = do + let subdir = tmpdir show n + ensuredir subdir + let p = (proc pp ps) + { env = Just ((subenv, show (n, crippledfilesystem, adjustedbranchok)):environ) + , cwd = Just subdir + } + (_, _, _, pid) <- createProcessConcurrent p + ret <- waitForProcess pid + -- Work around this strange issue + -- https://github.com/UnkindPartition/tasty/issues/326 + -- when other workaround does not work. + if ret == ExitFailure (-11) + then runone n + else return ret + nvar <- newTVarIO (1, length ts) + exitcodes <- forConcurrently [1..numjobs] $ \_ -> + worker [] nvar runone + let exitcodes' = concat exitcodes + unless (keepFailuresOption opts) finalCleanup + if all (== ExitSuccess) exitcodes' + then exitSuccess + else case (filter (/= ExitFailure 1) exitcodes') of + [] -> do + putStrLn " (Failures above could be due to a bug in git-annex, or an incompatibility" + putStrLn " with utilities, such as git, installed on this system.)" + exitFailure + v -> do + putStrLn $ " Test subprocesses exited with unexpected exit codes: " ++ show v + exitFailure + go (Just subenvval) = case readish subenvval of + Nothing -> error ("Bad " ++ subenv) + Just (n, crippledfilesystem, adjustedbranchok) -> isolateGitConfig $ do + let ts = mkts numparts crippledfilesystem adjustedbranchok opts + let t = topLevelTestGroup + -- Work around this strange issue + -- https://github.com/UnkindPartition/tasty/issues/326 + [ testGroup "Tasty" + [ testProperty "tasty self-check" True + ] + , ts !! (n - 1) + ] + case tryIngredients ingredients (tastyOptionSet opts) t of + Nothing -> error "No tests found!?" + Just act -> ifM act + ( exitSuccess + , exitFailure + ) + +topLevelTestGroup :: [TestTree] -> TestTree +topLevelTestGroup = testGroup "Tests" + +tastyParser :: [TestTree] -> ([String], Parser Test.Tasty.Options.OptionSet) +#if MIN_VERSION_tasty(1,3,0) +tastyParser ts = go +#else +tastyParser ts = ([], go) +#endif + where + go = suiteOptionParser ingredients (topLevelTestGroup ts) + +ingredients :: [Ingredient] +ingredients = + [ listingTests + , rerunningTests [consoleTestReporter] + ] + diff --git a/Types/MetaData.hs b/Types/MetaData.hs --- a/Types/MetaData.hs +++ b/Types/MetaData.hs @@ -67,7 +67,7 @@ instance ToJSON' MetaData where toJSON' (MetaData m) = object $ map go (M.toList m) where - go (MetaField f, s) = (CI.original f, toJSON' s) + go (MetaField f, s) = (textKey (CI.original f), toJSON' s) instance FromJSON MetaData where parseJSON (Object o) = do diff --git a/Types/Test.hs b/Types/Test.hs --- a/Types/Test.hs +++ b/Types/Test.hs @@ -1,6 +1,6 @@ {- git-annex test data types. - - - Copyright 2011-2017 Joey Hess + - Copyright 2011-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -8,27 +8,16 @@ module Types.Test where import Test.Tasty.Options -import Data.Monoid -import qualified Data.Semigroup as Sem -import Prelude +import Types.Concurrency import Types.Command data TestOptions = TestOptions { tastyOptionSet :: OptionSet , keepFailuresOption :: Bool , fakeSsh :: Bool + , concurrentJobs :: Maybe Concurrency , internalData :: CmdParams } - -instance Sem.Semigroup TestOptions where - a <> b = TestOptions - (tastyOptionSet a <> tastyOptionSet b) - (keepFailuresOption a || keepFailuresOption b) - (fakeSsh a || fakeSsh b) - (internalData a <> internalData b) - -instance Monoid TestOptions where - mempty = TestOptions mempty False False mempty type TestRunner = TestOptions -> IO () diff --git a/Utility/Aeson.hs b/Utility/Aeson.hs --- a/Utility/Aeson.hs +++ b/Utility/Aeson.hs @@ -7,7 +7,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, CPP #-} module Utility.Aeson ( module X, @@ -15,11 +15,19 @@ encode, packString, packByteString, + textKey, ) where +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson as X hiding (ToJSON, toJSON, encode, Key) +#else import Data.Aeson as X hiding (ToJSON, toJSON, encode) +#endif import Data.Aeson hiding (encode) import qualified Data.Aeson +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as AK +#endif import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as L @@ -67,6 +75,14 @@ packString s = case T.decodeUtf8' (encodeBS s) of Right t -> t Left _ -> T.pack s + +#if MIN_VERSION_aeson(2,0,0) +textKey :: T.Text -> AK.Key +textKey = AK.fromText +#else +textKey :: T.Text -> T.Text +textKey = id +#endif -- | The same as packString . decodeBS, but more efficient in the usual -- case. diff --git a/Utility/AuthToken.hs b/Utility/AuthToken.hs --- a/Utility/AuthToken.hs +++ b/Utility/AuthToken.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# LANGUAGE PackageImports #-} + module Utility.AuthToken ( AuthToken, toAuthToken, diff --git a/Utility/Base64.hs b/Utility/Base64.hs --- a/Utility/Base64.hs +++ b/Utility/Base64.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# LANGUAGE PackageImports #-} + module Utility.Base64 where import Utility.FileSystemEncoding diff --git a/Utility/Hash.hs b/Utility/Hash.hs --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, PackageImports #-} module Utility.Hash ( sha1, diff --git a/Utility/HttpManagerRestricted.hs b/Utility/HttpManagerRestricted.hs deleted file mode 100644 --- a/Utility/HttpManagerRestricted.hs +++ /dev/null @@ -1,300 +0,0 @@ -{- | Restricted `ManagerSettings` for - - - - Copyright 2018 Joey Hess - - - - Portions from http-client-tls Copyright (c) 2013 Michael Snoyman - - - - License: MIT - -} - -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, LambdaCase, PatternGuards #-} - --- This is a vendored copy of Network.HTTP.Client.Restricted from the --- http-client-restricted package, and will be removed once that package --- is available in all build environments. -module Utility.HttpManagerRestricted ( - Restriction, - checkAddressRestriction, - addressRestriction, - mkRestrictedManagerSettings, - ConnectionRestricted(..), - connectionRestricted, - ProxyRestricted(..), - IPAddrString, -) where - -import Network.HTTP.Client -import Network.HTTP.Client.Internal (ManagerSettings(..), Connection, runProxyOverride) -import Network.HTTP.Client.TLS (mkManagerSettingsContext) -import Network.Socket -import Network.BSD (getProtocolNumber) -import Control.Exception -import qualified Network.Connection as NC -import qualified Data.ByteString.UTF8 as BU -import Data.Maybe -import Data.Default -import Data.Typeable -import qualified Data.Semigroup as Sem -import Data.Monoid -import Control.Applicative -import Prelude - --- | Configuration of which HTTP connections to allow and which to --- restrict. -data Restriction = Restriction - { checkAddressRestriction :: AddrInfo -> Maybe ConnectionRestricted - } - --- | Decide if a HTTP connection is allowed based on the IP address --- of the server. --- --- After the restriction is checked, the same IP address is used --- to connect to the server. This avoids DNS rebinding attacks --- being used to bypass the restriction. --- --- > myRestriction :: Restriction --- > myRestriction = addressRestriction $ \addr -> --- > if isPrivateAddress addr --- > then Just $ connectionRestricted --- > ("blocked connection to private IP address " ++) --- > else Nothing -addressRestriction :: (AddrInfo -> Maybe ConnectionRestricted) -> Restriction -addressRestriction f = mempty { checkAddressRestriction = f } - -appendRestrictions :: Restriction -> Restriction -> Restriction -appendRestrictions a b = Restriction - { checkAddressRestriction = \addr -> - checkAddressRestriction a addr <|> checkAddressRestriction b addr - } - --- | mempty does not restrict HTTP connections in any way -instance Monoid Restriction where - mempty = Restriction - { checkAddressRestriction = \_ -> Nothing - } - -instance Sem.Semigroup Restriction where - (<>) = appendRestrictions - --- | Value indicating that a connection was restricted, and giving the --- reason why. -data ConnectionRestricted = ConnectionRestricted String - deriving (Show, Typeable) - -instance Exception ConnectionRestricted - --- | A string containing an IP address, for display to a user. -type IPAddrString = String - --- | Constructs a ConnectionRestricted, passing the function a string --- containing the IP address of the HTTP server. -connectionRestricted :: (IPAddrString -> String) -> AddrInfo -> ConnectionRestricted -connectionRestricted mkmessage = - ConnectionRestricted . mkmessage . showSockAddress . addrAddress - --- | Value indicating that the http proxy will not be used. -data ProxyRestricted = ProxyRestricted - deriving (Show) - --- Adjusts a ManagerSettings to enforce a Restriction. The restriction --- will be checked each time a Request is made, and for each redirect --- followed. --- --- This overrides the `managerRawConnection` --- and `managerTlsConnection` with its own implementations that check --- the Restriction. They should otherwise behave the same as the --- ones provided by http-client-tls. --- --- This function is not exported, because using it with a ManagerSettings --- produced by something other than http-client-tls would result in --- surprising behavior, since its connection methods would not be used. --- --- The http proxy is also checked against the Restriction, and if --- access to it is blocked, the http proxy will not be used. -restrictManagerSettings - :: Maybe NC.ConnectionContext - -> Maybe NC.TLSSettings - -> Restriction - -> ManagerSettings - -> IO (ManagerSettings, Maybe ProxyRestricted) -restrictManagerSettings mcontext mtls cfg base = restrictProxy cfg $ base - { managerRawConnection = restrictedRawConnection cfg - , managerTlsConnection = restrictedTlsConnection mcontext mtls cfg - , managerWrapException = wrapOurExceptions base - } - --- | Makes a TLS-capable ManagerSettings with a Restriction applied to it. --- --- The Restriction will be checked each time a Request is made, and for --- each redirect followed. --- --- Aside from checking the Restriction, it should behave the same as --- `Network.HTTP.Client.TLS.mkManagerSettingsContext` --- from http-client-tls. --- --- > main = do --- > manager <- newManager . fst --- > =<< mkRestrictedManagerSettings myRestriction Nothing Nothing --- > request <- parseRequest "http://httpbin.org/get" --- > response <- httpLbs request manager --- > print $ responseBody response --- --- The HTTP proxy is also checked against the Restriction, and will not be --- used if the Restriction does not allow it. Just ProxyRestricted --- is returned when the HTTP proxy has been restricted. --- --- See `mkManagerSettingsContext` for why --- it can be useful to provide a `NC.ConnectionContext`. --- --- Note that SOCKS is not supported. -mkRestrictedManagerSettings - :: Restriction - -> Maybe NC.ConnectionContext - -> Maybe NC.TLSSettings - -> IO (ManagerSettings, Maybe ProxyRestricted) -mkRestrictedManagerSettings cfg mcontext mtls = - restrictManagerSettings mcontext mtls cfg $ - mkManagerSettingsContext mcontext (fromMaybe def mtls) Nothing - -restrictProxy - :: Restriction - -> ManagerSettings - -> IO (ManagerSettings, Maybe ProxyRestricted) -restrictProxy cfg base = do - http_proxy_addr <- getproxyaddr False - https_proxy_addr <- getproxyaddr True - let (http_proxy, http_r) = mkproxy http_proxy_addr - let (https_proxy, https_r) = mkproxy https_proxy_addr - let ms = managerSetInsecureProxy http_proxy $ - managerSetSecureProxy https_proxy base - return (ms, http_r <|> https_r) - where - -- This does not use localhost because http-client may choose - -- not to use the proxy for localhost. - testnetip = "198.51.100.1" - dummyreq https = parseRequest_ $ - "http" ++ (if https then "s" else "") ++ "://" ++ testnetip - - getproxyaddr https = extractproxy >>= \case - Nothing -> return Nothing - Just p -> do - proto <- getProtocolNumber "tcp" - let serv = show (proxyPort p) - let hints = defaultHints - { addrFlags = [AI_ADDRCONFIG] - , addrProtocol = proto - , addrSocketType = Stream - } - let h = BU.toString $ proxyHost p - getAddrInfo (Just hints) (Just h) (Just serv) >>= \case - [] -> return Nothing - (addr:_) -> return $ Just addr - where - -- These contortions are necessary until this issue - -- is fixed: - -- https://github.com/snoyberg/http-client/issues/355 - extractproxy = do - let po = if https - then managerProxySecure base - else managerProxyInsecure base - f <- runProxyOverride po https - return $ proxy $ f $ dummyreq https - - mkproxy Nothing = (noProxy, Nothing) - mkproxy (Just proxyaddr) = case checkAddressRestriction cfg proxyaddr of - Nothing -> (addrtoproxy (addrAddress proxyaddr), Nothing) - Just _ -> (noProxy, Just ProxyRestricted) - - addrtoproxy addr = case addr of - SockAddrInet pn _ -> mk pn - SockAddrInet6 pn _ _ _ -> mk pn - _ -> noProxy - where - mk pn = useProxy Network.HTTP.Client.Proxy - { proxyHost = BU.fromString (showSockAddress addr) - , proxyPort = fromIntegral pn - } - -wrapOurExceptions :: ManagerSettings -> Request -> IO a -> IO a -wrapOurExceptions base req a = - let wrapper se - | Just (_ :: ConnectionRestricted) <- fromException se = - toException $ HttpExceptionRequest req $ - InternalException se - | otherwise = se - in managerWrapException base req (handle (throwIO . wrapper) a) - -restrictedRawConnection :: Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection) -restrictedRawConnection cfg = getConnection cfg Nothing Nothing - -restrictedTlsConnection :: Maybe NC.ConnectionContext -> Maybe NC.TLSSettings -> Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection) -restrictedTlsConnection mcontext mtls cfg = - getConnection cfg (Just (fromMaybe def mtls)) mcontext - --- Based on Network.HTTP.Client.TLS.getTlsConnection. --- --- Checks the Restriction --- --- Does not support SOCKS. -getConnection - :: Restriction - -> Maybe NC.TLSSettings - -> Maybe NC.ConnectionContext - -> IO (Maybe HostAddress -> String -> Int -> IO Connection) -getConnection cfg tls mcontext = do - context <- maybe NC.initConnectionContext return mcontext - return $ \_ha h p -> bracketOnError - (go context h p) - NC.connectionClose - convertConnection - where - go context h p = do - let connparams = NC.ConnectionParams - { NC.connectionHostname = h - , NC.connectionPort = fromIntegral p - , NC.connectionUseSecure = tls - , NC.connectionUseSocks = Nothing -- unsupprted - } - proto <- getProtocolNumber "tcp" - let serv = show p - let hints = defaultHints - { addrFlags = [AI_ADDRCONFIG] - , addrProtocol = proto - , addrSocketType = Stream - } - addrs <- getAddrInfo (Just hints) (Just h) (Just serv) - bracketOnError - (firstSuccessful $ map tryToConnect addrs) - close - (\sock -> NC.connectFromSocket context sock connparams) - where - tryToConnect addr = case checkAddressRestriction cfg addr of - Nothing -> bracketOnError - (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) - close - (\sock -> connect sock (addrAddress addr) >> return sock) - Just r -> throwIO r - firstSuccessful [] = throwIO $ NC.HostNotResolved h - firstSuccessful (a:as) = a `catch` \(e ::IOException) -> - case as of - [] -> throwIO e - _ -> firstSuccessful as - --- Copied from Network.HTTP.Client.TLS, unfortunately not exported. -convertConnection :: NC.Connection -> IO Connection -convertConnection conn = makeConnection - (NC.connectionGetChunk conn) - (NC.connectionPut conn) - -- Closing an SSL connection gracefully involves writing/reading - -- on the socket. But when this is called the socket might be - -- already closed, and we get a @ResourceVanished@. - (NC.connectionClose conn `Control.Exception.catch` \(_ :: IOException) -> return ()) - --- For ipv4 and ipv6, the string will contain only the IP address, --- omitting the port that the Show instance includes. -showSockAddress :: SockAddr -> IPAddrString -showSockAddress a@(SockAddrInet _ _) = - takeWhile (/= ':') $ show a -showSockAddress a@(SockAddrInet6 _ _ _ _) = - takeWhile (/= ']') $ drop 1 $ show a -showSockAddress a = show a diff --git a/Utility/Path/Tests.hs b/Utility/Path/Tests.hs --- a/Utility/Path/Tests.hs +++ b/Utility/Path/Tests.hs @@ -49,7 +49,8 @@ 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 $ + relf = B.dropWhile isPathSeparator $ + B.filter (not . skipchar) $ toRawFilePath (fromTestableFilePath pt) skipchar b = b == (fromIntegral (ord ':')) diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -9,7 +9,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} module Utility.Url ( newManager, @@ -46,11 +45,7 @@ import Common import Utility.Debug import Utility.Metered -#ifdef WITH_HTTP_CLIENT_RESTRICTED import Network.HTTP.Client.Restricted -#else -import Utility.HttpManagerRestricted -#endif import Utility.IPAddress import qualified Utility.RawFilePath as R import Utility.Hash (IncrementalVerifier(..)) diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE OverloadedStrings, CPP, RankNTypes #-} +{-# LANGUAGE OverloadedStrings, CPP, RankNTypes, PackageImports #-} module Utility.WebApp ( browserProc, diff --git a/doc/git-annex-test.mdwn b/doc/git-annex-test.mdwn --- a/doc/git-annex-test.mdwn +++ b/doc/git-annex-test.mdwn @@ -20,6 +20,11 @@ There are several options, provided by Haskell's tasty test framework. Pass --help for details about those. +* `--jobs=N` `-JN` + + How many tests to run in parallel. The default is "cpus", which will + runs one job per CPU core. + * `--keep-failures` When there are test failures, leave the `.t` directory populated with diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1231,8 +1231,10 @@ Usually the write permission bits are unset to protect annexed objects from being modified or deleted. The freezecontent-command is run after - git-annex has removed the write bit. The thawcontent-command should undo - its effect, and is run before git-annex restores the write bit. + git-annex has removed (or attempted to remove) the write bit, and can + be used to prevent writing in some other way. + The thawcontent-command should undo its effect, and is run before + git-annex restores the write bit. In the command line, %path is replaced with the file or directory to operate on. @@ -1894,11 +1896,12 @@ # EXIT STATUS -git-annex, when called as a git subcommand, may return exit codes 0 or 1 -for success or failures, or, more rarely, 127 or 128 for certain very -specific failures. git-annex itself should return 0 on success and 1 on -failure, unless the `--time-limit=time` option is hit, in which case it -returns with exit code 101. +git-annex itself will exit 0 on success and 1 on failure, unless +the `--size-limit` or `--time-limit` option is hit, in +which case it exits 101. + +A few git-annex subcommands have other exit statuses used to indicate +specific problems, which are documented on their individual man pages. # ENVIRONMENT 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: 10.20220222 +Version: 10.20220322 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -284,18 +284,10 @@ Flag Dbus Description: Enable dbus support -Flag NetworkBSD - Description: Build with network-3.0 which split out network-bsd - Default: True - Flag GitLfs Description: Build with git-lfs library (rather than vendored copy) Default: True -Flag HttpClientRestricted - Description: Build with http-client-restricted library (rather than vendored copy) - Default: True - source-repository head type: git location: git://git-annex.branchable.com/ @@ -348,6 +340,7 @@ http-client-tls, http-types (>= 0.7), http-conduit (>= 2.3.0), + http-client-restricted (>= 0.0.2), conduit, time (>= 1.5.0), old-locale, @@ -374,16 +367,19 @@ attoparsec (>= 0.13.2.2), concurrent-output (>= 1.10), QuickCheck (>= 2.10.0), - tasty (>= 0.7), + tasty (>= 1.2), tasty-hunit, tasty-quickcheck, tasty-rerun, + ansi-terminal >= 0.9, aws (>= 0.20), - DAV (>= 1.0) + DAV (>= 1.0), + network (>= 3.0.0.0), + network-bsd CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs -Wincomplete-uni-patterns Default-Language: Haskell2010 - Default-Extensions: PackageImports, LambdaCase + Default-Extensions: LambdaCase Other-Extensions: TemplateHaskell -- Some things don't work with the non-threaded RTS. GHC-Options: -threaded @@ -413,23 +409,12 @@ else Build-Depends: unix (>= 2.7.2) - if flag(NetworkBSD) - Build-Depends: network-bsd, network (>= 3.0.0.0) - else - Build-Depends: network (< 3.0.0.0), network (>= 2.6.3.0) - if flag(GitLfs) Build-Depends: git-lfs (>= 1.2.0) CPP-Options: -DWITH_GIT_LFS else Other-Modules: Utility.GitLFS - if flag(HttpClientRestricted) - Build-Depends: http-client-restricted (>= 0.0.2) - CPP-Options: -DWITH_HTTP_CLIENT_RESTRICTED - else - Other-Modules: Utility.HttpManagerRestricted - if flag(Assistant) && ! os(solaris) && ! os(gnu) Build-Depends: mountpoints CPP-Options: -DWITH_ASSISTANT diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -9,9 +9,7 @@ dbus: false debuglocks: false benchmark: true - networkbsd: true gitlfs: true - httpclientrestricted: true packages: - '.' resolver: lts-18.13