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 FilenameDescr
  11 import Problem
  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 bd1 bd2
  31               _ -> die ["Bad args. Need 2 bindists."]
  32
  33 doit :: FilePath -> FilePath -> IO ()
  34 doit bd1 bd2
  35  = do tls1 <- readTarLines bd1
  36       tls2 <- readTarLines bd2
  37       content1 <- dieOnErrors $ mkContents tls1
  38       content2 <- dieOnErrors $ mkContents tls2
  39       let mySort = sortBy (compare `on` fst)
  40           sortedContent1 = mySort content1
  41           sortedContent2 = mySort content2
  42           (nubProbs1, nubbedContent1) = nubContents sortedContent1
  43           (nubProbs2, nubbedContent2) = nubContents sortedContent2
  44           differences = compareContent nubbedContent1
  45                                        nubbedContent2
  46           allProbs = map First nubProbs1 ++ map Second nubProbs2
  47                   ++ differences
  48       mapM_ (putStrLn . pprFileProblem) allProbs
  49
  50 mkContents :: [TarLine] -> Either Errors [(FilenameDescr, TarLine)]
  51 mkContents tls = case runState (mapM f tls) [] of
  52                  (xs, mapping) ->
  53                      case concat $ map (checkContent mapping) xs of
  54                      []   -> Right xs
  55                      errs -> Left errs
  56     where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
  57                     return (fnd, tl)
  58
  59 nubContents :: [(FilenameDescr, TarLine)]
  60             -> ([Problem], [(FilenameDescr, TarLine)])
  61 nubContents [] = ([], [])
  62 nubContents [x] = ([], [x])
  63 nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
  64  | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
  65  | otherwise  = (ps, x1 : xs')
  66     where (ps, xs') = nubContents xs
  67
  68 mkFilePathDescr :: FilePath -> State ThingVersionMap FilenameDescr
  69 mkFilePathDescr fp
  70  | Just [ghcVersion, _, middle, filename]
  71      <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
  72     = do ghcVersionDescr <- do mapping <- get
  73                                case addThingVersion mapping "ghc" ghcVersion of
  74                                    Just mapping' ->
  75                                        do put mapping'
  76                                           return (VersionOf "ghc")
  77                                    Nothing ->
  78                                        return (FP ghcVersion)
  79          filename' <- mkFileNameDescr filename
  80          let fd = FP "ghc-" : ghcVersionDescr : FP middle : FP "/" : filename'
  81          return $ normalise fd
  82  | otherwise = return [FP fp]
  83
  84 mkFileNameDescr :: FilePath -> State ThingVersionMap FilenameDescr
  85 mkFileNameDescr filename
  86  | Just [thing, thingVersion, _, ghcVersion, _]
  87        <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$")
  88              filename
  89     = do mapping <- get
  90          case addThingVersion mapping "ghc" ghcVersion of
  91              Just m ->
  92                  case addThingVersion m thing thingVersion of
  93                  Just m' ->
  94                      do put m'
  95                         return [FP "libHS", FP thing, FP "-", VersionOf thing,
  96                                 FP "-ghc", VersionOf "ghc", FP ".so"]
  97                  _ -> unchanged
  98              _ -> unchanged
  99  | Just [way, thingVersion, _]
 100        <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.so$")
 101              filename
 102     = do mapping <- get
 103          case addThingVersion mapping "ghc" thingVersion of
 104              Just mapping' ->
 105                  do put mapping'
 106                     return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
 107                             FP ".so"]
 108              _ -> unchanged
 109  | Just [thing, thingVersion, _, way]
 110        <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
 111              filename
 112     = do mapping <- get
 113          case addThingVersion mapping thing thingVersion of
 114              Just mapping' ->
 115                  do put mapping'
 116                     return [FP "libHS", FP thing, FP "-", VersionOf thing,
 117                             FP way, FP ".a"]
 118              _ -> unchanged
 119  | Just [thing, thingVersion, _]
 120        <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
 121              filename
 122     = do mapping <- get
 123          case addThingVersion mapping thing thingVersion of
 124              Just mapping' ->
 125                  do put mapping'
 126                     return [FP "HS", FP thing, FP "-", VersionOf thing,
 127                             FP ".o"]
 128              _ -> unchanged
 129  | otherwise = unchanged
 130     where unchanged = return [FP filename]
 131
 132 compareContent :: [(FilenameDescr, TarLine)] -> [(FilenameDescr, TarLine)]
 133                -> [FileProblem]
 134 compareContent [] [] = []
 135 compareContent xs [] = map (First  . ExtraFile . tlFileName . snd) xs
 136 compareContent [] ys = map (Second . ExtraFile . tlFileName . snd) ys
 137 compareContent xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2')
 138  = case fd1 `compare` fd2 of
 139    EQ -> map Change (compareTarLine tl1 tl2) ++ compareContent xs1' xs2'
 140    LT -> First  (ExtraFile (tlFileName tl1)) : compareContent xs1' xs2
 141    GT -> Second (ExtraFile (tlFileName tl2)) : compareContent xs1  xs2'
 142
 143 compareTarLine :: TarLine -> TarLine -> [Problem]
 144 compareTarLine tl1 tl2
 145     = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
 146    ++ [ FileSizeChanged    fn1 fn2 size1  size2  | sizeChanged ]
 147     where fn1 = tlFileName tl1
 148           fn2 = tlFileName tl2
 149           perms1 = tlPermissions tl1
 150           perms2 = tlPermissions tl2
 151           size1 = tlSize tl1
 152           size2 = tlSize tl2
 153           sizeChanged = abs (size1 - size2) > sizeAbs
 154                      && (((100 * size1) `div` size2) > sizePercentage ||
 155                          ((100 * size2) `div` size1) > sizePercentage)
 156
 157 versionRE :: String
 158 versionRE = "([0-9]+(\\.[0-9]+)*)"
 159