Skip to content

Commit 59daa5f

Browse files
dcouttsdcoutts
committed
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.
1 parent dfbd8bc commit 59daa5f

File tree

4 files changed

+251
-1
lines changed

4 files changed

+251
-1
lines changed

‎cabal-install/cabal-install.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -574,6 +574,7 @@ executable cabal
574574

575575
UnitTests.Distribution.Client.ArbitraryInstances
576576
UnitTests.Distribution.Client.FileMonitor
577+
UnitTests.Distribution.Client.Get
577578
UnitTests.Distribution.Client.GZipUtils
578579
UnitTests.Distribution.Client.Glob
579580
UnitTests.Distribution.Client.IndexUtils.Timestamp
@@ -642,6 +643,7 @@ Test-Suite unit-tests
642643
UnitTests.Distribution.Client.ArbitraryInstances
643644
UnitTests.Distribution.Client.Targets
644645
UnitTests.Distribution.Client.FileMonitor
646+
UnitTests.Distribution.Client.Get
645647
UnitTests.Distribution.Client.Glob
646648
UnitTests.Distribution.Client.GZipUtils
647649
UnitTests.Distribution.Client.Sandbox

‎cabal-install/tests/UnitTests.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ import qualified UnitTests.Distribution.Client.JobControl
2727
import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp
2828
import qualified UnitTests.Distribution.Client.InstallPlan
2929
import qualified UnitTests.Distribution.Client.VCS
30+
import qualified UnitTests.Distribution.Client.Get
3031

3132
import UnitTests.Options
3233

@@ -75,6 +76,8 @@ tests mtimeChangeCalibrated =
7576
UnitTests.Distribution.Client.InstallPlan.tests
7677
, testGroup "UnitTests.Distribution.Client.VCS" $
7778
UnitTests.Distribution.Client.VCS.tests mtimeChange
79+
, testGroup "UnitTests.Distribution.Client.Get"
80+
UnitTests.Distribution.Client.Get.tests
7881
]
7982

8083
main :: IO ()

‎cabal-install/tests/UnitTests/Distribution/Client/Get.hs

Lines changed: 234 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,234 @@
1+
{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
2+
module UnitTests.Distribution.Client.Get (tests) where
3+
4+
import Distribution.Client.Get
5+
6+
import Distribution.Types.PackageId
7+
import Distribution.Types.PackageName
8+
import Distribution.Types.SourceRepo
9+
import Distribution.Verbosity as Verbosity
10+
import Distribution.Version
11+
import Distribution.Simple.Utils
12+
( withTempDirectory )
13+
14+
import Control.Monad
15+
import Control.Exception
16+
import Data.Typeable
17+
import System.FilePath
18+
import System.Directory
19+
import System.Exit
20+
import System.IO.Error
21+
22+
import Test.Tasty
23+
import Test.Tasty.HUnit
24+
import UnitTests.Options (RunNetworkTests (..))
25+
26+
tests :: [TestTree]
27+
tests =
28+
[ testGroup "forkPackages"
29+
[ testCase "no repos" testNoRepos
30+
, testCase "no repos of requested kind" testNoReposOfKind
31+
, testCase "no repo type specified" testNoRepoType
32+
, testCase "unsupported repo type" testUnsupportedRepoType
33+
, testCase "no repo location specified" testNoRepoLocation
34+
, testCase "correct repo kind selection" testSelectRepoKind
35+
, testCase "repo destination exists" testRepoDestinationExists
36+
, testCase "git fetch failure" testGitFetchFailed
37+
]
38+
, askOption $ \(RunNetworkTests doRunNetTests) ->
39+
testGroup "forkPackages, network tests" $
40+
includeTestsIf doRunNetTests $
41+
[ testCase "git clone" testNetworkGitClone
42+
]
43+
]
44+
where
45+
includeTestsIf True xs = xs
46+
includeTestsIf False _ = []
47+
48+
49+
50+
verbosity :: Verbosity
51+
verbosity = Verbosity.silent -- for debugging try verbose
52+
53+
pkgidfoo :: PackageId
54+
pkgidfoo = PackageIdentifier (mkPackageName "foo") (mkVersion [1,0])
55+
56+
57+
-- ------------------------------------------------------------
58+
-- * Unit tests
59+
-- ------------------------------------------------------------
60+
61+
testNoRepos :: Assertion
62+
testNoRepos = do
63+
e <- assertException $
64+
clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
65+
e @?= ClonePackageNoSourceRepos pkgidfoo
66+
where
67+
pkgrepos = [(pkgidfoo, [])]
68+
69+
70+
testNoReposOfKind :: Assertion
71+
testNoReposOfKind = do
72+
e <- assertException $
73+
clonePackagesFromSourceRepo verbosity "." repokind pkgrepos
74+
e @?= ClonePackageNoSourceReposOfKind pkgidfoo repokind
75+
where
76+
pkgrepos = [(pkgidfoo, [repo])]
77+
repo = emptySourceRepo RepoHead
78+
repokind = Just RepoThis
79+
80+
81+
testNoRepoType :: Assertion
82+
testNoRepoType = do
83+
e <- assertException $
84+
clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
85+
e @?= ClonePackageNoRepoType pkgidfoo repo
86+
where
87+
pkgrepos = [(pkgidfoo, [repo])]
88+
repo = emptySourceRepo RepoHead
89+
90+
91+
testUnsupportedRepoType :: Assertion
92+
testUnsupportedRepoType = do
93+
e <- assertException $
94+
clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
95+
e @?= ClonePackageUnsupportedRepoType pkgidfoo repo repotype
96+
where
97+
pkgrepos = [(pkgidfoo, [repo])]
98+
repo = (emptySourceRepo RepoHead) {
99+
repoType = Just repotype
100+
}
101+
repotype = OtherRepoType "baz"
102+
103+
104+
testNoRepoLocation :: Assertion
105+
testNoRepoLocation = do
106+
e <- assertException $
107+
clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
108+
e @?= ClonePackageNoRepoLocation pkgidfoo repo
109+
where
110+
pkgrepos = [(pkgidfoo, [repo])]
111+
repo = (emptySourceRepo RepoHead) {
112+
repoType = Just repotype
113+
}
114+
repotype = Darcs
115+
116+
117+
testSelectRepoKind :: Assertion
118+
testSelectRepoKind =
119+
sequence_
120+
[ do e <- test requestedRepoType pkgrepos
121+
e @?= ClonePackageNoRepoType pkgidfoo expectedRepo
122+
123+
e' <- test requestedRepoType (reverse pkgrepos)
124+
e' @?= ClonePackageNoRepoType pkgidfoo expectedRepo
125+
| let test rt rs = assertException $
126+
clonePackagesFromSourceRepo verbosity "." rt rs
127+
, (requestedRepoType, expectedRepo) <- cases
128+
]
129+
where
130+
pkgrepos = [(pkgidfoo, [repo1, repo2, repo3])]
131+
repo1 = emptySourceRepo RepoThis
132+
repo2 = emptySourceRepo RepoHead
133+
repo3 = emptySourceRepo (RepoKindUnknown "bar")
134+
cases = [ (Nothing, repo1)
135+
, (Just RepoThis, repo1)
136+
, (Just RepoHead, repo2)
137+
, (Just (RepoKindUnknown "bar"), repo3)
138+
]
139+
140+
141+
testRepoDestinationExists :: Assertion
142+
testRepoDestinationExists =
143+
withTempDirectory verbosity "." "repos" $ \tmpdir -> do
144+
let pkgdir = tmpdir </> "foo"
145+
createDirectory pkgdir
146+
e1 <- assertException $
147+
clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
148+
e1 @?= ClonePackageDestinationExists pkgidfoo pkgdir True {- isdir -}
149+
150+
removeDirectory pkgdir
151+
152+
writeFile pkgdir ""
153+
e2 <- assertException $
154+
clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
155+
e2 @?= ClonePackageDestinationExists pkgidfoo pkgdir False {- isfile -}
156+
where
157+
pkgrepos = [(pkgidfoo, [repo])]
158+
repo = (emptySourceRepo RepoHead) {
159+
repoType = Just Darcs,
160+
repoLocation = Just ""
161+
}
162+
163+
164+
testGitFetchFailed :: Assertion
165+
testGitFetchFailed =
166+
withTempDirectory verbosity "." "repos" $ \tmpdir -> do
167+
let srcdir = tmpdir </> "src"
168+
repo = (emptySourceRepo RepoHead) {
169+
repoType = Just Git,
170+
repoLocation = Just srcdir
171+
}
172+
pkgrepos = [(pkgidfoo, [repo])]
173+
e1 <- assertException $
174+
clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
175+
e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo "git" (ExitFailure 128)
176+
177+
178+
testNetworkGitClone :: Assertion
179+
testNetworkGitClone =
180+
withTempDirectory verbosity "." "repos" $ \tmpdir -> do
181+
let repo1 = (emptySourceRepo RepoHead) {
182+
repoType = Just Git,
183+
repoLocation = Just "https://github.com/haskell/zlib.git"
184+
}
185+
clonePackagesFromSourceRepo verbosity tmpdir Nothing
186+
[(mkpkgid "zlib1", [repo1])]
187+
assertFileContains (tmpdir </> "zlib1/zlib.cabal") ["name:", "zlib"]
188+
189+
let repo2 = (emptySourceRepo RepoHead) {
190+
repoType = Just Git,
191+
repoLocation = Just (tmpdir </> "zlib1")
192+
}
193+
clonePackagesFromSourceRepo verbosity tmpdir Nothing
194+
[(mkpkgid "zlib2", [repo2])]
195+
assertFileContains (tmpdir </> "zlib2/zlib.cabal") ["name:", "zlib"]
196+
197+
let repo3 = (emptySourceRepo RepoHead) {
198+
repoType = Just Git,
199+
repoLocation = Just (tmpdir </> "zlib1"),
200+
repoTag = Just "0.5.0.0"
201+
}
202+
clonePackagesFromSourceRepo verbosity tmpdir Nothing
203+
[(mkpkgid "zlib3", [repo3])]
204+
assertFileContains (tmpdir </> "zlib3/zlib.cabal") ["version:", "0.5.0.0"]
205+
where
206+
mkpkgid nm = PackageIdentifier (mkPackageName nm) (mkVersion [])
207+
208+
209+
-- ------------------------------------------------------------
210+
-- * HUnit utils
211+
-- ------------------------------------------------------------
212+
213+
assertException :: forall e a. (Exception e, HasCallStack) => IO a -> IO e
214+
assertException action = do
215+
r <- try action
216+
case r of
217+
Left e -> return e
218+
Right _ -> assertFailure $ "expected exception of type "
219+
++ show (typeOf (undefined :: e))
220+
221+
222+
-- | Expect that one line in a file matches exactly the given words (i.e. at
223+
-- least insensitive to whitespace)
224+
--
225+
assertFileContains :: HasCallStack => FilePath -> [String] -> Assertion
226+
assertFileContains file expected = do
227+
c <- readFile file `catch` \e ->
228+
if isDoesNotExistError e
229+
then assertFailure $ "expected a file to exist: " ++ file
230+
else throwIO e
231+
unless (expected `elem` map words (lines c)) $
232+
assertFailure $ "expected the file " ++ file ++ " to contain "
233+
++ show (take 100 expected)
234+

‎cabal-install/tests/UnitTests/Options.hs

Lines changed: 12 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22

33
module UnitTests.Options ( OptionShowSolverLog(..)
44
, OptionMtimeChangeDelay(..)
5+
, RunNetworkTests(..)
56
, extraOptions )
67
where
78

@@ -18,14 +19,15 @@ extraOptions :: [OptionDescription]
1819
extraOptions =
1920
[ Option (Proxy :: Proxy OptionShowSolverLog)
2021
, Option (Proxy :: Proxy OptionMtimeChangeDelay)
22+
, Option (Proxy :: Proxy RunNetworkTests)
2123
]
2224

2325
newtype OptionShowSolverLog = OptionShowSolverLog Bool
2426
deriving Typeable
2527

2628
instance IsOption OptionShowSolverLog where
2729
defaultValue = OptionShowSolverLog False
28-
parseValue = fmap OptionShowSolverLog . safeRead
30+
parseValue = fmap OptionShowSolverLog . safeReadBool
2931
optionName = return "show-solver-log"
3032
optionHelp = return "Show full log from the solver"
3133
optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)
@@ -39,3 +41,12 @@ instance IsOption OptionMtimeChangeDelay where
3941
optionName = return "mtime-change-delay"
4042
optionHelp = return $ "How long to wait before attempting to detect"
4143
++ "file modification, in microseconds"
44+
45+
newtype RunNetworkTests = RunNetworkTests Bool
46+
deriving Typeable
47+
48+
instance IsOption RunNetworkTests where
49+
defaultValue = RunNetworkTests True
50+
parseValue = fmap RunNetworkTests . safeReadBool
51+
optionName = return "run-network-tests"
52+
optionHelp = return "Run tests that need network access (default true)."

0 commit comments

Comments
 (0)