Commit 42e52bbb authored by Duncan Coutts's avatar Duncan Coutts Committed by Alexis Williams
Browse files

Add tests for the new 'get -s' implementation

It covers all the failure modes, and currently includes one actual
network test where we fetch a git repo. There is a new testsuite feature
flag to disable network tests, and we probably want to use that in CI.
parent a4120f49
......@@ -583,6 +583,7 @@ executable cabal
UnitTests.Distribution.Client.ArbitraryInstances
UnitTests.Distribution.Client.FileMonitor
UnitTests.Distribution.Client.Get
UnitTests.Distribution.Client.GZipUtils
UnitTests.Distribution.Client.Glob
UnitTests.Distribution.Client.IndexUtils.Timestamp
......@@ -651,6 +652,7 @@ Test-Suite unit-tests
UnitTests.Distribution.Client.ArbitraryInstances
UnitTests.Distribution.Client.Targets
UnitTests.Distribution.Client.FileMonitor
UnitTests.Distribution.Client.Get
UnitTests.Distribution.Client.Glob
UnitTests.Distribution.Client.GZipUtils
UnitTests.Distribution.Client.Sandbox
......
......@@ -27,6 +27,7 @@ import qualified UnitTests.Distribution.Client.JobControl
import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp
import qualified UnitTests.Distribution.Client.InstallPlan
import qualified UnitTests.Distribution.Client.VCS
import qualified UnitTests.Distribution.Client.Get
import UnitTests.Options
......@@ -75,6 +76,8 @@ tests mtimeChangeCalibrated =
UnitTests.Distribution.Client.InstallPlan.tests
, testGroup "UnitTests.Distribution.Client.VCS" $
UnitTests.Distribution.Client.VCS.tests mtimeChange
, testGroup "UnitTests.Distribution.Client.Get"
UnitTests.Distribution.Client.Get.tests
]
main :: IO ()
......
{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
module UnitTests.Distribution.Client.Get (tests) where
import Distribution.Client.Get
import Distribution.Types.PackageId
import Distribution.Types.PackageName
import Distribution.Types.SourceRepo
import Distribution.Verbosity as Verbosity
import Distribution.Version
import Distribution.Simple.Utils
( withTempDirectory )
import Control.Monad
import Control.Exception
import Data.Typeable
import System.FilePath
import System.Directory
import System.Exit
import System.IO.Error
import Test.Tasty
import Test.Tasty.HUnit
import UnitTests.Options (RunNetworkTests (..))
tests :: [TestTree]
tests =
[ testGroup "forkPackages"
[ testCase "no repos" testNoRepos
, testCase "no repos of requested kind" testNoReposOfKind
, testCase "no repo type specified" testNoRepoType
, testCase "unsupported repo type" testUnsupportedRepoType
, testCase "no repo location specified" testNoRepoLocation
, testCase "correct repo kind selection" testSelectRepoKind
, testCase "repo destination exists" testRepoDestinationExists
, testCase "git fetch failure" testGitFetchFailed
]
, askOption $ \(RunNetworkTests doRunNetTests) ->
testGroup "forkPackages, network tests" $
includeTestsIf doRunNetTests $
[ testCase "git clone" testNetworkGitClone
]
]
where
includeTestsIf True xs = xs
includeTestsIf False _ = []
verbosity :: Verbosity
verbosity = Verbosity.silent -- for debugging try verbose
pkgidfoo :: PackageId
pkgidfoo = PackageIdentifier (mkPackageName "foo") (mkVersion [1,0])
-- ------------------------------------------------------------
-- * Unit tests
-- ------------------------------------------------------------
testNoRepos :: Assertion
testNoRepos = do
e <- assertException $
clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
e @?= ClonePackageNoSourceRepos pkgidfoo
where
pkgrepos = [(pkgidfoo, [])]
testNoReposOfKind :: Assertion
testNoReposOfKind = do
e <- assertException $
clonePackagesFromSourceRepo verbosity "." repokind pkgrepos
e @?= ClonePackageNoSourceReposOfKind pkgidfoo repokind
where
pkgrepos = [(pkgidfoo, [repo])]
repo = emptySourceRepo RepoHead
repokind = Just RepoThis
testNoRepoType :: Assertion
testNoRepoType = do
e <- assertException $
clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
e @?= ClonePackageNoRepoType pkgidfoo repo
where
pkgrepos = [(pkgidfoo, [repo])]
repo = emptySourceRepo RepoHead
testUnsupportedRepoType :: Assertion
testUnsupportedRepoType = do
e <- assertException $
clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
e @?= ClonePackageUnsupportedRepoType pkgidfoo repo repotype
where
pkgrepos = [(pkgidfoo, [repo])]
repo = (emptySourceRepo RepoHead) {
repoType = Just repotype
}
repotype = OtherRepoType "baz"
testNoRepoLocation :: Assertion
testNoRepoLocation = do
e <- assertException $
clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
e @?= ClonePackageNoRepoLocation pkgidfoo repo
where
pkgrepos = [(pkgidfoo, [repo])]
repo = (emptySourceRepo RepoHead) {
repoType = Just repotype
}
repotype = Darcs
testSelectRepoKind :: Assertion
testSelectRepoKind =
sequence_
[ do e <- test requestedRepoType pkgrepos
e @?= ClonePackageNoRepoType pkgidfoo expectedRepo
e' <- test requestedRepoType (reverse pkgrepos)
e' @?= ClonePackageNoRepoType pkgidfoo expectedRepo
| let test rt rs = assertException $
clonePackagesFromSourceRepo verbosity "." rt rs
, (requestedRepoType, expectedRepo) <- cases
]
where
pkgrepos = [(pkgidfoo, [repo1, repo2, repo3])]
repo1 = emptySourceRepo RepoThis
repo2 = emptySourceRepo RepoHead
repo3 = emptySourceRepo (RepoKindUnknown "bar")
cases = [ (Nothing, repo1)
, (Just RepoThis, repo1)
, (Just RepoHead, repo2)
, (Just (RepoKindUnknown "bar"), repo3)
]
testRepoDestinationExists :: Assertion
testRepoDestinationExists =
withTempDirectory verbosity "." "repos" $ \tmpdir -> do
let pkgdir = tmpdir </> "foo"
createDirectory pkgdir
e1 <- assertException $
clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
e1 @?= ClonePackageDestinationExists pkgidfoo pkgdir True {- isdir -}
removeDirectory pkgdir
writeFile pkgdir ""
e2 <- assertException $
clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
e2 @?= ClonePackageDestinationExists pkgidfoo pkgdir False {- isfile -}
where
pkgrepos = [(pkgidfoo, [repo])]
repo = (emptySourceRepo RepoHead) {
repoType = Just Darcs,
repoLocation = Just ""
}
testGitFetchFailed :: Assertion
testGitFetchFailed =
withTempDirectory verbosity "." "repos" $ \tmpdir -> do
let srcdir = tmpdir </> "src"
repo = (emptySourceRepo RepoHead) {
repoType = Just Git,
repoLocation = Just srcdir
}
pkgrepos = [(pkgidfoo, [repo])]
e1 <- assertException $
clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo "git" (ExitFailure 128)
testNetworkGitClone :: Assertion
testNetworkGitClone =
withTempDirectory verbosity "." "repos" $ \tmpdir -> do
let repo1 = (emptySourceRepo RepoHead) {
repoType = Just Git,
repoLocation = Just "https://github.com/haskell/zlib.git"
}
clonePackagesFromSourceRepo verbosity tmpdir Nothing
[(mkpkgid "zlib1", [repo1])]
assertFileContains (tmpdir </> "zlib1/zlib.cabal") ["name:", "zlib"]
let repo2 = (emptySourceRepo RepoHead) {
repoType = Just Git,
repoLocation = Just (tmpdir </> "zlib1")
}
clonePackagesFromSourceRepo verbosity tmpdir Nothing
[(mkpkgid "zlib2", [repo2])]
assertFileContains (tmpdir </> "zlib2/zlib.cabal") ["name:", "zlib"]
let repo3 = (emptySourceRepo RepoHead) {
repoType = Just Git,
repoLocation = Just (tmpdir </> "zlib1"),
repoTag = Just "0.5.0.0"
}
clonePackagesFromSourceRepo verbosity tmpdir Nothing
[(mkpkgid "zlib3", [repo3])]
assertFileContains (tmpdir </> "zlib3/zlib.cabal") ["version:", "0.5.0.0"]
where
mkpkgid nm = PackageIdentifier (mkPackageName nm) (mkVersion [])
-- ------------------------------------------------------------
-- * HUnit utils
-- ------------------------------------------------------------
assertException :: forall e a. (Exception e, HasCallStack) => IO a -> IO e
assertException action = do
r <- try action
case r of
Left e -> return e
Right _ -> assertFailure $ "expected exception of type "
++ show (typeOf (undefined :: e))
-- | Expect that one line in a file matches exactly the given words (i.e. at
-- least insensitive to whitespace)
--
assertFileContains :: HasCallStack => FilePath -> [String] -> Assertion
assertFileContains file expected = do
c <- readFile file `catch` \e ->
if isDoesNotExistError e
then assertFailure $ "expected a file to exist: " ++ file
else throwIO e
unless (expected `elem` map words (lines c)) $
assertFailure $ "expected the file " ++ file ++ " to contain "
++ show (take 100 expected)
......@@ -2,6 +2,7 @@
module UnitTests.Options ( OptionShowSolverLog(..)
, OptionMtimeChangeDelay(..)
, RunNetworkTests(..)
, extraOptions )
where
......@@ -18,6 +19,7 @@ extraOptions :: [OptionDescription]
extraOptions =
[ Option (Proxy :: Proxy OptionShowSolverLog)
, Option (Proxy :: Proxy OptionMtimeChangeDelay)
, Option (Proxy :: Proxy RunNetworkTests)
]
newtype OptionShowSolverLog = OptionShowSolverLog Bool
......@@ -25,7 +27,7 @@ newtype OptionShowSolverLog = OptionShowSolverLog Bool
instance IsOption OptionShowSolverLog where
defaultValue = OptionShowSolverLog False
parseValue = fmap OptionShowSolverLog . safeRead
parseValue = fmap OptionShowSolverLog . safeReadBool
optionName = return "show-solver-log"
optionHelp = return "Show full log from the solver"
optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)
......@@ -39,3 +41,12 @@ instance IsOption OptionMtimeChangeDelay where
optionName = return "mtime-change-delay"
optionHelp = return $ "How long to wait before attempting to detect"
++ "file modification, in microseconds"
newtype RunNetworkTests = RunNetworkTests Bool
deriving Typeable
instance IsOption RunNetworkTests where
defaultValue = RunNetworkTests True
parseValue = fmap RunNetworkTests . safeReadBool
optionName = return "run-network-tests"
optionHelp = return "Run tests that need network access (default true)."
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment