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