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