Cabal-tests/tests/HackageTests.hs

   1 {-# LANGUAGE BangPatterns        #-}
   2 {-# LANGUAGE CPP                 #-}
   3 {-# LANGUAGE Rank2Types          #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 #if !MIN_VERSION_deepseq(1,4,0)
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 #endif
   8
   9 module Main where
  10
  11 import Distribution.Compat.Semigroup
  12 import Prelude ()
  13 import Prelude.Compat
  14
  15 import Control.Applicative                         (many, (<**>), (<|>))
  16 import Control.DeepSeq                             (NFData (..), force)
  17 import Control.Exception                           (evaluate)
  18 import Control.Monad                               (join, unless, when)
  19 import Data.Foldable                               (traverse_)
  20 import Data.List                                   (isPrefixOf, isSuffixOf)
  21 import Data.Maybe                                  (mapMaybe)
  22 import Data.Monoid                                 (Sum (..))
  23 import Distribution.PackageDescription.Check       (PackageCheck (..), checkPackage)
  24 import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
  25 import Distribution.PackageDescription.Quirks      (patchQuirks)
  26 import Distribution.Simple.Utils                   (fromUTF8BS, toUTF8BS)
  27 import Numeric                                     (showFFloat)
  28 import System.Directory                            (getXdgDirectory, XdgDirectory(XdgCache, XdgConfig), getAppUserDataDirectory, doesDirectoryExist)
  29 import System.Environment                          (lookupEnv)
  30 import System.Exit                                 (exitFailure)
  31 import System.FilePath                             ((</>))
  32
  33 import Data.Orphans ()
  34
  35 import qualified Codec.Archive.Tar                      as Tar
  36 import qualified Codec.Archive.Tar.Entry                as Tar
  37 import qualified Data.ByteString                        as B
  38 import qualified Data.ByteString.Char8                  as B8
  39 import qualified Data.ByteString.Lazy                   as BSL
  40 import qualified Distribution.Fields.Parser             as Parsec
  41 import qualified Distribution.Fields.Pretty             as PP
  42 import qualified Distribution.PackageDescription.Parsec as Parsec
  43 import qualified Distribution.Parsec                    as Parsec
  44 import qualified Options.Applicative                    as O
  45 import qualified System.Clock                           as Clock
  46
  47 import           Distribution.Compat.Lens
  48 import qualified Distribution.Types.GenericPackageDescription.Lens as L
  49 import qualified Distribution.Types.PackageDescription.Lens        as L
  50
  51 -- import Distribution.Types.BuildInfo                (BuildInfo (cppOptions))
  52 -- import qualified Distribution.Types.BuildInfo.Lens                 as L
  53
  54 #ifdef MIN_VERSION_tree_diff
  55 import Data.TreeDiff                 (ediff)
  56 import Data.TreeDiff.Instances.Cabal ()
  57 import Data.TreeDiff.Pretty          (ansiWlEditExprCompact)
  58 #endif
  59
  60 import Data.Time.Clock.System
  61 import Data.Time.Format
  62
  63 -------------------------------------------------------------------------------
  64 -- parseIndex: Index traversal
  65 -------------------------------------------------------------------------------
  66
  67 parseIndex :: (Monoid a, NFData a) => (Tar.EpochTime -> FilePath -> Bool)
  68            -> (FilePath -> B.ByteString -> IO a) -> IO a
  69 parseIndex predicate action = do
  70     configPath <- getCabalConfigPath
  71     cfg        <- B.readFile configPath
  72     cfgFields  <- either (fail . show) pure $ Parsec.readFields cfg
  73     repoCache  <- case lookupInConfig "remote-repo-cache" cfgFields of
  74                     []        -> getCacheDirPath   -- Default
  75                     (rrc : _) -> return rrc        -- User-specified
  76     let repos        = reposFromConfig cfgFields
  77         tarName repo = repoCache </> repo </> "01-index.tar"
  78     mconcat <$> traverse (parseIndex' predicate action . tarName) repos
  79   where
  80     getCacheDirPath =
  81         getXdgDirectory XdgCache $ "cabal" </> "packages"
  82     getCabalConfigPath = do
  83         mx <- lookupEnv "CABAL_CONFIG"
  84         case mx of
  85             Just x  -> return x
  86             Nothing -> do
  87               mDir <- maybeGetCabalDir
  88               case mDir of
  89                 Nothing -> getXdgDirectory XdgConfig $ "cabal" </> "config"
  90                 Just dir -> return $ dir </> "config"
  91     maybeGetCabalDir :: IO (Maybe FilePath)
  92     maybeGetCabalDir = do
  93       mDir <- lookupEnv "CABAL_DIR"
  94       case mDir of
  95         Just dir -> return $ Just dir
  96         Nothing -> do
  97           defaultDir <- getAppUserDataDirectory "cabal"
  98           dotCabalExists <- doesDirectoryExist defaultDir
  99           return $ if dotCabalExists
 100                    then Just defaultDir
 101                    else Nothing
 102
 103
 104 parseIndex'
 105     :: (Monoid a, NFData a)
 106     => (Tar.EpochTime -> FilePath -> Bool)
 107     -> (FilePath -> B.ByteString -> IO a) -> FilePath -> IO a
 108 parseIndex' predicate action path = do
 109     putStrLn $ "Reading index from: " ++ path
 110     contents <- BSL.readFile path
 111     let entries = Tar.read contents
 112         entries' = Tar.foldEntries cons [] (error . show) entries
 113     foldIO f entries'
 114
 115   where
 116     cons entry entries
 117         | predicate (Tar.entryTime entry) (Tar.entryPath entry) = entry : entries
 118         | otherwise = entries
 119
 120     f entry = case Tar.entryContent entry of
 121         Tar.NormalFile contents _
 122             | ".cabal" `isSuffixOf` fpath -> do
 123                 bs <- evaluate (BSL.toStrict contents)
 124                 res <- action fpath bs
 125                 evaluate (force res)
 126             | otherwise ->
 127                 return mempty
 128         Tar.Directory -> return mempty
 129         _             -> putStrLn ("Unknown content in " ++ fpath)
 130                          >> return mempty
 131      where
 132        fpath = Tar.entryPath entry
 133
 134 -------------------------------------------------------------------------------
 135 -- readFields tests: very fast test for 'readFields' - first step of parser
 136 -------------------------------------------------------------------------------
 137
 138 readFieldTest :: FilePath -> B.ByteString -> IO ()
 139 readFieldTest fpath bs = case Parsec.readFields bs' of
 140     Right _  -> return ()
 141     Left err -> do
 142         putStrLn fpath
 143         print err
 144         exitFailure
 145   where
 146     (_, bs') = patchQuirks bs
 147
 148 -------------------------------------------------------------------------------
 149 -- Parsec test: whether we can parse everything
 150 -------------------------------------------------------------------------------
 151
 152 parseParsecTest :: Bool -> FilePath -> B.ByteString -> IO ParsecResult
 153 parseParsecTest keepGoing fpath bs = do
 154     let (warnings, result) = Parsec.runParseResult $
 155                              Parsec.parseGenericPackageDescription bs
 156
 157     let w | null warnings = 0
 158           | otherwise     = 1
 159
 160     case result of
 161         Right gpd                    -> do
 162             forEachGPD fpath bs gpd
 163             return (ParsecResult 1 w 0)
 164
 165         Left (_, errors) | keepGoing -> do
 166             traverse_ (putStrLn . Parsec.showPError fpath) errors
 167             return (ParsecResult 1 w 1)
 168                          | otherwise -> do
 169             traverse_ (putStrLn . Parsec.showPError fpath) errors
 170             exitFailure
 171
 172 -- | A hook to make queries on Hackage
 173 forEachGPD :: FilePath -> B8.ByteString -> L.GenericPackageDescription -> IO ()
 174 forEachGPD _ _ _ = return ()
 175
 176 -------------------------------------------------------------------------------
 177 -- ParsecResult
 178 -------------------------------------------------------------------------------
 179
 180 data ParsecResult = ParsecResult !Int !Int !Int
 181   deriving (Eq, Show)
 182
 183 instance Semigroup ParsecResult where
 184     ParsecResult x y z <> ParsecResult u v w = ParsecResult (x + u) (y + v) (z + w)
 185
 186 instance Monoid ParsecResult where
 187     mempty  = ParsecResult 0 0 0
 188     mappend = (<>)
 189
 190 instance NFData ParsecResult where
 191     rnf (ParsecResult _ _ _) = ()
 192
 193 -------------------------------------------------------------------------------
 194 -- Check test
 195 -------------------------------------------------------------------------------
 196
 197 parseCheckTest :: FilePath -> B.ByteString -> IO CheckResult
 198 parseCheckTest fpath bs = do
 199     let (warnings, parsec) = Parsec.runParseResult $
 200                              Parsec.parseGenericPackageDescription bs
 201     case parsec of
 202         Right gpd -> do
 203             let checks = checkPackage gpd
 204             let w [] = 0
 205                 w _  = 1
 206
 207             -- Look into invalid cpp options
 208             -- _ <- L.traverseBuildInfos checkCppFlags gpd
 209
 210             -- one for file, many checks
 211             return (CheckResult 1 (w warnings) 0 0 0 0 0 0 <> foldMap toCheckResult checks)
 212         Left (_, errors) -> do
 213             traverse_ (putStrLn . Parsec.showPError fpath) errors
 214             exitFailure
 215
 216 -- checkCppFlags :: BuildInfo -> IO BuildInfo
 217 -- checkCppFlags bi = do
 218 --     for_ (cppOptions bi) $ \opt ->
 219 --         unless (any (`isPrefixOf` opt) ["-D", "-U", "-I"]) $
 220 --             putStrLn opt
 221 --
 222 --     return bi
 223
 224 data CheckResult = CheckResult !Int !Int !Int !Int !Int !Int !Int !Int
 225
 226 instance NFData CheckResult where
 227     rnf !_ = ()
 228
 229 instance Semigroup CheckResult where
 230     CheckResult n w a b c d e f <> CheckResult n' w' a' b' c' d' e' f' =
 231         CheckResult (n + n') (w + w') (a + a') (b + b') (c + c') (d + d') (e + e') (f + f')
 232
 233 instance Monoid CheckResult where
 234     mempty = CheckResult 0 0 0 0 0 0 0 0
 235     mappend = (<>)
 236
 237 toCheckResult :: PackageCheck -> CheckResult
 238 toCheckResult PackageBuildImpossible {}    = CheckResult 0 0 1 1 0 0 0 0
 239 toCheckResult PackageBuildWarning {}       = CheckResult 0 0 1 0 1 0 0 0
 240 toCheckResult PackageDistSuspicious {}     = CheckResult 0 0 1 0 0 1 0 0
 241 toCheckResult PackageDistSuspiciousWarn {} = CheckResult 0 0 1 0 0 0 1 0
 242 toCheckResult PackageDistInexcusable {}    = CheckResult 0 0 1 0 0 0 0 1
 243
 244 -------------------------------------------------------------------------------
 245 -- Roundtrip test
 246 -------------------------------------------------------------------------------
 247
 248 roundtripTest :: Bool -> FilePath -> B.ByteString -> IO (Sum Int)
 249 roundtripTest testFieldsTransform fpath bs = do
 250     x0 <- parse "1st" bs
 251     let bs' = showGenericPackageDescription x0
 252     y0 <- parse "2nd" (toUTF8BS bs')
 253
 254     -- strip description, there are format variations
 255     let y = y0 & L.packageDescription . L.description .~ mempty
 256     let x = x0 & L.packageDescription . L.description .~ mempty
 257
 258     assertEqual' bs' x y
 259
 260     -- fromParsecField, "shallow" parser/pretty roundtrip
 261     when testFieldsTransform $
 262         if checkUTF8 patchedBs
 263         then do
 264             parsecFields <- assertRight $ Parsec.readFields patchedBs
 265             let prettyFields = PP.fromParsecFields parsecFields
 266             let bs'' = PP.showFields (return PP.NoComment) prettyFields
 267             z0 <- parse "3rd" (toUTF8BS bs'')
 268
 269             -- note: we compare "raw" GPDs, on purpose; stricter equality
 270             assertEqual' bs'' x0 z0
 271         else
 272             putStrLn $ fpath ++ " : looks like invalid UTF8"
 273
 274     return (Sum 1)
 275   where
 276     patchedBs = snd (patchQuirks bs)
 277
 278     checkUTF8 bs' = replacementChar `notElem` fromUTF8BS bs' where
 279         replacementChar = '\xfffd'
 280
 281
 282     assertRight (Right x) = return x
 283     assertRight (Left err) = do
 284         putStrLn fpath
 285         print err
 286         exitFailure
 287
 288     assertEqual' bs' x y = unless (x == y || fpath == "ixset/1.0.4/ixset.cabal") $ do
 289         putStrLn fpath
 290 #ifdef MIN_VERSION_tree_diff
 291         putStrLn "====== tree-diff:"
 292         print $ ansiWlEditExprCompact $ ediff x y
 293 #else
 294         putStrLn "<<<<<<"
 295         print x
 296         putStrLn "======"
 297         print y
 298         putStrLn ">>>>>>"
 299 #endif
 300         putStrLn "====== contents:"
 301         putStrLn bs'
 302         exitFailure
 303
 304     parse phase c = do
 305         let (_, x') = Parsec.runParseResult $
 306                       Parsec.parseGenericPackageDescription c
 307         case x' of
 308             Right gpd -> pure gpd
 309             Left (_, errs) -> do
 310                 putStrLn $ fpath ++ " " ++ phase
 311                 traverse_ print errs
 312                 B.putStr c
 313                 fail "parse error"
 314
 315 -------------------------------------------------------------------------------
 316 -- Main
 317 -------------------------------------------------------------------------------
 318
 319 main :: IO ()
 320 main = join (O.execParser opts)
 321   where
 322     opts = O.info (optsP <**> O.helper) $ mconcat
 323         [ O.fullDesc
 324         , O.progDesc "tests using Hackage's index"
 325         ]
 326
 327     indexP =
 328       fmap cvt <$> O.optional (O.strOption (O.long "index-state" <> O.metavar "YYYY-MM-DD"))
 329       where
 330        cvt =
 331         systemSeconds . utcToSystemTime .
 332           parseTimeOrError False defaultTimeLocale "%Y-%m-%d"
 333
 334     optsP = subparser
 335         [ command "read-fields" readFieldsP
 336           "Parse outer format (to '[Field]', TODO: apply Quirks)"
 337         , command "parsec"      parsecP     "Parse GPD with parsec"
 338         , command "roundtrip"   roundtripP  "parse . pretty . parse = parse"
 339         , command "check"       checkP      "Check GPD"
 340         ] <|> pure defaultA
 341
 342     defaultA = do
 343         putStrLn "Default action: parsec k"
 344         parsecA ["k"] False Nothing
 345
 346     readFieldsP = readFieldsA <$> prefixP <*> indexP
 347     readFieldsA pfx idx = parseIndex (mkPredicate pfx idx) readFieldTest
 348
 349     parsecP = parsecA <$> prefixP <*> keepGoingP <*> indexP
 350     keepGoingP =
 351         O.flag' True  (O.long "keep-going") <|>
 352         O.flag' False (O.long "no-keep-going") <|>
 353         pure False
 354
 355     parsecA pfx keepGoing idx = do
 356         begin <- Clock.getTime Clock.Monotonic
 357         ParsecResult n w f <- parseIndex (mkPredicate pfx idx) (parseParsecTest keepGoing)
 358         end <- Clock.getTime Clock.Monotonic
 359         let diff = Clock.toNanoSecs $ Clock.diffTimeSpec end begin
 360
 361         putStrLn $ show n ++ " files processed"
 362         putStrLn $ show w ++ " files contained warnings"
 363         putStrLn $ show f ++ " files failed to parse"
 364         putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e9                  :: Double) " seconds elapsed"
 365         putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e6 / fromIntegral n :: Double) " milliseconds per file"
 366
 367     roundtripP = roundtripA <$> prefixP <*> testFieldsP <*> indexP
 368     roundtripA pfx testFieldsTransform idx = do
 369         Sum n <- parseIndex (mkPredicate pfx idx) (roundtripTest testFieldsTransform)
 370         putStrLn $ show n ++ " files processed"
 371
 372     checkP = checkA <$> prefixP <*> indexP
 373     checkA pfx idx = do
 374         CheckResult n w x a b c d e <- parseIndex (mkPredicate pfx idx) parseCheckTest
 375         putStrLn $ show n ++ " files processed"
 376         putStrLn $ show w ++ " files have lexer/parser warnings"
 377         putStrLn $ show x ++ " files have check warnings"
 378         putStrLn $ show a ++ " build impossible"
 379         putStrLn $ show b ++ " build warning"
 380         putStrLn $ show c ++ " build dist suspicious"
 381         putStrLn $ show d ++ " build dist suspicious warning"
 382         putStrLn $ show e ++ " build dist inexcusable"
 383
 384     prefixP = many $ O.strArgument $ mconcat
 385         [ O.metavar "PREFIX"
 386         , O.help "Check only files starting with a prefix"
 387         ]
 388
 389     testFieldsP = O.switch $ mconcat
 390         [ O.long "fields-transform"
 391         , O.help "Test also 'showFields . fromParsecFields . readFields' transform"
 392         ]
 393
 394     indexPredicate :: Maybe Tar.EpochTime -> (k -> Bool) -> (Tar.EpochTime -> k -> Bool)
 395     indexPredicate Nothing k = const k
 396     indexPredicate (Just indexDate) k =
 397         \e -> if (e <= indexDate) then k else const False
 398
 399     mkPredicate :: [String] -> Maybe Tar.EpochTime -> (Tar.EpochTime -> FilePath -> Bool)
 400     mkPredicate [] idx = indexPredicate idx (const True)
 401     mkPredicate pfxs idx = indexPredicate idx (\n -> any (`isPrefixOf` n) pfxs)
 402
 403     command name p desc = O.command name
 404                           (O.info (p <**> O.helper) (O.progDesc desc))
 405     subparser = O.subparser . mconcat
 406
 407 -------------------------------------------------------------------------------
 408 -- Index shuffling
 409 -------------------------------------------------------------------------------
 410
 411 -- TODO: Use 'Cabal' for this?
 412 reposFromConfig :: [Parsec.Field ann] -> [String]
 413 reposFromConfig fields = takeWhile (/= ':') <$> mapMaybe f fields
 414   where
 415     f (Parsec.Field (Parsec.Name _ name) fieldLines)
 416         | B8.unpack name == "remote-repo" =
 417             Just $ fieldLinesToString fieldLines
 418     f (Parsec.Section (Parsec.Name _ name)
 419        [Parsec.SecArgName _ secName]    _fieldLines)
 420         | B8.unpack name == "repository" =
 421             Just $ B8.unpack secName
 422     f _ = Nothing
 423
 424 -- | Looks up the given key in the cabal configuration file
 425 lookupInConfig :: String -> [Parsec.Field ann] -> [String]
 426 lookupInConfig key = mapMaybe f
 427   where
 428     f (Parsec.Field (Parsec.Name _ name) fieldLines)
 429         | B8.unpack name == key =
 430             Just $ fieldLinesToString fieldLines
 431     f _ = Nothing
 432
 433 fieldLinesToString :: [Parsec.FieldLine ann] -> String
 434 fieldLinesToString fieldLines =
 435     B8.unpack $ B.concat $ bsFromFieldLine <$> fieldLines
 436   where
 437     bsFromFieldLine (Parsec.FieldLine _ bs) = bs
 438
 439 -------------------------------------------------------------------------------
 440 -- Utilities
 441 -------------------------------------------------------------------------------
 442
 443 -- | We assume that monoid is commutative.
 444 --
 445 -- First we chunk input (as single cabal file is little work)
 446 foldIO :: forall a m. (Monoid m, NFData m) => (a -> IO m) -> [a] -> IO m
 447 foldIO f = go mempty where
 448     go !acc [] = acc
 449     go !acc (x:xs) = go (mappend acc (f x)) xs
 450
 451 -------------------------------------------------------------------------------
 452 -- Orphans
 453 -------------------------------------------------------------------------------
 454
 455 #if !MIN_VERSION_deepseq(1,4,0)
 456 instance NFData a => NFData (Sum a) where
 457     rnf (Sum a)  = rnf a
 458 #endif