module Test.Sunlight
( Description
, Compiler
, GhcPkg
, Cabal
, TestInputs(..)
, runTests
) where
import Distribution.Package
import Distribution.Text
import Test.Sunlight.Shell
import System.Directory
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Version
import Data.Tuple.Select
import qualified Data.ByteString.Char8 as BS8
import Data.Monoid
import Data.Time
import System.Locale (defaultTimeLocale)
import Data.List (intersperse)
import System.Random
import Control.Monad
import System.Exit
data InstallResult = InstallResult
{ drOutput :: CmdResult
, drGhcPkg :: CmdResult
} deriving Show
instance CheckOk InstallResult where
isOk r = all isOk . map ($ r) $ [drOutput, drGhcPkg]
installDeps
:: [PackageIdentifier]
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> IO InstallResult
installDeps cs ghc pkg cabal db dir = do
let opts =
[ "install"
, "--verbose=2"
, "--with-compiler=" ++ ghc
, "--with-hc-pkg=" ++ pkg
, "--prefix=" ++ dir
, "--disable-library-profiling"
, "--disable-executable-profiling"
, "--package-db=clear"
, "--package-db=global"
, "--package-db=" ++ db
, "--enable-tests"
, "--disable-documentation"
, "--only-dependencies"
] ++ map constraint cs
out <- tee cabal opts
let pkgOpts = [ "list", "--global", "--package-conf=" ++ db ]
pkgOut <- tee pkg pkgOpts
return $ InstallResult out pkgOut
constraint :: PackageIdentifier -> String
constraint i = "--constraint=" ++ name ++ "==" ++ ver
where
name = display . pkgName $ i
ver = display . pkgVersion $ i
data PackageInstResult = PackageInstResult
{ piSetup :: CmdResult
, piConfigure :: CmdResult
, piBuild :: CmdResult
, piInst :: CmdResult
, piGhcPkg :: CmdResult
} deriving Show
instance CheckOk PackageInstResult where
isOk r = all isOk . map ($ r) $
[ piSetup, piConfigure, piBuild, piInst, piGhcPkg ]
installPackage
:: FilePath
-> FilePath
-> FilePath
-> FilePath
-> IO PackageInstResult
installPackage ghc pkg db pfx = do
let opts =
[ "configure"
, "--verbose=2"
, "--with-compiler=" ++ ghc
, "--with-hc-pkg=" ++ pkg
, "--prefix=" ++ pfx
, "--package-db=clear"
, "--package-db=global"
, "--package-db=" ++ db
, "--enable-tests"
]
rBuildSetup <- tee "ghc" ["--make", "Setup.hs"]
rConf <- tee "./Setup" opts
let bOpts =
[ "build", "--verbose=2" ]
rBuild <- tee "./Setup" bOpts
rInst <- tee "./Setup" ["install", "--verbose=2"]
rPkg <- tee pkg
[ "list"
, "--global"
, "--package-conf=" ++ db
]
return $ PackageInstResult rBuildSetup rConf rBuild rInst rPkg
testPackage
:: [(String, [String])]
-> IO [CmdResult]
testPackage = mapM (uncurry tee)
data InstallAndTestResult = InstallAndTestResult
{ itDate :: UTCTime
, itGhcVersion :: CmdResult
, itPkgVersion :: CmdResult
, itCabalVersion :: CmdResult
, itCompileSetup :: CmdResult
, itSdistDeps :: CmdResult
, itSdistPkg :: CmdResult
, itInit :: CmdResult
, itDeps :: InstallResult
, itPackage :: PackageInstResult
, itTest :: [CmdResult]
} deriving Show
instance CheckOk InstallAndTestResult where
isOk r = and [ rsltsOk, testsOk,
isOk (itDeps r), isOk (itPackage r) ]
where
rsltsOk = all isOk . map ($ r) $
[ itGhcVersion, itPkgVersion, itCabalVersion, itCompileSetup,
itSdistDeps, itSdistPkg, itInit ]
testsOk = all isOk . itTest $ r
installAndTest
:: [PackageIdentifier]
-> UTCTime
-> FilePath
-> FilePath
-> FilePath
-> [(String, [String])]
-> IO InstallAndTestResult
installAndTest cs date ghc pkg cabal test =
withTempDirectory verbose "." "sunlight" $ \relDir -> do
dir <- canonicalizePath relDir
let setup = dir ++ "/Setup"
distDeps = dir ++ "/distDeps"
distPkg = dir ++ "/distPkg"
db = dir ++ "/db"
pfx = dir ++ "/prefix"
ghcVer <- tee ghc ["--version"]
pkgVer <- tee pkg ["--version"]
cblVer <- tee "cabal" ["--version"]
rSetup <- tee ghc ["--make", "-outputdir", dir,
"-o", setup, "Setup.hs"]
rDistDeps <- tee setup
["sdist", "--output-directory=" ++ distDeps ]
rDistPkg <- tee setup
["sdist", "--output-directory=" ++ distPkg ]
createDirectory pfx
rInit <- tee pkg ["init", db]
rDeps <- inDirectory distDeps $
installDeps cs ghc pkg cabal db pfx
rInst <- inDirectory distPkg
$ installPackage ghc pkg db pfx
rTest <- inDirectory distPkg $ testPackage test
return $ InstallAndTestResult date ghcVer pkgVer cblVer
rSetup rDistDeps rDistPkg
rInit rDeps rInst rTest
lowestVersions
:: GenericPackageDescription
-> Either Dependency [PackageIdentifier]
lowestVersions pd = mapM lowestVersion ls
where
ls = depsLib ++ depsExe ++ depsTest ++ depsBench
depsLib = case condLibrary pd of
Nothing -> []
Just deps -> getDependencies deps
getDeps = getDepsList pd
depsExe = getDeps condExecutables
depsTest = getDeps condTestSuites
depsBench = getDeps condBenchmarks
getDepsList
:: GenericPackageDescription
-> (GenericPackageDescription -> [(a, CondTree b [Dependency] c)])
-> [Dependency]
getDepsList d f = concatMap getDependencies . map snd . f $ d
getDependencies
:: CondTree v [Dependency] a
-> [Dependency]
getDependencies t =
let this = condTreeConstraints t
rest = concatMap getDependencies . map sel2
. condTreeComponents $ t
in this ++ rest
lowestVersion :: Dependency -> Either Dependency PackageIdentifier
lowestVersion d@(Dependency n r) = case asVersionIntervals r of
[] -> Left d
(LowerBound v b, _):_
| b == ExclusiveBound -> Left d
| otherwise -> Right $ PackageIdentifier n v
testLowestVersions
:: UTCTime
-> FilePath
-> FilePath
-> FilePath
-> [(String, [String])]
-> GenericPackageDescription
-> Either Dependency (IO InstallAndTestResult)
testLowestVersions date ghc pkg cabal test d = case lowestVersions d of
Left e -> Left e
Right ps -> Right $ installAndTest ps date ghc pkg cabal test
testDefaultVersions
:: UTCTime
-> FilePath
-> FilePath
-> FilePath
-> [(String, [String])]
-> IO InstallAndTestResult
testDefaultVersions date ghc pkg cabal test =
installAndTest [] date ghc pkg cabal test
testMultipleVersions
:: UTCTime
-> (FilePath, FilePath)
-> [(FilePath, FilePath)]
-> FilePath
-> [(String, [String])]
-> GenericPackageDescription
-> Either Dependency
(IO (InstallAndTestResult, [InstallAndTestResult]))
testMultipleVersions date (lowestGhc, lowestPkg) rest cabal test pd =
case testLowestVersions date lowestGhc lowestPkg cabal test pd of
Left d -> Left d
Right g -> Right $ do
r1 <- g
let testRest (c, p) = testDefaultVersions date c p cabal test
rs <- mapM testRest rest
return (r1, rs)
versionsReport
:: BS8.ByteString
-> Compiler
-> Description
-> UTCTime
-> InstallAndTestResult
-> BS8.ByteString
versionsReport desc c d t r = BS8.concat
[ "This package was tested to work with these dependency\n"
, "versions and compiler version.\n"
, desc
, "Tested as of: " <> (BS8.pack . show $ t) <> "\n"
, "Path to compiler: " <> BS8.pack c <> "\n"
, "Compiler description: " <> BS8.pack d <> "\n"
, "\n"
] <>
(crStdOut . piGhcPkg . itPackage $ r)
minimumVersionsReport
:: Compiler
-> Description
-> UTCTime
-> InstallAndTestResult
-> BS8.ByteString
minimumVersionsReport = versionsReport
"These are the minimum versions given in the .cabal file.\n"
writeMinimumVersionsReport :: BS8.ByteString -> IO ()
writeMinimumVersionsReport = BS8.writeFile "minimum-versions.txt"
currentVersionsReport
:: UTCTime
-> [(Description, Compiler, a)]
-> [InstallAndTestResult]
-> Maybe BS8.ByteString
currentVersionsReport t ds ts
| null ds || null ts = Nothing
| otherwise = Just $ versionsReport dep comp desc t r
where
dep = "These are the default versions fetched by cabal install.\n"
(desc, comp, _) = last ds
r = last ts
writeCurrentVersionsReport :: BS8.ByteString -> IO ()
writeCurrentVersionsReport = BS8.writeFile "current-versions.txt"
instance ShowBS InstallResult where
showBS r = showBS (drOutput r)
<> showBS (drGhcPkg r)
instance ShowBS PackageInstResult where
showBS r =
showBS (piSetup r)
<> showBS (piConfigure r)
<> showBS (piBuild r)
<> showBS (piInst r)
<> showBS (piGhcPkg r)
instance ShowBS InstallAndTestResult where
showBS i =
"Current time: " <> showBS (itDate i) <> "\n"
<> showBS (itGhcVersion i)
<> showBS (itPkgVersion i)
<> showBS (itCabalVersion i)
<> showBS (itCompileSetup i)
<> showBS (itSdistDeps i)
<> showBS (itSdistPkg i)
<> showBS (itInit i)
<> showBS (itDeps i)
<> showBS (itPackage i)
<> (BS8.concat . map showBS . itTest $ i)
randomString :: IO String
randomString =
fmap (map toEnum)
$ replicateM 4 (getStdRandom (randomR (fromEnum 'a', fromEnum 'z')))
makeResultFile
:: UTCTime
-> String
-> String
-> String
-> InstallAndTestResult
-> IO ()
makeResultFile utct rand desc comp res = do
let dir = resultDirectory utct rand
createDirectoryIfMissing True dir
let fn = dir ++ "/" ++ desc ++ "-" ++ comp ++ "-"
++ passFail ++ ".txt"
passFail
| isOk res = "passed"
| otherwise = "FAILED"
BS8.writeFile fn . showBS $ res
resultDirectory
:: UTCTime
-> String
-> String
resultDirectory t s = concat . intersperse "/" $
["sunlight", yr, mo, dy, ti, s ]
where
(y, m, d) = toGregorian . utctDay $ t
yr = show y
mo = pad . show $ m
dy = pad . show $ d
pad str
| length str > 1 = str
| otherwise = '0':str
ti = formatTime defaultTimeLocale "%H%M%S" t
type Description = String
type Compiler = String
type GhcPkg = String
type Cabal = String
data TestInputs = TestInputs
{ tiDescription :: Maybe GenericPackageDescription
, tiCabal :: Cabal
, tiLowest :: (Description, Compiler, GhcPkg)
, tiDefault :: [(Description, Compiler, GhcPkg)]
, tiTest :: [(String, [String])]
} deriving Show
runTests :: TestInputs -> IO ()
runTests i = do
desc <- case tiDescription i of
Just pd -> return pd
Nothing -> do
path <- defaultPackageDesc verbose
readPackageDescription verbose path
date <- getCurrentTime
randStr <- randomString
let last2 (_, b, c) = (b, c)
eiRes = testMultipleVersions date
(last2 . tiLowest $ i) (map last2 . tiDefault $ i)
(tiCabal i) (tiTest i) desc
(r1, rs) <- case eiRes of
Left e -> dependencyError e
Right g -> g
makeResultFile date randStr "lowest" (sel1 . tiLowest $ i) r1
let makeRest r (d, _, _) = makeResultFile date randStr "current" d r
_ <- zipWithM makeRest rs (tiDefault i)
when (not $ isOk r1 && all isOk rs) exitFailure
writeMinimumVersionsReport $ minimumVersionsReport
(sel2 . tiLowest $ i) (sel1 . tiLowest $ i) date r1
maybe (return ()) writeCurrentVersionsReport $ currentVersionsReport
date (tiDefault i) rs
exitSuccess
dependencyError :: Dependency -> IO a
dependencyError d = putStrLn s >> exitFailure
where
s = "dependency invalid: " ++ show d ++ " sunlight requires "
++ "that you specify a fixed lower bound for each dependency."