distrib/compare/compare.hs

   1 {-# LANGUAGE PatternGuards #-}
   2
   3 module Main (main) where
   4
   5 import Control.Monad.State
   6 import Data.Function
   7 import Data.List
   8 import System.Environment
   9
  10 import BuildInfo
  11 import FilenameDescr
  12 import Problem
  13 import Utils
  14 import Tar
  15
  16 -- TODO:
  17 -- * Check installed trees too
  18 -- * Check hashbangs
  19
  20 -- Only size changes > sizeAbs are considered an issue
  21 sizeAbs :: Integer
  22 sizeAbs = 1000
  23
  24 -- Only a size change of sizePercentage% or more is considered an issue
  25 sizePercentage :: Integer
  26 sizePercentage = 150
  27
  28 main :: IO ()
  29 main = do args <- getArgs
  30           case args of
  31               [bd1, bd2]                          -> doit False bd1 bd2
  32               ["--ignore-size-changes", bd1, bd2] -> doit True  bd1 bd2
  33               _ -> die ["Bad args. Need 2 bindists."]
  34
  35 doit :: Bool -> FilePath -> FilePath -> IO ()
  36 doit ignoreSizeChanges bd1 bd2
  37  = do let windows = any ("mingw" `isPrefixOf`) (tails bd1)
  38       tls1 <- readTarLines bd1
  39       tls2 <- readTarLines bd2
  40       -- If it looks like we have a Windows "bindist" then just
  41       -- set ways to [] for now.
  42       ways1 <- if windows then return []
  43                           else dieOnErrors $ findWays tls1
  44       ways2 <- if windows then return []
  45                           else dieOnErrors $ findWays tls2
  46       content1 <- dieOnErrors $ mkContents ways1 tls1
  47       content2 <- dieOnErrors $ mkContents ways2 tls2
  48       let mySort = sortBy (compare `on` fst)
  49           sortedContent1 = mySort content1
  50           sortedContent2 = mySort content2
  51           (nubProbs1, nubbedContent1) = nubContents sortedContent1
  52           (nubProbs2, nubbedContent2) = nubContents sortedContent2
  53           differences = compareContent ways1 nubbedContent1
  54                                        ways2 nubbedContent2
  55           allProbs = map First nubProbs1 ++ map Second nubProbs2
  56                   ++ diffWays ways1 ways2
  57                   ++ differences
  58           wantedProbs = if ignoreSizeChanges
  59                         then filter (not . isSizeChange) allProbs
  60                         else allProbs
  61       mapM_ (putStrLn . pprFileProblem) wantedProbs
  62
  63 findWays :: [TarLine] -> Either Errors Ways
  64 findWays = foldr f (Left ["Couldn't find ways"])
  65     where f tl res = case re regex (tlFileName tl) of
  66                      Just [dashedWays] ->
  67                          Right (unSepList '-' dashedWays)
  68                      _ ->
  69                          res
  70           regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
  71
  72 diffWays :: Ways -> Ways -> [FileProblem]
  73 diffWays ws1 ws2 = f (sort ws1) (sort ws2)
  74     where f [] [] = []
  75           f xs [] = map (First . ExtraWay) xs
  76           f [] ys = map (First . ExtraWay) ys
  77           f xs@(x : xs') ys@(y : ys')
  78               = case x `compare` y of
  79                 LT -> First  (ExtraWay x) : f xs' ys
  80                 GT -> Second (ExtraWay y) : f xs  ys'
  81                 EQ ->                       f xs' ys'
  82
  83 mkContents :: Ways -> [TarLine] -> Either Errors [(FilenameDescr, TarLine)]
  84 mkContents ways tls
  85     = case runState (mapM f tls) initialBuildInfo of
  86       (xs, finalBuildInfo) ->
  87           case concat $ map (checkContent finalBuildInfo) xs of
  88           []   -> Right xs
  89           errs -> Left errs
  90     where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
  91                     return (fnd, tl)
  92           initialBuildInfo = BuildInfo {
  93                                  biThingVersionMap = [],
  94                                  biWays = ways
  95                              }
  96
  97 nubContents :: [(FilenameDescr, TarLine)]
  98             -> ([Problem], [(FilenameDescr, TarLine)])
  99 nubContents [] = ([], [])
 100 nubContents [x] = ([], [x])
 101 nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
 102  | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
 103  | otherwise  = (ps, x1 : xs')
 104     where (ps, xs') = nubContents xs
 105
 106 mkFilePathDescr :: FilePath -> State BuildInfo FilenameDescr
 107 mkFilePathDescr fp
 108  | Just [ghcVersion, _, middle, filename]
 109      <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
 110     = do ghcVersionDescr <- do mapping <- getThingVersionMap
 111                                case addThingVersion mapping "ghc" ghcVersion of
 112                                    Just mapping' ->
 113                                        do putThingVersionMap mapping'
 114                                           return (VersionOf "ghc")
 115                                    Nothing ->
 116                                        return (FP ghcVersion)
 117          filename' <- mkFileNameDescr filename
 118          let fd = FP "ghc-" : ghcVersionDescr : FP middle : FP "/" : filename'
 119          return $ normalise fd
 120  | otherwise = return [FP fp]
 121
 122 mkFileNameDescr :: FilePath -> State BuildInfo FilenameDescr
 123 mkFileNameDescr filename
 124  | Just [thing, thingVersion, _, ghcVersion, _]
 125        <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$")
 126              filename
 127     = do mapping <- getThingVersionMap
 128          case addThingVersion mapping "ghc" ghcVersion of
 129              Just m ->
 130                  case addThingVersion m thing thingVersion of
 131                  Just m' ->
 132                      do putThingVersionMap m'
 133                         return [FP "libHS", FP thing, FP "-", VersionOf thing,
 134                                 FP "-ghc", VersionOf "ghc", FP ".so"]
 135                  _ -> unchanged
 136              _ -> unchanged
 137  | Just [way, thingVersion, _]
 138        <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.so$")
 139              filename
 140     = do mapping <- getThingVersionMap
 141          case addThingVersion mapping "ghc" thingVersion of
 142              Just mapping' ->
 143                  do putThingVersionMap mapping'
 144                     return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
 145                             FP ".so"]
 146              _ -> unchanged
 147  | Just [thing, thingVersion, _, way]
 148        <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
 149              filename
 150     = do mapping <- getThingVersionMap
 151          case addThingVersion mapping thing thingVersion of
 152              Just mapping' ->
 153                  do putThingVersionMap mapping'
 154                     return [FP "libHS", FP thing, FP "-", VersionOf thing,
 155                             FP way, FP ".a"]
 156              _ -> unchanged
 157  | Just [thing, thingVersion, _]
 158        <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
 159              filename
 160     = do mapping <- getThingVersionMap
 161          case addThingVersion mapping thing thingVersion of
 162              Just mapping' ->
 163                  do putThingVersionMap mapping'
 164                     return [FP "HS", FP thing, FP "-", VersionOf thing,
 165                             FP ".o"]
 166              _ -> unchanged
 167  | Just [dashedWays, depType]
 168        <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
 169              filename
 170     = do ways <- getWays
 171          if unSepList '-' dashedWays == ways
 172              then return [FP ".depend-", Ways, FP ".", FP depType]
 173              else unchanged
 174  | otherwise = unchanged
 175     where unchanged = return [FP filename]
 176
 177 compareContent :: Ways -> [(FilenameDescr, TarLine)]
 178                -> Ways -> [(FilenameDescr, TarLine)]
 179                -> [FileProblem]
 180 compareContent _ [] _ [] = []
 181 compareContent _ xs _ [] = map (First  . ExtraFile . tlFileName . snd) xs
 182 compareContent _ [] _ ys = map (Second . ExtraFile . tlFileName . snd) ys
 183 compareContent ways1 xs1 ways2 xs2
 184     = case (xs1, xs2) of
 185       ([], []) -> []
 186       (xs, []) -> concatMap (mkExtraFile ways1 First  . tlFileName . snd) xs
 187       ([], ys) -> concatMap (mkExtraFile ways2 Second . tlFileName . snd) ys
 188       ((fd1, tl1) : xs1', (fd2, tl2) : xs2') ->
 189           case fd1 `compare` fd2 of
 190           EQ -> map Change (compareTarLine tl1 tl2)
 191              ++ compareContent ways1 xs1' ways2 xs2'
 192           LT -> mkExtraFile ways1 First  (tlFileName tl1)
 193              ++ compareContent ways1 xs1' ways2 xs2
 194           GT -> mkExtraFile ways2 Second (tlFileName tl2)
 195              ++ compareContent ways1 xs1 ways2 xs2'
 196     where mkExtraFile ways mkFileProblem filename
 197               = case findFileWay filename of
 198                 Just way
 199                  | way `elem` ways -> []
 200                 _                  -> [mkFileProblem (ExtraFile filename)]
 201
 202 findFileWay :: FilePath -> Maybe String
 203 findFileWay fp
 204  | Just [way] <- re "\\.([a-z_]+)_hi$" fp
 205     = Just way
 206  | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp
 207     = Just way
 208  | otherwise = Nothing
 209
 210 compareTarLine :: TarLine -> TarLine -> [Problem]
 211 compareTarLine tl1 tl2
 212     = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
 213    ++ [ FileSizeChanged    fn1 fn2 size1  size2  | sizeChanged ]
 214     where fn1 = tlFileName tl1
 215           fn2 = tlFileName tl2
 216           perms1 = tlPermissions tl1
 217           perms2 = tlPermissions tl2
 218           size1 = tlSize tl1
 219           size2 = tlSize tl2
 220           sizeChanged = abs (size1 - size2) > sizeAbs
 221                      && (((100 * size1) `div` size2) > sizePercentage ||
 222                          ((100 * size2) `div` size1) > sizePercentage)
 223
 224 versionRE :: String
 225 versionRE = "([0-9]+(\\.[0-9]+)*)"
 226