PackageTreeDiff.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

-- | A library for pkgtreediff for comparing trees of rpm packages
module Distribution.RPM.PackageTreeDiff
  (RpmPackage(..),
   readRpmPkg,
   showRpmPkg,
   rpmPkgIdent,
   appendArch,
   dropRpmArch,
   rpmPkgVerRel,
   RpmPackageDiff(..),
   diffPkgs,
   diffPkg,
   Ignore(..),
   Mode(..),
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Data.Char
import Data.Maybe
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as T

-- | Mode describes the kind of summary generated by compareDirs
data Mode = AutoSummary | NoSummary | ShowSummary | Added | Deleted | Updated | RST
  deriving Eq

-- | Ignore describes how comparison is done
data Ignore = IgnoreNone    -- ^ do not ignore version or release
            | IgnoreRelease -- ^ ignore differences in release
            | IgnoreVersion -- ^ ignore differences in version
  deriving Eq

type Name = Text
type Arch = Text

data VersionRelease = VerRel Text Text
  deriving Eq

instance Ord VersionRelease where
  compare (VerRel v1 r1) (VerRel v2 r2) =
    case rpmVerCompare v1 v2 of
      EQ -> rpmVerCompare r1 r2
      o -> o

data VerChunk = TildeChunk Int | CaretChunk Int | TxtChunk Text | IntChunk Int
  deriving (Eq,Ord,Show)

data RpmCharCategory = RpmTilde | RpmCaret | RpmOther | RpmLatin | RpmDigit
  deriving Eq

verChunk :: Text -> VerChunk
verChunk t | T.all isDigit t = (IntChunk . read . T.unpack) t
verChunk t | T.all (== '~') t = (TildeChunk . T.length) t
verChunk t | T.all (== '^') t = (CaretChunk . T.length) t
verChunk t = TxtChunk t

rpmVerCompare :: Text -> Text -> Ordering
rpmVerCompare v1 v2 | v1 == v2 = EQ
rpmVerCompare v1 v2 =
  compareChunks (verList v1) (verList v2)
  where
    compareChunks [] [] = EQ
    compareChunks (c:cs) (c':cs') | c == c' = compareChunks cs cs'
    compareChunks ((TildeChunk n):_) ((TildeChunk n'):_) = compare n' n
    compareChunks ((CaretChunk n):_) ((CaretChunk n'):_) = compare n' n
    compareChunks ((TildeChunk _):_) _ = LT
    compareChunks _ ((TildeChunk _):_) = GT
    compareChunks ((CaretChunk _):_) _ = LT
    compareChunks _ ((CaretChunk _):_) = GT
    compareChunks _ [] = GT
    compareChunks [] _ = LT
    compareChunks (c:_) (c':_) = compare c c'

verList :: Text -> [VerChunk]
verList = map verChunk . filter (T.all (/= '.')) . T.groupBy (\ c1 c2 -> rpmCategory c1 == rpmCategory c2)

latinChars :: [Char]
latinChars = ['A'..'Z'] ++ ['a'..'z']

rpmCategory :: Char -> RpmCharCategory
rpmCategory c | isDigit c = RpmDigit
rpmCategory c | c `elem` latinChars = RpmLatin
rpmCategory '~' = RpmTilde
rpmCategory '^' = RpmCaret
rpmCategory _ = RpmOther

-- eqVR True ignore release
eqVR :: Ignore -> VersionRelease -> VersionRelease -> Bool
eqVR IgnoreNone vr vr' = vr == vr'
eqVR IgnoreRelease (VerRel v _) (VerRel v' _) = v == v'
eqVR IgnoreVersion _ _ = True

-- | Text for the version-release of an RpmPackage
rpmPkgVerRel :: RpmPackage -> Text
rpmPkgVerRel = txtVerRel . rpmVerRel
  where
    txtVerRel (VerRel v r) = v <> T.singleton '-' <> r

-- | RPM package with name, version-release, and maybe architecture
data RpmPackage = RpmPkg {rpmName :: Name, rpmVerRel :: VersionRelease, rpmMArch :: Maybe Arch}
  deriving (Eq, Ord)

-- | Text identifier for an RPM package identified by name and arch
rpmPkgIdent :: RpmPackage -> Text
rpmPkgIdent p  = rpmName p <> appendArch p

-- | Helper to add an arch suffix
appendArch :: RpmPackage -> Text
appendArch p = maybe "" ("." <>) (rpmMArch p)

-- | drop arch from RpmPackage
dropRpmArch :: RpmPackage -> RpmPackage
dropRpmArch (RpmPkg n vr _) = RpmPkg n vr Nothing

-- | Render an RpmPackage
showRpmPkg :: RpmPackage -> Text
showRpmPkg p = rpmPkgIdent p <> T.pack "  " <> rpmPkgVerRel p

-- | Parse an RpmPackage
readRpmPkg :: Text -> RpmPackage
readRpmPkg t =
  if compnts < 3 then error $ "Malformed rpm package name: " ++ T.unpack t
  else RpmPkg name (VerRel ver rel) (Just arch)
  where
    compnts = length pieces
    (nvr',arch) = T.breakOnEnd "." $ fromMaybe t $ T.stripSuffix ".rpm" t
    pieces = reverse $ T.splitOn "-" $ T.dropEnd 1 nvr'
    (rel:ver:emaN) = pieces
    name = T.intercalate "-" $ reverse emaN

-- | RpmPackageDiff type encodes how a particular rpm package differs between trees
data RpmPackageDiff = PkgUpdate RpmPackage RpmPackage
                 | PkgAdd RpmPackage
                 | PkgDel RpmPackage
                 | PkgArch RpmPackage RpmPackage
  deriving Eq

-- | Compare two lists of packages NVRs
diffPkgs :: Ignore -> [RpmPackage] -> [RpmPackage] -> [RpmPackageDiff]
diffPkgs _ [] [] = []
diffPkgs ignore (p:ps) [] = PkgDel p : diffPkgs ignore ps []
diffPkgs ignore [] (p:ps) = PkgAdd p : diffPkgs ignore [] ps
diffPkgs ignore (p1:ps1) (p2:ps2) =
  case compareNames p1 p2 of
    LT -> PkgDel p1 : diffPkgs ignore ps1 (p2:ps2)
    EQ -> let diff = diffPkg ignore p1 p2
              diffs = diffPkgs ignore ps1 ps2
          in if isJust diff then fromJust diff : diffs else diffs
    GT -> PkgAdd p2 : diffPkgs ignore (p1:ps1) ps2

-- | Compare two rpms of a package
diffPkg :: Ignore -> RpmPackage-> RpmPackage-> Maybe RpmPackageDiff
diffPkg ignore p1 p2 | rpmPkgIdent p1 == rpmPkgIdent p2 =
                           if eqVR ignore (rpmVerRel p1) (rpmVerRel p2)
                           then Nothing
                           else Just $ PkgUpdate p1 p2
--diffPkg ignore p1 p2 | rpmName p1 == rpmName p2 =
--                            diffPkg ignore True (RpmPkg n1 v1) (RpmPkg n2 v2)
diffPkg _ p1 p2 | rpmName p1 == rpmName p2 && rpmPkgIdent p1 /= rpmPkgIdent p2 = Just $ PkgArch p1 p2
diffPkg _ _ _ = Nothing

compareNames :: RpmPackage -> RpmPackage -> Ordering
compareNames p1 p2 = compare (rpmName p1) (rpmName p2)