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 tls1 <- readTarLines bd1
  38       tls2 <- readTarLines bd2
  39       ways1 <- dieOnErrors $ findWays tls1
  40       ways2 <- dieOnErrors $ findWays tls2
  41       content1 <- dieOnErrors $ mkContents ways1 tls1
  42       content2 <- dieOnErrors $ mkContents ways2 tls2
  43       let mySort = sortBy (compare `on` fst)
  44           sortedContent1 = mySort content1
  45           sortedContent2 = mySort content2
  46           (nubProbs1, nubbedContent1) = nubContents sortedContent1
  47           (nubProbs2, nubbedContent2) = nubContents sortedContent2
  48           differences = compareContent ways1 nubbedContent1
  49                                        ways2 nubbedContent2
  50           allProbs = map First nubProbs1 ++ map Second nubProbs2
  51                   ++ diffWays ways1 ways2
  52                   ++ differences
  53           wantedProbs = if ignoreSizeChanges
  54                         then filter (not . isSizeChange) allProbs
  55                         else allProbs
  56       mapM_ (putStrLn . pprFileProblem) wantedProbs
  57
  58 findWays :: [TarLine] -> Either Errors Ways
  59 findWays = foldr f (Left ["Couldn't find ways"])
  60     where f tl res = case re regex (tlFileName tl) of
  61                      Just [dashedWays] ->
  62                          Right (unSepList '-' dashedWays)
  63                      _ ->
  64                          res
  65           regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
  66
  67 diffWays :: Ways -> Ways -> [FileProblem]
  68 diffWays ws1 ws2 = f (sort ws1) (sort ws2)
  69     where f [] [] = []
  70           f xs [] = map (First . ExtraWay) xs
  71           f [] ys = map (First . ExtraWay) ys
  72           f xs@(x : xs') ys@(y : ys')
  73               = case x `compare` y of
  74                 LT -> First  (ExtraWay x) : f xs' ys
  75                 GT -> Second (ExtraWay y) : f xs  ys'
  76                 EQ ->                       f xs' ys'
  77
  78 mkContents :: Ways -> [TarLine] -> Either Errors [(FilenameDescr, TarLine)]
  79 mkContents ways tls
  80     = case runState (mapM f tls) initialBuildInfo of
  81       (xs, finalBuildInfo) ->
  82           case concat $ map (checkContent finalBuildInfo) xs of
  83           []   -> Right xs
  84           errs -> Left errs
  85     where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
  86                     return (fnd, tl)
  87           initialBuildInfo = BuildInfo {
  88                                  biThingVersionMap = [],
  89                                  biWays = ways
  90                              }
  91
  92 nubContents :: [(FilenameDescr, TarLine)]
  93             -> ([Problem], [(FilenameDescr, TarLine)])
  94 nubContents [] = ([], [])
  95 nubContents [x] = ([], [x])
  96 nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
  97  | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
  98  | otherwise  = (ps, x1 : xs')
  99     where (ps, xs') = nubContents xs
 100
 101 mkFilePathDescr :: FilePath -> State BuildInfo FilenameDescr
 102 mkFilePathDescr fp
 103  | Just [ghcVersion, _, middle, filename]
 104      <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
 105     = do ghcVersionDescr <- do mapping <- getThingVersionMap
 106                                case addThingVersion mapping "ghc" ghcVersion of
 107                                    Just mapping' ->
 108                                        do putThingVersionMap mapping'
 109                                           return (VersionOf "ghc")
 110                                    Nothing ->
 111                                        return (FP ghcVersion)
 112          filename' <- mkFileNameDescr filename
 113          let fd = FP "ghc-" : ghcVersionDescr : FP middle : FP "/" : filename'
 114          return $ normalise fd
 115  | otherwise = return [FP fp]
 116
 117 mkFileNameDescr :: FilePath -> State BuildInfo FilenameDescr
 118 mkFileNameDescr filename
 119  | Just [thing, thingVersion, _, ghcVersion, _]
 120        <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$")
 121              filename
 122     = do mapping <- getThingVersionMap
 123          case addThingVersion mapping "ghc" ghcVersion of
 124              Just m ->
 125                  case addThingVersion m thing thingVersion of
 126                  Just m' ->
 127                      do putThingVersionMap m'
 128                         return [FP "libHS", FP thing, FP "-", VersionOf thing,
 129                                 FP "-ghc", VersionOf "ghc", FP ".so"]
 130                  _ -> unchanged
 131              _ -> unchanged
 132  | Just [way, thingVersion, _]
 133        <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.so$")
 134              filename
 135     = do mapping <- getThingVersionMap
 136          case addThingVersion mapping "ghc" thingVersion of
 137              Just mapping' ->
 138                  do putThingVersionMap mapping'
 139                     return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
 140                             FP ".so"]
 141              _ -> unchanged
 142  | Just [thing, thingVersion, _, way]
 143        <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
 144              filename
 145     = do mapping <- getThingVersionMap
 146          case addThingVersion mapping thing thingVersion of
 147              Just mapping' ->
 148                  do putThingVersionMap mapping'
 149                     return [FP "libHS", FP thing, FP "-", VersionOf thing,
 150                             FP way, FP ".a"]
 151              _ -> unchanged
 152  | Just [thing, thingVersion, _]
 153        <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
 154              filename
 155     = do mapping <- getThingVersionMap
 156          case addThingVersion mapping thing thingVersion of
 157              Just mapping' ->
 158                  do putThingVersionMap mapping'
 159                     return [FP "HS", FP thing, FP "-", VersionOf thing,
 160                             FP ".o"]
 161              _ -> unchanged
 162  | Just [dashedWays, depType]
 163        <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
 164              filename
 165     = do ways <- getWays
 166          if unSepList '-' dashedWays == ways
 167              then return [FP ".depend-", Ways, FP ".", FP depType]
 168              else unchanged
 169  | otherwise = unchanged
 170     where unchanged = return [FP filename]
 171
 172 compareContent :: Ways -> [(FilenameDescr, TarLine)]
 173                -> Ways -> [(FilenameDescr, TarLine)]
 174                -> [FileProblem]
 175 compareContent _ [] _ [] = []
 176 compareContent _ xs _ [] = map (First  . ExtraFile . tlFileName . snd) xs
 177 compareContent _ [] _ ys = map (Second . ExtraFile . tlFileName . snd) ys
 178 compareContent ways1 xs1 ways2 xs2
 179     = case (xs1, xs2) of
 180       ([], []) -> []
 181       (xs, []) -> concatMap (mkExtraFile ways1 First  . tlFileName . snd) xs
 182       ([], ys) -> concatMap (mkExtraFile ways2 Second . tlFileName . snd) ys
 183       ((fd1, tl1) : xs1', (fd2, tl2) : xs2') ->
 184           case fd1 `compare` fd2 of
 185           EQ -> map Change (compareTarLine tl1 tl2)
 186              ++ compareContent ways1 xs1' ways2 xs2'
 187           LT -> mkExtraFile ways1 First  (tlFileName tl1)
 188              ++ compareContent ways1 xs1' ways2 xs2
 189           GT -> mkExtraFile ways2 Second (tlFileName tl2)
 190              ++ compareContent ways1 xs1 ways2 xs2'
 191     where mkExtraFile ways mkFileProblem filename
 192               = case findFileWay filename of
 193                 Just way
 194                  | way `elem` ways -> []
 195                 _                  -> [mkFileProblem (ExtraFile filename)]
 196
 197 findFileWay :: FilePath -> Maybe String
 198 findFileWay fp
 199  | Just [way] <- re "\\.([a-z_]+)_hi$" fp
 200     = Just way
 201  | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp
 202     = Just way
 203  | otherwise = Nothing
 204
 205 compareTarLine :: TarLine -> TarLine -> [Problem]
 206 compareTarLine tl1 tl2
 207     = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
 208    ++ [ FileSizeChanged    fn1 fn2 size1  size2  | sizeChanged ]
 209     where fn1 = tlFileName tl1
 210           fn2 = tlFileName tl2
 211           perms1 = tlPermissions tl1
 212           perms2 = tlPermissions tl2
 213           size1 = tlSize tl1
 214           size2 = tlSize tl2
 215           sizeChanged = abs (size1 - size2) > sizeAbs
 216                      && (((100 * size1) `div` size2) > sizePercentage ||
 217                          ((100 * size2) `div` size1) > sizePercentage)
 218
 219 versionRE :: String
 220 versionRE = "([0-9]+(\\.[0-9]+)*)"
 221