Cabal-3.4.0.0: tests/HackageTests.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if !MIN_VERSION_deepseq(1,4,0)
{-# OPTIONS_GHC -fno-warn-orphans #-}
#endif
module Main where
import Distribution.Compat.Semigroup
import Prelude ()
import Prelude.Compat
import Control.Applicative (many, (<**>), (<|>))
import Control.DeepSeq (NFData (..), force)
import Control.Exception (evaluate)
import Control.Monad (join, unless, when)
import Data.Foldable (traverse_)
import Data.List (isPrefixOf, isSuffixOf)
import Data.Maybe (mapMaybe)
import Data.Monoid (Sum (..))
import Distribution.PackageDescription.Check (PackageCheck (..), checkPackage)
import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
import Distribution.PackageDescription.Quirks (patchQuirks)
import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)
import Numeric (showFFloat)
import System.Directory (getAppUserDataDirectory)
import System.Environment (lookupEnv)
import System.Exit (exitFailure)
import System.FilePath ((</>))
import Data.Orphans ()
import qualified Codec.Archive.Tar as Tar
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BSL
import qualified Distribution.Fields.Parser as Parsec
import qualified Distribution.Fields.Pretty as PP
import qualified Distribution.PackageDescription.Parsec as Parsec
import qualified Distribution.Parsec as Parsec
import qualified Options.Applicative as O
import qualified System.Clock as Clock
import Distribution.Compat.Lens
import qualified Distribution.Types.GenericPackageDescription.Lens as L
import qualified Distribution.Types.PackageDescription.Lens as L
-- import Distribution.Types.BuildInfo (BuildInfo (cppOptions))
-- import qualified Distribution.Types.BuildInfo.Lens as L
#ifdef MIN_VERSION_tree_diff
import Data.TreeDiff (ediff)
import Data.TreeDiff.Instances.Cabal ()
import Data.TreeDiff.Pretty (ansiWlEditExprCompact)
#endif
-------------------------------------------------------------------------------
-- parseIndex: Index traversal
-------------------------------------------------------------------------------
parseIndex :: (Monoid a, NFData a) => (FilePath -> Bool)
-> (FilePath -> B.ByteString -> IO a) -> IO a
parseIndex predicate action = do
cabalDir <- getAppUserDataDirectory "cabal"
configPath <- getCabalConfigPath cabalDir
cfg <- B.readFile configPath
cfgFields <- either (fail . show) pure $ Parsec.readFields cfg
let repos = reposFromConfig cfgFields
repoCache = case lookupInConfig "remote-repo-cache" cfgFields of
[] -> cabalDir </> "packages" -- Default
(rrc : _) -> rrc -- User-specified
tarName repo = repoCache </> repo </> "01-index.tar"
mconcat <$> traverse (parseIndex' predicate action . tarName) repos
where
getCabalConfigPath cabalDir = do
mx <- lookupEnv "CABAL_CONFIG"
case mx of
Just x -> return x
Nothing -> return (cabalDir </> "config")
parseIndex'
:: (Monoid a, NFData a)
=> (FilePath -> Bool)
-> (FilePath -> B.ByteString -> IO a) -> FilePath -> IO a
parseIndex' predicate action path = do
putStrLn $ "Reading index from: " ++ path
contents <- BSL.readFile path
let entries = Tar.read contents
entries' = Tar.foldEntries cons [] (error . show) entries
foldIO f entries'
where
cons entry entries
| predicate (Tar.entryPath entry) = entry : entries
| otherwise = entries
f entry = case Tar.entryContent entry of
Tar.NormalFile contents _
| ".cabal" `isSuffixOf` fpath -> do
bs <- evaluate (BSL.toStrict contents)
res <- action fpath bs
evaluate (force res)
| otherwise ->
return mempty
Tar.Directory -> return mempty
_ -> putStrLn ("Unknown content in " ++ fpath)
>> return mempty
where
fpath = Tar.entryPath entry
-------------------------------------------------------------------------------
-- readFields tests: very fast test for 'readFields' - first step of parser
-------------------------------------------------------------------------------
readFieldTest :: FilePath -> B.ByteString -> IO ()
readFieldTest fpath bs = case Parsec.readFields bs' of
Right _ -> return ()
Left err -> do
putStrLn fpath
print err
exitFailure
where
(_, bs') = patchQuirks bs
-------------------------------------------------------------------------------
-- Parsec test: whether we can parse everything
-------------------------------------------------------------------------------
parseParsecTest :: Bool -> FilePath -> B.ByteString -> IO ParsecResult
parseParsecTest keepGoing fpath bs = do
let (warnings, result) = Parsec.runParseResult $
Parsec.parseGenericPackageDescription bs
let w | null warnings = 0
| otherwise = 1
case result of
Right gpd -> do
forEachGPD fpath bs gpd
return (ParsecResult 1 w 0)
Left (_, errors) | keepGoing -> do
traverse_ (putStrLn . Parsec.showPError fpath) errors
return (ParsecResult 1 w 1)
| otherwise -> do
traverse_ (putStrLn . Parsec.showPError fpath) errors
exitFailure
-- | A hook to make queries on Hackage
forEachGPD :: FilePath -> B8.ByteString -> L.GenericPackageDescription -> IO ()
forEachGPD _ _ _ = return ()
-------------------------------------------------------------------------------
-- ParsecResult
-------------------------------------------------------------------------------
data ParsecResult = ParsecResult !Int !Int !Int
deriving (Eq, Show)
instance Semigroup ParsecResult where
ParsecResult x y z <> ParsecResult u v w = ParsecResult (x + u) (y + v) (z + w)
instance Monoid ParsecResult where
mempty = ParsecResult 0 0 0
mappend = (<>)
instance NFData ParsecResult where
rnf (ParsecResult _ _ _) = ()
-------------------------------------------------------------------------------
-- Check test
-------------------------------------------------------------------------------
parseCheckTest :: FilePath -> B.ByteString -> IO CheckResult
parseCheckTest fpath bs = do
let (warnings, parsec) = Parsec.runParseResult $
Parsec.parseGenericPackageDescription bs
case parsec of
Right gpd -> do
let checks = checkPackage gpd Nothing
let w [] = 0
w _ = 1
-- Look into invalid cpp options
-- _ <- L.traverseBuildInfos checkCppFlags gpd
-- one for file, many checks
return (CheckResult 1 (w warnings) 0 0 0 0 0 0 <> foldMap toCheckResult checks)
Left (_, errors) -> do
traverse_ (putStrLn . Parsec.showPError fpath) errors
exitFailure
-- checkCppFlags :: BuildInfo -> IO BuildInfo
-- checkCppFlags bi = do
-- for_ (cppOptions bi) $ \opt ->
-- unless (any (`isPrefixOf` opt) ["-D", "-U", "-I"]) $
-- putStrLn opt
--
-- return bi
data CheckResult = CheckResult !Int !Int !Int !Int !Int !Int !Int !Int
instance NFData CheckResult where
rnf !_ = ()
instance Semigroup CheckResult where
CheckResult n w a b c d e f <> CheckResult n' w' a' b' c' d' e' f' =
CheckResult (n + n') (w + w') (a + a') (b + b') (c + c') (d + d') (e + e') (f + f')
instance Monoid CheckResult where
mempty = CheckResult 0 0 0 0 0 0 0 0
mappend = (<>)
toCheckResult :: PackageCheck -> CheckResult
toCheckResult PackageBuildImpossible {} = CheckResult 0 0 1 1 0 0 0 0
toCheckResult PackageBuildWarning {} = CheckResult 0 0 1 0 1 0 0 0
toCheckResult PackageDistSuspicious {} = CheckResult 0 0 1 0 0 1 0 0
toCheckResult PackageDistSuspiciousWarn {} = CheckResult 0 0 1 0 0 0 1 0
toCheckResult PackageDistInexcusable {} = CheckResult 0 0 1 0 0 0 0 1
-------------------------------------------------------------------------------
-- Roundtrip test
-------------------------------------------------------------------------------
roundtripTest :: Bool -> FilePath -> B.ByteString -> IO (Sum Int)
roundtripTest testFieldsTransform fpath bs = do
x0 <- parse "1st" bs
let bs' = showGenericPackageDescription x0
y0 <- parse "2nd" (toUTF8BS bs')
-- we mungled license here
let y1 = y0
-- license-files: ""
let stripEmpty = filter (/="")
let x1 = x0 & L.packageDescription . L.licenseFiles %~ stripEmpty
let y2 = y1 & L.packageDescription . L.licenseFiles %~ stripEmpty
let y = y2 & L.packageDescription . L.description .~ mempty
let x = x1 & L.packageDescription . L.description .~ mempty
assertEqual' bs' x y
-- fromParsecField, "shallow" parser/pretty roundtrip
when testFieldsTransform $
if checkUTF8 patchedBs
then do
parsecFields <- assertRight $ Parsec.readFields patchedBs
let prettyFields = PP.fromParsecFields parsecFields
let bs'' = PP.showFields (return []) prettyFields
z0 <- parse "3rd" (toUTF8BS bs'')
-- note: we compare "raw" GPDs, on purpose; stricter equality
assertEqual' bs'' x0 z0
else
putStrLn $ fpath ++ " : looks like invalid UTF8"
return (Sum 1)
where
patchedBs = snd (patchQuirks bs)
checkUTF8 bs' = replacementChar `notElem` fromUTF8BS bs' where
replacementChar = '\xfffd'
assertRight (Right x) = return x
assertRight (Left err) = do
putStrLn fpath
print err
exitFailure
assertEqual' bs' x y = unless (x == y || fpath == "ixset/1.0.4/ixset.cabal") $ do
putStrLn fpath
#ifdef MIN_VERSION_tree_diff
putStrLn "====== tree-diff:"
print $ ansiWlEditExprCompact $ ediff x y
#else
putStrLn "<<<<<<"
print x
putStrLn "======"
print y
putStrLn ">>>>>>"
#endif
putStrLn "====== contents:"
putStrLn bs'
exitFailure
parse phase c = do
let (_, x') = Parsec.runParseResult $
Parsec.parseGenericPackageDescription c
case x' of
Right gpd -> pure gpd
Left (_, errs) -> do
putStrLn $ fpath ++ " " ++ phase
traverse_ print errs
B.putStr c
fail "parse error"
-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------
main :: IO ()
main = join (O.execParser opts)
where
opts = O.info (optsP <**> O.helper) $ mconcat
[ O.fullDesc
, O.progDesc "tests using Hackage's index"
]
optsP = subparser
[ command "read-fields" readFieldsP
"Parse outer format (to '[Field]', TODO: apply Quirks)"
, command "parsec" parsecP "Parse GPD with parsec"
, command "roundtrip" roundtripP "parse . pretty . parse = parse"
, command "check" checkP "Check GPD"
] <|> pure defaultA
defaultA = do
putStrLn "Default action: parsec k"
parsecA (mkPredicate ["k"]) False
readFieldsP = readFieldsA <$> prefixP
readFieldsA pfx = parseIndex pfx readFieldTest
parsecP = parsecA <$> prefixP <*> keepGoingP
keepGoingP =
O.flag' True (O.long "keep-going") <|>
O.flag' False (O.long "no-keep-going") <|>
pure False
parsecA pfx keepGoing = do
begin <- Clock.getTime Clock.Monotonic
ParsecResult n w f <- parseIndex pfx (parseParsecTest keepGoing)
end <- Clock.getTime Clock.Monotonic
let diff = Clock.toNanoSecs $ Clock.diffTimeSpec end begin
putStrLn $ show n ++ " files processed"
putStrLn $ show w ++ " files contained warnings"
putStrLn $ show f ++ " files failed to parse"
putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e9 :: Double) " seconds elapsed"
roundtripP = roundtripA <$> prefixP <*> testFieldsP
roundtripA pfx testFieldsTransform = do
Sum n <- parseIndex pfx (roundtripTest testFieldsTransform)
putStrLn $ show n ++ " files processed"
checkP = checkA <$> prefixP
checkA pfx = do
CheckResult n w x a b c d e <- parseIndex pfx parseCheckTest
putStrLn $ show n ++ " files processed"
putStrLn $ show w ++ " files have lexer/parser warnings"
putStrLn $ show x ++ " files have check warnings"
putStrLn $ show a ++ " build impossible"
putStrLn $ show b ++ " build warning"
putStrLn $ show c ++ " build dist suspicious"
putStrLn $ show d ++ " build dist suspicious warning"
putStrLn $ show e ++ " build dist inexcusable"
prefixP = fmap mkPredicate $ many $ O.strArgument $ mconcat
[ O.metavar "PREFIX"
, O.help "Check only files starting with a prefix"
]
testFieldsP = O.switch $ mconcat
[ O.long "fields-transform"
, O.help "Test also 'showFields . fromParsecFields . readFields' transform"
]
mkPredicate [] = const True
mkPredicate pfxs = \n -> any (`isPrefixOf` n) pfxs
command name p desc = O.command name
(O.info (p <**> O.helper) (O.progDesc desc))
subparser = O.subparser . mconcat
-------------------------------------------------------------------------------
-- Index shuffling
-------------------------------------------------------------------------------
-- TODO: Use 'Cabal' for this?
reposFromConfig :: [Parsec.Field ann] -> [String]
reposFromConfig fields = takeWhile (/= ':') <$> mapMaybe f fields
where
f (Parsec.Field (Parsec.Name _ name) fieldLines)
| B8.unpack name == "remote-repo" =
Just $ fieldLinesToString fieldLines
f (Parsec.Section (Parsec.Name _ name)
[Parsec.SecArgName _ secName] _fieldLines)
| B8.unpack name == "repository" =
Just $ B8.unpack secName
f _ = Nothing
-- | Looks up the given key in the cabal configuration file
lookupInConfig :: String -> [Parsec.Field ann] -> [String]
lookupInConfig key = mapMaybe f
where
f (Parsec.Field (Parsec.Name _ name) fieldLines)
| B8.unpack name == key =
Just $ fieldLinesToString fieldLines
f _ = Nothing
fieldLinesToString :: [Parsec.FieldLine ann] -> String
fieldLinesToString fieldLines =
B8.unpack $ B.concat $ bsFromFieldLine <$> fieldLines
where
bsFromFieldLine (Parsec.FieldLine _ bs) = bs
-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------
-- | We assume that monoid is commutative.
--
-- First we chunk input (as single cabal file is little work)
foldIO :: forall a m. (Monoid m, NFData m) => (a -> IO m) -> [a] -> IO m
foldIO f = go mempty where
go !acc [] = acc
go !acc (x:xs) = go (mappend acc (f x)) xs
-------------------------------------------------------------------------------
-- Orphans
-------------------------------------------------------------------------------
#if !MIN_VERSION_deepseq(1,4,0)
instance NFData a => NFData (Sum a) where
rnf (Sum a) = rnf a
#endif