distrib/compare/FilenameDescr.hs

   1
   2 module FilenameDescr where
   3
   4 import Data.Either
   5 import Data.List
   6
   7 import BuildInfo
   8 import Utils
   9 import Tar
  10
  11 -- We can't just compare plain filenames, because versions numbers of GHC
  12 -- and the libaries will vary. So we use FilenameDescr instead, which
  13 -- abstracts out the version numbers.
  14 type FilenameDescr = [FilenameDescrBit]
  15 data FilenameDescrBit = VersionOf String
  16                       | HashOf String
  17                       | FP String
  18                       | Ways
  19     deriving (Show, Eq, Ord)
  20
  21 normalise :: FilenameDescr -> FilenameDescr
  22 normalise [] = []
  23 normalise [x] = [x]
  24 normalise (FP x1 : FP x2 : xs) = normalise (FP (x1 ++ x2) : xs)
  25 normalise (x : xs) = x : normalise xs
  26
  27 -- Sanity check that the FilenameDescr matches the filename in the tar line
  28 checkContent :: BuildInfo -> (FilenameDescr, TarLine) -> Errors
  29 checkContent buildInfo (fd, tl)
  30  = let fn = tlFileName tl
  31    in case flattenFilenameDescr buildInfo fd of
  32       Right fn' ->
  33           if fn' == fn
  34           then []
  35           else ["checkContent: Can't happen: filename mismatch: " ++ show fn]
  36       Left errs ->
  37           errs
  38
  39 flattenFilenameDescr :: BuildInfo -> FilenameDescr
  40                      -> Either Errors FilePath
  41 flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of
  42                                     ([], strs) -> Right (concat strs)
  43                                     (errs, _) -> Left (concat errs)
  44     where f (FP fp) = Right fp
  45           f (VersionOf thing)
  46            = case lookup thing (biThingVersionMap buildInfo) of
  47              Just v -> Right v
  48              Nothing -> Left ["Can't happen: thing has no version in mapping"]
  49           f (HashOf thing)
  50            = case lookup thing (biThingHashMap buildInfo) of
  51              Just v -> Right v
  52              Nothing -> Left ["Can't happen: thing has no hash in mapping"]
  53           f Ways = case biMaybeWays buildInfo of
  54                    Just ways -> Right $ intercalate "-" ways
  55                    Nothing   -> Left ["Can't happen: No ways, but Ways is used"]
  56