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 tls1 <- readTarLines bd1
  37       tls2 <- readTarLines bd2
  38       let mWays1 = findWays tls1
  39           mWays2 = findWays tls2
  40       wayDifferences <- case (mWays1, mWays2) of
  41                         (Nothing, Nothing) ->
  42                             return []
  43                         (Just ways1, Just ways2) ->
  44                             return $ diffWays ways1 ways2
  45                         _ ->
  46                             die ["One input has ways, but the other doesn't"]
  47       (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1
  48       (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2
  49       let sortedContent1 = sortByFst content1
  50           sortedContent2 = sortByFst content2
  51           (nubProbs1, nubbedContent1) = nubContents sortedContent1
  52           (nubProbs2, nubbedContent2) = nubContents sortedContent2
  53           differences = compareContent mWays1 nubbedContent1
  54                                        mWays2 nubbedContent2
  55           allProbs = map First nubProbs1 ++ map Second nubProbs2
  56                   ++ diffThingVersionMap tvm1 tvm2
  57                   ++ wayDifferences
  58                   ++ differences
  59           wantedProbs = if ignoreSizeChanges
  60                         then filter (not . isSizeChange) allProbs
  61                         else allProbs
  62       mapM_ (putStrLn . pprFileChange) wantedProbs
  63
  64 -- *nix bindists have ways.
  65 -- Windows "bindists", install trees, and testsuites don't.
  66 findWays :: [TarLine] -> Maybe Ways
  67 findWays tls = msum $ map f tls
  68     where f tl = case re regex (tlFileName tl) of
  69                  Just [dashedWays] -> Just (unSepList '-' dashedWays)
  70                  _                 -> Nothing
  71           regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
  72
  73 diffWays :: Ways -> Ways -> [FileChange]
  74 diffWays ws1 ws2 = f (sort ws1) (sort ws2)
  75     where f [] [] = []
  76           f xs [] = map (First  . ExtraWay) xs
  77           f [] ys = map (Second . ExtraWay) ys
  78           f xs@(x : xs') ys@(y : ys')
  79               = case x `compare` y of
  80                 LT -> First  (ExtraWay x) : f xs' ys
  81                 GT -> Second (ExtraWay y) : f xs  ys'
  82                 EQ ->                       f xs' ys'
  83
  84 diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange]
  85 diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2)
  86     where f [] [] = []
  87           f xs [] = map (First  . ExtraThing . fst) xs
  88           f [] ys = map (Second . ExtraThing . fst) ys
  89           f xs@((xt, xv) : xs') ys@((yt, yv) : ys')
  90               = case xt `compare` yt of
  91                 LT -> First  (ExtraThing xt) : f xs' ys
  92                 GT -> Second (ExtraThing yt) : f xs  ys'
  93                 EQ -> let this = if xv == yv
  94                                  then []
  95                                  else [Change (ThingVersionChanged xt xv yv)]
  96                       in this ++ f xs' ys'
  97
  98 mkContents :: Maybe Ways -> [TarLine]
  99            -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap)
 100 mkContents mWays tls
 101     = case runStateT (mapM f tls) (emptyBuildInfo mWays) of
 102       Nothing -> Left ["Can't happen: mkContents: Nothing"]
 103       Just (xs, finalBuildInfo) ->
 104           case concat $ map (checkContent finalBuildInfo) xs of
 105           []   -> Right (xs, biThingVersionMap finalBuildInfo)
 106           errs -> Left errs
 107     where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
 108                     return (fnd, tl)
 109
 110 nubContents :: [(FilenameDescr, TarLine)]
 111             -> ([Change], [(FilenameDescr, TarLine)])
 112 nubContents [] = ([], [])
 113 nubContents [x] = ([], [x])
 114 nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
 115  | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
 116  | otherwise  = (ps, x1 : xs')
 117     where (ps, xs') = nubContents xs
 118
 119 mkFilePathDescr :: FilePath -> BIMonad FilenameDescr
 120 mkFilePathDescr fp
 121  | Just [ghcVersion, _, middle, filename]
 122      <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
 123     = do haveThingVersion "ghc" ghcVersion
 124          middle' <- mkMiddleDescr middle
 125          filename' <- mkFileNameDescr filename
 126          let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename'
 127          return $ normalise fd
 128  | otherwise = return [FP fp]
 129
 130 mkMiddleDescr :: FilePath -> BIMonad FilenameDescr
 131 mkMiddleDescr middle
 132  -- haddock docs in a Windows installed tree
 133  | Just [thing, thingVersion, _, src]
 134        <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$")
 135              middle
 136     = do haveThingVersion thing thingVersion
 137          return [FP "/doc/html/libraries/",
 138                  FP thing, FP "-", VersionOf thing, FP src]
 139       `mplus` unchanged
 140  -- libraries in a Windows installed tree
 141  | Just [thing, thingVersion, _, rest]
 142        <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$")
 143              middle
 144     = do haveThingVersion thing thingVersion
 145          return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest]
 146       `mplus` unchanged
 147  -- Windows in-tree gcc
 148  | Just [prefix, _, _, gccVersion, _, rest]
 149        <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$")
 150              middle
 151     = do haveThingVersion "gcc" gccVersion
 152          return [FP prefix, VersionOf "gcc", FP rest]
 153       `mplus` unchanged
 154  | otherwise = unchanged
 155     where unchanged = return [FP middle]
 156
 157 mkFileNameDescr :: FilePath -> BIMonad FilenameDescr
 158 mkFileNameDescr filename
 159  | Just [prog, ghcVersion, _, exe]
 160        <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$")
 161              filename
 162     = do haveThingVersion "ghc" ghcVersion
 163          return [FP prog, FP "-", VersionOf "ghc", FP exe]
 164       `mplus` unchanged
 165  | Just [thing, thingVersion, _, ghcVersion, _, soDll]
 166        <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
 167              filename
 168     = do haveThingVersion "ghc" ghcVersion
 169          haveThingVersion thing thingVersion
 170          return [FP "libHS", FP thing, FP "-", VersionOf thing,
 171                  FP "-ghc", VersionOf "ghc", FP ".", FP soDll]
 172       `mplus` unchanged
 173  | Just [way, thingVersion, _, soDll]
 174        <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
 175              filename
 176     = do haveThingVersion "ghc" thingVersion
 177          return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
 178                  FP ".", FP soDll]
 179       `mplus` unchanged
 180  | Just [thingVersion, _, soDll]
 181        <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
 182              filename
 183     = do haveThingVersion "ghc" thingVersion
 184          return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll]
 185       `mplus` unchanged
 186  | Just [thing, thingVersion, _, way]
 187        <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
 188              filename
 189     = do haveThingVersion thing thingVersion
 190          return [FP "libHS", FP thing, FP "-", VersionOf thing,
 191                  FP way, FP ".a"]
 192       `mplus` unchanged
 193  | Just [thing, thingVersion, _]
 194        <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
 195              filename
 196     = do haveThingVersion thing thingVersion
 197          return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"]
 198       `mplus` unchanged
 199  | Just [thing, thingVersion, _, thingHash]
 200        <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$")
 201              filename
 202     = do haveThingVersion thing thingVersion
 203          haveThingHash    thing thingHash
 204          return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing,
 205                  FP ".conf"]
 206       `mplus` unchanged
 207  | Just [thingVersion, _]
 208        <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$")
 209              filename
 210     = do haveThingVersion "gcc" thingVersion
 211          return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"]
 212       `mplus` unchanged
 213  | Just [dashedWays, depType]
 214        <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
 215              filename
 216     = do mWays <- getMaybeWays
 217          if Just (unSepList '-' dashedWays) == mWays
 218              then return [FP ".depend-", Ways, FP ".", FP depType]
 219              else unchanged
 220  | otherwise = unchanged
 221     where unchanged = return [FP filename]
 222
 223 compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)]
 224                -> Maybe Ways -> [(FilenameDescr, TarLine)]
 225                -> [FileChange]
 226 compareContent mWays1 xs1all mWays2 xs2all
 227  = f xs1all xs2all
 228     where f [] [] = []
 229           f xs [] = concatMap (mkExtraFile mWays1 mWays2 First  . tlFileName . snd) xs
 230           f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys
 231           f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2')
 232            = case fd1 `compare` fd2 of
 233              EQ -> map Change (compareTarLine tl1 tl2)
 234                 ++ f xs1' xs2'
 235              LT -> mkExtraFile mWays1 mWays2 First  (tlFileName tl1)
 236                 ++ f xs1' xs2
 237              GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2)
 238                 ++ f xs1 xs2'
 239           mkExtraFile mWaysMe mWaysThem mkFileChange filename
 240               = case (findFileWay filename, mWaysMe, mWaysThem) of
 241                 (Just way, Just waysMe, Just waysThem)
 242                  | (way `elem` waysMe) && not (way `elem` waysThem) -> []
 243                 _                  -> [mkFileChange (ExtraFile filename)]
 244
 245 findFileWay :: FilePath -> Maybe String
 246 findFileWay fp
 247  | Just [way] <- re "\\.([a-z_]+)_hi$" fp
 248     = Just way
 249  | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp
 250     = Just way
 251  | otherwise = Nothing
 252
 253 compareTarLine :: TarLine -> TarLine -> [Change]
 254 compareTarLine tl1 tl2
 255     = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
 256    ++ [ FileSizeChanged    fn1 fn2 size1  size2  | sizeChanged ]
 257     where fn1 = tlFileName tl1
 258           fn2 = tlFileName tl2
 259           perms1 = tlPermissions tl1
 260           perms2 = tlPermissions tl2
 261           size1 = tlSize tl1
 262           size2 = tlSize tl2
 263           sizeChanged = abs (size1 - size2) > sizeAbs
 264                      && (((100 * size1) `div` size2) > sizePercentage ||
 265                          ((100 * size2) `div` size1) > sizePercentage)
 266
 267 versionRE :: String
 268 versionRE = "([0-9]+(\\.[0-9]+)*)"
 269