Split Test.hs and avoid optimising it much, to need less memory to compile.
The ghc options were found by Sean Whitton; the debian arm autobuilders need those to build w/o OOM, and it seems to involve llvm using too much memory to optimize Test. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.
This commit is contained in:
Joey Hess
parent
bbdfdaa833
commit
8ccfbd14d0
4 changed files with 541 additions and 505 deletions
|
|
@ -15,6 +15,8 @@ git-annex (6.20180113) UNRELEASED; urgency=medium
|
||||||
last line.
|
last line.
|
||||||
* git-annex.cabal: Once more try to not build the assistant on the hurd,
|
* git-annex.cabal: Once more try to not build the assistant on the hurd,
|
||||||
hopefully hackage finally recognises that OS.
|
hopefully hackage finally recognises that OS.
|
||||||
|
* Split Test.hs and avoid optimising it much, to need less memory to
|
||||||
|
compile.
|
||||||
|
|
||||||
-- Joey Hess <id@joeyh.name> Wed, 24 Jan 2018 20:42:55 -0400
|
-- Joey Hess <id@joeyh.name> Wed, 24 Jan 2018 20:42:55 -0400
|
||||||
|
|
||||||
|
|
|
||||||
509
Test.hs
509
Test.hs
|
|
@ -6,10 +6,13 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{- Avoid optimising this file much, since it's large and does not need it._-}
|
||||||
|
{-# OPTIONS_GHC -O1 -optlo-O2 #-}
|
||||||
|
|
||||||
module Test where
|
module Test where
|
||||||
|
|
||||||
import Types.Test
|
import Types.Test
|
||||||
|
import Test.Framework
|
||||||
import Options.Applicative.Types
|
import Options.Applicative.Types
|
||||||
|
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
|
|
@ -29,12 +32,8 @@ import CmdLine.GitAnnex.Options
|
||||||
|
|
||||||
import qualified Utility.SafeCommand
|
import qualified Utility.SafeCommand
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import qualified Annex.UUID
|
|
||||||
import qualified Annex.Version
|
import qualified Annex.Version
|
||||||
import qualified Backend
|
|
||||||
import qualified Git.CurrentRepo
|
|
||||||
import qualified Git.Filename
|
import qualified Git.Filename
|
||||||
import qualified Git.Construct
|
|
||||||
import qualified Git.Types
|
import qualified Git.Types
|
||||||
import qualified Git.Ref
|
import qualified Git.Ref
|
||||||
import qualified Git.LsTree
|
import qualified Git.LsTree
|
||||||
|
|
@ -43,8 +42,6 @@ import qualified Annex.Locations
|
||||||
#ifndef mingw32_HOST_OS
|
#ifndef mingw32_HOST_OS
|
||||||
import qualified Types.GitConfig
|
import qualified Types.GitConfig
|
||||||
#endif
|
#endif
|
||||||
import qualified Types.KeySource
|
|
||||||
import qualified Types.Backend
|
|
||||||
import qualified Types.TrustLevel
|
import qualified Types.TrustLevel
|
||||||
import qualified Types
|
import qualified Types
|
||||||
import qualified Logs.MapLog
|
import qualified Logs.MapLog
|
||||||
|
|
@ -57,14 +54,11 @@ import qualified Logs.PreferredContent
|
||||||
import qualified Types.MetaData
|
import qualified Types.MetaData
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import qualified Key
|
import qualified Key
|
||||||
import qualified Types.Key
|
|
||||||
import qualified Types.Messages
|
|
||||||
import qualified Config
|
import qualified Config
|
||||||
import qualified Config.Cost
|
import qualified Config.Cost
|
||||||
import qualified Crypto
|
import qualified Crypto
|
||||||
import qualified Database.Keys
|
import qualified Database.Keys
|
||||||
import qualified Annex.WorkTree
|
import qualified Annex.WorkTree
|
||||||
import qualified Annex.Link
|
|
||||||
import qualified Annex.Init
|
import qualified Annex.Init
|
||||||
import qualified Annex.CatFile
|
import qualified Annex.CatFile
|
||||||
import qualified Annex.Path
|
import qualified Annex.Path
|
||||||
|
|
@ -72,7 +66,6 @@ import qualified Annex.AdjustedBranch
|
||||||
import qualified Annex.VectorClock
|
import qualified Annex.VectorClock
|
||||||
import qualified Annex.View
|
import qualified Annex.View
|
||||||
import qualified Annex.View.ViewedFile
|
import qualified Annex.View.ViewedFile
|
||||||
import qualified Annex.Action
|
|
||||||
import qualified Logs.View
|
import qualified Logs.View
|
||||||
import qualified Utility.Path
|
import qualified Utility.Path
|
||||||
import qualified Utility.FileMode
|
import qualified Utility.FileMode
|
||||||
|
|
@ -85,17 +78,13 @@ import qualified Utility.InodeCache
|
||||||
import qualified Utility.Env
|
import qualified Utility.Env
|
||||||
import qualified Utility.Env.Set
|
import qualified Utility.Env.Set
|
||||||
import qualified Utility.Matcher
|
import qualified Utility.Matcher
|
||||||
import qualified Utility.Exception
|
|
||||||
import qualified Utility.Hash
|
import qualified Utility.Hash
|
||||||
import qualified Utility.Scheduled
|
import qualified Utility.Scheduled
|
||||||
import qualified Utility.Scheduled.QuickCheck
|
import qualified Utility.Scheduled.QuickCheck
|
||||||
import qualified Utility.HumanTime
|
import qualified Utility.HumanTime
|
||||||
import qualified Utility.ThreadScheduler
|
|
||||||
import qualified Utility.Base64
|
import qualified Utility.Base64
|
||||||
import qualified Utility.Tmp.Dir
|
import qualified Utility.Tmp.Dir
|
||||||
import qualified Utility.FileSystemEncoding
|
import qualified Utility.FileSystemEncoding
|
||||||
import qualified Command.Uninit
|
|
||||||
import qualified CmdLine.GitAnnex as GitAnnex
|
|
||||||
#ifndef mingw32_HOST_OS
|
#ifndef mingw32_HOST_OS
|
||||||
import qualified Remote.Helper.Encryptable
|
import qualified Remote.Helper.Encryptable
|
||||||
import qualified Types.Crypto
|
import qualified Types.Crypto
|
||||||
|
|
@ -158,7 +147,7 @@ ingredients =
|
||||||
|
|
||||||
tests :: Bool -> TestOptions -> TestTree
|
tests :: Bool -> TestOptions -> TestTree
|
||||||
tests crippledfilesystem opts = testGroup "Tests" $ properties :
|
tests crippledfilesystem opts = testGroup "Tests" $ properties :
|
||||||
map (\(d, te) -> withTestMode te (unitTests d)) testmodes
|
map (\(d, te) -> withTestMode te initTests (unitTests d)) testmodes
|
||||||
where
|
where
|
||||||
testmodes = catMaybes
|
testmodes = catMaybes
|
||||||
[ Just ("v6 unlocked", (testMode opts "6") { unlockedFiles = True })
|
[ Just ("v6 unlocked", (testMode opts "6") { unlockedFiles = True })
|
||||||
|
|
@ -1734,493 +1723,3 @@ test_addurl = intmpclonerepo $ do
|
||||||
let dest = "addurlurldest"
|
let dest = "addurlurldest"
|
||||||
git_annex "addurl" ["--file", dest, url] @? ("addurl failed on " ++ url ++ " with --file")
|
git_annex "addurl" ["--file", dest, url] @? ("addurl failed on " ++ url ++ " with --file")
|
||||||
doesFileExist dest @? (dest ++ " missing after addurl --file")
|
doesFileExist dest @? (dest ++ " missing after addurl --file")
|
||||||
|
|
||||||
-- This is equivilant to running git-annex, but it's all run in-process
|
|
||||||
-- so test coverage collection works.
|
|
||||||
git_annex :: String -> [String] -> IO Bool
|
|
||||||
git_annex command params = do
|
|
||||||
-- catch all errors, including normally fatal errors
|
|
||||||
r <- try run ::IO (Either SomeException ())
|
|
||||||
case r of
|
|
||||||
Right _ -> return True
|
|
||||||
Left _ -> return False
|
|
||||||
where
|
|
||||||
run = GitAnnex.run optParser Nothing (command:"-q":params)
|
|
||||||
|
|
||||||
{- Runs git-annex and returns its output. -}
|
|
||||||
git_annex_output :: String -> [String] -> IO String
|
|
||||||
git_annex_output command params = do
|
|
||||||
pp <- Annex.Path.programPath
|
|
||||||
got <- Utility.Process.readProcess pp (command:params)
|
|
||||||
-- Since the above is a separate process, code coverage stats are
|
|
||||||
-- not gathered for things run in it.
|
|
||||||
-- Run same command again, to get code coverage.
|
|
||||||
_ <- git_annex command params
|
|
||||||
return got
|
|
||||||
|
|
||||||
git_annex_expectoutput :: String -> [String] -> [String] -> IO ()
|
|
||||||
git_annex_expectoutput command params expected = do
|
|
||||||
got <- lines <$> git_annex_output command params
|
|
||||||
got == expected @? ("unexpected value running " ++ command ++ " " ++ show params ++ " -- got: " ++ show got ++ " expected: " ++ show expected)
|
|
||||||
|
|
||||||
-- Runs an action in the current annex. Note that shutdown actions
|
|
||||||
-- are not run; this should only be used for actions that query state.
|
|
||||||
annexeval :: Types.Annex a -> IO a
|
|
||||||
annexeval a = do
|
|
||||||
s <- Annex.new =<< Git.CurrentRepo.get
|
|
||||||
Annex.eval s $ do
|
|
||||||
Annex.setOutput Types.Messages.QuietOutput
|
|
||||||
a `finally` Annex.Action.stopCoProcesses
|
|
||||||
|
|
||||||
innewrepo :: Assertion -> Assertion
|
|
||||||
innewrepo a = withgitrepo $ \r -> indir r a
|
|
||||||
|
|
||||||
inmainrepo :: Assertion -> Assertion
|
|
||||||
inmainrepo = indir mainrepodir
|
|
||||||
|
|
||||||
with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)
|
|
||||||
with_ssh_origin cloner a = cloner $ do
|
|
||||||
origindir <- absPath
|
|
||||||
=<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null")
|
|
||||||
let originurl = "localhost:" ++ origindir
|
|
||||||
boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"
|
|
||||||
a
|
|
||||||
where
|
|
||||||
config = "remote.origin.url"
|
|
||||||
|
|
||||||
intmpclonerepo :: Assertion -> Assertion
|
|
||||||
intmpclonerepo a = withtmpclonerepo $ \r -> indir r a
|
|
||||||
|
|
||||||
intmpclonerepoInDirect :: Assertion -> Assertion
|
|
||||||
intmpclonerepoInDirect a = intmpclonerepo $
|
|
||||||
ifM isdirect
|
|
||||||
( putStrLn "not supported in direct mode; skipping"
|
|
||||||
, a
|
|
||||||
)
|
|
||||||
where
|
|
||||||
isdirect = annexeval $ do
|
|
||||||
Annex.Init.initialize (Annex.Init.AutoInit False) Nothing Nothing
|
|
||||||
Config.isDirect
|
|
||||||
|
|
||||||
checkRepo :: Types.Annex a -> FilePath -> IO a
|
|
||||||
checkRepo getval d = do
|
|
||||||
s <- Annex.new =<< Git.Construct.fromPath d
|
|
||||||
Annex.eval s $
|
|
||||||
getval `finally` Annex.Action.stopCoProcesses
|
|
||||||
|
|
||||||
isInDirect :: FilePath -> IO Bool
|
|
||||||
isInDirect = checkRepo (not <$> Config.isDirect)
|
|
||||||
|
|
||||||
intmpbareclonerepo :: Assertion -> Assertion
|
|
||||||
intmpbareclonerepo a = withtmpclonerepo' (newCloneRepoConfig { bareClone = True } ) $
|
|
||||||
\r -> indir r a
|
|
||||||
|
|
||||||
intmpsharedclonerepo :: Assertion -> Assertion
|
|
||||||
intmpsharedclonerepo a = withtmpclonerepo' (newCloneRepoConfig { sharedClone = True } ) $
|
|
||||||
\r -> indir r a
|
|
||||||
|
|
||||||
withtmpclonerepo :: (FilePath -> Assertion) -> Assertion
|
|
||||||
withtmpclonerepo = withtmpclonerepo' newCloneRepoConfig
|
|
||||||
|
|
||||||
withtmpclonerepo' :: CloneRepoConfig -> (FilePath -> Assertion) -> Assertion
|
|
||||||
withtmpclonerepo' cfg a = do
|
|
||||||
dir <- tmprepodir
|
|
||||||
clone <- clonerepo mainrepodir dir cfg
|
|
||||||
r <- tryNonAsync (a clone)
|
|
||||||
case r of
|
|
||||||
Right () -> return ()
|
|
||||||
Left e -> do
|
|
||||||
whenM (keepFailures <$> getTestMode) $
|
|
||||||
putStrLn $ "** Preserving repo for failure analysis in " ++ clone
|
|
||||||
throwM e
|
|
||||||
|
|
||||||
disconnectOrigin :: Assertion
|
|
||||||
disconnectOrigin = boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm"
|
|
||||||
|
|
||||||
withgitrepo :: (FilePath -> Assertion) -> Assertion
|
|
||||||
withgitrepo = bracket (setuprepo mainrepodir) return
|
|
||||||
|
|
||||||
indir :: FilePath -> Assertion -> Assertion
|
|
||||||
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 ()))
|
|
||||||
case r of
|
|
||||||
Right () -> return ()
|
|
||||||
Left e -> throwM e
|
|
||||||
|
|
||||||
setuprepo :: FilePath -> IO FilePath
|
|
||||||
setuprepo dir = do
|
|
||||||
cleanup dir
|
|
||||||
ensuretmpdir
|
|
||||||
boolSystem "git" [Param "init", Param "-q", File dir] @? "git init failed"
|
|
||||||
configrepo dir
|
|
||||||
return dir
|
|
||||||
|
|
||||||
data CloneRepoConfig = CloneRepoConfig
|
|
||||||
{ bareClone :: Bool
|
|
||||||
, sharedClone :: Bool
|
|
||||||
}
|
|
||||||
|
|
||||||
newCloneRepoConfig :: CloneRepoConfig
|
|
||||||
newCloneRepoConfig = CloneRepoConfig
|
|
||||||
{ bareClone = False
|
|
||||||
, sharedClone = False
|
|
||||||
}
|
|
||||||
|
|
||||||
-- clones are always done as local clones; we cannot test ssh clones
|
|
||||||
clonerepo :: FilePath -> FilePath -> CloneRepoConfig -> IO FilePath
|
|
||||||
clonerepo old new cfg = do
|
|
||||||
cleanup new
|
|
||||||
ensuretmpdir
|
|
||||||
let cloneparams = catMaybes
|
|
||||||
[ Just $ Param "clone"
|
|
||||||
, Just $ Param "-q"
|
|
||||||
, if bareClone cfg then Just (Param "--bare") else Nothing
|
|
||||||
, if sharedClone cfg then Just (Param "--shared") else Nothing
|
|
||||||
, Just $ File old
|
|
||||||
, Just $ File new
|
|
||||||
]
|
|
||||||
boolSystem "git" cloneparams @? "git clone failed"
|
|
||||||
configrepo new
|
|
||||||
indir new $ do
|
|
||||||
ver <- annexVersion <$> getTestMode
|
|
||||||
if ver == Annex.Version.defaultVersion
|
|
||||||
then git_annex "init" ["-q", new] @? "git annex init failed"
|
|
||||||
else git_annex "init" ["-q", new, "--version", ver] @? "git annex init failed"
|
|
||||||
unless (bareClone cfg) $
|
|
||||||
indir new $
|
|
||||||
setupTestMode
|
|
||||||
return new
|
|
||||||
|
|
||||||
configrepo :: FilePath -> IO ()
|
|
||||||
configrepo dir = indir dir $ do
|
|
||||||
-- ensure git is set up to let commits happen
|
|
||||||
boolSystem "git" [Param "config", Param "user.name", Param "Test User"] @? "git config failed"
|
|
||||||
boolSystem "git" [Param "config", Param "user.email", Param "test@example.com"] @? "git config failed"
|
|
||||||
-- avoid signed commits by test suite
|
|
||||||
boolSystem "git" [Param "config", Param "commit.gpgsign", Param "false"] @? "git config failed"
|
|
||||||
-- tell git-annex to not annex the ingitfile
|
|
||||||
boolSystem "git"
|
|
||||||
[ Param "config"
|
|
||||||
, Param "annex.largefiles"
|
|
||||||
, Param ("exclude=" ++ ingitfile)
|
|
||||||
] @? "git config annex.largefiles failed"
|
|
||||||
|
|
||||||
ensuretmpdir :: IO ()
|
|
||||||
ensuretmpdir = do
|
|
||||||
e <- doesDirectoryExist tmpdir
|
|
||||||
unless e $
|
|
||||||
createDirectory tmpdir
|
|
||||||
|
|
||||||
{- Prevent global git configs from affecting the test suite. -}
|
|
||||||
isolateGitConfig :: IO a -> IO a
|
|
||||||
isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do
|
|
||||||
tmphomeabs <- absPath tmphome
|
|
||||||
Utility.Env.Set.setEnv "HOME" tmphomeabs True
|
|
||||||
Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True
|
|
||||||
Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True
|
|
||||||
a
|
|
||||||
|
|
||||||
cleanup :: FilePath -> IO ()
|
|
||||||
cleanup dir = whenM (doesDirectoryExist dir) $ do
|
|
||||||
Command.Uninit.prepareRemoveAnnexDir' dir
|
|
||||||
-- This can fail if files in the directory are still open by a
|
|
||||||
-- subprocess.
|
|
||||||
void $ tryIO $ removeDirectoryRecursive dir
|
|
||||||
|
|
||||||
finalCleanup :: IO ()
|
|
||||||
finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
|
|
||||||
Annex.Action.reapZombies
|
|
||||||
Command.Uninit.prepareRemoveAnnexDir' tmpdir
|
|
||||||
catchIO (removeDirectoryRecursive tmpdir) $ \e -> do
|
|
||||||
print e
|
|
||||||
putStrLn "sleeping 10 seconds and will retry directory cleanup"
|
|
||||||
Utility.ThreadScheduler.threadDelaySeconds $
|
|
||||||
Utility.ThreadScheduler.Seconds 10
|
|
||||||
whenM (doesDirectoryExist tmpdir) $ do
|
|
||||||
Annex.Action.reapZombies
|
|
||||||
removeDirectoryRecursive tmpdir
|
|
||||||
|
|
||||||
checklink :: FilePath -> Assertion
|
|
||||||
checklink f =
|
|
||||||
-- in direct mode, it may be a symlink, or not, depending
|
|
||||||
-- on whether the content is present.
|
|
||||||
unlessM (annexeval Config.isDirect) $
|
|
||||||
ifM (annexeval Config.crippledFileSystem)
|
|
||||||
( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f))
|
|
||||||
@? f ++ " is not a (crippled) symlink"
|
|
||||||
, do
|
|
||||||
s <- getSymbolicLinkStatus f
|
|
||||||
isSymbolicLink s @? f ++ " is not a symlink"
|
|
||||||
)
|
|
||||||
|
|
||||||
checkregularfile :: FilePath -> Assertion
|
|
||||||
checkregularfile f = do
|
|
||||||
s <- getSymbolicLinkStatus f
|
|
||||||
isRegularFile s @? f ++ " is not a normal file"
|
|
||||||
return ()
|
|
||||||
|
|
||||||
checkdoesnotexist :: FilePath -> Assertion
|
|
||||||
checkdoesnotexist f =
|
|
||||||
(either (const True) (const False) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))
|
|
||||||
@? f ++ " exists unexpectedly"
|
|
||||||
|
|
||||||
checkexists :: FilePath -> Assertion
|
|
||||||
checkexists f =
|
|
||||||
(either (const False) (const True) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))
|
|
||||||
@? f ++ " does not exist"
|
|
||||||
|
|
||||||
checkcontent :: FilePath -> Assertion
|
|
||||||
checkcontent f = do
|
|
||||||
c <- Utility.Exception.catchDefaultIO "could not read file" $ readFile f
|
|
||||||
assertEqual ("checkcontent " ++ f) (content f) c
|
|
||||||
|
|
||||||
checkunwritable :: FilePath -> Assertion
|
|
||||||
checkunwritable f = unlessM (annexeval Config.isDirect) $ do
|
|
||||||
-- Look at permissions bits rather than trying to write or
|
|
||||||
-- using fileAccess because if run as root, any file can be
|
|
||||||
-- modified despite permissions.
|
|
||||||
s <- getFileStatus f
|
|
||||||
let mode = fileMode s
|
|
||||||
when (mode == mode `unionFileModes` ownerWriteMode) $
|
|
||||||
assertFailure $ "able to modify annexed file's " ++ f ++ " content"
|
|
||||||
|
|
||||||
checkwritable :: FilePath -> Assertion
|
|
||||||
checkwritable f = do
|
|
||||||
s <- getFileStatus f
|
|
||||||
let mode = fileMode s
|
|
||||||
unless (mode == mode `unionFileModes` ownerWriteMode) $
|
|
||||||
assertFailure $ "unable to modify " ++ f
|
|
||||||
|
|
||||||
checkdangling :: FilePath -> Assertion
|
|
||||||
checkdangling f = ifM (annexeval Config.crippledFileSystem)
|
|
||||||
( return () -- probably no real symlinks to test
|
|
||||||
, do
|
|
||||||
r <- tryIO $ readFile f
|
|
||||||
case r of
|
|
||||||
Left _ -> return () -- expected; dangling link
|
|
||||||
Right _ -> assertFailure $ f ++ " was not a dangling link as expected"
|
|
||||||
)
|
|
||||||
|
|
||||||
checklocationlog :: FilePath -> Bool -> Assertion
|
|
||||||
checklocationlog f expected = do
|
|
||||||
thisuuid <- annexeval Annex.UUID.getUUID
|
|
||||||
r <- annexeval $ Annex.WorkTree.lookupFile f
|
|
||||||
case r of
|
|
||||||
Just k -> do
|
|
||||||
uuids <- annexeval $ Remote.keyLocations k
|
|
||||||
assertEqual ("bad content in location log for " ++ f ++ " key " ++ Key.key2file k ++ " uuid " ++ show thisuuid)
|
|
||||||
expected (thisuuid `elem` uuids)
|
|
||||||
_ -> assertFailure $ f ++ " failed to look up key"
|
|
||||||
|
|
||||||
checkbackend :: FilePath -> Types.Backend -> Assertion
|
|
||||||
checkbackend file expected = do
|
|
||||||
b <- annexeval $ maybe (return Nothing) (Backend.getBackend file)
|
|
||||||
=<< Annex.WorkTree.lookupFile file
|
|
||||||
assertEqual ("backend for " ++ file) (Just expected) b
|
|
||||||
|
|
||||||
checkispointerfile :: FilePath -> Assertion
|
|
||||||
checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile f) $
|
|
||||||
assertFailure $ f ++ " is not a pointer file"
|
|
||||||
|
|
||||||
inlocationlog :: FilePath -> Assertion
|
|
||||||
inlocationlog f = checklocationlog f True
|
|
||||||
|
|
||||||
notinlocationlog :: FilePath -> Assertion
|
|
||||||
notinlocationlog f = checklocationlog f False
|
|
||||||
|
|
||||||
runchecks :: [FilePath -> Assertion] -> FilePath -> Assertion
|
|
||||||
runchecks [] _ = return ()
|
|
||||||
runchecks (a:as) f = do
|
|
||||||
a f
|
|
||||||
runchecks as f
|
|
||||||
|
|
||||||
annexed_notpresent :: FilePath -> Assertion
|
|
||||||
annexed_notpresent f = ifM (unlockedFiles <$> getTestMode)
|
|
||||||
( annexed_notpresent_unlocked f
|
|
||||||
, annexed_notpresent_locked f
|
|
||||||
)
|
|
||||||
|
|
||||||
annexed_notpresent_locked :: FilePath -> Assertion
|
|
||||||
annexed_notpresent_locked = runchecks [checklink, checkdangling, notinlocationlog]
|
|
||||||
|
|
||||||
annexed_notpresent_unlocked :: FilePath -> Assertion
|
|
||||||
annexed_notpresent_unlocked = runchecks [checkregularfile, checkispointerfile, notinlocationlog]
|
|
||||||
|
|
||||||
annexed_present :: FilePath -> Assertion
|
|
||||||
annexed_present f = ifM (unlockedFiles <$> getTestMode)
|
|
||||||
( annexed_present_unlocked f
|
|
||||||
, annexed_present_locked f
|
|
||||||
)
|
|
||||||
|
|
||||||
annexed_present_locked :: FilePath -> Assertion
|
|
||||||
annexed_present_locked f = ifM (annexeval Config.crippledFileSystem)
|
|
||||||
( runchecks [checklink, inlocationlog] f
|
|
||||||
, runchecks [checklink, checkcontent, checkunwritable, inlocationlog] f
|
|
||||||
)
|
|
||||||
|
|
||||||
annexed_present_unlocked :: FilePath -> Assertion
|
|
||||||
annexed_present_unlocked = runchecks
|
|
||||||
[checkregularfile, checkcontent, checkwritable, inlocationlog]
|
|
||||||
|
|
||||||
unannexed :: FilePath -> Assertion
|
|
||||||
unannexed = runchecks [checkregularfile, checkcontent, checkwritable]
|
|
||||||
|
|
||||||
add_annex :: FilePath -> IO Bool
|
|
||||||
add_annex f = ifM (unlockedFiles <$> getTestMode)
|
|
||||||
( boolSystem "git" [Param "add", File f]
|
|
||||||
, git_annex "add" [f]
|
|
||||||
)
|
|
||||||
|
|
||||||
data TestMode = TestMode
|
|
||||||
{ forceDirect :: Bool
|
|
||||||
, unlockedFiles :: Bool
|
|
||||||
, annexVersion :: Annex.Version.Version
|
|
||||||
, keepFailures :: Bool
|
|
||||||
} deriving (Read, Show)
|
|
||||||
|
|
||||||
testMode :: TestOptions -> Annex.Version.Version -> TestMode
|
|
||||||
testMode opts v = TestMode
|
|
||||||
{ forceDirect = False
|
|
||||||
, unlockedFiles = False
|
|
||||||
, annexVersion = v
|
|
||||||
, keepFailures = keepFailuresOption opts
|
|
||||||
}
|
|
||||||
|
|
||||||
withTestMode :: TestMode -> TestTree -> TestTree
|
|
||||||
withTestMode testmode = withResource prepare release . const
|
|
||||||
where
|
|
||||||
prepare = do
|
|
||||||
setTestMode testmode
|
|
||||||
case tryIngredients [consoleTestReporter] mempty initTests of
|
|
||||||
Nothing -> error "No tests found!?"
|
|
||||||
Just act -> unlessM act $
|
|
||||||
error "init tests failed! cannot continue"
|
|
||||||
return ()
|
|
||||||
release _ = cleanup mainrepodir
|
|
||||||
|
|
||||||
setTestMode :: TestMode -> IO ()
|
|
||||||
setTestMode testmode = do
|
|
||||||
currdir <- getCurrentDirectory
|
|
||||||
p <- Utility.Env.getEnvDefault "PATH" ""
|
|
||||||
|
|
||||||
mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True)
|
|
||||||
-- Ensure that the just-built git annex is used.
|
|
||||||
[ ("PATH", currdir ++ [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
|
|
||||||
-- name.
|
|
||||||
, ("GIT_AUTHOR_EMAIL", "test@example.com")
|
|
||||||
, ("GIT_AUTHOR_NAME", "git-annex test")
|
|
||||||
, ("GIT_COMMITTER_EMAIL", "test@example.com")
|
|
||||||
, ("GIT_COMMITTER_NAME", "git-annex test")
|
|
||||||
-- force gpg into batch mode for the tests
|
|
||||||
, ("GPG_BATCH", "1")
|
|
||||||
-- Make git and git-annex access ssh remotes on the local
|
|
||||||
-- filesystem, without using ssh at all.
|
|
||||||
, ("GIT_SSH_COMMAND", "git-annex test --fakessh --")
|
|
||||||
, ("GIT_ANNEX_USE_GIT_SSH", "1")
|
|
||||||
, ("TESTMODE", show testmode)
|
|
||||||
]
|
|
||||||
|
|
||||||
runFakeSsh :: [String] -> IO ()
|
|
||||||
runFakeSsh ("-n":ps) = runFakeSsh ps
|
|
||||||
runFakeSsh (_host:cmd:[]) = do
|
|
||||||
(_, _, _, pid) <- createProcess (shell cmd)
|
|
||||||
exitWith =<< waitForProcess pid
|
|
||||||
runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps
|
|
||||||
|
|
||||||
getTestMode :: IO TestMode
|
|
||||||
getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" ""
|
|
||||||
|
|
||||||
setupTestMode :: IO ()
|
|
||||||
setupTestMode = do
|
|
||||||
testmode <- getTestMode
|
|
||||||
when (forceDirect testmode) $
|
|
||||||
git_annex "direct" ["-q"] @? "git annex direct failed"
|
|
||||||
|
|
||||||
changeToTmpDir :: FilePath -> IO ()
|
|
||||||
changeToTmpDir t = do
|
|
||||||
topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set")
|
|
||||||
setCurrentDirectory $ topdir ++ "/" ++ t
|
|
||||||
|
|
||||||
tmpdir :: String
|
|
||||||
tmpdir = ".t"
|
|
||||||
|
|
||||||
mainrepodir :: FilePath
|
|
||||||
mainrepodir = tmpdir </> "repo"
|
|
||||||
|
|
||||||
tmprepodir :: IO FilePath
|
|
||||||
tmprepodir = go (0 :: Int)
|
|
||||||
where
|
|
||||||
go n = do
|
|
||||||
let d = tmpdir </> "tmprepo" ++ show n
|
|
||||||
ifM (doesDirectoryExist d)
|
|
||||||
( go $ n + 1
|
|
||||||
, return d
|
|
||||||
)
|
|
||||||
|
|
||||||
annexedfile :: String
|
|
||||||
annexedfile = "foo"
|
|
||||||
|
|
||||||
annexedfiledup :: String
|
|
||||||
annexedfiledup = "foodup"
|
|
||||||
|
|
||||||
wormannexedfile :: String
|
|
||||||
wormannexedfile = "apple"
|
|
||||||
|
|
||||||
sha1annexedfile :: String
|
|
||||||
sha1annexedfile = "sha1foo"
|
|
||||||
|
|
||||||
sha1annexedfiledup :: String
|
|
||||||
sha1annexedfiledup = "sha1foodup"
|
|
||||||
|
|
||||||
ingitfile :: String
|
|
||||||
ingitfile = "bar.c"
|
|
||||||
|
|
||||||
content :: FilePath -> String
|
|
||||||
content f
|
|
||||||
| f == annexedfile = "annexed file content"
|
|
||||||
| f == ingitfile = "normal file content"
|
|
||||||
| f == sha1annexedfile ="sha1 annexed file content"
|
|
||||||
| f == annexedfiledup = content annexedfile
|
|
||||||
| f == sha1annexedfiledup = content sha1annexedfile
|
|
||||||
| f == wormannexedfile = "worm annexed file content"
|
|
||||||
| "import" `isPrefixOf` f = "imported content"
|
|
||||||
| otherwise = "unknown file " ++ f
|
|
||||||
|
|
||||||
changecontent :: FilePath -> IO ()
|
|
||||||
changecontent f = writeFile f $ changedcontent f
|
|
||||||
|
|
||||||
changedcontent :: FilePath -> String
|
|
||||||
changedcontent f = content f ++ " (modified)"
|
|
||||||
|
|
||||||
backendSHA1 :: Types.Backend
|
|
||||||
backendSHA1 = backend_ "SHA1"
|
|
||||||
|
|
||||||
backendSHA256 :: Types.Backend
|
|
||||||
backendSHA256 = backend_ "SHA256"
|
|
||||||
|
|
||||||
backendSHA256E :: Types.Backend
|
|
||||||
backendSHA256E = backend_ "SHA256E"
|
|
||||||
|
|
||||||
backendWORM :: Types.Backend
|
|
||||||
backendWORM = backend_ "WORM"
|
|
||||||
|
|
||||||
backend_ :: String -> Types.Backend
|
|
||||||
backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety
|
|
||||||
|
|
||||||
getKey :: Types.Backend -> FilePath -> IO Types.Key
|
|
||||||
getKey b f = fromJust <$> annexeval go
|
|
||||||
where
|
|
||||||
go = Types.Backend.getKey b
|
|
||||||
Types.KeySource.KeySource
|
|
||||||
{ Types.KeySource.keyFilename = f
|
|
||||||
, Types.KeySource.contentLocation = f
|
|
||||||
, Types.KeySource.inodeCache = Nothing
|
|
||||||
}
|
|
||||||
|
|
|
||||||
534
Test/Framework.hs
Normal file
534
Test/Framework.hs
Normal file
|
|
@ -0,0 +1,534 @@
|
||||||
|
{- git-annex test suite framework
|
||||||
|
-
|
||||||
|
- Copyright 2010-2017 Joey Hess <id@joeyh.name>
|
||||||
|
-
|
||||||
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
|
-}
|
||||||
|
|
||||||
|
module Test.Framework where
|
||||||
|
|
||||||
|
import Test.Tasty
|
||||||
|
import Test.Tasty.Runners
|
||||||
|
import Test.Tasty.HUnit
|
||||||
|
|
||||||
|
import Common
|
||||||
|
import Types.Test
|
||||||
|
|
||||||
|
import qualified Annex
|
||||||
|
import qualified Annex.UUID
|
||||||
|
import qualified Annex.Version
|
||||||
|
import qualified Backend
|
||||||
|
import qualified Git.CurrentRepo
|
||||||
|
import qualified Git.Construct
|
||||||
|
import qualified Types.KeySource
|
||||||
|
import qualified Types.Backend
|
||||||
|
import qualified Types
|
||||||
|
import qualified Remote
|
||||||
|
import qualified Key
|
||||||
|
import qualified Types.Key
|
||||||
|
import qualified Types.Messages
|
||||||
|
import qualified Config
|
||||||
|
import qualified Annex.WorkTree
|
||||||
|
import qualified Annex.Link
|
||||||
|
import qualified Annex.Init
|
||||||
|
import qualified Annex.Path
|
||||||
|
import qualified Annex.Action
|
||||||
|
import qualified Utility.Process
|
||||||
|
import qualified Utility.Env
|
||||||
|
import qualified Utility.Env.Set
|
||||||
|
import qualified Utility.Exception
|
||||||
|
import qualified Utility.ThreadScheduler
|
||||||
|
import qualified Utility.Tmp.Dir
|
||||||
|
import qualified Command.Uninit
|
||||||
|
import qualified CmdLine.GitAnnex as GitAnnex
|
||||||
|
|
||||||
|
-- This is equivilant to running git-annex, but it's all run in-process
|
||||||
|
-- so test coverage collection works.
|
||||||
|
git_annex :: String -> [String] -> IO Bool
|
||||||
|
git_annex command params = do
|
||||||
|
-- catch all errors, including normally fatal errors
|
||||||
|
r <- try run ::IO (Either SomeException ())
|
||||||
|
case r of
|
||||||
|
Right _ -> return True
|
||||||
|
Left _ -> return False
|
||||||
|
where
|
||||||
|
run = GitAnnex.run dummyTestOptParser Nothing (command:"-q":params)
|
||||||
|
dummyTestOptParser = pure mempty
|
||||||
|
|
||||||
|
{- Runs git-annex and returns its output. -}
|
||||||
|
git_annex_output :: String -> [String] -> IO String
|
||||||
|
git_annex_output command params = do
|
||||||
|
pp <- Annex.Path.programPath
|
||||||
|
got <- Utility.Process.readProcess pp (command:params)
|
||||||
|
-- Since the above is a separate process, code coverage stats are
|
||||||
|
-- not gathered for things run in it.
|
||||||
|
-- Run same command again, to get code coverage.
|
||||||
|
_ <- git_annex command params
|
||||||
|
return got
|
||||||
|
|
||||||
|
git_annex_expectoutput :: String -> [String] -> [String] -> IO ()
|
||||||
|
git_annex_expectoutput command params expected = do
|
||||||
|
got <- lines <$> git_annex_output command params
|
||||||
|
got == expected @? ("unexpected value running " ++ command ++ " " ++ show params ++ " -- got: " ++ show got ++ " expected: " ++ show expected)
|
||||||
|
|
||||||
|
-- Runs an action in the current annex. Note that shutdown actions
|
||||||
|
-- are not run; this should only be used for actions that query state.
|
||||||
|
annexeval :: Types.Annex a -> IO a
|
||||||
|
annexeval a = do
|
||||||
|
s <- Annex.new =<< Git.CurrentRepo.get
|
||||||
|
Annex.eval s $ do
|
||||||
|
Annex.setOutput Types.Messages.QuietOutput
|
||||||
|
a `finally` Annex.Action.stopCoProcesses
|
||||||
|
|
||||||
|
innewrepo :: Assertion -> Assertion
|
||||||
|
innewrepo a = withgitrepo $ \r -> indir r a
|
||||||
|
|
||||||
|
inmainrepo :: Assertion -> Assertion
|
||||||
|
inmainrepo = indir mainrepodir
|
||||||
|
|
||||||
|
with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)
|
||||||
|
with_ssh_origin cloner a = cloner $ do
|
||||||
|
origindir <- absPath
|
||||||
|
=<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null")
|
||||||
|
let originurl = "localhost:" ++ origindir
|
||||||
|
boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"
|
||||||
|
a
|
||||||
|
where
|
||||||
|
config = "remote.origin.url"
|
||||||
|
|
||||||
|
intmpclonerepo :: Assertion -> Assertion
|
||||||
|
intmpclonerepo a = withtmpclonerepo $ \r -> indir r a
|
||||||
|
|
||||||
|
intmpclonerepoInDirect :: Assertion -> Assertion
|
||||||
|
intmpclonerepoInDirect a = intmpclonerepo $
|
||||||
|
ifM isdirect
|
||||||
|
( putStrLn "not supported in direct mode; skipping"
|
||||||
|
, a
|
||||||
|
)
|
||||||
|
where
|
||||||
|
isdirect = annexeval $ do
|
||||||
|
Annex.Init.initialize (Annex.Init.AutoInit False) Nothing Nothing
|
||||||
|
Config.isDirect
|
||||||
|
|
||||||
|
checkRepo :: Types.Annex a -> FilePath -> IO a
|
||||||
|
checkRepo getval d = do
|
||||||
|
s <- Annex.new =<< Git.Construct.fromPath d
|
||||||
|
Annex.eval s $
|
||||||
|
getval `finally` Annex.Action.stopCoProcesses
|
||||||
|
|
||||||
|
isInDirect :: FilePath -> IO Bool
|
||||||
|
isInDirect = checkRepo (not <$> Config.isDirect)
|
||||||
|
|
||||||
|
intmpbareclonerepo :: Assertion -> Assertion
|
||||||
|
intmpbareclonerepo a = withtmpclonerepo' (newCloneRepoConfig { bareClone = True } ) $
|
||||||
|
\r -> indir r a
|
||||||
|
|
||||||
|
intmpsharedclonerepo :: Assertion -> Assertion
|
||||||
|
intmpsharedclonerepo a = withtmpclonerepo' (newCloneRepoConfig { sharedClone = True } ) $
|
||||||
|
\r -> indir r a
|
||||||
|
|
||||||
|
withtmpclonerepo :: (FilePath -> Assertion) -> Assertion
|
||||||
|
withtmpclonerepo = withtmpclonerepo' newCloneRepoConfig
|
||||||
|
|
||||||
|
withtmpclonerepo' :: CloneRepoConfig -> (FilePath -> Assertion) -> Assertion
|
||||||
|
withtmpclonerepo' cfg a = do
|
||||||
|
dir <- tmprepodir
|
||||||
|
clone <- clonerepo mainrepodir dir cfg
|
||||||
|
r <- tryNonAsync (a clone)
|
||||||
|
case r of
|
||||||
|
Right () -> return ()
|
||||||
|
Left e -> do
|
||||||
|
whenM (keepFailures <$> getTestMode) $
|
||||||
|
putStrLn $ "** Preserving repo for failure analysis in " ++ clone
|
||||||
|
throwM e
|
||||||
|
|
||||||
|
disconnectOrigin :: Assertion
|
||||||
|
disconnectOrigin = boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm"
|
||||||
|
|
||||||
|
withgitrepo :: (FilePath -> Assertion) -> Assertion
|
||||||
|
withgitrepo = bracket (setuprepo mainrepodir) return
|
||||||
|
|
||||||
|
indir :: FilePath -> Assertion -> Assertion
|
||||||
|
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 ()))
|
||||||
|
case r of
|
||||||
|
Right () -> return ()
|
||||||
|
Left e -> throwM e
|
||||||
|
|
||||||
|
setuprepo :: FilePath -> IO FilePath
|
||||||
|
setuprepo dir = do
|
||||||
|
cleanup dir
|
||||||
|
ensuretmpdir
|
||||||
|
boolSystem "git" [Param "init", Param "-q", File dir] @? "git init failed"
|
||||||
|
configrepo dir
|
||||||
|
return dir
|
||||||
|
|
||||||
|
data CloneRepoConfig = CloneRepoConfig
|
||||||
|
{ bareClone :: Bool
|
||||||
|
, sharedClone :: Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
newCloneRepoConfig :: CloneRepoConfig
|
||||||
|
newCloneRepoConfig = CloneRepoConfig
|
||||||
|
{ bareClone = False
|
||||||
|
, sharedClone = False
|
||||||
|
}
|
||||||
|
|
||||||
|
-- clones are always done as local clones; we cannot test ssh clones
|
||||||
|
clonerepo :: FilePath -> FilePath -> CloneRepoConfig -> IO FilePath
|
||||||
|
clonerepo old new cfg = do
|
||||||
|
cleanup new
|
||||||
|
ensuretmpdir
|
||||||
|
let cloneparams = catMaybes
|
||||||
|
[ Just $ Param "clone"
|
||||||
|
, Just $ Param "-q"
|
||||||
|
, if bareClone cfg then Just (Param "--bare") else Nothing
|
||||||
|
, if sharedClone cfg then Just (Param "--shared") else Nothing
|
||||||
|
, Just $ File old
|
||||||
|
, Just $ File new
|
||||||
|
]
|
||||||
|
boolSystem "git" cloneparams @? "git clone failed"
|
||||||
|
configrepo new
|
||||||
|
indir new $ do
|
||||||
|
ver <- annexVersion <$> getTestMode
|
||||||
|
if ver == Annex.Version.defaultVersion
|
||||||
|
then git_annex "init" ["-q", new] @? "git annex init failed"
|
||||||
|
else git_annex "init" ["-q", new, "--version", ver] @? "git annex init failed"
|
||||||
|
unless (bareClone cfg) $
|
||||||
|
indir new $
|
||||||
|
setupTestMode
|
||||||
|
return new
|
||||||
|
|
||||||
|
configrepo :: FilePath -> IO ()
|
||||||
|
configrepo dir = indir dir $ do
|
||||||
|
-- ensure git is set up to let commits happen
|
||||||
|
boolSystem "git" [Param "config", Param "user.name", Param "Test User"] @? "git config failed"
|
||||||
|
boolSystem "git" [Param "config", Param "user.email", Param "test@example.com"] @? "git config failed"
|
||||||
|
-- avoid signed commits by test suite
|
||||||
|
boolSystem "git" [Param "config", Param "commit.gpgsign", Param "false"] @? "git config failed"
|
||||||
|
-- tell git-annex to not annex the ingitfile
|
||||||
|
boolSystem "git"
|
||||||
|
[ Param "config"
|
||||||
|
, Param "annex.largefiles"
|
||||||
|
, Param ("exclude=" ++ ingitfile)
|
||||||
|
] @? "git config annex.largefiles failed"
|
||||||
|
|
||||||
|
ensuretmpdir :: IO ()
|
||||||
|
ensuretmpdir = do
|
||||||
|
e <- doesDirectoryExist tmpdir
|
||||||
|
unless e $
|
||||||
|
createDirectory tmpdir
|
||||||
|
|
||||||
|
{- Prevent global git configs from affecting the test suite. -}
|
||||||
|
isolateGitConfig :: IO a -> IO a
|
||||||
|
isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do
|
||||||
|
tmphomeabs <- absPath tmphome
|
||||||
|
Utility.Env.Set.setEnv "HOME" tmphomeabs True
|
||||||
|
Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True
|
||||||
|
Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True
|
||||||
|
a
|
||||||
|
|
||||||
|
cleanup :: FilePath -> IO ()
|
||||||
|
cleanup dir = whenM (doesDirectoryExist dir) $ do
|
||||||
|
Command.Uninit.prepareRemoveAnnexDir' dir
|
||||||
|
-- This can fail if files in the directory are still open by a
|
||||||
|
-- subprocess.
|
||||||
|
void $ tryIO $ removeDirectoryRecursive dir
|
||||||
|
|
||||||
|
finalCleanup :: IO ()
|
||||||
|
finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
|
||||||
|
Annex.Action.reapZombies
|
||||||
|
Command.Uninit.prepareRemoveAnnexDir' tmpdir
|
||||||
|
catchIO (removeDirectoryRecursive tmpdir) $ \e -> do
|
||||||
|
print e
|
||||||
|
putStrLn "sleeping 10 seconds and will retry directory cleanup"
|
||||||
|
Utility.ThreadScheduler.threadDelaySeconds $
|
||||||
|
Utility.ThreadScheduler.Seconds 10
|
||||||
|
whenM (doesDirectoryExist tmpdir) $ do
|
||||||
|
Annex.Action.reapZombies
|
||||||
|
removeDirectoryRecursive tmpdir
|
||||||
|
|
||||||
|
checklink :: FilePath -> Assertion
|
||||||
|
checklink f =
|
||||||
|
-- in direct mode, it may be a symlink, or not, depending
|
||||||
|
-- on whether the content is present.
|
||||||
|
unlessM (annexeval Config.isDirect) $
|
||||||
|
ifM (annexeval Config.crippledFileSystem)
|
||||||
|
( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f))
|
||||||
|
@? f ++ " is not a (crippled) symlink"
|
||||||
|
, do
|
||||||
|
s <- getSymbolicLinkStatus f
|
||||||
|
isSymbolicLink s @? f ++ " is not a symlink"
|
||||||
|
)
|
||||||
|
|
||||||
|
checkregularfile :: FilePath -> Assertion
|
||||||
|
checkregularfile f = do
|
||||||
|
s <- getSymbolicLinkStatus f
|
||||||
|
isRegularFile s @? f ++ " is not a normal file"
|
||||||
|
return ()
|
||||||
|
|
||||||
|
checkdoesnotexist :: FilePath -> Assertion
|
||||||
|
checkdoesnotexist f =
|
||||||
|
(either (const True) (const False) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))
|
||||||
|
@? f ++ " exists unexpectedly"
|
||||||
|
|
||||||
|
checkexists :: FilePath -> Assertion
|
||||||
|
checkexists f =
|
||||||
|
(either (const False) (const True) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))
|
||||||
|
@? f ++ " does not exist"
|
||||||
|
|
||||||
|
checkcontent :: FilePath -> Assertion
|
||||||
|
checkcontent f = do
|
||||||
|
c <- Utility.Exception.catchDefaultIO "could not read file" $ readFile f
|
||||||
|
assertEqual ("checkcontent " ++ f) (content f) c
|
||||||
|
|
||||||
|
checkunwritable :: FilePath -> Assertion
|
||||||
|
checkunwritable f = unlessM (annexeval Config.isDirect) $ do
|
||||||
|
-- Look at permissions bits rather than trying to write or
|
||||||
|
-- using fileAccess because if run as root, any file can be
|
||||||
|
-- modified despite permissions.
|
||||||
|
s <- getFileStatus f
|
||||||
|
let mode = fileMode s
|
||||||
|
when (mode == mode `unionFileModes` ownerWriteMode) $
|
||||||
|
assertFailure $ "able to modify annexed file's " ++ f ++ " content"
|
||||||
|
|
||||||
|
checkwritable :: FilePath -> Assertion
|
||||||
|
checkwritable f = do
|
||||||
|
s <- getFileStatus f
|
||||||
|
let mode = fileMode s
|
||||||
|
unless (mode == mode `unionFileModes` ownerWriteMode) $
|
||||||
|
assertFailure $ "unable to modify " ++ f
|
||||||
|
|
||||||
|
checkdangling :: FilePath -> Assertion
|
||||||
|
checkdangling f = ifM (annexeval Config.crippledFileSystem)
|
||||||
|
( return () -- probably no real symlinks to test
|
||||||
|
, do
|
||||||
|
r <- tryIO $ readFile f
|
||||||
|
case r of
|
||||||
|
Left _ -> return () -- expected; dangling link
|
||||||
|
Right _ -> assertFailure $ f ++ " was not a dangling link as expected"
|
||||||
|
)
|
||||||
|
|
||||||
|
checklocationlog :: FilePath -> Bool -> Assertion
|
||||||
|
checklocationlog f expected = do
|
||||||
|
thisuuid <- annexeval Annex.UUID.getUUID
|
||||||
|
r <- annexeval $ Annex.WorkTree.lookupFile f
|
||||||
|
case r of
|
||||||
|
Just k -> do
|
||||||
|
uuids <- annexeval $ Remote.keyLocations k
|
||||||
|
assertEqual ("bad content in location log for " ++ f ++ " key " ++ Key.key2file k ++ " uuid " ++ show thisuuid)
|
||||||
|
expected (thisuuid `elem` uuids)
|
||||||
|
_ -> assertFailure $ f ++ " failed to look up key"
|
||||||
|
|
||||||
|
checkbackend :: FilePath -> Types.Backend -> Assertion
|
||||||
|
checkbackend file expected = do
|
||||||
|
b <- annexeval $ maybe (return Nothing) (Backend.getBackend file)
|
||||||
|
=<< Annex.WorkTree.lookupFile file
|
||||||
|
assertEqual ("backend for " ++ file) (Just expected) b
|
||||||
|
|
||||||
|
checkispointerfile :: FilePath -> Assertion
|
||||||
|
checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile f) $
|
||||||
|
assertFailure $ f ++ " is not a pointer file"
|
||||||
|
|
||||||
|
inlocationlog :: FilePath -> Assertion
|
||||||
|
inlocationlog f = checklocationlog f True
|
||||||
|
|
||||||
|
notinlocationlog :: FilePath -> Assertion
|
||||||
|
notinlocationlog f = checklocationlog f False
|
||||||
|
|
||||||
|
runchecks :: [FilePath -> Assertion] -> FilePath -> Assertion
|
||||||
|
runchecks [] _ = return ()
|
||||||
|
runchecks (a:as) f = do
|
||||||
|
a f
|
||||||
|
runchecks as f
|
||||||
|
|
||||||
|
annexed_notpresent :: FilePath -> Assertion
|
||||||
|
annexed_notpresent f = ifM (unlockedFiles <$> getTestMode)
|
||||||
|
( annexed_notpresent_unlocked f
|
||||||
|
, annexed_notpresent_locked f
|
||||||
|
)
|
||||||
|
|
||||||
|
annexed_notpresent_locked :: FilePath -> Assertion
|
||||||
|
annexed_notpresent_locked = runchecks [checklink, checkdangling, notinlocationlog]
|
||||||
|
|
||||||
|
annexed_notpresent_unlocked :: FilePath -> Assertion
|
||||||
|
annexed_notpresent_unlocked = runchecks [checkregularfile, checkispointerfile, notinlocationlog]
|
||||||
|
|
||||||
|
annexed_present :: FilePath -> Assertion
|
||||||
|
annexed_present f = ifM (unlockedFiles <$> getTestMode)
|
||||||
|
( annexed_present_unlocked f
|
||||||
|
, annexed_present_locked f
|
||||||
|
)
|
||||||
|
|
||||||
|
annexed_present_locked :: FilePath -> Assertion
|
||||||
|
annexed_present_locked f = ifM (annexeval Config.crippledFileSystem)
|
||||||
|
( runchecks [checklink, inlocationlog] f
|
||||||
|
, runchecks [checklink, checkcontent, checkunwritable, inlocationlog] f
|
||||||
|
)
|
||||||
|
|
||||||
|
annexed_present_unlocked :: FilePath -> Assertion
|
||||||
|
annexed_present_unlocked = runchecks
|
||||||
|
[checkregularfile, checkcontent, checkwritable, inlocationlog]
|
||||||
|
|
||||||
|
unannexed :: FilePath -> Assertion
|
||||||
|
unannexed = runchecks [checkregularfile, checkcontent, checkwritable]
|
||||||
|
|
||||||
|
add_annex :: FilePath -> IO Bool
|
||||||
|
add_annex f = ifM (unlockedFiles <$> getTestMode)
|
||||||
|
( boolSystem "git" [Param "add", File f]
|
||||||
|
, git_annex "add" [f]
|
||||||
|
)
|
||||||
|
|
||||||
|
data TestMode = TestMode
|
||||||
|
{ forceDirect :: Bool
|
||||||
|
, unlockedFiles :: Bool
|
||||||
|
, annexVersion :: Annex.Version.Version
|
||||||
|
, keepFailures :: Bool
|
||||||
|
} deriving (Read, Show)
|
||||||
|
|
||||||
|
testMode :: TestOptions -> Annex.Version.Version -> TestMode
|
||||||
|
testMode opts v = TestMode
|
||||||
|
{ forceDirect = False
|
||||||
|
, unlockedFiles = False
|
||||||
|
, annexVersion = v
|
||||||
|
, keepFailures = keepFailuresOption opts
|
||||||
|
}
|
||||||
|
|
||||||
|
withTestMode :: TestMode -> TestTree -> TestTree -> TestTree
|
||||||
|
withTestMode testmode inittests = withResource prepare release . const
|
||||||
|
where
|
||||||
|
prepare = do
|
||||||
|
setTestMode testmode
|
||||||
|
case tryIngredients [consoleTestReporter] mempty inittests of
|
||||||
|
Nothing -> error "No tests found!?"
|
||||||
|
Just act -> unlessM act $
|
||||||
|
error "init tests failed! cannot continue"
|
||||||
|
return ()
|
||||||
|
release _ = cleanup mainrepodir
|
||||||
|
|
||||||
|
setTestMode :: TestMode -> IO ()
|
||||||
|
setTestMode testmode = do
|
||||||
|
currdir <- getCurrentDirectory
|
||||||
|
p <- Utility.Env.getEnvDefault "PATH" ""
|
||||||
|
|
||||||
|
mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True)
|
||||||
|
-- Ensure that the just-built git annex is used.
|
||||||
|
[ ("PATH", currdir ++ [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
|
||||||
|
-- name.
|
||||||
|
, ("GIT_AUTHOR_EMAIL", "test@example.com")
|
||||||
|
, ("GIT_AUTHOR_NAME", "git-annex test")
|
||||||
|
, ("GIT_COMMITTER_EMAIL", "test@example.com")
|
||||||
|
, ("GIT_COMMITTER_NAME", "git-annex test")
|
||||||
|
-- force gpg into batch mode for the tests
|
||||||
|
, ("GPG_BATCH", "1")
|
||||||
|
-- Make git and git-annex access ssh remotes on the local
|
||||||
|
-- filesystem, without using ssh at all.
|
||||||
|
, ("GIT_SSH_COMMAND", "git-annex test --fakessh --")
|
||||||
|
, ("GIT_ANNEX_USE_GIT_SSH", "1")
|
||||||
|
, ("TESTMODE", show testmode)
|
||||||
|
]
|
||||||
|
|
||||||
|
runFakeSsh :: [String] -> IO ()
|
||||||
|
runFakeSsh ("-n":ps) = runFakeSsh ps
|
||||||
|
runFakeSsh (_host:cmd:[]) = do
|
||||||
|
(_, _, _, pid) <- createProcess (shell cmd)
|
||||||
|
exitWith =<< waitForProcess pid
|
||||||
|
runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps
|
||||||
|
|
||||||
|
getTestMode :: IO TestMode
|
||||||
|
getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" ""
|
||||||
|
|
||||||
|
setupTestMode :: IO ()
|
||||||
|
setupTestMode = do
|
||||||
|
testmode <- getTestMode
|
||||||
|
when (forceDirect testmode) $
|
||||||
|
git_annex "direct" ["-q"] @? "git annex direct failed"
|
||||||
|
|
||||||
|
changeToTmpDir :: FilePath -> IO ()
|
||||||
|
changeToTmpDir t = do
|
||||||
|
topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set")
|
||||||
|
setCurrentDirectory $ topdir ++ "/" ++ t
|
||||||
|
|
||||||
|
tmpdir :: String
|
||||||
|
tmpdir = ".t"
|
||||||
|
|
||||||
|
mainrepodir :: FilePath
|
||||||
|
mainrepodir = tmpdir </> "repo"
|
||||||
|
|
||||||
|
tmprepodir :: IO FilePath
|
||||||
|
tmprepodir = go (0 :: Int)
|
||||||
|
where
|
||||||
|
go n = do
|
||||||
|
let d = tmpdir </> "tmprepo" ++ show n
|
||||||
|
ifM (doesDirectoryExist d)
|
||||||
|
( go $ n + 1
|
||||||
|
, return d
|
||||||
|
)
|
||||||
|
|
||||||
|
annexedfile :: String
|
||||||
|
annexedfile = "foo"
|
||||||
|
|
||||||
|
annexedfiledup :: String
|
||||||
|
annexedfiledup = "foodup"
|
||||||
|
|
||||||
|
wormannexedfile :: String
|
||||||
|
wormannexedfile = "apple"
|
||||||
|
|
||||||
|
sha1annexedfile :: String
|
||||||
|
sha1annexedfile = "sha1foo"
|
||||||
|
|
||||||
|
sha1annexedfiledup :: String
|
||||||
|
sha1annexedfiledup = "sha1foodup"
|
||||||
|
|
||||||
|
ingitfile :: String
|
||||||
|
ingitfile = "bar.c"
|
||||||
|
|
||||||
|
content :: FilePath -> String
|
||||||
|
content f
|
||||||
|
| f == annexedfile = "annexed file content"
|
||||||
|
| f == ingitfile = "normal file content"
|
||||||
|
| f == sha1annexedfile ="sha1 annexed file content"
|
||||||
|
| f == annexedfiledup = content annexedfile
|
||||||
|
| f == sha1annexedfiledup = content sha1annexedfile
|
||||||
|
| f == wormannexedfile = "worm annexed file content"
|
||||||
|
| "import" `isPrefixOf` f = "imported content"
|
||||||
|
| otherwise = "unknown file " ++ f
|
||||||
|
|
||||||
|
changecontent :: FilePath -> IO ()
|
||||||
|
changecontent f = writeFile f $ changedcontent f
|
||||||
|
|
||||||
|
changedcontent :: FilePath -> String
|
||||||
|
changedcontent f = content f ++ " (modified)"
|
||||||
|
|
||||||
|
backendSHA1 :: Types.Backend
|
||||||
|
backendSHA1 = backend_ "SHA1"
|
||||||
|
|
||||||
|
backendSHA256 :: Types.Backend
|
||||||
|
backendSHA256 = backend_ "SHA256"
|
||||||
|
|
||||||
|
backendSHA256E :: Types.Backend
|
||||||
|
backendSHA256E = backend_ "SHA256E"
|
||||||
|
|
||||||
|
backendWORM :: Types.Backend
|
||||||
|
backendWORM = backend_ "WORM"
|
||||||
|
|
||||||
|
backend_ :: String -> Types.Backend
|
||||||
|
backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety
|
||||||
|
|
||||||
|
getKey :: Types.Backend -> FilePath -> IO Types.Key
|
||||||
|
getKey b f = fromJust <$> annexeval go
|
||||||
|
where
|
||||||
|
go = Types.Backend.getKey b
|
||||||
|
Types.KeySource.KeySource
|
||||||
|
{ Types.KeySource.keyFilename = f
|
||||||
|
, Types.KeySource.contentLocation = f
|
||||||
|
, Types.KeySource.inodeCache = Nothing
|
||||||
|
}
|
||||||
|
|
@ -943,6 +943,7 @@ Executable git-annex
|
||||||
RemoteDaemon.Transport.Ssh.Types
|
RemoteDaemon.Transport.Ssh.Types
|
||||||
RemoteDaemon.Types
|
RemoteDaemon.Types
|
||||||
Test
|
Test
|
||||||
|
Test.Framework
|
||||||
Types
|
Types
|
||||||
Types.ActionItem
|
Types.ActionItem
|
||||||
Types.Availability
|
Types.Availability
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue