1module Main (main) where 2 3import Control.Monad.State 4import Data.Char 5import Data.List 6import System.Directory 7import System.Environment 8import System.FilePath 9 10import BuildInfo 11import FilenameDescr 12import Change 13import Utils 14import Tar 15 16-- TODO: 17-- * Check installed trees too 18-- * Check hashbangs 19 20sizeChangeThresholds :: [(Integer, -- Theshold only applies if one of 21 -- the files is at least this big 22 Integer)] -- Size changed if the larger file's 23 -- size is at least this %age of the 24 -- smaller file's size 25sizeChangeThresholds = [( 1000, 150), 26 (50 * 1000, 110)] 27 28main :: IO () 29main = do args <- getArgs 30 (ignoreSizeChanges, p1, p2) <- 31 case args of 32 [p1, p2] -> return (False, p1, p2) 33 ["--ignore-size-changes", p1, p2] -> return (True, p1, p2) 34 _ -> die ["Bad args. Need 2 filepaths."] 35 doFileOrDirectory ignoreSizeChanges p1 p2 36 37doFileOrDirectory :: Bool -> FilePath -> FilePath -> IO () 38doFileOrDirectory ignoreSizeChanges p1 p2 39 = do b <- doesDirectoryExist p1 40 let doit = if b then doDirectory else doFile 41 doit ignoreSizeChanges p1 p2 42 43doDirectory :: Bool -> FilePath -> FilePath -> IO () 44doDirectory ignoreSizeChanges p1 p2 45 = do fs1 <- getDirectoryContents p1 46 fs2 <- getDirectoryContents p2 47 let isVersionChar c = isDigit c || c == '.' 48 mkFileInfo "." = return [] 49 mkFileInfo ".." = return [] 50 mkFileInfo fp@('g':'h':'c':'-':x:xs) 51 | isDigit x = return [(("ghc-", "VERSION", dropWhile isVersionChar xs), fp)] 52 | otherwise = die ["No version number in " ++ show fp] 53 mkFileInfo fp = do warn ["Unrecognised filename " ++ show fp] 54 return [] 55 fss1' <- mapM mkFileInfo fs1 56 fss2' <- mapM mkFileInfo fs2 57 let fs1' = sort $ concat fss1' 58 fs2' = sort $ concat fss2' 59 60 putBreak = putStrLn "==========" 61 extraFile d fp = do putBreak 62 putStrLn ("Extra file in " ++ show d 63 ++ ": " ++ show fp) 64 doFiles [] [] = do putBreak 65 putStrLn "Done." 66 doFiles ((_, fp) : xs) [] = do extraFile p1 fp 67 doFiles xs [] 68 doFiles [] ((_, fp) : ys) = do extraFile p2 fp 69 doFiles [] ys 70 doFiles xs@((fpc1, fp1) : xs') ys@((fpc2, fp2) : ys') 71 = do case fpc1 `compare` fpc2 of 72 EQ -> 73 do putBreak 74 putStrLn $ unwords ["Doing", show fp1, show fp2] 75 doFile ignoreSizeChanges (p1 </> fp1) 76 (p2 </> fp2) 77 doFiles xs' ys' 78 LT -> do extraFile p1 fp1 79 doFiles xs' ys 80 GT -> do extraFile p2 fp2 81 doFiles xs ys' 82 doFiles fs1' fs2' 83 84doFile :: Bool -> FilePath -> FilePath -> IO () 85doFile ignoreSizeChanges bd1 bd2 86 = do tls1 <- readTarLines bd1 87 tls2 <- readTarLines bd2 88 let mWays1 = findWays tls1 89 mWays2 = findWays tls2 90 wayDifferences <- case (mWays1, mWays2) of 91 (Nothing, Nothing) -> 92 return [] 93 (Just ways1, Just ways2) -> 94 return $ diffWays ways1 ways2 95 _ -> 96 die ["One input has ways, but the other doesn't"] 97 (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1 98 (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2 99 let sortedContent1 = sortByFst content1 100 sortedContent2 = sortByFst content2 101 (nubProbs1, nubbedContent1) = nubContents sortedContent1 102 (nubProbs2, nubbedContent2) = nubContents sortedContent2 103 differences = compareContent mWays1 nubbedContent1 104 mWays2 nubbedContent2 105 allProbs = map First nubProbs1 ++ map Second nubProbs2 106 ++ diffThingVersionMap tvm1 tvm2 107 ++ wayDifferences 108 ++ differences 109 wantedProbs = if ignoreSizeChanges 110 then filter (not . isSizeChange) allProbs 111 else allProbs 112 mapM_ (putStrLn . pprFileChange) wantedProbs 113 114-- *nix bindists have ways. 115-- Windows "bindists", install trees, and testsuites don't. 116findWays :: [TarLine] -> Maybe Ways 117findWays tls = msum $ map f tls 118 where f tl = case re regex (tlFileName tl) of 119 Just [dashedWays] -> Just (unSepList '-' dashedWays) 120 _ -> Nothing 121 regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell" 122 123diffWays :: Ways -> Ways -> [FileChange] 124diffWays ws1 ws2 = f (sort ws1) (sort ws2) 125 where f [] [] = [] 126 f xs [] = map (First . ExtraWay) xs 127 f [] ys = map (Second . ExtraWay) ys 128 f xs@(x : xs') ys@(y : ys') 129 = case x `compare` y of 130 LT -> First (ExtraWay x) : f xs' ys 131 GT -> Second (ExtraWay y) : f xs ys' 132 EQ -> f xs' ys' 133 134diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange] 135diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2) 136 where f [] [] = [] 137 f xs [] = map (First . ExtraThing . fst) xs 138 f [] ys = map (Second . ExtraThing . fst) ys 139 f xs@((xt, xv) : xs') ys@((yt, yv) : ys') 140 = case xt `compare` yt of 141 LT -> First (ExtraThing xt) : f xs' ys 142 GT -> Second (ExtraThing yt) : f xs ys' 143 EQ -> let this = if xv == yv 144 then [] 145 else [Change (ThingVersionChanged xt xv yv)] 146 in this ++ f xs' ys' 147 148mkContents :: Maybe Ways -> [TarLine] 149 -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap) 150mkContents mWays tls 151 = case runStateT (mapM f tls) (emptyBuildInfo mWays) of 152 Nothing -> Left ["Can't happen: mkContents: Nothing"] 153 Just (xs, finalBuildInfo) -> 154 case concat $ map (checkContent finalBuildInfo) xs of 155 [] -> Right (xs, biThingVersionMap finalBuildInfo) 156 errs -> Left errs 157 where f tl = do fnd <- mkFilePathDescr (tlFileName tl) 158 return (fnd, tl) 159 160nubContents :: [(FilenameDescr, TarLine)] 161 -> ([Change], [(FilenameDescr, TarLine)]) 162nubContents [] = ([], []) 163nubContents [x] = ([], [x]) 164nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _)) 165 | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs') 166 | otherwise = (ps, x1 : xs') 167 where (ps, xs') = nubContents xs 168 169mkFilePathDescr :: FilePath -> BIMonad FilenameDescr 170mkFilePathDescr fp 171 | Just [ghcVersion, _, middle, filename] 172 <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp 173 = do haveThingVersion "ghc" ghcVersion 174 middle' <- mkMiddleDescr middle 175 filename' <- mkFileNameDescr filename 176 let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename' 177 return $ normaliseDescr fd 178 | otherwise = return [FP fp] 179 180mkMiddleDescr :: FilePath -> BIMonad FilenameDescr 181mkMiddleDescr middle 182 -- haddock docs in a Windows installed tree 183 | Just [thing, thingVersion, _, src] 184 <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$") 185 middle 186 = do haveThingVersion thing thingVersion 187 return [FP "/doc/html/libraries/", 188 FP thing, FP "-", VersionOf thing, FP src] 189 `mplus` unchanged 190 -- libraries in a Windows installed tree 191 | Just [thing, thingVersion, _, rest] 192 <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$") 193 middle 194 = do haveThingVersion thing thingVersion 195 return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest] 196 `mplus` unchanged 197 -- Windows in-tree gcc 198 | Just [prefix, _, _, gccVersion, _, rest] 199 <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$") 200 middle 201 = do haveThingVersion "gcc" gccVersion 202 return [FP prefix, VersionOf "gcc", FP rest] 203 `mplus` unchanged 204 | otherwise = unchanged 205 where unchanged = return [FP middle] 206 207mkFileNameDescr :: FilePath -> BIMonad FilenameDescr 208mkFileNameDescr filename 209 | Just [prog, ghcVersion, _, exe] 210 <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$") 211 filename 212 = do haveThingVersion "ghc" ghcVersion 213 return [FP prog, FP "-", VersionOf "ghc", FP exe] 214 `mplus` unchanged 215 | Just [thing, thingVersion, _, ghcVersion, _, soDll] 216 <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") 217 filename 218 = do haveThingVersion "ghc" ghcVersion 219 haveThingVersion thing thingVersion 220 return [FP "libHS", FP thing, FP "-", VersionOf thing, 221 FP "-ghc", VersionOf "ghc", FP ".", FP soDll] 222 `mplus` unchanged 223 | Just [way, thingVersion, _, soDll] 224 <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") 225 filename 226 = do haveThingVersion "ghc" thingVersion 227 return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc", 228 FP ".", FP soDll] 229 `mplus` unchanged 230 | Just [thingVersion, _, soDll] 231 <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") 232 filename 233 = do haveThingVersion "ghc" thingVersion 234 return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll] 235 `mplus` unchanged 236 | Just [thing, thingVersion, _, way] 237 <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$") 238 filename 239 = do haveThingVersion thing thingVersion 240 return [FP "libHS", FP thing, FP "-", VersionOf thing, 241 FP way, FP ".a"] 242 `mplus` unchanged 243 | Just [thing, thingVersion, _] 244 <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$") 245 filename 246 = do haveThingVersion thing thingVersion 247 return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"] 248 `mplus` unchanged 249 | Just [thing, thingVersion, _, thingHash] 250 <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$") 251 filename 252 = do haveThingVersion thing thingVersion 253 haveThingHash thing thingHash 254 return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing, 255 FP ".conf"] 256 `mplus` unchanged 257 | Just [thingVersion, _] 258 <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$") 259 filename 260 = do haveThingVersion "gcc" thingVersion 261 return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"] 262 `mplus` unchanged 263 | Just [dashedWays, depType] 264 <- re "^\\.depend-(.*)\\.(haskell|c_asm)" 265 filename 266 = do mWays <- getMaybeWays 267 if Just (unSepList '-' dashedWays) == mWays 268 then return [FP ".depend-", Ways, FP ".", FP depType] 269 else unchanged 270 | otherwise = unchanged 271 where unchanged = return [FP filename] 272 273compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)] 274 -> Maybe Ways -> [(FilenameDescr, TarLine)] 275 -> [FileChange] 276compareContent mWays1 xs1all mWays2 xs2all 277 = f xs1all xs2all 278 where f [] [] = [] 279 f xs [] = concatMap (mkExtraFile mWays1 mWays2 First . tlFileName . snd) xs 280 f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys 281 f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2') 282 = case fd1 `compare` fd2 of 283 EQ -> map Change (compareTarLine tl1 tl2) 284 ++ f xs1' xs2' 285 LT -> mkExtraFile mWays1 mWays2 First (tlFileName tl1) 286 ++ f xs1' xs2 287 GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2) 288 ++ f xs1 xs2' 289 mkExtraFile mWaysMe mWaysThem mkFileChange filename 290 = case (findFileWay filename, mWaysMe, mWaysThem) of 291 (Just way, Just waysMe, Just waysThem) 292 | (way `elem` waysMe) && not (way `elem` waysThem) -> [] 293 _ -> [mkFileChange (ExtraFile filename)] 294 295findFileWay :: FilePath -> Maybe String 296findFileWay fp 297 | Just [way] <- re "\\.([a-z_]+)_hi$" fp 298 = Just way 299 | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp 300 = Just way 301 | otherwise = Nothing 302 303compareTarLine :: TarLine -> TarLine -> [Change] 304compareTarLine tl1 tl2 305 = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ] 306 ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ] 307 where fn1 = tlFileName tl1 308 fn2 = tlFileName tl2 309 perms1 = tlPermissions tl1 310 perms2 = tlPermissions tl2 311 size1 = tlSize tl1 312 size2 = tlSize tl2 313 sizeMin = size1 `min` size2 314 sizeMax = size1 `max` size2 315 sizeChanged = any sizeChangeThresholdReached sizeChangeThresholds 316 sizeChangeThresholdReached (reqSize, percentage) 317 = (sizeMax >= reqSize) 318 && (((100 * sizeMax) `div` sizeMin) >= percentage) 319 320versionRE :: String 321versionRE = "([0-9]+(\\.[0-9]+)*)" 322 323