Commit 90d7a88f authored by Ian Lynagh's avatar Ian Lynagh

bindist checker improvements

* Some refactoring
* Support for Windows filenames
* Some support for installed trees (as Windows "bindists" are really
  install trees)
parent cb28985e
......@@ -3,39 +3,61 @@ module BuildInfo where
import Control.Monad.State
type BIMonad = StateT BuildInfo Maybe
data BuildInfo = BuildInfo {
biThingVersionMap :: ThingVersionMap,
biThingHashMap :: ThingHashMap,
biWays :: Ways
}
deriving Show
type ThingMap = [(String, String)]
-- Mapping from thing (e.g. "Cabal") to version (e.g. "1.10.0.0")
type ThingVersionMap = [(String, String)]
type ThingVersionMap = ThingMap
-- Mapping from thing (e.g. "Cabal") to ABI hash
-- (e.g. "e1f7c380581d61d42b0360d440cc35ed")
type ThingHashMap = ThingMap
-- The list of ways in the order the build system uses them, e.g.
-- ["v", "p", "dyn"] => we have ".depend-v-p-dyn.haskell" files
type Ways = [String]
addThingVersion :: ThingVersionMap -> String -> String -> Maybe ThingVersionMap
addThingVersion mapping thing version
emptyBuildInfo :: Ways -> BuildInfo
emptyBuildInfo ways = BuildInfo {
biThingVersionMap = [],
biThingHashMap = [],
biWays = ways
}
addThingMap :: ThingMap -> String -> String -> Maybe ThingMap
addThingMap mapping thing str
= case lookup thing mapping of
Just version' ->
if version == version'
Just str' ->
if str == str'
then Just mapping
else Nothing
Nothing ->
Just ((thing, version) : mapping)
Just ((thing, str) : mapping)
getThingVersionMap :: State BuildInfo ThingVersionMap
getThingVersionMap = do st <- get
return $ biThingVersionMap st
getWays :: State BuildInfo Ways
getWays :: BIMonad Ways
getWays = do st <- get
return $ biWays st
putThingVersionMap :: ThingVersionMap -> State BuildInfo ()
putThingVersionMap tm = do st <- get
put $ st { biThingVersionMap = tm }
putWays :: Ways -> State BuildInfo ()
haveThingVersion :: String -> String -> BIMonad ()
haveThingVersion thing thingVersion
= do st <- get
case addThingMap (biThingVersionMap st) thing thingVersion of
Nothing -> fail "Inconsistent version"
Just tvm -> put $ st { biThingVersionMap = tvm }
haveThingHash :: String -> String -> BIMonad ()
haveThingHash thing thingHash
= do st <- get
case addThingMap (biThingHashMap st) thing thingHash of
Nothing -> fail "Inconsistent hash"
Just thm -> put $ st { biThingHashMap = thm }
putWays :: Ways -> BIMonad ()
putWays ws = do st <- get
put $ st { biWays = ws }
module Change where
data FileChange = First Change
| Second Change
| Change Change
data Change = DuplicateFile FilePath
| ExtraFile FilePath
| ExtraWay String
| ExtraThing String
| ThingVersionChanged String String String
| PermissionsChanged FilePath FilePath String String
| FileSizeChanged FilePath FilePath Integer Integer
isSizeChange :: FileChange -> Bool
isSizeChange (Change (FileSizeChanged {})) = True
isSizeChange _ = False
pprFileChange :: FileChange -> String
pprFileChange (First p) = "First " ++ pprChange p
pprFileChange (Second p) = "Second " ++ pprChange p
pprFileChange (Change p) = "Change " ++ pprChange p
pprChange :: Change -> String
pprChange (DuplicateFile fp) = "Duplicate file: " ++ show fp
pprChange (ExtraFile fp) = "Extra file: " ++ show fp
pprChange (ExtraWay w) = "Extra way: " ++ show w
pprChange (ExtraThing t) = "Extra thing: " ++ show t
pprChange (ThingVersionChanged t v1 v2)
= "Version changed for " ++ show t ++ ":\n"
++ " " ++ v1 ++ " -> " ++ v2
pprChange (PermissionsChanged fp1 fp2 p1 p2)
= "Permissions changed:\n"
++ " " ++ show fp1
++ " " ++ show fp2
++ " " ++ p1 ++ " -> " ++ p2
pprChange (FileSizeChanged fp1 fp2 s1 s2)
= "Size changed:\n"
++ " " ++ show fp1 ++ "\n"
++ " " ++ show fp2 ++ "\n"
++ " " ++ show s1 ++ " -> " ++ show s2
......@@ -13,6 +13,7 @@ import Tar
-- abstracts out the version numbers.
type FilenameDescr = [FilenameDescrBit]
data FilenameDescrBit = VersionOf String
| HashOf String
| FP String
| Ways
deriving (Show, Eq, Ord)
......@@ -45,5 +46,9 @@ flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of
= case lookup thing (biThingVersionMap buildInfo) of
Just v -> Right v
Nothing -> Left ["Can't happen: thing has no version in mapping"]
f (HashOf thing)
= case lookup thing (biThingHashMap buildInfo) of
Just v -> Right v
Nothing -> Left ["Can't happen: thing has no hash in mapping"]
f Ways = Right $ intercalate "-" $ biWays buildInfo
module Problem where
data FileProblem = First Problem
| Second Problem
| Change Problem
data Problem = DuplicateFile FilePath
| ExtraFile FilePath
| ExtraWay String
| PermissionsChanged FilePath FilePath String String
| FileSizeChanged FilePath FilePath Integer Integer
isSizeChange :: FileProblem -> Bool
isSizeChange (Change (FileSizeChanged {})) = True
isSizeChange _ = False
pprFileProblem :: FileProblem -> String
pprFileProblem (First p) = "First " ++ pprProblem p
pprFileProblem (Second p) = "Second " ++ pprProblem p
pprFileProblem (Change p) = "Change " ++ pprProblem p
pprProblem :: Problem -> String
pprProblem (DuplicateFile fp) = "Duplicate file: " ++ show fp
pprProblem (ExtraFile fp) = "Extra file: " ++ show fp
pprProblem (ExtraWay w) = "Extra way: " ++ show w
pprProblem (PermissionsChanged fp1 fp2 p1 p2)
= "Permissions changed:\n"
++ " " ++ show fp1
++ " " ++ show fp2
++ " " ++ p1 ++ " -> " ++ p2
pprProblem (FileSizeChanged fp1 fp2 s1 s2)
= "Size changed:\n"
++ " " ++ show fp1 ++ "\n"
++ " " ++ show fp2 ++ "\n"
++ " " ++ show s1 ++ " -> " ++ show s2
module Utils where
import Data.Function
import Data.List
import System.Exit
import System.IO
import Text.Regex.Posix
......@@ -33,3 +35,6 @@ unSepList x xs = case break (x ==) xs of
(this, []) ->
[this]
sortByFst :: Ord a => [(a, b)] -> [(a, b)]
sortByFst = sortBy (compare `on` fst)
......@@ -3,13 +3,12 @@
module Main (main) where
import Control.Monad.State
import Data.Function
import Data.List
import System.Environment
import BuildInfo
import FilenameDescr
import Problem
import Change
import Utils
import Tar
......@@ -43,22 +42,22 @@ doit ignoreSizeChanges bd1 bd2
else dieOnErrors $ findWays tls1
ways2 <- if windows then return []
else dieOnErrors $ findWays tls2
content1 <- dieOnErrors $ mkContents ways1 tls1
content2 <- dieOnErrors $ mkContents ways2 tls2
let mySort = sortBy (compare `on` fst)
sortedContent1 = mySort content1
sortedContent2 = mySort content2
(content1, tvm1) <- dieOnErrors $ mkContents ways1 tls1
(content2, tvm2) <- dieOnErrors $ mkContents ways2 tls2
let sortedContent1 = sortByFst content1
sortedContent2 = sortByFst content2
(nubProbs1, nubbedContent1) = nubContents sortedContent1
(nubProbs2, nubbedContent2) = nubContents sortedContent2
differences = compareContent ways1 nubbedContent1
ways2 nubbedContent2
allProbs = map First nubProbs1 ++ map Second nubProbs2
++ diffThingVersionMap tvm1 tvm2
++ diffWays ways1 ways2
++ differences
wantedProbs = if ignoreSizeChanges
then filter (not . isSizeChange) allProbs
else allProbs
mapM_ (putStrLn . pprFileProblem) wantedProbs
mapM_ (putStrLn . pprFileChange) wantedProbs
findWays :: [TarLine] -> Either Errors Ways
findWays = foldr f (Left ["Couldn't find ways"])
......@@ -69,33 +68,45 @@ findWays = foldr f (Left ["Couldn't find ways"])
res
regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
diffWays :: Ways -> Ways -> [FileProblem]
diffWays :: Ways -> Ways -> [FileChange]
diffWays ws1 ws2 = f (sort ws1) (sort ws2)
where f [] [] = []
f xs [] = map (First . ExtraWay) xs
f [] ys = map (First . ExtraWay) ys
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'
mkContents :: Ways -> [TarLine] -> Either Errors [(FilenameDescr, TarLine)]
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 :: Ways -> [TarLine]
-> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap)
mkContents ways tls
= case runState (mapM f tls) initialBuildInfo of
(xs, finalBuildInfo) ->
= case runStateT (mapM f tls) (emptyBuildInfo ways) of
Nothing -> Left ["Can't happen: mkContents: Nothing"]
Just (xs, finalBuildInfo) ->
case concat $ map (checkContent finalBuildInfo) xs of
[] -> Right xs
[] -> Right (xs, biThingVersionMap finalBuildInfo)
errs -> Left errs
where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
return (fnd, tl)
initialBuildInfo = BuildInfo {
biThingVersionMap = [],
biWays = ways
}
nubContents :: [(FilenameDescr, TarLine)]
-> ([Problem], [(FilenameDescr, TarLine)])
-> ([Change], [(FilenameDescr, TarLine)])
nubContents [] = ([], [])
nubContents [x] = ([], [x])
nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
......@@ -103,67 +114,100 @@ nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
| otherwise = (ps, x1 : xs')
where (ps, xs') = nubContents xs
mkFilePathDescr :: FilePath -> State BuildInfo FilenameDescr
mkFilePathDescr :: FilePath -> BIMonad FilenameDescr
mkFilePathDescr fp
| Just [ghcVersion, _, middle, filename]
<- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
= do ghcVersionDescr <- do mapping <- getThingVersionMap
case addThingVersion mapping "ghc" ghcVersion of
Just mapping' ->
do putThingVersionMap mapping'
return (VersionOf "ghc")
Nothing ->
return (FP ghcVersion)
= do haveThingVersion "ghc" ghcVersion
middle' <- mkMiddleDescr middle
filename' <- mkFileNameDescr filename
let fd = FP "ghc-" : ghcVersionDescr : FP middle : FP "/" : filename'
let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename'
return $ normalise fd
| otherwise = return [FP fp]
mkFileNameDescr :: FilePath -> State BuildInfo FilenameDescr
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 [thing, thingVersion, _, ghcVersion, _]
<- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$")
| Just [prog, ghcVersion, _, exe]
<- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$")
filename
= do mapping <- getThingVersionMap
case addThingVersion mapping "ghc" ghcVersion of
Just m ->
case addThingVersion m thing thingVersion of
Just m' ->
do putThingVersionMap 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$")
= 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)$")
filename
= do mapping <- getThingVersionMap
case addThingVersion mapping "ghc" thingVersion of
Just mapping' ->
do putThingVersionMap mapping'
return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
FP ".so"]
_ -> unchanged
= 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)$")
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)$")
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 mapping <- getThingVersionMap
case addThingVersion mapping thing thingVersion of
Just mapping' ->
do putThingVersionMap mapping'
return [FP "libHS", FP thing, FP "-", VersionOf thing,
FP way, FP ".a"]
_ -> unchanged
= 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 mapping <- getThingVersionMap
case addThingVersion mapping thing thingVersion of
Just mapping' ->
do putThingVersionMap mapping'
return [FP "HS", FP thing, FP "-", VersionOf thing,
FP ".o"]
_ -> unchanged
= 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
......@@ -176,7 +220,7 @@ mkFileNameDescr filename
compareContent :: Ways -> [(FilenameDescr, TarLine)]
-> Ways -> [(FilenameDescr, TarLine)]
-> [FileProblem]
-> [FileChange]
compareContent _ [] _ [] = []
compareContent _ xs _ [] = map (First . ExtraFile . tlFileName . snd) xs
compareContent _ [] _ ys = map (Second . ExtraFile . tlFileName . snd) ys
......@@ -193,11 +237,11 @@ compareContent ways1 xs1 ways2 xs2
++ compareContent ways1 xs1' ways2 xs2
GT -> mkExtraFile ways2 Second (tlFileName tl2)
++ compareContent ways1 xs1 ways2 xs2'
where mkExtraFile ways mkFileProblem filename
where mkExtraFile ways mkFileChange filename
= case findFileWay filename of
Just way
| way `elem` ways -> []
_ -> [mkFileProblem (ExtraFile filename)]
_ -> [mkFileChange (ExtraFile filename)]
findFileWay :: FilePath -> Maybe String
findFileWay fp
......@@ -207,7 +251,7 @@ findFileWay fp
= Just way
| otherwise = Nothing
compareTarLine :: TarLine -> TarLine -> [Problem]
compareTarLine :: TarLine -> TarLine -> [Change]
compareTarLine tl1 tl2
= [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment