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