1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
|
{-# LANGUAGE PatternGuards #-}
module Main (main) where
import Control.Monad.State
import Data.List
import System.Environment
import BuildInfo
import FilenameDescr
import Change
import Utils
import Tar
-- TODO:
-- * Check installed trees too
-- * Check hashbangs
-- Only size changes > sizeAbs are considered an issue
sizeAbs :: Integer
sizeAbs = 1000
-- Only a size change of sizePercentage% or more is considered an issue
sizePercentage :: Integer
sizePercentage = 150
main :: IO ()
main = do args <- getArgs
case args of
[bd1, bd2] -> doit False bd1 bd2
["--ignore-size-changes", bd1, bd2] -> doit True bd1 bd2
_ -> die ["Bad args. Need 2 bindists."]
doit :: Bool -> FilePath -> FilePath -> IO ()
doit 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 $ normalise 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
sizeChanged = abs (size1 - size2) > sizeAbs
&& (((100 * size1) `div` size2) > sizePercentage ||
((100 * size2) `div` size1) > sizePercentage)
versionRE :: String
versionRE = "([0-9]+(\\.[0-9]+)*)"
|
