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
|
{-# LANGUAGE PatternGuards #-}
module Main (main) where
import Control.Monad.State
import Data.Function
import Data.List
import System.Environment
import FilenameDescr
import Problem
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 bd1 bd2
_ -> die ["Bad args. Need 2 bindists."]
doit :: FilePath -> FilePath -> IO ()
doit bd1 bd2
= do tls1 <- readTarLines bd1
tls2 <- readTarLines bd2
content1 <- dieOnErrors $ mkContents tls1
content2 <- dieOnErrors $ mkContents tls2
let mySort = sortBy (compare `on` fst)
sortedContent1 = mySort content1
sortedContent2 = mySort content2
(nubProbs1, nubbedContent1) = nubContents sortedContent1
(nubProbs2, nubbedContent2) = nubContents sortedContent2
differences = compareContent nubbedContent1
nubbedContent2
allProbs = map First nubProbs1 ++ map Second nubProbs2
++ differences
mapM_ (putStrLn . pprFileProblem) allProbs
mkContents :: [TarLine] -> Either Errors [(FilenameDescr, TarLine)]
mkContents tls = case runState (mapM f tls) [] of
(xs, mapping) ->
case concat $ map (checkContent mapping) xs of
[] -> Right xs
errs -> Left errs
where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
return (fnd, tl)
nubContents :: [(FilenameDescr, TarLine)]
-> ([Problem], [(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 -> State ThingVersionMap FilenameDescr
mkFilePathDescr fp
| Just [ghcVersion, _, middle, filename]
<- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
= do ghcVersionDescr <- do mapping <- get
case addThingVersion mapping "ghc" ghcVersion of
Just mapping' ->
do put mapping'
return (VersionOf "ghc")
Nothing ->
return (FP ghcVersion)
filename' <- mkFileNameDescr filename
let fd = FP "ghc-" : ghcVersionDescr : FP middle : FP "/" : filename'
return $ normalise fd
| otherwise = return [FP fp]
mkFileNameDescr :: FilePath -> State ThingVersionMap FilenameDescr
mkFileNameDescr filename
| Just [thing, thingVersion, _, ghcVersion, _]
<- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$")
filename
= do mapping <- get
case addThingVersion mapping "ghc" ghcVersion of
Just m ->
case addThingVersion m thing thingVersion of
Just m' ->
do put m'
return [FP "libHS", FP thing, FP "-", VersionOf thing,
FP "-ghc", VersionOf "ghc", FP ".so"]
_ -> unchanged
_ -> unchanged
| Just [way, thingVersion, _]
<- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.so$")
filename
= do mapping <- get
case addThingVersion mapping "ghc" thingVersion of
Just mapping' ->
do put mapping'
return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
FP ".so"]
_ -> unchanged
| Just [thing, thingVersion, _, way]
<- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
filename
= do mapping <- get
case addThingVersion mapping thing thingVersion of
Just mapping' ->
do put mapping'
return [FP "libHS", FP thing, FP "-", VersionOf thing,
FP way, FP ".a"]
_ -> unchanged
| Just [thing, thingVersion, _]
<- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
filename
= do mapping <- get
case addThingVersion mapping thing thingVersion of
Just mapping' ->
do put mapping'
return [FP "HS", FP thing, FP "-", VersionOf thing,
FP ".o"]
_ -> unchanged
| otherwise = unchanged
where unchanged = return [FP filename]
compareContent :: [(FilenameDescr, TarLine)] -> [(FilenameDescr, TarLine)]
-> [FileProblem]
compareContent [] [] = []
compareContent xs [] = map (First . ExtraFile . tlFileName . snd) xs
compareContent [] ys = map (Second . ExtraFile . tlFileName . snd) ys
compareContent xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2')
= case fd1 `compare` fd2 of
EQ -> map Change (compareTarLine tl1 tl2) ++ compareContent xs1' xs2'
LT -> First (ExtraFile (tlFileName tl1)) : compareContent xs1' xs2
GT -> Second (ExtraFile (tlFileName tl2)) : compareContent xs1 xs2'
compareTarLine :: TarLine -> TarLine -> [Problem]
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]+)*)"
|
