diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,14 @@ +git-annex (7.20181105) upstream; urgency=medium + + * Fix test suite failure when git-annex test is not run inside a git + repository. + * Fix a P2P protocol hang. + * importfeed: Avoid erroring out when a feed has been repeatedly broken, + as that can leave other imported files not checked into git. + * Increase minimum QuickCheck version. + + -- Joey Hess Mon, 05 Nov 2018 13:31:09 -0400 + git-annex (7.20181031) upstream; urgency=medium * Added v7 repository mode. v6 upgrades automatically to v7, but diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -78,21 +78,18 @@ perform opts cache url = do v <- findDownloads url case v of - [] -> do + [] -> next $ feedProblem url "bad feed content; no enclosures to download" - next $ return True l -> do showOutput ok <- and <$> mapM (performDownload opts cache) l - unless ok $ - feedProblem url "problem downloading some item(s) from feed" - next $ cleanup url True + next $ cleanup url ok cleanup :: URLString -> Bool -> CommandCleanup -cleanup url ok = do - when ok $ - clearFeedProblem url - return ok +cleanup url True = do + clearFeedProblem url + return True +cleanup url False = feedProblem url "problem downloading some item(s) from feed" data ToDownload = ToDownload { feed :: Feed @@ -370,11 +367,17 @@ noneValue = "none" {- Called when there is a problem with a feed. - - Throws an error if the feed is broken, otherwise shows a warning. -} -feedProblem :: URLString -> String -> Annex () + - + - If the feed has been broken for some time, + - returns False, otherwise only warns. -} +feedProblem :: URLString -> String -> Annex Bool feedProblem url message = ifM (checkFeedBroken url) - ( giveup $ message ++ " (having repeated problems with feed: " ++ url ++ ")" - , warning $ "warning: " ++ message + ( do + warning $ message ++ " (having repeated problems with feed: " ++ url ++ ")" + return False + , do + warning $ "warning: " ++ message + return True ) {- A feed is only broken if problems have occurred repeatedly, for at diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -50,18 +50,19 @@ size <- inAnnex' isJust Nothing getsize k runner (next (Len <$> size)) ReadContent k af o sender next -> do + let proceed c = do + r <- tryNonAsync c + case r of + Left e -> return $ Left $ ProtoFailureException e + Right (Left e) -> return $ Left e + Right (Right ok) -> runner (next ok) v <- tryNonAsync $ prepSendAnnex k case v of - Right (Just (f, checkchanged)) -> do - v' <- tryNonAsync $ - transfer upload k af $ - sinkfile f o checkchanged sender - case v' of - Left e -> return $ Left $ ProtoFailureException e - Right (Left e) -> return $ Left e - Right (Right ok) -> runner (next ok) - -- content not available - Right Nothing -> runner (next False) + Right (Just (f, checkchanged)) -> proceed $ + transfer upload k af $ + sinkfile f o checkchanged sender + Right Nothing -> proceed $ + runner (sender mempty (return Invalid)) Left e -> return $ Left $ ProtoFailureException e StoreContent k af o l getb validitycheck next -> do -- This is the same as the retrievalSecurityPolicy of diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -238,8 +238,9 @@ -- present. | ReadContent Key AssociatedFile Offset (L.ByteString -> Proto Validity -> Proto Bool) (Bool -> c) -- ^ Reads the content of a key and sends it to the callback. - -- If the content is not available, sends L.empty to the callback. - -- Note that the content may change while it's being sent. + -- May send any amount of data, including L.empty if the content is + -- not available. The callback must deal with that. + -- And the content may change while it's being sent. -- The callback is passed a validity check that it can run after -- sending the content to detect when this happened. | StoreContent Key AssociatedFile Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) (Bool -> c) diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -60,7 +60,6 @@ import qualified Annex.Init import qualified Annex.CatFile import qualified Annex.Path -import qualified Annex.AdjustedBranch import qualified Annex.VectorClock import qualified Annex.View import qualified Annex.View.ViewedFile @@ -1100,9 +1099,9 @@ {- Conflict resolution while in an adjusted branch. -} test_conflict_resolution_adjusted_branch :: Assertion -test_conflict_resolution_adjusted_branch = whenM (annexeval Annex.AdjustedBranch.isSupported) $ +test_conflict_resolution_adjusted_branch = withtmpclonerepo $ \r1 -> - withtmpclonerepo $ \r2 -> do + withtmpclonerepo $ \r2 -> whenM (adjustedbranchsupported r2) $ do indir r1 $ do disconnectOrigin writecontent conflictor "conflictor1" @@ -1449,9 +1448,9 @@ - where the same file is added to both independently. The bad merge - emptied the whole tree. -} test_adjusted_branch_merge_regression :: Assertion -test_adjusted_branch_merge_regression = whenM (annexeval Annex.AdjustedBranch.isSupported) $ +test_adjusted_branch_merge_regression = do withtmpclonerepo $ \r1 -> - withtmpclonerepo $ \r2 -> do + withtmpclonerepo $ \r2 -> whenM (adjustedbranchsupported r1) $ do pair r1 r2 setup r1 setup r2 @@ -1476,22 +1475,21 @@ - a subtree to an existing tree lost files. -} test_adjusted_branch_subtree_regression :: Assertion test_adjusted_branch_subtree_regression = - whenM (annexeval Annex.AdjustedBranch.isSupported) $ - withtmpclonerepo $ \r -> do - indir r $ do - disconnectOrigin - git_annex "upgrade" [] @? "upgrade failed" - git_annex "adjust" ["--unlock", "--force"] @? "adjust failed" - createDirectoryIfMissing True "a/b/c" - writecontent "a/b/c/d" "foo" - git_annex "add" ["a/b/c"] @? "add a/b/c failed" - git_annex "sync" [] @? "sync failed" - createDirectoryIfMissing True "a/b/x" - writecontent "a/b/x/y" "foo" - git_annex "add" ["a/b/x"] @? "add a/b/x failed" - git_annex "sync" [] @? "sync failed" - boolSystem "git" [Param "checkout", Param "master"] @? "git checkout master failed" - doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync") + withtmpclonerepo $ \r -> whenM (adjustedbranchsupported r) $ do + indir r $ do + disconnectOrigin + git_annex "upgrade" [] @? "upgrade failed" + git_annex "adjust" ["--unlock", "--force"] @? "adjust failed" + createDirectoryIfMissing True "a/b/c" + writecontent "a/b/c/d" "foo" + git_annex "add" ["a/b/c"] @? "add a/b/c failed" + git_annex "sync" [] @? "sync failed" + createDirectoryIfMissing True "a/b/x" + writecontent "a/b/x/y" "foo" + git_annex "add" ["a/b/x"] @? "add a/b/x failed" + git_annex "sync" [] @? "sync failed" + boolSystem "git" [Param "checkout", Param "master"] @? "git checkout master failed" + doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync") {- Set up repos as remotes of each other. -} pair :: FilePath -> FilePath -> Assertion diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -35,6 +35,7 @@ import qualified Annex.Init import qualified Annex.Path import qualified Annex.Action +import qualified Annex.AdjustedBranch import qualified Utility.Process import qualified Utility.Env import qualified Utility.Env.Set @@ -160,17 +161,22 @@ withgitrepo :: (FilePath -> Assertion) -> Assertion withgitrepo = bracket (setuprepo mainrepodir) return -indir :: FilePath -> Assertion -> Assertion +indir :: FilePath -> IO a -> IO a indir dir a = do currdir <- getCurrentDirectory -- Assertion failures throw non-IO errors; catch -- any type of error and change back to currdir before -- rethrowing. - r <- bracket_ (changeToTmpDir dir) (setCurrentDirectory currdir) - (try a::IO (Either SomeException ())) + r <- bracket_ + (changeToTmpDir dir) + (setCurrentDirectory currdir) + (tryNonAsync a) case r of - Right () -> return () + Right v -> return v Left e -> throwM e + +adjustedbranchsupported :: FilePath -> IO Bool +adjustedbranchsupported repo = indir repo $ annexeval Annex.AdjustedBranch.isSupported setuprepo :: FilePath -> IO FilePath setuprepo dir = do diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -269,16 +269,8 @@ arbitrary = frequency -- timestamp is not usually negative [ (50, MTimeLowRes <$> (abs . fromInteger <$> arbitrary)) - , (50, MTimeHighRes <$> (abs <$> arbposixtime)) + , (50, MTimeHighRes <$> arbitrary) ] - where - -- include fractional part, which the usual instance does not - arbposixtime = do - t <- arbitrary - f <- arbitrary - return $ if f == 0 - then t - else t + recip f #ifdef mingw32_HOST_OS instance Arbitrary FileID where diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -6,7 +6,7 @@ -} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances, CPP #-} +{-# LANGUAGE TypeSynonymInstances #-} module Utility.QuickCheck ( module X @@ -15,29 +15,23 @@ import Test.QuickCheck as X import Data.Time.Clock.POSIX +import Data.Ratio import System.Posix.Types -#if ! MIN_VERSION_QuickCheck(2,8,2) -import qualified Data.Map as M -import qualified Data.Set as S -#endif -import Control.Applicative import Prelude -#if ! MIN_VERSION_QuickCheck(2,8,2) -instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where - arbitrary = M.fromList <$> arbitrary - -instance (Arbitrary v, Ord v) => Arbitrary (S.Set v) where - arbitrary = S.fromList <$> arbitrary -#endif - -{- Times before the epoch are excluded, and no fraction is included. -} +{- Times before the epoch are excluded. Half with decimal and half without. -} instance Arbitrary POSIXTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral + arbitrary = do + n <- nonNegative arbitrarySizedBoundedIntegral :: Gen Int + d <- nonNegative arbitrarySizedIntegral + withd <- arbitrary + return $ if withd + then fromIntegral n + fromRational (1 % max d 1) + else fromIntegral n {- Pids are never negative, or 0. -} instance Arbitrary ProcessID where - arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) + arbitrary = positive arbitrarySizedBoundedIntegral {- Inodes are never negative. -} instance Arbitrary FileID where 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: 7.20181031 +Version: 7.20181105 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -356,7 +356,7 @@ split, attoparsec, concurrent-output (>= 1.6), - QuickCheck (>= 2.1), + QuickCheck (>= 2.8.2), tasty (>= 0.7), tasty-hunit, tasty-quickcheck,