cabal-dev-0.9.2: test/RunTests.hs
import qualified Codec.Archive.Tar as Tar
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Applicative ( (<$>), (<*>), pure )
import Control.Monad ( replicateM, when )
import Control.Monad.Random ( Rand, getRandomR, evalRandIO )
import Data.Char ( isAscii, isAlphaNum, isLetter )
import Data.List ( intercalate )
import Data.Monoid ( mempty )
import Distribution.Package ( PackageIdentifier(..), PackageName(..)
, packageId, packageName )
import Distribution.Simple.GHC ( getInstalledPackages )
import Distribution.Simple.Compiler ( PackageDB(..)
)
import Distribution.Simple.Program ( configureAllKnownPrograms
, addKnownPrograms
, emptyProgramConfiguration
, ghcPkgProgram
, ghcProgram
, ProgramConfiguration
)
import Distribution.Simple.PackageIndex ( lookupSourcePackageId, allPackages
, SearchResult(..), searchByName
, PackageIndex
)
import Distribution.InstalledPackageInfo ( installedPackageId )
import Distribution.Simple.Utils ( withTempDirectory, info )
import Distribution.Text ( simpleParse, display )
import Distribution.Verbosity ( normal, Verbosity, showForCabal, verbose )
import Distribution.Version ( Version(..) )
import Distribution.Dev.Flags ( parseGlobalFlags, GlobalFlag(CabalInstallArg) )
import Distribution.Dev.InitPkgDb ( initPkgDb )
import Distribution.Dev.Sandbox ( newSandbox, pkgConf, Sandbox, KnownVersion, sandbox, indexTar )
import System.IO ( withBinaryFile, IOMode(ReadMode) )
import System.Cmd ( rawSystem )
import System.Process ( readProcessWithExitCode )
import System.Directory ( getTemporaryDirectory, createDirectory, doesFileExist, removeFile )
import System.Environment ( getArgs )
import System.Exit ( ExitCode(ExitSuccess) )
import System.FilePath ( (</>), (<.>), takeExtension, replaceExtension )
import System.Random ( RandomGen )
import Test.Framework ( defaultMainWithArgs, Test, testGroup )
import Test.Framework.Providers.HUnit ( testCase )
import Test.HUnit ( (@?=) )
import qualified Test.HUnit as HUnit
import Distribution.Simple.InstallDirs
import Distribution.Simple.Setup
import Distribution.ParseUtils
import Data.Function ( on )
tests :: Verbosity -> FilePath -> [Test]
tests v p =
[ testGroup "Basic invocation tests" $ testBasicInvocation p
, testGroup "Sandboxed" $
[ testCase "add-source stays sandboxed (no-space dir)" $
addSourceStaysSandboxed v p "fake-package."
, testCase "add-source stays sandboxed (dir with spaces)" $
addSourceStaysSandboxed v p "fake package."
, testCase "Builds ok regardless of the state of the logs directory" $
assertLogLocationOk v p
, testCase "Index tar files contain all contents" $
assertTarFileOk v p
]
]
testBasicInvocation :: FilePath -> [Test]
testBasicInvocation p =
[ testCase "--help exists with success" $
assertExitsSuccess p ["--help"]
, testCase "--version exists with success" $
assertExitsSuccess p ["--version"]
, testCase "--numeric-version has parseable output" $
assertProgramOutput checkNumericVersion p ["--numeric-version"]
, testCase "exits with failure when no arguments are supplied" $
assertExitsFailure p []
, testCase "short flag is passed through to cabal" $
assertShortFlags
]
main :: IO ()
main = do
args <- getArgs
-- The first argument is the cabal-dev executable. The remaining
-- arguments are passed directly to test-framework
let (cabalDev, testFrameworkArgs) =
case args of
(x:xs) -> (x, xs)
[] -> ("cabal-dev", [])
defaultMainWithArgs (tests normal cabalDev) testFrameworkArgs
assertProgramOutput :: (String -> Bool) -> FilePath -> [String]
-> HUnit.Assertion
assertProgramOutput f = assertProgram "has proper output" $
\(c, s, _) -> (c == ExitSuccess) && f s
assertExitsSuccess :: FilePath -> [String] -> HUnit.Assertion
assertExitsSuccess = assertProgram "exits successfully" $
(ExitSuccess ==) . fst3
assertExitsFailure :: FilePath -> [String] -> HUnit.Assertion
assertExitsFailure = assertProgram "exits with failure" $
(ExitSuccess /=) . fst3
-- | Test for short flags. Verifies that a short flag can make it past the cabal-dev
-- command line arg parser (and then, presumably, to cabal-install).
-- Created due to issue 6: https://github.com/creswick/cabal-dev/issues#issue/6
assertShortFlags :: HUnit.Assertion
assertShortFlags = (parseGlobalFlags $ words "install -f-curl") @?= ([CabalInstallArg "-f-curl"],["install"],[])
fst3 :: (a, b, c) -> a
fst3 (x, _, _) = x
assertProgram :: String -> ((ExitCode, String, String) -> Bool) -> FilePath -> [String]
-> HUnit.Assertion
assertProgram desc f progPath progArgs = do
res <- readProcessWithExitCode progPath progArgs ""
let msg = concat [ desc
, " failed for "
, progPath
, " "
, show progArgs
, ": "
, show res
]
HUnit.assertBool msg $ f res
-- |Check that cabal-dev add-source makes a package installable by
-- cabal-dev and that cabal-dev install for that package afterwards
-- makes it available in the sandbox, but not outside.
addSourceStaysSandboxed :: Verbosity -> FilePath -> FilePath
-> HUnit.Assertion
addSourceStaysSandboxed v cabalDev dirName =
withTempPackage v dirName $ \readPackageIndex packageDir sb pId -> do
let pkgStr = display pId
sbPkgs <- readPackageIndex (privateStack sb)
gPkgs <- readPackageIndex globalStack
-- XXX: Cabal returns a single "empty" package if you try to
-- read an empty package db, so we remove any package that has
-- an empty name before comparing
let s = filter ((/= "") . display) .
map installedPackageId .
allPackages
HUnit.assertEqual
"Newly created package index should be empty"
(s gPkgs) (s sbPkgs)
let withCabalDev f aa = do
f cabalDev (["-s", sandbox sb] ++ aa)
-- Fails because the package is not available. XXX: this
-- could fail if our randomly chosen filename is available on
-- hackage. We should actually use a cabal-install config
-- with an empty package index
withCabalDev assertExitsFailure ["install", pkgStr]
withCabalDev assertExitsSuccess ["add-source", packageDir]
-- Do the installation. Now this library should be registered
-- with GHC
withCabalDev assertExitsSuccess
["install", pkgStr, "--verbose=" ++ showForCabal v]
-- Check that we can find the library in our private package db stack
pkgIdx' <- readPackageIndex (privateStack sb)
info v $ dumpIndex pkgIdx'
case lookupSourcePackageId pkgIdx' pId of
[] -> HUnit.assertFailure $
"After installation, package " ++ pkgStr ++ " was not found"
[_] -> return ()
_ -> HUnit.assertFailure $
"Unexpectedly got more than one match for " ++ pkgStr
-- And that we can't find it in the shared package db stack
sharedIdx <- readPackageIndex sharedStack
info v $ dumpIndex sharedIdx
case lookupSourcePackageId sharedIdx pId of
[] -> return ()
_ -> HUnit.assertFailure $
"Found " ++ pkgStr ++ " in a shared package db!"
where
-- The package dbs that cabal-dev will consult
privateStack sb = [GlobalPackageDB, SpecificPackageDB $ pkgConf sb]
globalStack = [GlobalPackageDB]
-- |Test that the existence or non-existence of the logs directory
-- does not cause build failures.
--
-- Before this test, we had a bug that derived from
-- System.Directory.canonicalizePath behaving differently depending on
-- the state of the filesystem. This test tickled the bug, and now we
-- are not using canonicalizePath.
assertLogLocationOk :: Verbosity -> FilePath -> HUnit.Assertion
assertLogLocationOk v cabalDev =
mapM_ setupLogs
[ -- Works fine when its not there
(assertExitsSuccess, const $ return ())
, -- Works fine when its a directory
(assertExitsSuccess, createDirectory)
, -- Fails if it's a file
(assertExitsFailure, (`writeFile` "bogus log data"))
]
where
setupLogs (expectation, act) =
withTempPackage v "check-build-log." $ \_ packageDir sb pId -> do
let pkgStr = display pId
let logsPth = sandbox sb </> "logs"
let lsMsg msg =
when (v >= verbose) $ do
putStrLn msg
print ("ls", ["-ld", logsPth])
_ <- rawSystem "ls" ["-ld", logsPth]
return ()
let withCabalDev f aa = do
f cabalDev (["-s", sandbox sb] ++ aa)
_ <- act logsPth
lsMsg "BEFORE"
_ <- withCabalDev assertExitsSuccess ["add-source", packageDir]
_ <- withCabalDev expectation ["install", pkgStr]
lsMsg "AFTER"
assertTarFileOk :: Verbosity -> FilePath -> HUnit.Assertion
assertTarFileOk v cabalDev =
withTempPackage v "check-tar-file." $ \_ packageDir sb pId -> do
let withCabalDev f aa = do
f cabalDev (["-s", sandbox sb] ++ aa)
_ <- withCabalDev assertExitsSuccess ["add-source", packageDir]
withBinaryFile (indexTar sb) ReadMode $ \h -> do
entries <- Tar.read `fmap` L.hGetContents h
let selectCabalFile _ m@(Just _) = m
selectCabalFile e Nothing = do
case Tar.entryContent e of
Tar.NormalFile b _ | isCabalFile e -> Just b
_ -> Nothing
isCabalFile e = takeExtension (Tar.entryPath e) == ".cabal"
let c = Tar.foldEntries selectCabalFile Nothing (const Nothing) entries
case c of
Nothing -> HUnit.assertFailure "Failed to find a cabal file"
Just extracted ->
let baseCabalName = display (packageName pId) <.> "cabal"
in withBinaryFile (packageDir </> baseCabalName) ReadMode $ \h1 ->
do original <- L.hGetContents h1
HUnit.assertEqual "Cabal files before and after tarring"
original extracted
print (L.length original, L.length extracted)
L.putStr original
----------------------------------------------------------------
-- Utility code for testing sandboxing
-- Check that this string contains a numeric version
checkNumericVersion :: String -> Bool
checkNumericVersion s =
case lines s of
[l] -> case simpleParse l of
Just v -> let _ = v :: Version
in True
Nothing -> False
_ -> False
-- |Generate a minimal cabal file for a given package identifier
--
-- This Cabal file is useful for testing whether cabal-install can
-- install things, and what the side-effects of installing a package
-- are. Note that there are many side-effects that are not invoked by
-- this package, however!
genCabalFile :: PackageIdentifier -> String
genCabalFile pId =
unlines
[ "Name: " ++ display (pkgName pId)
, "Version: " ++ display (pkgVersion pId)
, "Build-type: Simple"
, "Cabal-version: >=1.2"
, "Maintainer: nobody"
, "Description: This package contains no source code, and only enough in\
\ the Cabal file to make it buildable"
, "Category: Testing"
, "License: BSD3"
, "Synopsis: The most minimal package that will build"
, "Library"
, " build-depends: base"
]
-- |Generate a random Cabal package identifier
--
-- XXX: If the package identifier is over a certain size, then
-- cabal-install will fail because a filename is "too long." It's
-- unclear what this limit is, but this function has been tweaked to
-- generate a shorter name. There is still a big enough range of
-- values that it should be pretty easy to find a name that doesn't
-- conflict with something else, though.
mkRandomPkgId :: RandomGen g => Rand g PackageIdentifier
mkRandomPkgId = PackageIdentifier <$> getRandomName <*> getRandomVersion
where
getRandomVersion = Version <$> getRandomBranch <*> pure tags
where tags = []
-- A branch is a version number
getRandomBranch = do
n <- getRandomR (1, 4)
replicateM n $ getRandomR (0, 100)
getRandomName = do
i <- getRandomR (1, 5)
segs <- replicateM i getRandomSegment
return $ PackageName $ intercalate "-" segs
-- A Cabal package name segment must be at least one character
-- long, consist of alphanumeric characters, and contain at
-- least one letter.
getRandomSegment = do
aChar <- getRandomChar pkgLetter
before <- getRandomStr pkgChar 5
after <- getRandomStr pkgChar 5
return $ before ++ [aChar] ++ after
-- Given a predicate, select a random character from the first
-- 256 characters that satsifies that predicate. An exception
-- will be raised if no character matches the predicate.
getRandomChar p = do
let rng = filter p ['\0'..'\255']
i <- getRandomR (0, length rng - 1)
return $ rng !! i
-- Get a random string of characters that match the predicate p
-- of length [0..n]
getRandomStr p n = do
i <- getRandomR (0, n)
replicateM i $ getRandomChar p
pkgLetter c = isAscii c && isLetter c
pkgChar c = isAscii c && isAlphaNum c
-- A human-readable package index dump
dumpIndex :: PackageIndex -> String
dumpIndex pkgIdx = unlines $ "Package index contents:":
map (showString " " . display . packageId)
(allPackages pkgIdx)
-- Return a program database containing the programs we need to
-- load a package index
configurePrerequisites :: Verbosity -> IO ProgramConfiguration
configurePrerequisites v =
configureAllKnownPrograms v $
addKnownPrograms toConfigure emptyProgramConfiguration
where
-- The programs that need to be configured in order to load a
-- package index
toConfigure = [ ghcPkgProgram
, ghcProgram
]
-- A package db stack that includes only shared package databases
sharedStack :: [PackageDB]
sharedStack = [GlobalPackageDB, UserPackageDB]
-- Given a package index, generate a package name that is not in
-- that index. It is unlikely that a randomly generated name
-- will be in the package index, but we will try three times to
-- make it wildly unlikely.
findUnusedPackageId :: Verbosity -> PackageIndex -> IO PackageIdentifier
findUnusedPackageId v pkgIdx = go []
where
go ps = do
when (length ps > 2) $ HUnit.assertFailure $
showString "Failed to find an unused package id. Tried:" $
intercalate " " $
map display ps
pId <- evalRandIO mkRandomPkgId
case searchByName pkgIdx (display $ packageName pId) of
None -> do info v $ "Found unused package " ++ display pId
return pId
_ -> go (pId:ps)
-- |Create a dummy Cabal package in a temporary directory and invoke a
-- function with the state dependent on the temporary directory.
withTempPackage
:: Verbosity -> String
-> (([PackageDB] -> IO PackageIndex)
-> FilePath
-> Sandbox KnownVersion -> PackageIdentifier -> IO a)
-> IO a
withTempPackage v dirName f =
do pConf <- configurePrerequisites v
let readPackageIndex stack = getInstalledPackages v stack pConf
-- Get the shared package index and choose a package identifier
-- that is not in it
pkgIdx <- readPackageIndex sharedStack
info v $ dumpIndex pkgIdx
pId <- findUnusedPackageId v pkgIdx
-- Create a temporary directory in which to build and install
-- the bogus package
tmp <- getTemporaryDirectory
withTempDirectory v tmp dirName $ \d -> do
let sandboxDir = d </> "cabal-dev"
let packageDir = d </> "pkg"
let cabalFileName = packageDir </> display (pkgName pId) <.> "cabal"
createDirectory packageDir
writeFile cabalFileName (genCabalFile pId)
info v $ unlines [ "Generated cabal file:"
, genCabalFile pId
]
when (v >= verbose) $ rawSystem "ls" ["-l"] >> return ()
sb <- initPkgDb v =<< newSandbox v sandboxDir
f readPackageIndex packageDir sb pId