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