path: root/distrib/compare/compare.hs

module Main (main) where

import Control.Monad.State
import Data.Char
import Data.List
import System.Directory
import System.Environment
import System.FilePath

import BuildInfo
import FilenameDescr
import Change
import Utils
import Tar

-- TODO:
-- * Check installed trees too
-- * Check hashbangs

sizeChangeThresholds :: [(Integer,  -- Threshold only applies if one of
                                    -- the files is at least this big
                          Integer)] -- Size changed if the larger file's
                                    -- size is at least this %age of the
                                    -- smaller file's size
sizeChangeThresholds = [(     1000, 150),
                        (50 * 1000, 110)]

main :: IO ()
main = do args <- getArgs
          (ignoreSizeChanges, p1, p2) <-
              case args of
              [p1, p2]                          -> return (False, p1, p2)
              ["--ignore-size-changes", p1, p2] -> return (True,  p1, p2)
              _ -> die ["Bad args. Need 2 filepaths."]
          doFileOrDirectory ignoreSizeChanges p1 p2

doFileOrDirectory :: Bool -> FilePath -> FilePath -> IO ()
doFileOrDirectory ignoreSizeChanges p1 p2
 = do b <- doesDirectoryExist p1
      let doit = if b then doDirectory else doFile
      doit ignoreSizeChanges p1 p2

doDirectory :: Bool -> FilePath -> FilePath -> IO ()
doDirectory ignoreSizeChanges p1 p2
 = do fs1 <- getDirectoryContents p1
      fs2 <- getDirectoryContents p2
      let isVersionChar c = isDigit c || c == '.'
          mkFileInfo "." = return []
          mkFileInfo ".." = return []
          mkFileInfo fp@('g':'h':'c':'-':x:xs)
           | isDigit x = return [(("ghc-", "VERSION", dropWhile isVersionChar xs), fp)]
           | otherwise = die ["No version number in " ++ show fp]
          mkFileInfo fp = do warn ["Unrecognised filename " ++ show fp]
                             return []
      fss1' <- mapM mkFileInfo fs1
      fss2' <- mapM mkFileInfo fs2
      let fs1' = sort $ concat fss1'
          fs2' = sort $ concat fss2'

          putBreak = putStrLn "=========="
          extraFile d fp = do putBreak
                              putStrLn ("Extra file in " ++ show d
                                     ++ ": " ++ show fp)
          doFiles [] [] = do putBreak
                             putStrLn "Done."
          doFiles ((_, fp) : xs) [] = do extraFile p1 fp
                                         doFiles xs []
          doFiles [] ((_, fp) : ys) = do extraFile p2 fp
                                         doFiles [] ys
          doFiles xs@((fpc1, fp1) : xs') ys@((fpc2, fp2) : ys')
              = do case fpc1 `compare` fpc2 of
                       EQ ->
                           do putBreak
                              putStrLn $ unwords ["Doing", show fp1, show fp2]
                              doFile ignoreSizeChanges (p1 </> fp1)
                                                       (p2 </> fp2)
                              doFiles xs' ys'
                       LT -> do extraFile p1 fp1
                                doFiles xs' ys
                       GT -> do extraFile p2 fp2
                                doFiles xs ys'
      doFiles fs1' fs2'

doFile :: Bool -> FilePath -> FilePath -> IO ()
doFile ignoreSizeChanges bd1 bd2
 = do tls1 <- readTarLines bd1
      tls2 <- readTarLines bd2
      let mWays1 = findWays tls1
          mWays2 = findWays tls2
      wayDifferences <- case (mWays1, mWays2) of
                        (Nothing, Nothing) ->
                            return []
                        (Just ways1, Just ways2) ->
                            return $ diffWays ways1 ways2
                        _ ->
                            die ["One input has ways, but the other doesn't"]
      (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1
      (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2
      let sortedContent1 = sortByFst content1
          sortedContent2 = sortByFst content2
          (nubProbs1, nubbedContent1) = nubContents sortedContent1
          (nubProbs2, nubbedContent2) = nubContents sortedContent2
          differences = compareContent mWays1 nubbedContent1
                                       mWays2 nubbedContent2
          allProbs = map First nubProbs1 ++ map Second nubProbs2
                  ++ diffThingVersionMap tvm1 tvm2
                  ++ wayDifferences
                  ++ differences
          wantedProbs = if ignoreSizeChanges
                        then filter (not . isSizeChange) allProbs
                        else allProbs
      mapM_ (putStrLn . pprFileChange) wantedProbs

-- *nix bindists have ways.
-- Windows "bindists", install trees, and testsuites don't.
findWays :: [TarLine] -> Maybe Ways
findWays tls = msum $ map f tls
    where f tl = case re regex (tlFileName tl) of
                 Just [dashedWays] -> Just (unSepList '-' dashedWays)
                 _                 -> Nothing
          regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"

diffWays :: Ways -> Ways -> [FileChange]
diffWays ws1 ws2 = f (sort ws1) (sort ws2)
    where f [] [] = []
          f xs [] = map (First  . ExtraWay) xs
          f [] ys = map (Second . ExtraWay) ys
          f xs@(x : xs') ys@(y : ys')
              = case x `compare` y of
                LT -> First  (ExtraWay x) : f xs' ys
                GT -> Second (ExtraWay y) : f xs  ys'
                EQ ->                       f xs' ys'

diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange]
diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2)
    where f [] [] = []
          f xs [] = map (First  . ExtraThing . fst) xs
          f [] ys = map (Second . ExtraThing . fst) ys
          f xs@((xt, xv) : xs') ys@((yt, yv) : ys')
              = case xt `compare` yt of
                LT -> First  (ExtraThing xt) : f xs' ys
                GT -> Second (ExtraThing yt) : f xs  ys'
                EQ -> let this = if xv == yv
                                 then []
                                 else [Change (ThingVersionChanged xt xv yv)]
                      in this ++ f xs' ys'

mkContents :: Maybe Ways -> [TarLine]
           -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap)
mkContents mWays tls
    = case runStateT (mapM f tls) (emptyBuildInfo mWays) of
      Nothing -> Left ["Can't happen: mkContents: Nothing"]
      Just (xs, finalBuildInfo) ->
          case concat $ map (checkContent finalBuildInfo) xs of
          []   -> Right (xs, biThingVersionMap finalBuildInfo)
          errs -> Left errs
    where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
                    return (fnd, tl)

nubContents :: [(FilenameDescr, TarLine)]
            -> ([Change], [(FilenameDescr, TarLine)])
nubContents [] = ([], [])
nubContents [x] = ([], [x])
nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
 | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
 | otherwise  = (ps, x1 : xs')
    where (ps, xs') = nubContents xs

mkFilePathDescr :: FilePath -> BIMonad FilenameDescr
mkFilePathDescr fp
 | Just [ghcVersion, _, middle, filename]
     <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
    = do haveThingVersion "ghc" ghcVersion
         middle' <- mkMiddleDescr middle
         filename' <- mkFileNameDescr filename
         let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename'
         return $ normaliseDescr fd
 | otherwise = return [FP fp]

mkMiddleDescr :: FilePath -> BIMonad FilenameDescr
mkMiddleDescr middle
 -- haddock docs in a Windows installed tree
 | Just [thing, thingVersion, _, src]
       <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$")
             middle
    = do haveThingVersion thing thingVersion
         return [FP "/doc/html/libraries/",
                 FP thing, FP "-", VersionOf thing, FP src]
      `mplus` unchanged
 -- libraries in a Windows installed tree
 | Just [thing, thingVersion, _, rest]
       <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$")
             middle
    = do haveThingVersion thing thingVersion
         return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest]
      `mplus` unchanged
 -- Windows in-tree gcc
 | Just [prefix, _, _, gccVersion, _, rest]
       <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$")
             middle
    = do haveThingVersion "gcc" gccVersion
         return [FP prefix, VersionOf "gcc", FP rest]
      `mplus` unchanged
 | otherwise = unchanged
    where unchanged = return [FP middle]

mkFileNameDescr :: FilePath -> BIMonad FilenameDescr
mkFileNameDescr filename
 | Just [prog, ghcVersion, _, exe]
       <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$")
             filename
    = do haveThingVersion "ghc" ghcVersion
         return [FP prog, FP "-", VersionOf "ghc", FP exe]
      `mplus` unchanged
 | Just [thing, thingVersion, _, ghcVersion, _, soDll]
       <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
             filename
    = do haveThingVersion "ghc" ghcVersion
         haveThingVersion thing thingVersion
         return [FP "libHS", FP thing, FP "-", VersionOf thing,
                 FP "-ghc", VersionOf "ghc", FP ".", FP soDll]
      `mplus` unchanged
 | Just [way, thingVersion, _, soDll]
       <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
             filename
    = do haveThingVersion "ghc" thingVersion
         return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
                 FP ".", FP soDll]
      `mplus` unchanged
 | Just [thingVersion, _, soDll]
       <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
             filename
    = do haveThingVersion "ghc" thingVersion
         return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll]
      `mplus` unchanged
 | Just [thing, thingVersion, _, way]
       <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
             filename
    = do haveThingVersion thing thingVersion
         return [FP "libHS", FP thing, FP "-", VersionOf thing,
                 FP way, FP ".a"]
      `mplus` unchanged
 | Just [thing, thingVersion, _]
       <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
             filename
    = do haveThingVersion thing thingVersion
         return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"]
      `mplus` unchanged
 | Just [thing, thingVersion, _, thingHash]
       <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$")
             filename
    = do haveThingVersion thing thingVersion
         haveThingHash    thing thingHash
         return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing,
                 FP ".conf"]
      `mplus` unchanged
 | Just [thingVersion, _]
       <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$")
             filename
    = do haveThingVersion "gcc" thingVersion
         return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"]
      `mplus` unchanged
 | Just [dashedWays, depType]
       <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
             filename
    = do mWays <- getMaybeWays
         if Just (unSepList '-' dashedWays) == mWays
             then return [FP ".depend-", Ways, FP ".", FP depType]
             else unchanged
 | otherwise = unchanged
    where unchanged = return [FP filename]

compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)]
               -> Maybe Ways -> [(FilenameDescr, TarLine)]
               -> [FileChange]
compareContent mWays1 xs1all mWays2 xs2all
 = f xs1all xs2all
    where f [] [] = []
          f xs [] = concatMap (mkExtraFile mWays1 mWays2 First  . tlFileName . snd) xs
          f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys
          f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2')
           = case fd1 `compare` fd2 of
             EQ -> map Change (compareTarLine tl1 tl2)
                ++ f xs1' xs2'
             LT -> mkExtraFile mWays1 mWays2 First  (tlFileName tl1)
                ++ f xs1' xs2
             GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2)
                ++ f xs1 xs2'
          mkExtraFile mWaysMe mWaysThem mkFileChange filename
              = case (findFileWay filename, mWaysMe, mWaysThem) of
                (Just way, Just waysMe, Just waysThem)
                 | (way `elem` waysMe) && not (way `elem` waysThem) -> []
                _                  -> [mkFileChange (ExtraFile filename)]

findFileWay :: FilePath -> Maybe String
findFileWay fp
 | Just [way] <- re "\\.([a-z_]+)_hi$" fp
    = Just way
 | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp
    = Just way
 | otherwise = Nothing

compareTarLine :: TarLine -> TarLine -> [Change]
compareTarLine tl1 tl2
    = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
   ++ [ FileSizeChanged    fn1 fn2 size1  size2  | sizeChanged ]
    where fn1 = tlFileName tl1
          fn2 = tlFileName tl2
          perms1 = tlPermissions tl1
          perms2 = tlPermissions tl2
          size1 = tlSize tl1
          size2 = tlSize tl2
          sizeMin = size1 `min` size2
          sizeMax = size1 `max` size2
          sizeChanged = any sizeChangeThresholdReached sizeChangeThresholds
          sizeChangeThresholdReached (reqSize, percentage)
              = (sizeMax >= reqSize)
             && (((100 * sizeMax) `div` sizeMin) >= percentage)

versionRE :: String
versionRE = "([0-9]+(\\.[0-9]+)*)"