distrib/compare/compare.hs

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