diff --git a/importer/BDCS/Depclose.hs b/importer/BDCS/Depclose.hs
new file mode 100644
index 0000000..8a0ae4f
--- /dev/null
+++ b/importer/BDCS/Depclose.hs
@@ -0,0 +1,244 @@
+-- Copyright (C) 2017 Red Hat, Inc.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Lesser General Public
+-- License as published by the Free Software Foundation; either
+-- version 2.1 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+-- Lesser General Public License for more details.
+--
+-- You should have received a copy of the GNU Lesser General Public
+-- License along with this library; if not, see .
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module BDCS.Depclose(DepFormula,
+ depclose)
+ where
+
+import Codec.RPM.Version(DepRequirement(..), EVR(..), parseDepRequirement, satisfies)
+import qualified Codec.RPM.Version as RPM(DepOrdering(EQ))
+import Control.Monad(filterM, foldM, when)
+import Control.Monad.Except(MonadError, throwError)
+import Control.Monad.IO.Class(MonadIO)
+import Data.Bifunctor(first)
+import Data.List(intersect)
+import Data.Maybe(fromMaybe, mapMaybe)
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Database.Persist.Sql(SqlPersistT)
+
+import BDCS.Depsolve(Formula(..))
+import BDCS.DB
+import BDCS.Files(pathToGroupId)
+import BDCS.Groups(getGroupId, getRequirementsForGroup)
+import BDCS.GroupKeyValue(getGroupsByKeyVal, getKeyValuesForGroup, getValueForGroup)
+import BDCS.KeyType
+import qualified BDCS.ReqType as RT
+import Utils.Error(errorToMaybe)
+import Utils.Monad(concatMapM, foldMaybeM, mapMaybeM)
+
+data ParentItem = GroupId (Key Groups)
+ | Provides DepRequirement
+ deriving (Eq, Ord)
+
+-- The Set is used to store the groups that are parents of the current subexpression,
+-- used to detect dependency loops and stop recursion. For instance:
+--
+-- A Requires B
+-- B Requires C
+-- C Requires A
+--
+-- When depclose gets to C Requires A it can stop, since that has already been resolved.
+type DepParents = Set.Set ParentItem
+
+-- type of the depclose results
+type DepFormula = Formula (Key Groups)
+
+-- given a path to a mddb, a list of architectures, and a list of RPMS, return a formula describing the dependencies
+-- The general idea is, given a list of packages to depclose, convert each to a group id, and for each id:
+-- - gather the conflict and obsolete information, find matching group ids, express as Not conflict/obsolete-id
+-- - gather the requirement expressions, for each:
+-- * find a list of matching group ids
+-- * if empty, the dependency is not satisfiable
+-- * recurse on each group id to gather the requirements of the requirement
+-- * return the expression as an Or of the matching group ids
+-- - return the whole thing as an And [self, conflict/obsolete information, requirement information]
+--
+-- Everything is run in a state with two components: a Map from groupid to expression to act as a cache,
+-- and a Set containing the group ids that are part of the current branch of the dependency tree in order
+-- to detect and ignore loops.
+depclose :: (MonadError String m, MonadIO m) => [T.Text] -> [T.Text] -> SqlPersistT m DepFormula
+depclose arches nevras = do
+ -- Convert each NEVRA into a group ID.
+ groupIds <- mapM getGroupId nevras
+
+ -- resolve each group id into a DepFormula
+ -- Use foldM to pass the parents set from resolving one group into the next group, so we
+ -- don't depclose things already depclosed from a previous group ID.
+ (formulas, _) <- foldM foldIdToFormula ([], Set.empty) groupIds
+
+ -- Every requirement in the list is required, so the final result is an And of the individual results.
+ return $ And formulas
+ where
+ -- turn groupIdToFormula into something we can use with fold
+ foldIdToFormula :: (MonadError String m, MonadIO m) => ([DepFormula], DepParents) -> Key Groups -> SqlPersistT m ([DepFormula], DepParents)
+ foldIdToFormula (formulaAcc, parents) groupId = first (:formulaAcc) <$> groupIdToFormula parents groupId
+
+ -- convert a group id to a dependency formula. First, check the cache to see if we've already gathered this group id
+ groupIdToFormula :: (MonadError String m, MonadIO m) => DepParents -> Key Groups -> SqlPersistT m (DepFormula, DepParents)
+ groupIdToFormula parents groupId = do
+ -- add this group id to the parents set
+ let parents' = Set.insert (GroupId groupId) parents
+
+ -- grab the key/value based data
+ conflicts <- getKeyValuesForGroup groupId (TextKey "rpm-conflict") >>= mapM kvToDep
+ obsoletes <- getKeyValuesForGroup groupId (TextKey "rpm-obsolete") >>= mapM kvToDep
+
+ -- map the strings to group ids. Obsolete and Conflict both express a potential group id
+ -- that should NOT be included in the final, depsolved result, so express that information here
+ -- as Not
+ --
+ -- In RPM headers: the expressions in Conflicts headers match corresponding names in the Provides
+ -- headers. Obsoletes, however, matches package names.
+ conflictIds <- concatMapM providerIds conflicts
+ obsoleteIds <- concatMapM nameReqIds obsoletes
+ let obsConflictFormulas = map Not (conflictIds ++ obsoleteIds)
+
+ -- grab all of the providers strings and add them to the parents set
+ -- Saving this data allows us to avoid repeatedly depclosing over a requirement provided
+ -- by more than one group. For instance, if there's more than one version of glibc available
+ -- in the mddb, a requirement for "libc.so.6" might resolve to Or [glibc-1, glibc-2]. Since
+ -- there are two choices, we can't say that either group id is definitely part of the expression,
+ -- but "libc.so.6" is definitely solved as part of the expression and does not need to be repeated.
+ providesSet <- Set.union parents'
+ <$> Set.fromList
+ <$> map Provides
+ <$> (getKeyValuesForGroup groupId (TextKey "rpm-provide") >>= mapM kvToDep)
+
+ -- Now the recursive part. First, grab everything from the requirements table for this group:
+ -- TODO maybe do something with strength, context, etc.
+
+ requirements <- getRequirementsForGroup groupId RT.Runtime >>= mapM reqToDep
+
+ -- Resolve each requirement to a list of group ids. Each group id is a possibility for satisfying
+ -- the requirement. An empty list means the requirement cannot be satisfied.
+ -- Zip the list of ids with the original requirement for error reporting.
+ requirementIds <- zip requirements <$> mapM providerIds requirements
+
+ -- Resolve each list of group ids to a formula
+ -- Fold the parents set returned by each requirement into the next requirement, so we don't repeat
+ -- ourselves too much.
+ (requirementFormulas, requirementParents) <- foldMaybeM resolveOneReq ([], providesSet) requirementIds
+
+ -- add an atom for the groupId itself, And it all together
+ return (And (Atom groupId : obsConflictFormulas ++ requirementFormulas), requirementParents)
+ where
+ resolveOneReq :: (MonadError String m, MonadIO m) => ([DepFormula], DepParents) -> (DepRequirement, [Key Groups]) -> SqlPersistT m (Maybe ([DepFormula], DepParents))
+ resolveOneReq (formulaAcc, parentAcc) (req, idlist) =
+ -- If any of the possible ids are in the parents set, the requirement is already satisfied in the parents
+ if | any (`Set.member` parentAcc) (map GroupId idlist) -> return Nothing
+ -- If this exact requirement is already in the parents set, the requirement is already solved, so skip this group
+ | Set.member (Provides req) parentAcc -> return Nothing
+ | otherwise -> do
+ -- map each possible ID to a forumula, discarding the ones that cannot be satisfied
+ (formulaList, parentList) <- unzip <$> mapMaybeM (errorToMaybe . groupIdToFormula parentAcc) idlist
+
+ -- If nothing worked, that's an error
+ when (null formulaList) $ throwError $ "Unable to resolve requirement: " ++ show req
+
+ -- The solution to this requirement is an Or of all the possibilities
+ -- The group ids that are definitely required by this formulas is the intersection of all of the individual sets
+ let reqFormula = Or formulaList
+ let reqParents = foldl1 Set.intersection parentList
+
+ -- Add the results to the accumulators
+ return $ Just (reqFormula : formulaAcc, Set.union parentAcc reqParents)
+
+ -- convert requirements to group IDs
+
+ -- Given a DepRequirement, return the group ids with a matching rpm-provide key/val
+ providerIds :: (MonadError String m, MonadIO m) => DepRequirement -> SqlPersistT m [Key Groups]
+ providerIds req = do
+ -- Pull the name out of the requirement
+ let DepRequirement reqname _ = req
+
+ -- Find all groups with a matching rpm-provide
+ vals <- getGroupsByKeyVal "rpm" (TextKey "rpm-provide") (Just reqname)
+
+ -- Filter out any that don't have a matching version
+ -- convert the second part of the tuple (the KeyVal) to a Dep and check it against the input req
+ valsVersion <- filterM (fmap (`satisfies` req) . kvToDep . snd) vals
+
+ -- we're done with the actual expression now, just need the group ids
+ let valsVersionIds = map fst valsVersion
+
+ -- Filter out the ones with the wrong arch
+ providerVals <- filterM matchesArch valsVersionIds
+
+ -- If the requirement looks like a filename, check for groups providing the file *in addition to* rpm-provide
+ fileVals <- if "/" `T.isPrefixOf` reqname then pathToGroupId reqname >>= filterM matchesArch
+ else return []
+
+ return $ providerVals ++ fileVals
+
+ -- Given a DepRequirement, return the group ids that match by name.
+ -- This is used to satisfy Obsoletes
+ nameReqIds :: MonadIO m => DepRequirement -> SqlPersistT m [Key Groups]
+ nameReqIds req = do
+ -- Pull the name out of the requirement
+ let DepRequirement reqname _ = req
+
+ vals <- map fst <$> getGroupsByKeyVal "rpm" (TextKey "name") (Just reqname)
+
+ -- filter out the values that don't match by arch
+ valsArch <- filterM matchesArch vals
+
+ -- If there is no version in the DepRequirement we're trying to satisfy, we're done.
+ -- otherwise, grab more info from the mddb to turn each group id into a name = EVR DepRequirement,
+ -- and filter out the ones that do not satisfy the version.
+ case req of
+ DepRequirement _ Nothing -> return valsArch
+ DepRequirement _ (Just _) -> filterM (\gid -> do
+ providerReq <- groupIdToDep reqname gid
+ return $ req `satisfies` providerReq)
+ valsArch
+ where
+ -- Return a versioned DepRequirement expression for this group id
+ groupIdToDep :: MonadIO m => T.Text -> Key Groups -> SqlPersistT m DepRequirement
+ groupIdToDep name groupId = do
+ epochStr <- getValueForGroup groupId (TextKey "epoch")
+ version <- fromMaybe "" <$> getValueForGroup groupId (TextKey "version")
+ release <- fromMaybe "" <$> getValueForGroup groupId (TextKey "release")
+
+ let epochInt = read <$> T.unpack <$> epochStr
+
+ return $ DepRequirement name $ Just (RPM.EQ, EVR {epoch=epochInt, version, release})
+
+ -- Check if the given group matches either the target arch or noarch
+ matchesArch :: MonadIO m => Key Groups -> SqlPersistT m Bool
+ matchesArch groupId = do
+ kvArches <- mapMaybe keyValVal_value <$> getKeyValuesForGroup groupId (TextKey "arch")
+ return $ (not . null) (("noarch":arches) `intersect` kvArches)
+
+ -- various ways of converting things to DepRequirement
+
+ -- convert the Either ParseError result from parseDepRequirement to a MonadError String
+ parseDepRequirementError :: MonadError String m => T.Text -> m DepRequirement
+ parseDepRequirementError req = either (throwError . show) return $ parseDepRequirement req
+
+ -- key/val to DepRequirement, for rpm-provide/rpm-confict/rpm-obsolete values
+ kvToDep :: MonadError String m => KeyVal -> m DepRequirement
+ kvToDep KeyVal {keyValExt_value=Nothing} = throwError "Invalid key/val data"
+ kvToDep KeyVal {keyValExt_value=Just ext} = parseDepRequirementError ext
+
+ -- Requirement to DepRequirement
+ reqToDep :: MonadError String m => Requirements -> m DepRequirement
+ reqToDep Requirements{..} = parseDepRequirementError requirementsReq_expr
diff --git a/importer/BDCS/Depsolve.hs b/importer/BDCS/Depsolve.hs
index 8107d9d..9403b9e 100644
--- a/importer/BDCS/Depsolve.hs
+++ b/importer/BDCS/Depsolve.hs
@@ -13,20 +13,28 @@
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, see .
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE TupleSections #-}
module BDCS.Depsolve(Formula(..),
CNFLiteral(..),
CNFAtom(..),
CNFFormula,
- formulaToCnf,
- solveCNF)
+ DepAssignment,
+ formulaToCNF,
+ solveCNF
+-- export private symbols for testing
+#ifdef TEST
+ , pureLiteralEliminate
+ , unitPropagate
+#endif
+ )
where
-import Control.Applicative((<|>))
-import Control.Monad.State(State, evalState, get, state)
+import Control.Monad.Except(MonadError, catchError, throwError)
+import Control.Monad.State(State, evalState, state)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.Maybe(isNothing, mapMaybe)
@@ -59,16 +67,16 @@ data CNFAtom a = CNFAtom (CNFLiteral a)
type CNFFormula a = [[CNFAtom a]]
-formulaToCnf :: Formula a -> CNFFormula a
-formulaToCnf f =
+formulaToCNF :: Formula a -> CNFFormula a
+formulaToCNF f =
-- wrap the call in a State Int starting at 0 to create a counter for substitution variables
- evalState (formulaToCnf' f) 0
+ evalState (formulaToCNF' f) 0
where
- formulaToCnf' :: Formula a -> State Int (CNFFormula a)
+ formulaToCNF' :: Formula a -> State Int (CNFFormula a)
-- easy ones: a becomes AND(OR(a)), NOT(a) becomes AND(OR(NOT(a)))
- formulaToCnf' (Atom x) = return [[CNFAtom (CNFOriginal x)]]
- formulaToCnf' (Not x) = return [[CNFNot (CNFOriginal x)]]
+ formulaToCNF' (Atom x) = return [[CNFAtom (CNFOriginal x)]]
+ formulaToCNF' (Not x) = return [[CNFNot (CNFOriginal x)]]
-- -- for an expression of the form And [a1, a2, a3, ...], we need to convert
-- each a1, a2, ... to CNF and concatenate the results.
@@ -86,7 +94,7 @@ formulaToCnf f =
-- Or[a1_or2_1, a1_or2_2],
-- Or[a2_or1_1, a2_or1_2],
-- Or[a2_or2_1, a2_or2_2]]
- formulaToCnf' (And andFormulas) = concatMapM formulaToCnf' andFormulas
+ formulaToCNF' (And andFormulas) = concatMapM formulaToCNF' andFormulas
-- For Or, the equivalent formula is exponentially larger than the original, so instead
-- create an equisatisfiable formula using new substitution variables, via Tseytin transformations.
@@ -120,21 +128,21 @@ formulaToCnf f =
-- to CNF via distribution as above. We then have AND , which is CNF.
-- end of recursion: OR of nothing is nothing, OR of 1 thing is just that thing
- formulaToCnf' (Or []) = return [[]]
- formulaToCnf' (Or [x]) = formulaToCnf' x
+ formulaToCNF' (Or []) = return [[]]
+ formulaToCNF' (Or [x]) = formulaToCNF' x
- formulaToCnf' (Or (x:xs)) = do
+ formulaToCNF' (Or (x:xs)) = do
-- Get and increment the counter
subVar <- state $ \i -> (CNFSubstitute i, i+1)
-- recurse on the left hand expression
- lhCNF <- formulaToCnf' x
+ lhCNF <- formulaToCNF' x
-- distribute NOT(subVar) AND lhCNF by adding NOT(subVar) into each of the OR lists
let lhSubCNF = map (CNFNot subVar:) lhCNF
-- recurse on the right hand side
- rhCNF <- formulaToCnf' (Or xs)
+ rhCNF <- formulaToCNF' (Or xs)
-- distribute subVar across the right hand expression
let rhSubCNF = map (CNFAtom subVar:) rhCNF
@@ -147,8 +155,6 @@ type DepAssignment a = (a, Bool)
-- internal types for the variable=bool assignments
type AssignmentMap a = Map (CNFLiteral a) Bool
-type AssignmentState a = State (AssignmentMap a)
-
-- if the formula is unsolvable, returns Nothing, other Just the list of assignments
-- This function uses the Davis-Putnam-Logemann-Loveman procedure for satisfying the formula, which is as follows:
@@ -166,136 +172,135 @@ type AssignmentState a = State (AssignmentMap a)
-- once simplified, pick a literal and assign it to True and try to satisfy the formula. If that doesn't work, assign to to False.
--
-- Repeat until solved.
-solveCNF :: Ord a => CNFFormula a -> Maybe [DepAssignment a]
-solveCNF formula = evalState (solveCNF' formula) Map.empty
+solveCNF :: (MonadError String m, Ord a) => CNFFormula a -> m [DepAssignment a]
+solveCNF formula = solveCNF' Map.empty formula
where
-- helper function that takes an assignment map and a formula
- solveCNF' :: Ord a => CNFFormula a -> AssignmentState a (Maybe [DepAssignment a])
- solveCNF' f =
+ solveCNF' :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m [DepAssignment a]
+ solveCNF' assignments f =
-- simplify the formula. simplify will recurse as necessary
- simplify f >>= \case
- -- if things failed during simplify, the formula is unsatisfiable
- Nothing -> return Nothing
+ simplify assignments f >>= \case
-- All clauses have been satisfied, we're done. Return the assignments
- Just [] -> Just <$> assignmentsToList
+ (assignments', []) -> return $ assignmentsToList assignments'
-- otherwise, try an assignment, or if that fails try the opposite assignment
- Just formula' -> guessAndCheck formula'
+ (assignments', formula') -> guessAndCheck assignments' formula'
- guessAndCheck :: Ord a => CNFFormula a -> AssignmentState a (Maybe [DepAssignment a])
- guessAndCheck f@((firstLiteral:_):_) = do
- assignments <- get
- return $ try assignments True <|> try assignments False
+ guessAndCheck :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m [DepAssignment a]
+ guessAndCheck assignments f@((firstLiteral:_):_) =
+ try True `catchError` const (try False)
where
- -- Run in a new state so we can backtrack
- try assignments val = let
- tryAssignments = Map.insert (atomToLiteral firstLiteral) val assignments
- in
- evalState (solveCNF' f) tryAssignments
- guessAndCheck _ = return Nothing
-
- simplify :: Ord a => CNFFormula a -> AssignmentState a (Maybe (CNFFormula a))
- simplify f = do
+ try val = do
+ let tryAssignments = Map.insert (atomToLiteral firstLiteral) val assignments
+ solveCNF' tryAssignments f
+
+ -- probably shouldn't happen
+ guessAndCheck assignments ([]:ys) = guessAndCheck assignments ys
+
+ -- No variables left, so we're done
+ guessAndCheck _ [] = return []
+
+ simplify :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m (AssignmentMap a, CNFFormula a)
+ simplify assignments f = do
-- pureLiteralEliminate only updates the assignments, the assigned literals are actually
-- removed by unitPropagate.
- pureLiteralEliminate Set.empty f
-
- unitPropagate f >>= \case
- Nothing -> return Nothing
- result@(Just upFormula) ->
- -- repeat until the formula doesn't change
- if f == upFormula then return result
- else simplify upFormula
-
- -- find pure literals and add them to the assignment map. This just updates assignments and does not make a decision as
- -- to satisfiability. It works by assuming every new literal it finds is pure and then correcting as needed. The Set
- -- argument is the literals that have been found to be unpure (i.e, they appear as both A and ~A)
- pureLiteralEliminate :: Ord a => Set (CNFLiteral a) -> CNFFormula a -> AssignmentState a ()
-
- -- end of recursion
- pureLiteralEliminate _ [] = return ()
- -- end of a clause, move on to the next one
- pureLiteralEliminate unpure ([]:ys) = pureLiteralEliminate unpure ys
-
- pureLiteralEliminate unpure ((x:xs):ys) = do
- unpure' <- state updateAssignments
- pureLiteralEliminate unpure' (xs:ys)
- where
- updateAssignments assignments = let
- literalX = atomToLiteral x
- in
- case (x, Map.lookup literalX assignments, Set.member literalX unpure) of
- -- something we've already marked as unpure, skip it
- (_, _, True) -> (unpure, assignments)
-
- -- Not in the map, add it
- (CNFAtom a, Nothing, _) -> (unpure, Map.insert a True assignments)
- (CNFNot a, Nothing, _) -> (unpure, Map.insert a False assignments)
-
- -- In the map and matches our guess, keep it
- (CNFAtom _, Just True, _) -> (unpure, assignments)
- (CNFNot _, Just False, _) -> (unpure, assignments)
-
- -- otherwise we guessed wrong. Remove from the map and add to unpure
- _ -> (Set.insert literalX unpure, Map.delete literalX assignments)
-
- unitPropagate :: Ord a => CNFFormula a -> AssignmentState a (Maybe (CNFFormula a))
-
- -- We have a unit! If it's new, add it to assignments and eliminate the unit
- -- If it's something in assignments, check that it matches
- unitPropagate ([x]:ys) = do
- isSatisfiable <- state satisfiable
- if isSatisfiable then
- unitPropagate ys
- else
- return Nothing
- where
- satisfiable assignments = let
- literalX = atomToLiteral x
- boolX = atomToBool x
- literalLookup = Map.lookup literalX assignments
- in
- -- if literalLookup is Nothing, this is a new literal. add it to assignments
- if | isNothing literalLookup -> (True, Map.insert literalX boolX assignments)
- -- old literal, matches
- | Just boolX == literalLookup -> (True, assignments)
- -- old literal, does not match
- | otherwise -> (False, assignments)
-
- -- for clauses with more than one thing:
- -- if the clause contains any literal that matches the map, the whole clause is true and we can remove it
- -- otherwise, remove any literals that do not match the map, as they cannot be true. If, after removing
- -- untrue literals, the clause is empty, the expression is unsolvable.
- unitPropagate (clause:ys) = do
- assignments <- get
-
- let clauseTrue = any (\atom -> Just (atomToBool atom) == Map.lookup (atomToLiteral atom) assignments) clause
- let clauseFiltered = filter (\atom -> Just (not (atomToBool atom)) == Map.lookup (atomToLiteral atom) assignments) clause
-
- if | clauseTrue -> unitPropagate ys
- | null clauseFiltered -> return Nothing
- | otherwise -> (unitPropagate <$> (clauseFiltered:)) ys
-
- unitPropagate _ = return Nothing
-
- assignmentsToList :: Ord a => AssignmentState a [DepAssignment a]
- assignmentsToList = do
- -- start by getting everything out of the map as a list of (CNFLiteral, Bool)
- assignments <- get
- let literalList = Map.foldlWithKey (\acc key val -> (key, val):acc) [] assignments
+ let pleAssignments = pureLiteralEliminate Set.empty assignments f
- -- map each (literal, bool) to Maybe (orig, bool), mapMaybe will filter out the Nothings
- return $ mapMaybe (\(literal, value) -> (,value) <$> literalToOriginal literal) literalList
-
- -- unwrap an atom
- atomToLiteral :: CNFAtom a -> CNFLiteral a
- atomToLiteral (CNFAtom x) = x
- atomToLiteral (CNFNot x) = x
+ (upAssignments, upFormula) <- unitPropagate pleAssignments f
- atomToBool :: CNFAtom a -> Bool
- atomToBool (CNFAtom _) = True
- atomToBool (CNFNot _) = False
+ -- repeat until the formula doesn't change
+ if f == upFormula then
+ return (upAssignments, upFormula)
+ else
+ simplify upAssignments upFormula
- -- unwrap original values, discard substitutes
- literalToOriginal :: CNFLiteral a -> Maybe a
- literalToOriginal (CNFOriginal x) = Just x
- literalToOriginal _ = Nothing
+ assignmentsToList :: Ord a => AssignmentMap a -> [DepAssignment a]
+ assignmentsToList assignments = let
+ -- start by getting everything out of the map as a list of (CNFLiteral, Bool)
+ literalList = Map.assocs assignments
+ in
+ -- map each (literal, bool) to Maybe (orig, bool), mapMaybe will filter out the Nothings
+ mapMaybe literalToOriginal literalList
+ where
+ -- unwrap original values, discard substitutes
+ literalToOriginal :: (CNFLiteral a, Bool) -> Maybe (a, Bool)
+ literalToOriginal (CNFOriginal x, b) = Just (x, b)
+ literalToOriginal _ = Nothing
+
+-- find pure literals and add them to the assignment map. This just updates assignments and does not make a decision as
+-- to satisfiability. It works by assuming every new literal it finds is pure and then correcting as needed. The Set
+-- argument is the literals that have been found to be unpure (i.e, they appear as both A and ~A)
+pureLiteralEliminate :: Ord a => Set (CNFLiteral a) -> AssignmentMap a -> CNFFormula a -> AssignmentMap a
+
+-- end of recursion
+pureLiteralEliminate _ assignments [] = assignments
+-- end of a clause, move on to the next one
+pureLiteralEliminate unpure assignments ([]:ys) = pureLiteralEliminate unpure assignments ys
+
+-- update unpure and assignments based on the first element and continue
+pureLiteralEliminate unpure assignments ((x:xs):ys) = let
+ (unpure', assignments') = updateAssignments
+ in
+ pureLiteralEliminate unpure' assignments' (xs:ys)
+ where
+ updateAssignments = let
+ literalX = atomToLiteral x
+ in
+ case (x, Map.lookup literalX assignments, Set.member literalX unpure) of
+ -- something we've already marked as unpure, skip it
+ (_, _, True) -> (unpure, assignments)
+
+ -- Not in the map, add it
+ (CNFAtom a, Nothing, _) -> (unpure, Map.insert a True assignments)
+ (CNFNot a, Nothing, _) -> (unpure, Map.insert a False assignments)
+
+ -- In the map and matches our guess, keep it
+ (CNFAtom _, Just True, _) -> (unpure, assignments)
+ (CNFNot _, Just False, _) -> (unpure, assignments)
+
+ -- otherwise we guessed wrong. Remove from the map and add to unpure
+ _ -> (Set.insert literalX unpure, Map.delete literalX assignments)
+
+unitPropagate :: (MonadError String m, Ord a) => AssignmentMap a -> CNFFormula a -> m (AssignmentMap a, CNFFormula a)
+
+-- We have a unit! If it's new, add it to assignments and eliminate the unit
+-- If it's something in assignments, check that it matches
+unitPropagate assignments ([x]:ys) = do
+ let literalX = atomToLiteral x
+ let boolX = atomToBool x
+ let literalLookup = Map.lookup literalX assignments
+
+ -- if literalLookup is Nothing, this is a new literal. add it to the assignments.
+ assignments' <- if | isNothing literalLookup -> return $ Map.insert literalX boolX assignments
+ -- old literal, matches
+ | Just boolX == literalLookup -> return assignments
+ -- old literal, does not match
+ | otherwise -> throwError "Unable to solve expression"
+
+ unitPropagate assignments' ys
+
+-- for clauses with more than one thing:
+-- if the clause contains any literal that matches the map, the whole clause is true and we can remove it
+-- otherwise, remove any literals that do not match the map, as they cannot be true. If, after removing
+-- untrue literals, the clause is empty, the expression is unsolvable.
+unitPropagate assignments (clause:ys) = do
+ let clauseTrue = any (\atom -> Just (atomToBool atom) == Map.lookup (atomToLiteral atom) assignments) clause
+ let clauseFiltered = filter (\atom -> case Map.lookup (atomToLiteral atom) assignments of
+ Nothing -> True
+ Just x -> x == atomToBool atom) clause
+
+ if | clauseTrue -> unitPropagate assignments ys
+ | null clauseFiltered -> throwError "Unable to solve expression"
+ | otherwise -> do
+ (assignments', formula') <- unitPropagate assignments ys
+ return (assignments', clauseFiltered:formula')
+
+unitPropagate assignments [] = return (assignments, [])
+
+-- unwrap an atom
+atomToLiteral :: CNFAtom a -> CNFLiteral a
+atomToLiteral (CNFAtom x) = x
+atomToLiteral (CNFNot x) = x
+
+atomToBool :: CNFAtom a -> Bool
+atomToBool (CNFAtom _) = True
+atomToBool (CNFNot _) = False
diff --git a/importer/BDCS/Files.hs b/importer/BDCS/Files.hs
index eb8cdbe..d2547d7 100644
--- a/importer/BDCS/Files.hs
+++ b/importer/BDCS/Files.hs
@@ -19,13 +19,15 @@ module BDCS.Files(insertFiles,
files,
filesC,
groupIdToFiles,
- groupIdToFilesC)
+ groupIdToFilesC,
+ pathToGroupId)
where
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Trans.Resource(MonadResource)
import Data.Conduit((.|), Conduit, Source, toProducer)
import qualified Data.Conduit.List as CL
+import qualified Data.Text as T
import Database.Esqueleto
import BDCS.DB
@@ -68,3 +70,11 @@ groupIdToFiles groupid = do
groupIdToFilesC :: MonadResource m => Conduit (Key Groups) (SqlPersistT m) Files
groupIdToFilesC = awaitWith $ \groupid -> toProducer (groupIdToFiles groupid) >> groupIdToFilesC
+
+pathToGroupId :: MonadIO m => T.Text -> SqlPersistT m [Key Groups]
+pathToGroupId path = do
+ vals <- select $ distinct $ from $ \(group_files `InnerJoin` fs) -> do
+ on $ group_files ^. GroupFilesFile_id ==. fs ^. FilesId
+ where_ $ fs ^. FilesPath ==. val path
+ return $ group_files ^. GroupFilesGroup_id
+ return $ map unValue vals
diff --git a/importer/BDCS/GroupKeyValue.hs b/importer/BDCS/GroupKeyValue.hs
index 544a280..fc049d1 100644
--- a/importer/BDCS/GroupKeyValue.hs
+++ b/importer/BDCS/GroupKeyValue.hs
@@ -13,13 +13,15 @@
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, see .
-module BDCS.GroupKeyValue(getKeyValuesForGroup,
+module BDCS.GroupKeyValue(getGroupsByKeyVal,
+ getKeyValuesForGroup,
getValueForGroup,
insertGroupKeyValue)
where
import Control.Monad.IO.Class(MonadIO)
import Data.Maybe(listToMaybe, mapMaybe)
+import Data.Bifunctor(bimap)
import qualified Data.Text as T
import Database.Esqueleto
@@ -46,3 +48,15 @@ getKeyValuesForGroup groupId key = do
-- Fetch the value for a key/val pair that is expected to occur only once
getValueForGroup :: MonadIO m => Key Groups -> KeyType -> SqlPersistT m (Maybe T.Text)
getValueForGroup groupId key = listToMaybe <$> mapMaybe keyValVal_value <$> getKeyValuesForGroup groupId key
+
+-- Return groups matching a given key/val
+getGroupsByKeyVal :: MonadIO m => T.Text -> KeyType -> Maybe T.Text -> SqlPersistT m [(Key Groups, KeyVal)]
+getGroupsByKeyVal groupType key value = do
+ vals <- select $ distinct $ from $ \(keyval `InnerJoin` group_keyval `InnerJoin` groups) -> do
+ on $ groups ^. GroupsId ==. group_keyval ^. GroupKeyValuesGroup_id
+ on $ keyval ^. KeyValId ==. group_keyval ^. GroupKeyValuesKey_val_id
+ where_ $ keyval ^. KeyValKey_value ==. val key &&.
+ keyval ^. KeyValVal_value ==? value &&.
+ groups ^. GroupsGroup_type ==. val groupType
+ return (group_keyval ^. GroupKeyValuesGroup_id, keyval)
+ return $ map (bimap unValue entityVal) vals
diff --git a/importer/BDCS/Groups.hs b/importer/BDCS/Groups.hs
index 4feaaa9..c3bb0bb 100644
--- a/importer/BDCS/Groups.hs
+++ b/importer/BDCS/Groups.hs
@@ -19,20 +19,21 @@
module BDCS.Groups(findGroupRequirements,
findRequires,
+ getGroupId,
getGroupIdC,
+ getRequirementsForGroup,
groups,
groupsC,
groupIdToNevra,
- nameToGroupId,
+ nameToGroupIds,
nevraToGroupId)
where
import Control.Monad.Except(MonadError, throwError)
import Control.Monad.IO.Class(MonadIO)
-import Control.Monad.Trans(lift)
-import Control.Monad.Trans.Resource(MonadBaseControl, MonadResource)
+import Control.Monad.Trans.Resource(MonadResource)
import Data.Bifunctor(bimap)
-import Data.Conduit((.|), Conduit, Source , yield)
+import Data.Conduit((.|), Conduit, Source)
import qualified Data.Conduit.List as CL
import Data.Maybe(isNothing, fromJust, fromMaybe)
import qualified Data.Text as T
@@ -43,7 +44,6 @@ import BDCS.GroupKeyValue(getValueForGroup)
import BDCS.KeyType
import qualified BDCS.ReqType as RT
import BDCS.RPM.Utils(splitFilename)
-import Utils.Conduit(awaitWith)
findGroupRequirements :: MonadIO m => Key Groups -> Key Requirements -> SqlPersistT m (Maybe (Key GroupRequirements))
findGroupRequirements groupId reqId = firstResult $
@@ -63,12 +63,15 @@ findRequires reqLang reqCtx reqStrength reqExpr = firstResult $
limit 1
return $ r ^. RequirementsId
-getGroupIdC :: (MonadError String m, MonadBaseControl IO m, MonadIO m) => Conduit T.Text (SqlPersistT m) (Key Groups)
-getGroupIdC = awaitWith $ \thing ->
- lift (nevraToGroupId $ splitFilename thing) >>= \case
- Just gid -> yield gid >> getGroupIdC
+getGroupId :: (MonadError String m, MonadIO m) => T.Text -> SqlPersistT m (Key Groups)
+getGroupId thing =
+ nevraToGroupId (splitFilename thing) >>= \case
+ Just gid -> return gid
Nothing -> throwError $ "No such group " ++ T.unpack thing
+getGroupIdC :: (MonadError String m, MonadIO m) => Conduit T.Text (SqlPersistT m) (Key Groups)
+getGroupIdC = CL.mapM getGroupId
+
groups :: MonadIO m => SqlPersistT m [(Key Groups, T.Text)]
groups = do
results <- select $ from $ \group -> do
@@ -95,17 +98,26 @@ groupIdToNevra groupId = do
then return Nothing
else return $ Just $ T.concat [fromMaybe "" e, fromJust n, "-", fromJust v, "-", fromJust r, ".", fromJust a]
--- Given a group name, return a group id
-nameToGroupId :: MonadIO m => T.Text -> SqlPersistT m (Maybe (Key Groups))
-nameToGroupId name = firstResult $
- select $ distinct $ from $ \(keyval `InnerJoin` group_keyval `InnerJoin` grps) -> do
- on $ keyval ^. KeyValId ==. group_keyval ^. GroupKeyValuesKey_val_id &&.
- group_keyval ^. GroupKeyValuesGroup_id ==. grps ^. GroupsId
- where_ $ keyval ^. KeyValKey_value ==. val (TextKey "name") &&.
- keyval ^. KeyValVal_value ==. just (val name) &&.
- grps ^. GroupsGroup_type ==. val "rpm"
- limit 1
- return $ grps ^. GroupsId
+getRequirementsForGroup :: MonadIO m => Key Groups -> RT.ReqContext -> SqlPersistT m [Requirements]
+getRequirementsForGroup groupId context = do
+ vals <- select $ from $ \(reqs `InnerJoin` groupreqs) -> do
+ on $ reqs ^. RequirementsId ==. groupreqs ^. GroupRequirementsReq_id
+ where_ $ groupreqs ^. GroupRequirementsGroup_id ==. val groupId &&.
+ reqs ^. RequirementsReq_context ==. val context
+ return reqs
+ return $ map entityVal vals
+
+-- Given a group name, return a list of matching group ids
+nameToGroupIds :: MonadIO m => T.Text -> SqlPersistT m [Key Groups]
+nameToGroupIds name = do
+ result <- select $ distinct $ from $ \(keyval `InnerJoin` group_keyval `InnerJoin` group) -> do
+ on $ keyval ^. KeyValId ==. group_keyval ^. GroupKeyValuesKey_val_id &&.
+ group_keyval ^. GroupKeyValuesGroup_id ==. group ^. GroupsId
+ where_ $ keyval ^. KeyValKey_value ==. val (TextKey "name") &&.
+ keyval ^. KeyValVal_value ==. just (val name) &&.
+ group ^. GroupsGroup_type ==. val "rpm"
+ return $ group ^. GroupsId
+ return $ map unValue result
nevraToGroupId :: MonadIO m => (T.Text, Maybe T.Text, T.Text, T.Text, T.Text) -> SqlPersistT m (Maybe (Key Groups))
nevraToGroupId (n, e, v, r, a) = firstResult $
diff --git a/importer/Utils/Error.hs b/importer/Utils/Error.hs
new file mode 100644
index 0000000..6d0c3a3
--- /dev/null
+++ b/importer/Utils/Error.hs
@@ -0,0 +1,15 @@
+module Utils.Error(errorToEither,
+ errorToMaybe)
+
+ where
+
+import Control.Monad.Except(MonadError, catchError)
+
+-- Convert an error action into an Either
+-- This is essentially runExceptT generalized to MonadError
+errorToEither :: MonadError e m => m a -> m (Either e a)
+errorToEither action = (Right <$> action) `catchError` (return . Left)
+
+-- Same as above, but discard the error
+errorToMaybe :: MonadError e m => m a -> m (Maybe a)
+errorToMaybe action = (Just <$> action) `catchError` (const . return) Nothing
diff --git a/importer/Utils/Monad.hs b/importer/Utils/Monad.hs
index fc747e8..7f8b7ba 100644
--- a/importer/Utils/Monad.hs
+++ b/importer/Utils/Monad.hs
@@ -1,9 +1,27 @@
module Utils.Monad(concatForM,
- concatMapM)
+ concatMapM,
+ foldMaybeM,
+ mapMaybeM)
where
+import Data.Maybe(catMaybes)
+
concatForM :: (Monad m, Traversable t) => t a -> (a -> m [b]) -> m [b]
concatForM lst fn = fmap concat (mapM fn lst)
concatMapM :: (Monad m, Traversable t) => (a -> m [b]) -> t a -> m [b]
concatMapM fn lst = fmap concat (mapM fn lst)
+
+mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
+mapMaybeM fn = fmap catMaybes . mapM fn
+
+-- foldM, but skip Nothing results
+foldMaybeM :: (Monad m) => (b -> a -> m (Maybe b)) -> b -> [a] -> m b
+foldMaybeM _ acc [] = return acc
+foldMaybeM action acc (x:xs) = do
+ result <- action acc x
+ case result of
+ -- skip this element, continue with the original accumulator
+ Nothing -> foldMaybeM action acc xs
+ -- Keep this one
+ Just r -> foldMaybeM action r xs
diff --git a/importer/bdcs.cabal b/importer/bdcs.cabal
index a1eab9c..4beb245 100644
--- a/importer/bdcs.cabal
+++ b/importer/bdcs.cabal
@@ -46,6 +46,7 @@ library
exposed-modules: BDCS.Builds,
BDCS.CS,
BDCS.DB,
+ BDCS.Depclose,
BDCS.Depsolve,
BDCS.Exceptions,
BDCS.Files,
@@ -90,12 +91,13 @@ library
Import.URI,
Utils.Conduit,
Utils.Either,
+ Utils.Error,
Utils.Mode,
Utils.Monad
build-depends: base >=4.9 && <5.0,
bytestring,
- codec-rpm >= 0.1.1 && < 0.2,
+ codec-rpm >= 0.1.3 && < 0.2,
cond,
containers,
conduit >= 1.2.8,
@@ -270,18 +272,50 @@ executable bdcs-tmpfiles
ghc-options: -Wall
+executable depsolve
+ main-is: depsolve.hs
+ hs-source-dirs: tools
+
+ build-depends: bdcs,
+ base >= 4.9 && < 5.0,
+ mtl >= 2.2.1,
+ persistent-sqlite,
+ text
+
+ default-language: Haskell2010
+
+ ghc-options: -Wall
+
Test-Suite test-bdcs
type: exitcode-stdio-1.0
- hs-source-dirs: tests
+ hs-source-dirs: ., tests
main-is: Spec.hs
build-depends: hspec,
base >= 4.8 && < 5.0,
- codec-rpm >= 0.1.1 && < 0.2,
+ bytestring,
+ codec-rpm >= 0.1.3 && < 0.2,
+ cond,
+ conduit >= 1.2.8,
+ containers,
+ directory,
+ esqueleto >= 2.5.3,
+ filepath,
+ gi-gio,
+ gi-glib,
monad-logger,
+ mtl >= 2.2.1,
+ parsec,
+ parsec-numbers,
persistent,
persistent-sqlite,
+ persistent-template,
resourcet,
- bdcs
+ text,
+ time,
+ unix
+
+ ghc-options: -Wall
+ cpp-options: -DTEST
default-language: Haskell2010
diff --git a/importer/tests/BDCS/DepcloseSpec.hs b/importer/tests/BDCS/DepcloseSpec.hs
new file mode 100644
index 0000000..947e313
--- /dev/null
+++ b/importer/tests/BDCS/DepcloseSpec.hs
@@ -0,0 +1,841 @@
+-- Copyright (C) 2017 Red Hat, Inc.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Lesser General Public
+-- License as published by the Free Software Foundation; either
+-- version 2.1 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+-- Lesser General Public License for more details.
+--
+-- You should have received a copy of the GNU Lesser General Public
+-- License along with this library; if not, see .
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module BDCS.DepcloseSpec(spec)
+ where
+
+import Control.Monad(void, when)
+import Control.Monad.Except(ExceptT, runExceptT)
+import Control.Monad.IO.Class(MonadIO)
+import Control.Monad.Logger(NoLoggingT)
+import Control.Monad.Trans.Resource(MonadBaseControl, ResourceT)
+import Data.Monoid((<>))
+import qualified Data.Text as T
+import Database.Persist(insert)
+import Database.Persist.Sql(Key, SqlPersistT, insertKey, toSqlKey)
+import Test.Hspec
+
+import BDCS.DB(Files(..), GroupFiles(..), Groups(..))
+import BDCS.Depclose(depclose)
+import BDCS.Depsolve(Formula(..))
+import BDCS.GroupKeyValue(insertGroupKeyValue)
+import BDCS.KeyType(KeyType(..))
+import BDCS.Requirements(insertGroupRequirement, insertRequirement)
+import qualified BDCS.ReqType as RT(ReqContext(..), ReqStrength(..))
+import BDCS.RPM.Requirements(mkGroupRequirement, mkRequirement)
+import Utils(withDb)
+
+-- The solutions provided by depclose are super messy (depsolve is supposed to clean them up),
+-- and any changes in depclose are likely to break these tests.
+spec :: Spec
+spec = describe "BDCS.Depclose Tests" $ do
+ let singleton_req = And [Atom (toSqlKey 1)]
+ let solution_1 = Right $ And [singleton_req]
+ it "depclose, singleton" $
+ withDeps (depclose arches ["singleton-1.0-1.x86_64"]) >>= (`shouldBe` solution_1)
+
+ let simple_req = And [Atom (toSqlKey 2), Or [singleton_req]]
+ let solution_2 = Right $ And [simple_req]
+ it "depclose, simple" $
+ withDeps (depclose arches ["simple-1.0-1.x86_64"]) >>= (`shouldBe` solution_2)
+
+ let simple_chain_req = And [Atom (toSqlKey 3), Or [simple_req]]
+ let solution_3 = Right $ And [simple_chain_req]
+ it "depclose, simple-chain" $
+ withDeps (depclose arches ["simple-chain-1.0-1.x86_64"]) >>= (`shouldBe` solution_3)
+
+ let provides_file_req = And [Atom (toSqlKey 4)]
+ let needs_file_req = And [Atom (toSqlKey 5), Or [provides_file_req]]
+ let solution_5 = Right $ And [needs_file_req]
+ it "depclose, needs-file" $
+ withDeps (depclose arches ["needs-file-1.0-1.x86_64"]) >>= (`shouldBe` solution_5)
+
+ let conflicts_req = And [Atom (toSqlKey 6), Not (toSqlKey 1)]
+ let solution_6 = Right $ And [conflicts_req]
+ it "depclose, conflicts" $
+ withDeps (depclose arches ["conflicts-1.0-1.x86_64"]) >>= (`shouldBe` solution_6)
+
+ let obsolete_req = And [Atom (toSqlKey 7), Not (toSqlKey 1)]
+ let solution_7 = Right $ And [obsolete_req]
+ it "depclose, obsoletes" $
+ withDeps (depclose arches ["obsoletes-1.0-1.x86_64"]) >>= (`shouldBe` solution_7)
+
+ let high_version_req = And [Atom (toSqlKey 10)]
+ let need_version_req = And [Atom (toSqlKey 11), Or [high_version_req]]
+ let solution_11 = Right $ And [need_version_req]
+ it "depclose, versioned requirement" $
+ withDeps (depclose arches ["needs-version-1.0-1.x86_64"]) >>= (`shouldBe` solution_11)
+
+ let obsolete_version_req = And [Atom (toSqlKey 12), Not (toSqlKey 9)]
+ let solution_12 = Right $ And [obsolete_version_req]
+ it "depclose, versioned obsolete" $
+ withDeps (depclose arches ["obsoletes-version-1.0-1.x86_64"]) >>= (`shouldBe` solution_12)
+
+ let loop_1_req = And [Atom (toSqlKey 14), Or [And [Atom (toSqlKey 15)]]]
+ let solution_15 = Right $ And [loop_1_req]
+ it "depclose, dependency cycle" $
+ withDeps (depclose arches ["loop-1-1.0-1.x86_64"]) >>= (`shouldBe` solution_15)
+
+ let choice_1_req = And [Atom (toSqlKey 17)]
+ let choice_2_req = And [Atom (toSqlKey 18)]
+ let choices_req = And [Atom (toSqlKey 16), Or [choice_1_req, choice_2_req]]
+ let solution_16 = Right $ And [choices_req]
+ it "depclose, multiple providers" $
+ withDeps (depclose arches ["choices-1.0-1.x86_64"]) >>= (`shouldBe` solution_16)
+
+ let solution_double = Right $ And [needs_file_req, singleton_req]
+ it "depclose, two things" $
+ withDeps (depclose arches ["singleton-1.0-1.x86_64", "needs-file-1.0-1.x86_64"]) >>= (`shouldBe` solution_double)
+
+ it "depclose, no such requirement" $
+ withDeps (depclose arches ["no-such-requirement-1.0-1.x86_64"]) >>= (`shouldBe` Left "Unable to resolve requirement: DepRequirement \"does-not-exist\" Nothing")
+
+ it "depclose, missing provides data" $
+ withDeps (depclose arches ["broken-conflicts-1.0-1.x86_64"]) >>= (`shouldBe` Left "Invalid key/val data")
+
+ it "depclose, no such package" $
+ withDeps (depclose arches ["does-not-exist-1.0-1.x86_64"]) >>= (`shouldBe` Left "No such group does-not-exist-1.0-1.x86_64")
+
+ -- run tests with (mostly) real data
+ -- this is more a demonstration of what's wrong with depclose than anything
+ let ncurses_base_req = And [Atom (toSqlKey 13)]
+ let tzdata_req = And [Atom (toSqlKey 10)]
+ let libgcc_req = And [Atom (toSqlKey 7)]
+
+ let libstdcplusplus_req = And [Atom (toSqlKey 8)
+ -- glibc in parents
+ -- libgcc in parents
+ ]
+
+ let xz_libs_req = And [Atom (toSqlKey 5)
+ -- glibc in parents
+ ]
+
+ let pcre_req = And [Atom (toSqlKey 6),
+ -- glibc in parents
+ Or [libstdcplusplus_req],
+ Or [libgcc_req]]
+
+ let libsepol_req = And [Atom (toSqlKey 9)
+ -- glibc in parents
+ ]
+
+ let libselinux_req = And [Atom (toSqlKey 4),
+ -- glibc in parents
+ Or [libsepol_req],
+ Or [pcre_req],
+ Or [xz_libs_req]]
+
+ let glibc_common_req = And [Atom (toSqlKey 3),
+ -- bash in parents
+ -- glibc in parents
+ Or [tzdata_req],
+ Or [libselinux_req]]
+
+ let nss_softokn_freebl_req = And [Atom (toSqlKey 11)
+ -- bash in parents
+ -- glibc in parents
+ ]
+
+ let glibc_req = And [Atom (toSqlKey 2),
+ Or [nss_softokn_freebl_req],
+ Or [glibc_common_req]]
+
+ let ncurses_req = And [Atom (toSqlKey 12),
+ -- glibc in parents
+ -- libgcc in parents
+ -- libstdc++ in parents
+ Or [ncurses_base_req]]
+
+ let bash_req = And [Atom (toSqlKey 1),
+ Or [ncurses_req],
+ Or [glibc_req]]
+ let bash_solution = Right $ And [bash_req]
+ it "depclose bash" $
+ withRealDeps (depclose arches ["bash-4.2.46-12.el7.x86_64"]) >>= (`shouldBe` bash_solution)
+
+ let glibc_req_2 = And [Atom (toSqlKey 1000),
+ Or [nss_softokn_freebl_req],
+ Or [glibc_common_req]]
+ let bash_req_2 = And [Atom (toSqlKey 1),
+ Or [ncurses_req],
+ Or [glibc_req, glibc_req_2]]
+ let bash_solution_2 = Right $ And [bash_req_2]
+ it "depclose bash, two glibcs" $
+ withGlibcUpgrade (depclose arches ["bash-4.2.46-12.el7.x86_64"]) >>= (`shouldBe` bash_solution_2)
+
+ -- tar requirements, minus requirements already pulled in by bash (glibc, libselinux)
+ let libattr_req = And [Atom (toSqlKey 16)]
+ let libacl_req = And [Atom (toSqlKey 15),
+ Or [libattr_req]]
+ let tar_with_bash_req = And [Atom (toSqlKey 14),
+ Or [libacl_req]]
+ let tar_with_bash_solution = Right $ And [tar_with_bash_req, bash_req]
+ it "depclose bash and tar at the same time" $
+ withRealDeps (depclose arches ["bash-4.2.46-12.el7.x86_64", "tar-2:1.26-29.el7.x86_64"]) >>= (`shouldBe` tar_with_bash_solution)
+ where
+ arches :: [T.Text]
+ arches = ["x86_64"]
+
+ addDeps :: MonadIO m => SqlPersistT m ()
+ addDeps = do
+ -- singleton, provides itself, requires nothing
+ let groupid_1 = toSqlKey 1
+ insertNEVRA groupid_1 "singleton" Nothing "1.0" "1" "x86_64"
+
+ -- simple, requires singleton and nothing else
+ let groupid_2 = toSqlKey 2
+ insertNEVRA groupid_2 "simple" Nothing "1.0" "1" "x86_64"
+ addReq groupid_2 "singleton"
+
+ -- simple-chain, requires simple which requires singleton
+ let groupid_3 = toSqlKey 3
+ insertNEVRA groupid_3 "simple-chain" Nothing "1.0" "1" "x86_64"
+ addReq groupid_3 "simple"
+
+ -- provides-file and needs-file, for file-based requirements
+ let groupid_4 = toSqlKey 4
+ insertNEVRA groupid_4 "provides-file" Nothing "1.0" "1" "x86_64"
+ addFile groupid_4 "/what/ever"
+ let groupid_5 = toSqlKey 5
+ insertNEVRA groupid_5 "needs-file" Nothing "1.0" "1" "x86_64"
+ addReq groupid_5 "/what/ever"
+
+ -- conflicts, conflicts with singleton
+ let groupid_6 = toSqlKey 6
+ insertNEVRA groupid_6 "conflicts" Nothing "1.0" "1" "x86_64"
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "singleton" (Just "singleton") groupid_6
+
+ -- obsoletes, same thing
+ let groupid_7 = toSqlKey 7
+ insertNEVRA groupid_7 "obsoletes" Nothing "1.0" "1" "x86_64"
+ void $ insertGroupKeyValue (TextKey "rpm-obsolete") "singleton" (Just "singleton") groupid_7
+
+ -- missing ext_val in a key/val that expects a version
+ let groupid_8 = toSqlKey 8
+ insertNEVRA groupid_8 "broken-conflicts" Nothing "1.0" "1" "x86_64"
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "missing-ext-value" Nothing groupid_8
+
+ -- versioned requirement
+ let groupid_9 = toSqlKey 9
+ insertNEVRA groupid_9 "versioned" Nothing "1.0" "1" "x86_64"
+ addProvide groupid_9 "version-test" (Just "= 1.0")
+
+ let groupid_10 = toSqlKey 10
+ insertNEVRA groupid_10 "versioned" Nothing "2.0" "1" "x86_64"
+ addProvide groupid_10 "version-test" (Just "= 2.0")
+
+ let groupid_11 = toSqlKey 11
+ insertNEVRA groupid_11 "needs-version" Nothing "1.0" "1" "x86_64"
+ addReq groupid_11 "versioned >= 2.0"
+
+ -- obsolete with version
+ let groupid_12 = toSqlKey 12
+ insertNEVRA groupid_12 "obsoletes-version" Nothing "1.0" "1" "x86_64"
+ void $ insertGroupKeyValue (TextKey "rpm-obsolete") "versioned" (Just "versioned < 2.0") groupid_12
+
+ -- unsatisfiable, package does not exist
+ let groupid_13 = toSqlKey 13
+ insertNEVRA groupid_13 "no-such-requirement" Nothing "1.0" "1" "x86_64"
+ addReq groupid_13 "does-not-exist"
+
+ -- create a loop
+ let groupid_14 = toSqlKey 14
+ insertNEVRA groupid_14 "loop-1" Nothing "1.0" "1" "x86_64"
+ addReq groupid_14 "loop-2"
+
+ let groupid_15 = toSqlKey 15
+ insertNEVRA groupid_15 "loop-2" Nothing "1.0" "1" "x86_64"
+ addReq groupid_15 "loop-1"
+
+ -- require something with multiple providers
+ let groupid_16 = toSqlKey 16
+ insertNEVRA groupid_16 "choices" Nothing "1.0" "1" "x86_64"
+ addReq groupid_16 "choices-req"
+
+ let groupid_17 = toSqlKey 17
+ insertNEVRA groupid_17 "choice-1" Nothing "1.0" "1" "x86_64"
+ addProvide groupid_17 "choices-req" Nothing
+
+ let groupid_18 = toSqlKey 18
+ insertNEVRA groupid_18 "choice-2" Nothing "1.0" "1" "x86_64"
+ addProvide groupid_18 "choices-req" Nothing
+
+ -- Real dependencies taken from CentOS 7 data
+ -- IDs:
+ -- 1: bash
+ -- 2: glibc
+ -- 3: glibc-common
+ -- 4: libselinux
+ -- 5: xz-libs
+ -- 6: pcre
+ -- 7: libgcc
+ -- 8: libstdc++
+ -- 9: libsepol
+ -- 10: tzdata
+ -- 11: nss-softokn-freebl
+ -- 12: ncurses-libs
+ -- 13: ncurses-base
+ -- 14: tar
+ -- 15: libacl
+ -- 16: libattr
+ addRealDeps :: MonadIO m => SqlPersistT m ()
+ addRealDeps = do
+ -- only the provides that are actually used are included, to try to keep things a little less out of control
+
+ let groupid_1 = toSqlKey 1
+ insertNEVRA groupid_1 "bash" Nothing "4.2.46" "12.el7" "x86_64"
+ addProvide groupid_1 "/bin/bash" Nothing
+ addProvide groupid_1 "/bin/sh" Nothing
+ addProvide groupid_1 "config(bash)" (Just "= 4.2.46-12.el7")
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_1
+ addFile groupid_1 "/usr/bin/bash"
+
+ -- self-provided
+ addReq groupid_1 "/bin/sh"
+ addReq groupid_1 "config(bash) = 4.2.46-12.el7"
+
+ -- provided by glibc (id 2)
+ addReq groupid_1 "libc.so.6()(64bit)"
+ addReq groupid_1 "libc.so.6(GLIBC_2.11)(64bit)"
+ addReq groupid_1 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_1 "libc.so.6(GLIBC_2.15)(64bit)"
+ addReq groupid_1 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_1 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_1 "libc.so.6(GLIBC_2.3.4)(64bit)"
+ addReq groupid_1 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_1 "libc.so.6(GLIBC_2.8)(64bit)"
+ addReq groupid_1 "libdl.so.2()(64bit)"
+ addReq groupid_1 "libdl.so.2(GLIBC_2.2.5)(64bit)"
+ addReq groupid_1 "rtld(GNU_HASH)"
+
+ -- ncurses-libs (id 12)
+ addReq groupid_1 "libtinfo.so.5()(64bit)"
+
+ let groupid_2 = toSqlKey 2
+ insertNEVRA groupid_2 "glibc" Nothing "2.17" "78.el7" "x86_64"
+ addProvide groupid_2 "config(glibc)" (Just "= 2.17-78.el7")
+ addProvide groupid_2 "ld-linux-x86-64.so.2()(64bit)" Nothing
+ addProvide groupid_2 "ld-linux-x86-64.so.2(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_2 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)" Nothing
+ addProvide groupid_2 "libCNS.so()(64bit)" Nothing
+ addProvide groupid_2 "libGB.so()(64bit)" Nothing
+ addProvide groupid_2 "libISOIR165.so()(64bit)" Nothing
+ addProvide groupid_2 "libJIS.so()(64bit)" Nothing
+ addProvide groupid_2 "libJISX0213.so()(64bit)" Nothing
+ addProvide groupid_2 "libKSC.so()(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6()(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.10)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.11)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.12)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.13)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.14)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.15)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.17)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.3)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.3.2)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.3.3)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.3.4)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.4)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.6)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.7)(64bit)" Nothing
+ addProvide groupid_2 "libc.so.6(GLIBC_2.8)(64bit)" Nothing
+ addProvide groupid_2 "libdl.so.2()(64bit)" Nothing
+ addProvide groupid_2 "libdl.so.2(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_2 "libm.so.6()(64bit)" Nothing
+ addProvide groupid_2 "libm.so.6(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_2 "libnsl.so.1()(64bit)" Nothing
+ addProvide groupid_2 "libnsl.so.1(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_2 "libnss_files.so.2()(64bit)" Nothing
+ addProvide groupid_2 "libpthread.so.0()(64bit)" Nothing
+ addProvide groupid_2 "libpthread.so.0(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_2 "libpthread.so.0(GLIBC_2.3.2)(64bit)" Nothing
+ addProvide groupid_2 "libpthread.so.0(GLIBC_2.3.3)(64bit)" Nothing
+ addProvide groupid_2 "libresolv.so.2()(64bit)" Nothing
+ addProvide groupid_2 "libresolv.so.2(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_2 "libresolv.so.2(GLIBC_2.9)(64bit)" Nothing
+ addProvide groupid_2 "rtld(GNU_HASH)" Nothing
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "kernel" (Just "kernel < 2.6.32") groupid_2
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "binutils" (Just "binutils < 2.19.51.0.10") groupid_2
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "prelink" (Just "prelink < 0.4.2") groupid_2
+ void $ insertGroupKeyValue (TextKey "rpm-obsolete") "glibc-profile" (Just "glibc-profile < 2.4") groupid_2
+ void $ insertGroupKeyValue (TextKey "rpm-obsolete") "nss_db" (Just "nss_db") groupid_2
+
+ -- self-provided
+ addReq groupid_2 "config(glibc) = 2.17-78.el7"
+ addReq groupid_2 "ld-linux-x86-64.so.2()(64bit)"
+ addReq groupid_2 "ld-linux-x86-64.so.2(GLIBC_2.2.5)(64bit)"
+ addReq groupid_2 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)"
+ addReq groupid_2 "libCNS.so()(64bit)"
+ addReq groupid_2 "libGB.so()(64bit)"
+ addReq groupid_2 "libISOIR165.so()(64bit)"
+ addReq groupid_2 "libJIS.so()(64bit)"
+ addReq groupid_2 "libJISX0213.so()(64bit)"
+ addReq groupid_2 "libKSC.so()(64bit)"
+ addReq groupid_2 "libc.so.6()(64bit)"
+ addReq groupid_2 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_2 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_2 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_2 "libc.so.6(GLIBC_2.3.2)(64bit)"
+ addReq groupid_2 "libc.so.6(GLIBC_2.3.3)(64bit)"
+ addReq groupid_2 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_2 "libdl.so.2()(64bit)"
+ addReq groupid_2 "libdl.so.2(GLIBC_2.2.5)(64bit)"
+ addReq groupid_2 "libnsl.so.1()(64bit)"
+ addReq groupid_2 "libnsl.so.1(GLIBC_2.2.5)(64bit)"
+ addReq groupid_2 "libnss_files.so.2()(64bit)"
+ addReq groupid_2 "libpthread.so.0()(64bit)"
+ addReq groupid_2 "libpthread.so.0(GLIBC_2.2.5)(64bit)"
+ addReq groupid_2 "libresolv.so.2()(64bit)"
+ addReq groupid_2 "libresolv.so.2(GLIBC_2.2.5)(64bit)"
+ addReq groupid_2 "libresolv.so.2(GLIBC_2.9)(64bit)"
+
+ -- glibc-common (id 3)
+ addReq groupid_2 "glibc-common = 2.17-78.el7"
+
+ -- nss-softokn-freebl (id 11)
+ addReq groupid_2 "libfreebl3.so()(64bit)"
+ addReq groupid_2 "libfreebl3.so(NSSRAWHASH_3.12.3)(64bit)"
+
+ let groupid_3 = toSqlKey 3
+ insertNEVRA groupid_3 "glibc-common" Nothing "2.17" "78.el7" "x86_64"
+ addProvide groupid_3 "config(glibc-common)" (Just "= 2.17-78.el7")
+
+ -- self-provided
+ addReq groupid_3 "config(glibc-common) = 2.17-78.el7"
+
+ -- provided by bash (id 1)
+ addReq groupid_3 "/bin/sh"
+ addReq groupid_3 "/usr/bin/bash"
+
+ -- provided by glibc (id 2)
+ addReq groupid_3 "glibc = 2.17-78.el7"
+ addReq groupid_3 "libc.so.6()(64bit)"
+ addReq groupid_3 "libc.so.6(GLIBC_2.10)(64bit)"
+ addReq groupid_3 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_3 "libc.so.6(GLIBC_2.15)(64bit)"
+ addReq groupid_3 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_3 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_3 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_3 "libdl.so.2()(64bit)"
+ addReq groupid_3 "libdl.so.2(GLIBC_2.2.5)(64bit)"
+
+ -- libselinux (id 4)
+ addReq groupid_3 "libselinux.so.1()(64bit)"
+
+ -- tzdata (id 10)
+ addReq groupid_3 "tzdata >= 2003a"
+
+ let groupid_4 = toSqlKey 4
+ insertNEVRA groupid_4 "libselinux" Nothing "2.2.2" "6.el7" "x86_64"
+ addProvide groupid_4 "libselinux.so.1()(64bit)" Nothing
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_4
+
+ -- self-provided
+ addReq groupid_4 "libselinux.so.1()(64bit)"
+
+ -- glibc (id 2)
+ addReq groupid_4 "ld-linux-x86-64.so.2()(64bit)"
+ addReq groupid_4 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)"
+ addReq groupid_4 "libc.so.6()(64bit)"
+ addReq groupid_4 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_4 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_4 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_4 "libc.so.6(GLIBC_2.3.2)(64bit)"
+ addReq groupid_4 "libc.so.6(GLIBC_2.3.4)(64bit)"
+ addReq groupid_4 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_4 "libc.so.6(GLIBC_2.7)(64bit)"
+ addReq groupid_4 "libc.so.6(GLIBC_2.8)(64bit)"
+ addReq groupid_4 "libdl.so.2()(64bit)"
+ addReq groupid_4 "libdl.so.2(GLIBC_2.2.5)(64bit)"
+ addReq groupid_4 "rtld(GNU_HASH)"
+
+ -- xz-libs (id 5)
+ addReq groupid_4 "liblzma.so.5()(64bit)"
+ addReq groupid_4 "liblzma.so.5(XZ_5.0)(64bit)"
+
+ -- pcre (id 6)
+ addReq groupid_4 "libpcre.so.1()(64bit)"
+ addReq groupid_4 "pcre"
+
+ -- libsepol (id 9)
+ addReq groupid_4 "libsepol >= 2.1.9-1"
+
+ let groupid_5 = toSqlKey 5
+ insertNEVRA groupid_5 "xz-libs" Nothing "5.1.2" "9alpha.el7" "x86_64"
+ addProvide groupid_5 "liblzma.so.5()(64bit)" Nothing
+ addProvide groupid_5 "liblzma.so.5(XZ_5.0)(64bit)" Nothing
+
+ -- provided by glibc (id 2)
+ addReq groupid_5 "libc.so.6()(64bit)"
+ addReq groupid_5 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_5 "libc.so.6(GLIBC_2.17)(64bit)"
+ addReq groupid_5 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_5 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_5 "libpthread.so.0()(64bit)"
+ addReq groupid_5 "libpthread.so.0(GLIBC_2.2.5)(64bit)"
+ addReq groupid_5 "libpthread.so.0(GLIBC_2.3.2)(64bit)"
+ addReq groupid_5 "libpthread.so.0(GLIBC_2.3.3)(64bit)"
+ addReq groupid_5 "rtld(GNU_HASH)"
+
+ let groupid_6 = toSqlKey 6
+ insertNEVRA groupid_6 "pcre" Nothing "8.32" "14.el7" "x86_64"
+ addProvide groupid_6 "libpcre.so.1()(64bit)" Nothing
+
+ -- self-provided
+ addReq groupid_6 "libpcre.so.1()(64bit)"
+
+ -- provided by glibc (id 2)
+ addReq groupid_6 "libc.so.6()(64bit)"
+ addReq groupid_6 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_6 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_6 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_6 "libc.so.6(GLIBC_2.3.4)(64bit)"
+ addReq groupid_6 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_6 "libm.so.6()(64bit)"
+ addReq groupid_6 "libpthread.so.0()(64bit)"
+ addReq groupid_6 "libpthread.so.0(GLIBC_2.2.5)(64bit)"
+ addReq groupid_6 "rtld(GNU_HASH)"
+
+ -- libgcc (id 7)
+ addReq groupid_6 "libgcc_s.so.1()(64bit)"
+ addReq groupid_6 "libgcc_s.so.1(GCC_3.0)(64bit)"
+
+ -- libstdc++ (id 8)
+ addReq groupid_6 "libstdc++.so.6()(64bit)"
+ addReq groupid_6 "libstdc++.so.6(CXXABI_1.3)(64bit)"
+ addReq groupid_6 "libstdc++.so.6(GLIBCXX_3.4)(64bit)"
+ addReq groupid_6 "libstdc++.so.6(GLIBCXX_3.4.9)(64bit)"
+
+ let groupid_7 = toSqlKey 7
+ insertNEVRA groupid_7 "libgcc" Nothing "4.8.3" "9.el7" "x86_64"
+ addProvide groupid_7 "libgcc_s.so.1()(64bit)" Nothing
+ addProvide groupid_7 "libgcc_s.so.1(GCC_3.0)(64bit)" Nothing
+ addProvide groupid_7 "libgcc_s.so.1(GCC_3.3)(64bit)" Nothing
+ addProvide groupid_7 "libgcc_s.so.1(GCC_4.2.0)(64bit)" Nothing
+ -- no requirements
+
+ let groupid_8 = toSqlKey 8
+ insertNEVRA groupid_8 "libstdc++" Nothing "4.8.3" "9.el7" "x86_64"
+ addProvide groupid_8 "libstdc++" (Just "= 4.8.2-16.el7")
+ addProvide groupid_8 "libstdc++.so.6()(64bit)" Nothing
+ addProvide groupid_8 "libstdc++.so.6(CXXABI_1.3)(64bit)" Nothing
+ addProvide groupid_8 "libstdc++.so.6(GLIBCXX_3.4)(64bit)" Nothing
+ addProvide groupid_8 "libstdc++.so.6(GLIBCXX_3.4.9)(64bit)" Nothing
+
+ -- glibc (id 2)
+ addReq groupid_8 "glibc >= 2.10.90-7"
+ addReq groupid_8 "ld-linux-x86-64.so.2()(64bit)"
+ addReq groupid_8 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)"
+ addReq groupid_8 "libc.so.6()(64bit)"
+ addReq groupid_8 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_8 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_8 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_8 "libc.so.6(GLIBC_2.3.2)(64bit)"
+ addReq groupid_8 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_8 "libm.so.6()(64bit)"
+ addReq groupid_8 "libm.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_8 "rtld(GNU_HASH)"
+
+ -- libgcc (id 7)
+ addReq groupid_8 "libgcc_s.so.1()(64bit)"
+ addReq groupid_8 "libgcc_s.so.1(GCC_3.0)(64bit)"
+ addReq groupid_8 "libgcc_s.so.1(GCC_3.3)(64bit)"
+ addReq groupid_8 "libgcc_s.so.1(GCC_4.2.0)(64bit)"
+
+ let groupid_9 = toSqlKey 9
+ insertNEVRA groupid_9 "libsepol" Nothing "2.1.9" "3.el7" "x86_64"
+ addProvide groupid_9 "libsepol.so.1()(64bit)" Nothing
+
+ -- provided by glibc (id 2)
+ addReq groupid_9 "libc.so.6()(64bit)"
+ addReq groupid_9 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_9 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_9 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_9 "libc.so.6(GLIBC_2.3.4)(64bit)"
+ addReq groupid_9 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_9 "rtld(GNU_HASH)"
+
+ let groupid_10 = toSqlKey 10
+ insertNEVRA groupid_10 "tzdata" Nothing "2015a" "1.el7" "noarch"
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "glibc-common" (Just "glibc-common <= 2.3.2-63") groupid_10
+ -- no requirements
+
+ let groupid_11 = toSqlKey 11
+ insertNEVRA groupid_11 "nss-softokn-freebl" Nothing "3.16.2.3" "9.el7" "x86_64"
+ addProvide groupid_11 "libfreebl3.so()(64bit)" Nothing
+ addProvide groupid_11 "libfreebl3.so(NSSRAWHASH_3.12.3)(64bit)" Nothing
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "nss" (Just "nss < 3.12.2.99.3-5") groupid_11
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "prelink" (Just "prelink < 0.4.3") groupid_11
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_11
+
+ -- bash (id 1)
+ addReq groupid_11 "/bin/bash"
+
+ -- glibc (id 2)
+ addReq groupid_11 "libc.so.6()(64bit)"
+ addReq groupid_11 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_11 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_11 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_11 "libc.so.6(GLIBC_2.3.4)(64bit)"
+ addReq groupid_11 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_11 "libdl.so.2()(64bit)"
+ addReq groupid_11 "libdl.so.2(GLIBC_2.2.5)(64bit)"
+ addReq groupid_11 "rtld(GNU_HASH)"
+
+ let groupid_12 = toSqlKey 12
+ insertNEVRA groupid_12 "ncurses-libs" Nothing "5.9" "13.20130511.el7" "x86_64"
+ addProvide groupid_12 "libform.so.5()(64bit)" Nothing
+ addProvide groupid_12 "libformw.so.5()(64bit)" Nothing
+ addProvide groupid_12 "libmenu.so.5()(64bit)" Nothing
+ addProvide groupid_12 "libmenuw.so.5()(64bit)" Nothing
+ addProvide groupid_12 "libncurses.so.5()(64bit)" Nothing
+ addProvide groupid_12 "libncursesw.so.5()(64bit)" Nothing
+ addProvide groupid_12 "libpanel.so.5()(64bit)" Nothing
+ addProvide groupid_12 "libpanelw.so.5()(64bit)" Nothing
+ addProvide groupid_12 "libtinfo.so.5()(64bit)" Nothing
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "ncurses" (Just "ncurses < 5.6.13") groupid_12
+ void $ insertGroupKeyValue (TextKey "rpm-obsolete") "ncurses" (Just "ncurses < 5.6.13") groupid_12
+ void $ insertGroupKeyValue (TextKey "rpm-obsolete") "libtermcap" (Just "libtermcap < 2.0.8-48") groupid_12
+
+ -- self-provided
+ addReq groupid_12 "libform.so.5()(64bit)"
+ addReq groupid_12 "libformw.so.5()(64bit)"
+ addReq groupid_12 "libmenu.so.5()(64bit)"
+ addReq groupid_12 "libmenuw.so.5()(64bit)"
+ addReq groupid_12 "libncurses.so.5()(64bit)"
+ addReq groupid_12 "libncursesw.so.5()(64bit)"
+ addReq groupid_12 "libpanel.so.5()(64bit)"
+ addReq groupid_12 "libpanelw.so.5()(64bit)"
+ addReq groupid_12 "libtinfo.so.5()(64bit)"
+
+ -- glibc (id 2)
+ addReq groupid_12 "libc.so.6()(64bit)"
+ addReq groupid_12 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_12 "libc.so.6(GLIBC_2.15)(64bit)"
+ addReq groupid_12 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_12 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_12 "libc.so.6(GLIBC_2.3.4)(64bit)"
+ addReq groupid_12 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_12 "libdl.so.2()(64bit)"
+ addReq groupid_12 "libdl.so.2(GLIBC_2.2.5)(64bit)"
+ addReq groupid_12 "libm.so.6()(64bit)"
+ addReq groupid_12 "rtld(GNU_HASH)"
+
+ -- libgcc (id 7)
+ addReq groupid_12 "libgcc_s.so.1()(64bit)"
+ addReq groupid_12 "libgcc_s.so.1(GCC_3.0)(64bit)"
+
+ -- libstdc++ (id 8)
+ addReq groupid_12 "libstdc++.so.6()(64bit)"
+ addReq groupid_12 "libstdc++.so.6(CXXABI_1.3)(64bit)"
+ addReq groupid_12 "libstdc++.so.6(GLIBCXX_3.4)(64bit)"
+
+ -- ncurses-base (id 13)
+ addReq groupid_12 "ncurses-base = 5.9-13.20130511.el7"
+
+ let groupid_13 = toSqlKey 13
+ insertNEVRA groupid_13 "ncurses-base" Nothing "5.9" "13.20130511.el7" "noarch"
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "ncurses" (Just "ncurses < 5.6-13") groupid_13
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_13
+ void $ insertGroupKeyValue (TextKey "rpm-obsolete") "termcap" (Just "termcap < 1:5.5-2") groupid_13
+ -- no requirements
+
+ let groupid_14 = toSqlKey 14
+ insertNEVRA groupid_14 "tar" (Just "2") "1.26" "29.el7" "x86_64"
+
+ -- glibc (id 2)
+ addReq groupid_14 "libc.so.6()(64bit)"
+ addReq groupid_14 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_14 "libc.so.6(GLIBC_2.17)(64bit)"
+ addReq groupid_14 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_14 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_14 "libc.so.6(GLIBC_2.3.4)(64bit)"
+ addReq groupid_14 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_14 "libc.so.6(GLIBC_2.6)(64bit)"
+ addReq groupid_14 "libc.so.6(GLIBC_2.7)(64bit)"
+ addReq groupid_14 "libc.so.6(GLIBC_2.8)(64bit)"
+ addReq groupid_14 "rtld(GNU_HASH)"
+
+ -- libselinux (id 4)
+ addReq groupid_14 "libselinux.so.1()(64bit)"
+
+ -- libacl (id 15)
+ addReq groupid_14 "libacl.so.1()(64bit)"
+ addReq groupid_14 "libacl.so.1(ACL_1.0)(64bit)"
+
+ let groupid_15 = toSqlKey 15
+ insertNEVRA groupid_15 "libacl" Nothing "2.2.51" "12.el7" "x86_64"
+ addProvide groupid_15 "libacl.so.1()(64bit)" Nothing
+ addProvide groupid_15 "libacl.so.1(ACL_1.0)(64bit)" Nothing
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_15
+
+ -- glibc (id 2)
+ addReq groupid_15 "libc.so.6()(64bit)"
+ addReq groupid_15 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_15 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_15 "libc.so.6(GLIBC_2.3.4)(64bit)"
+ addReq groupid_15 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_15 "rtld(GNU_HASH)"
+
+ -- libattr (id 16)
+ addReq groupid_15 "libattr.so.1()(64bit)"
+ addReq groupid_15 "libattr.so.1(ATTR_1.0)(64bit)"
+
+ let groupid_16 = toSqlKey 16
+ insertNEVRA groupid_16 "libattr" Nothing "2.4.46" "12.el7" "x86_64"
+ addProvide groupid_16 "libattr.so.1()(64bit)" Nothing
+ addProvide groupid_16 "libattr.so.1(ATTR_1.0)(64bit)" Nothing
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "filesystem" (Just "filesystem < 3") groupid_16
+
+ -- glibc (id 2)
+ addReq groupid_16 "libc.so.6()(64bit)"
+ addReq groupid_16 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_16 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_16 "rtld(GNU_HASH)"
+
+ addFile :: MonadIO m => Key Groups -> T.Text -> SqlPersistT m ()
+ addFile groupid path = do
+ fid <- insert $ Files path "root" "root" 0 (Just "checksum")
+ void $ insert $ GroupFiles groupid fid
+
+ addReq :: MonadIO m => Key Groups -> T.Text -> SqlPersistT m ()
+ addReq groupid expr = do
+ reqid <- insertRequirement $ mkRequirement RT.Runtime RT.Must expr
+ void $ insertGroupRequirement $ mkGroupRequirement groupid reqid
+
+ addProvide :: MonadIO m => Key Groups -> T.Text -> Maybe T.Text -> SqlPersistT m ()
+ addProvide groupid depname depver = let
+ depext = depname <> maybe "" (" " `T.append`) depver
+ in
+ void $ insertGroupKeyValue (TextKey "rpm-provide") depname (Just depext) groupid
+
+ insertNEVRA :: MonadIO m => Key Groups -> T.Text -> Maybe T.Text -> T.Text -> T.Text -> T.Text -> SqlPersistT m ()
+ insertNEVRA gid name epoch version release arch = do
+ insertKey gid $ Groups name "rpm"
+ void $ insertGroupKeyValue (TextKey "name") name Nothing gid
+ void $ insertGroupKeyValue (TextKey "version") version Nothing gid
+ void $ insertGroupKeyValue (TextKey "release") release Nothing gid
+ void $ insertGroupKeyValue (TextKey "arch") arch Nothing gid
+ maybe (return ())
+ (\e -> void $ insertGroupKeyValue (TextKey "epoch") e Nothing gid)
+ epoch
+
+ -- Add the self-provide
+ let evr = maybe "" (T.append ":") epoch <> version <> "-" <> release
+ addProvide gid name (Just ("= " <> evr))
+ when (arch /= "noarch") $ do
+ let archname = name <> "(" <> arch <> ")"
+ addProvide gid archname (Just ("= " <> evr))
+
+ withDeps :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (NoLoggingT (ResourceT (ExceptT e m))) a -> m (Either e a)
+ withDeps action = (runExceptT . withDb) (addDeps >> action)
+
+ withRealDeps :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (NoLoggingT (ResourceT (ExceptT e m))) a -> m (Either e a)
+ withRealDeps action = (runExceptT . withDb) (addRealDeps >> action)
+
+ -- Like withRealDeps, but with an extra glibc
+ addGlibcUpgrade :: MonadIO m => SqlPersistT m ()
+ addGlibcUpgrade = do
+ addRealDeps
+
+ let groupid_1000 = toSqlKey 1000
+ insertNEVRA groupid_1000 "glibc-upgrade" Nothing "3.0" "1" "x86_64"
+ -- Add all of the same provides and requires as glibc-2.17-78.el7.x86_64
+ addProvide groupid_1000 "glibc" (Just "= 2.17-78.el7")
+ addProvide groupid_1000 "glibc(x86_64)" (Just "= 2.17-78.el7")
+ addProvide groupid_1000 "config(glibc)" (Just "= 2.17-78.el7")
+ addProvide groupid_1000 "ld-linux-x86-64.so.2()(64bit)" Nothing
+ addProvide groupid_1000 "ld-linux-x86-64.so.2(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_1000 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)" Nothing
+ addProvide groupid_1000 "libCNS.so()(64bit)" Nothing
+ addProvide groupid_1000 "libGB.so()(64bit)" Nothing
+ addProvide groupid_1000 "libISOIR165.so()(64bit)" Nothing
+ addProvide groupid_1000 "libJIS.so()(64bit)" Nothing
+ addProvide groupid_1000 "libJISX0213.so()(64bit)" Nothing
+ addProvide groupid_1000 "libKSC.so()(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6()(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.10)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.11)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.12)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.13)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.14)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.15)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.17)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.3)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.3.2)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.3.3)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.3.4)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.4)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.7)(64bit)" Nothing
+ addProvide groupid_1000 "libc.so.6(GLIBC_2.8)(64bit)" Nothing
+ addProvide groupid_1000 "libdl.so.2()(64bit)" Nothing
+ addProvide groupid_1000 "libdl.so.2(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_1000 "libm.so.6()(64bit)" Nothing
+ addProvide groupid_1000 "libm.so.6(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_1000 "libnsl.so.1()(64bit)" Nothing
+ addProvide groupid_1000 "libnsl.so.1(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_1000 "libnss_files.so.2()(64bit)" Nothing
+ addProvide groupid_1000 "libpthread.so.0()(64bit)" Nothing
+ addProvide groupid_1000 "libpthread.so.0(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_1000 "libpthread.so.0(GLIBC_2.3.2)(64bit)" Nothing
+ addProvide groupid_1000 "libpthread.so.0(GLIBC_2.3.3)(64bit)" Nothing
+ addProvide groupid_1000 "libresolv.so.2()(64bit)" Nothing
+ addProvide groupid_1000 "libresolv.so.2(GLIBC_2.2.5)(64bit)" Nothing
+ addProvide groupid_1000 "libresolv.so.2(GLIBC_2.9)(64bit)" Nothing
+ addProvide groupid_1000 "rtld(GNU_HASH)" Nothing
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "kernel" (Just "kernel < 2.6.32") groupid_1000
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "binutils" (Just "binutils < 2.19.51.0.10") groupid_1000
+ void $ insertGroupKeyValue (TextKey "rpm-conflict") "prelink" (Just "prelink < 0.4.2") groupid_1000
+ void $ insertGroupKeyValue (TextKey "rpm-obsolete") "glibc-profile" (Just "glibc-profile < 2.4") groupid_1000
+ void $ insertGroupKeyValue (TextKey "rpm-obsolete") "nss_db" (Just "nss_db") groupid_1000
+ addReq groupid_1000 "config(glibc) = 2.17-78.el7"
+ addReq groupid_1000 "ld-linux-x86-64.so.2()(64bit)"
+ addReq groupid_1000 "ld-linux-x86-64.so.2(GLIBC_2.2.5)(64bit)"
+ addReq groupid_1000 "ld-linux-x86-64.so.2(GLIBC_2.3)(64bit)"
+ addReq groupid_1000 "libCNS.so()(64bit)"
+ addReq groupid_1000 "libGB.so()(64bit)"
+ addReq groupid_1000 "libISOIR165.so()(64bit)"
+ addReq groupid_1000 "libJIS.so()(64bit)"
+ addReq groupid_1000 "libJISX0213.so()(64bit)"
+ addReq groupid_1000 "libKSC.so()(64bit)"
+ addReq groupid_1000 "libc.so.6()(64bit)"
+ addReq groupid_1000 "libc.so.6(GLIBC_2.14)(64bit)"
+ addReq groupid_1000 "libc.so.6(GLIBC_2.2.5)(64bit)"
+ addReq groupid_1000 "libc.so.6(GLIBC_2.3)(64bit)"
+ addReq groupid_1000 "libc.so.6(GLIBC_2.3.2)(64bit)"
+ addReq groupid_1000 "libc.so.6(GLIBC_2.3.3)(64bit)"
+ addReq groupid_1000 "libc.so.6(GLIBC_2.4)(64bit)"
+ addReq groupid_1000 "libdl.so.2()(64bit)"
+ addReq groupid_1000 "libdl.so.2(GLIBC_2.2.5)(64bit)"
+ addReq groupid_1000 "libnsl.so.1()(64bit)"
+ addReq groupid_1000 "libnsl.so.1(GLIBC_2.2.5)(64bit)"
+ addReq groupid_1000 "libnss_files.so.2()(64bit)"
+ addReq groupid_1000 "libpthread.so.0()(64bit)"
+ addReq groupid_1000 "libpthread.so.0(GLIBC_2.2.5)(64bit)"
+ addReq groupid_1000 "libresolv.so.2()(64bit)"
+ addReq groupid_1000 "libresolv.so.2(GLIBC_2.2.5)(64bit)"
+ addReq groupid_1000 "libresolv.so.2(GLIBC_2.9)(64bit)"
+ addReq groupid_1000 "glibc-common = 2.17-78.el7"
+ addReq groupid_1000 "libfreebl3.so()(64bit)"
+ addReq groupid_1000 "libfreebl3.so(NSSRAWHASH_3.12.3)(64bit)"
+
+ withGlibcUpgrade :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (NoLoggingT (ResourceT (ExceptT e m))) a -> m (Either e a)
+ withGlibcUpgrade action = (runExceptT . withDb) (addGlibcUpgrade >> action)
diff --git a/importer/tests/BDCS/DepsolveSpec.hs b/importer/tests/BDCS/DepsolveSpec.hs
new file mode 100644
index 0000000..3f18cd4
--- /dev/null
+++ b/importer/tests/BDCS/DepsolveSpec.hs
@@ -0,0 +1,189 @@
+-- Copyright (C) 2017 Red Hat, Inc.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Lesser General Public
+-- License as published by the Free Software Foundation; either
+-- version 2.1 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+-- Lesser General Public License for more details.
+--
+-- You should have received a copy of the GNU Lesser General Public
+-- License along with this library; if not, see .
+
+module BDCS.DepsolveSpec(spec)
+ where
+
+import Control.Monad.Except(runExceptT)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Test.Hspec
+
+import BDCS.Depsolve
+
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+
+spec :: Spec
+spec = do
+ describe "BDCS.Depsolve.formulaToCNF tests" $ do
+ it "atom" $
+ formulaToCNF (Atom '1') `shouldBe` [[CNFAtom (CNFOriginal '1')]]
+
+ it "not" $
+ formulaToCNF (Not '1') `shouldBe` [[CNFNot (CNFOriginal '1')]]
+
+ it "and" $
+ formulaToCNF (And [Atom '1', Atom '2', Atom '3', Atom '4']) `shouldBe` [[CNFAtom (CNFOriginal '1')],
+ [CNFAtom (CNFOriginal '2')],
+ [CNFAtom (CNFOriginal '3')],
+ [CNFAtom (CNFOriginal '4')]]
+
+ it "Or 0 items" $
+ formulaToCNF (Or [] :: Formula ()) `shouldBe` ([[]] :: CNFFormula ())
+
+ it "Or 1 item" $
+ formulaToCNF (Or [Atom '1']) `shouldBe` [[CNFAtom (CNFOriginal '1')]]
+
+ -- See the comment in formulaToCNF for more detail. In short, for 1 OR 2 OR 3:
+ -- start with (1) OR (2 OR 3) ==> (sub 0 -> 1) AND (NOT(sub 0) -> (2 OR 3))
+ -- the left half becomes (NOT(sub0) OR 1), which is the first part of the result
+ -- the right half becomes (sub0 OR (2 OR 3))
+ -- recurse on (2 OR 3), adding sub0 to the front of each result
+
+ it "Or 2 items" $
+ formulaToCNF (Or [Atom '1', Atom '2']) `shouldBe` [[CNFNot (CNFSubstitute 0),
+ CNFAtom (CNFOriginal '1')],
+ [CNFAtom (CNFSubstitute 0),
+ CNFAtom (CNFOriginal '2')]]
+ it "Or 3 items" $
+ formulaToCNF (Or [Atom '1', Atom '2', Atom '3']) `shouldBe` [[CNFNot (CNFSubstitute 0),
+ CNFAtom (CNFOriginal '1')],
+ [CNFAtom (CNFSubstitute 0),
+ CNFNot (CNFSubstitute 1),
+ CNFAtom (CNFOriginal '2')],
+ [CNFAtom (CNFSubstitute 0),
+ CNFAtom (CNFSubstitute 1),
+ CNFAtom (CNFOriginal '3')]]
+
+ describe "BDCS.Depsolve.pureLiteralEliminate tests" $ do
+ it "pureLiteralEliminate, empty list" $
+ pureLiteralEliminate Set.empty Map.empty ([] :: CNFFormula Char) `shouldBe` Map.empty
+
+ it "already assigned, matches" $ do
+ let assignments = Map.singleton (CNFOriginal '1') True
+ let formula = [[CNFAtom (CNFOriginal '1')]]
+ let solution = assignments
+ pureLiteralEliminate Set.empty assignments formula `shouldBe` solution
+
+ it "already assigned, does not match" $ do
+ let assignments = Map.singleton (CNFOriginal '1') True
+ let formula = [[CNFNot (CNFOriginal '1')]]
+ let solution = Map.empty
+ pureLiteralEliminate Set.empty assignments formula `shouldBe` solution
+
+ it "pureLiteralEliminate, pure, appears once" $ do
+ let assignments = Map.empty
+ let formula = [[CNFAtom (CNFOriginal '1')]]
+ let solution = Map.singleton (CNFOriginal '1') True
+ pureLiteralEliminate Set.empty assignments formula `shouldBe` solution
+
+ it "pure, appears once negative" $ do
+ let assignments = Map.empty
+ let formula = [[CNFNot (CNFOriginal '1')]]
+ let solution = Map.singleton (CNFOriginal '1') False
+ pureLiteralEliminate Set.empty assignments formula `shouldBe` solution
+
+ it "pure, appears multiple times" $ do
+ let assignments = Map.empty
+ let formula = [[CNFAtom (CNFOriginal '1')],
+ [CNFAtom (CNFOriginal '1'),
+ CNFAtom (CNFOriginal '2')],
+ [CNFNot (CNFOriginal '2')]]
+ let solution = Map.singleton (CNFOriginal '1') True
+ pureLiteralEliminate Set.empty assignments formula `shouldBe` solution
+
+ it "pure, appears multiple times negative" $ do
+ let assignments = Map.empty
+ let formula = [[CNFNot (CNFOriginal '1')],
+ [CNFNot (CNFOriginal '1'),
+ CNFAtom (CNFOriginal '2')],
+ [CNFNot (CNFOriginal '2')]]
+ let solution = Map.singleton (CNFOriginal '1') False
+ pureLiteralEliminate Set.empty assignments formula `shouldBe` solution
+
+ it "unpure" $ do
+ let assignments = Map.empty
+ let formula = [[CNFAtom (CNFOriginal '1')],
+ [CNFNot (CNFOriginal '1')]]
+ let solution = Map.empty
+ pureLiteralEliminate Set.empty assignments formula `shouldBe` solution
+
+ it "unpure 2" $ do
+ let assignments = Map.empty
+ let formula = [[CNFAtom (CNFOriginal '1'),
+ CNFNot (CNFOriginal '1')],
+ [CNFNot (CNFOriginal '1')]]
+ let solution = Map.empty
+ pureLiteralEliminate Set.empty assignments formula `shouldBe` solution
+
+ describe "BDCS.Depsolve.unitPropagate tests" $ do
+ it "empty list" $
+ runExceptT (unitPropagate Map.empty ([] :: CNFFormula Char)) >>=
+ (`shouldBe` Right (Map.empty, []))
+
+ it "one thing" $
+ runExceptT (unitPropagate Map.empty [[CNFAtom (CNFOriginal '1')]]) >>=
+ (`shouldBe` Right (Map.singleton (CNFOriginal '1') True, []))
+
+ it "unit then elimate clause" $ do
+ let assignments = Map.empty
+ let formula = [[CNFAtom (CNFOriginal '1')],
+ [CNFAtom (CNFOriginal '1'),
+ CNFNot (CNFOriginal '2')]]
+ let assignments' = Map.singleton (CNFOriginal '1') True
+ let formula' = []
+ runExceptT (unitPropagate assignments formula) >>= (`shouldBe` Right (assignments', formula'))
+
+ it "unit then elimate impossible" $ do
+ let assignments = Map.empty
+ let formula = [[CNFAtom (CNFOriginal '1')],
+ [CNFAtom (CNFOriginal '2'),
+ CNFNot (CNFOriginal '1')]]
+ let assignments' = Map.singleton (CNFOriginal '1') True
+ let formula' = [[CNFAtom (CNFOriginal '2')]]
+ runExceptT (unitPropagate assignments formula) >>= (`shouldBe` Right (assignments', formula'))
+
+ it "unit then repeated" $ do
+ let assignments = Map.empty
+ let formula = [[CNFAtom (CNFOriginal '1')],
+ [CNFAtom (CNFOriginal '1')]]
+ let assignments' = Map.singleton (CNFOriginal '1') True
+ let formula' = []
+ runExceptT (unitPropagate assignments formula) >>= (`shouldBe` Right (assignments', formula'))
+
+ it "unit then unsolvable unit" $ do
+ let assignments = Map.empty
+ let formula = [[CNFAtom (CNFOriginal '1')],
+ [CNFNot (CNFOriginal '1')]]
+ runExceptT (unitPropagate assignments formula) >>= (`shouldBe` Left "Unable to solve expression")
+
+ it "units then unsolvable clause" $ do
+ let assignments = Map.empty
+ let formula = [[CNFAtom (CNFOriginal '1')],
+ [CNFAtom (CNFOriginal '2')],
+ [CNFNot (CNFOriginal '1'),
+ CNFNot (CNFOriginal '2')]]
+ runExceptT (unitPropagate assignments formula) >>= (`shouldBe` Left "Unable to solve expression")
+
+ describe "BDCS.Depsolve.solveCNF tests" $ do
+ it "empty formula" $ do
+ let formula = [] :: (CNFFormula Char)
+ let solution = [] :: [DepAssignment Char]
+ runExceptT (solveCNF formula) >>= (`shouldBe` Right solution)
+
+ it "singleton" $ do
+ let formula = [[CNFAtom (CNFOriginal '1')]]
+ let solution = [('1', True)]
+ runExceptT (solveCNF formula) >>= (`shouldBe` Right solution)
diff --git a/importer/tests/BDCS/GroupsSpec.hs b/importer/tests/BDCS/GroupsSpec.hs
index 84a4dcf..374c930 100644
--- a/importer/tests/BDCS/GroupsSpec.hs
+++ b/importer/tests/BDCS/GroupsSpec.hs
@@ -13,15 +13,22 @@
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, see .
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module BDCS.GroupsSpec(spec)
where
+import BDCS.DB(Groups(..))
import BDCS.Groups(nevraToGroupId)
-import BDCS.DB
+import BDCS.GroupKeyValue(insertGroupKeyValue)
+import BDCS.KeyType(KeyType(..))
-import Database.Persist.Sql(toSqlKey)
+import Control.Monad(void)
+import Control.Monad.IO.Class(MonadIO)
+import Control.Monad.Logger(NoLoggingT)
+import Control.Monad.Trans.Resource(MonadBaseControl, ResourceT)
+import Database.Persist.Sql(SqlPersistT, insertKey, toSqlKey)
import Test.Hspec
import Utils(withDb)
@@ -29,30 +36,53 @@ import Utils(withDb)
spec :: Spec
spec = describe "BDCS.Groups Tests" $ do
it "nevraToGroupId, has epoch" $
- -- gid <- withDb $ nevraToGroupId ("hasEpoch", Just "7", "1.0", "1.el7", "x86_64")
+ -- gid <- withNevras $ nevraToGroupId ("hasEpoch", Just "7", "1.0", "1.el7", "x86_64")
-- gid `shouldBe` Just (toSqlKey 1)
- withDb (nevraToGroupId ("hasEpoch", Just "7", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Just (toSqlKey 1))
+ withNevras (nevraToGroupId ("hasEpoch", Just "7", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Just (toSqlKey 1))
it "nevraToGroupId, no epoch" $
- withDb (nevraToGroupId ("noEpoch", Nothing, "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Just (toSqlKey 2))
+ withNevras (nevraToGroupId ("noEpoch", Nothing, "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Just (toSqlKey 2))
it "nevraToGroupId, has epoch, not specified" $
- withDb (nevraToGroupId ("hasEpoch", Nothing, "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing)
+ withNevras (nevraToGroupId ("hasEpoch", Nothing, "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing)
it "nevraToGroupId, no epoch, is specified" $
- withDb (nevraToGroupId ("noEpoch", Just "7", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing)
+ withNevras (nevraToGroupId ("noEpoch", Just "7", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing)
it "nevraToGroupId, has wrong epoch" $
- withDb (nevraToGroupId ("hasEpoch", Just "8", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing)
+ withNevras (nevraToGroupId ("hasEpoch", Just "8", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing)
it "nevraToGroupId, wrong name" $
- withDb (nevraToGroupId ("missingEpoch", Just "7", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing)
+ withNevras (nevraToGroupId ("missingEpoch", Just "7", "1.0", "1.el7", "x86_64")) >>= (`shouldBe` Nothing)
it "nevraToGroupId, wrong version" $
- withDb (nevraToGroupId ("hasEpoch", Just "7", "1.1", "1.el7", "x86_64")) >>= (`shouldBe` Nothing)
+ withNevras (nevraToGroupId ("hasEpoch", Just "7", "1.1", "1.el7", "x86_64")) >>= (`shouldBe` Nothing)
it "nevraToGroupId, wrong release" $
- withDb (nevraToGroupId ("hasEpoch", Just "7", "1.0", "2.el7", "x86_64")) >>= (`shouldBe` Nothing)
+ withNevras (nevraToGroupId ("hasEpoch", Just "7", "1.0", "2.el7", "x86_64")) >>= (`shouldBe` Nothing)
it "nevraToGroupId, wrong arch" $
- withDb (nevraToGroupId ("hasEpoch", Just "7", "1.0", "1.el7", "i686")) >>= (`shouldBe` Nothing)
+ withNevras (nevraToGroupId ("hasEpoch", Just "7", "1.0", "1.el7", "i686")) >>= (`shouldBe` Nothing)
+
+ where
+ addNevras :: MonadIO m => SqlPersistT m ()
+ addNevras = do
+ -- hasEpoch-7:1.0-1.el7.x86_64
+ let gid_1 = toSqlKey 1
+ insertKey gid_1 $ Groups "hasEpoch" "rpm"
+ void $ insertGroupKeyValue (TextKey "name") "hasEpoch" Nothing gid_1
+ void $ insertGroupKeyValue (TextKey "epoch") "7" Nothing gid_1
+ void $ insertGroupKeyValue (TextKey "version") "1.0" Nothing gid_1
+ void $ insertGroupKeyValue (TextKey "release") "1.el7" Nothing gid_1
+ void $ insertGroupKeyValue (TextKey "arch") "x86_64" Nothing gid_1
+
+ -- noEpoch-1.0-1.el7.x86_64
+ let gid_2 = toSqlKey 2
+ insertKey gid_2 $ Groups "noEpoch" "rpm"
+ void $ insertGroupKeyValue (TextKey "name") "noEpoch" Nothing gid_2
+ void $ insertGroupKeyValue (TextKey "version") "1.0" Nothing gid_2
+ void $ insertGroupKeyValue (TextKey "release") "1.el7" Nothing gid_2
+ void $ insertGroupKeyValue (TextKey "arch") "x86_64" Nothing gid_2
+
+ withNevras :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (NoLoggingT (ResourceT m)) a -> m a
+ withNevras action = withDb (addNevras >> action)
diff --git a/importer/tests/Utils.hs b/importer/tests/Utils.hs
index af3f8fa..19d65a5 100644
--- a/importer/tests/Utils.hs
+++ b/importer/tests/Utils.hs
@@ -24,12 +24,10 @@ import Control.Monad(void)
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Trans.Resource(MonadBaseControl, ResourceT)
import Control.Monad.Logger(NoLoggingT)
-import Database.Persist.Sql(Key, SqlBackend, SqlPersistT, ToBackendKey, insertKey, runMigrationSilent, toSqlKey)
+import Database.Persist.Sql(Key, SqlBackend, SqlPersistT, ToBackendKey, runMigrationSilent, toSqlKey)
import Database.Persist.Sqlite(runSqlite)
import BDCS.DB
-import BDCS.GroupKeyValue
-import BDCS.KeyType
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
@@ -41,23 +39,4 @@ withDb :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (NoLoggingT (Resourc
withDb action = runSqlite ":memory:" (initDb >> action)
where
initDb :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT m ()
- initDb = do
- void $ runMigrationSilent migrateAll
-
- -- For nevraToGroupId:
- -- hasEpoch-7:1.0-1.el7.x86_64
- let gid_1 = toSqlKey 1
- insertKey gid_1 $ Groups "hasEpoch" "rpm"
- void $ insertGroupKeyValue (TextKey "name") "hasEpoch" Nothing gid_1
- void $ insertGroupKeyValue (TextKey "epoch") "7" Nothing gid_1
- void $ insertGroupKeyValue (TextKey "version") "1.0" Nothing gid_1
- void $ insertGroupKeyValue (TextKey "release") "1.el7" Nothing gid_1
- void $ insertGroupKeyValue (TextKey "arch") "x86_64" Nothing gid_1
-
- -- noEpoch-1.0-1.el7.x86_64
- let gid_2 = toSqlKey 2
- insertKey gid_2 $ Groups "noEpoch" "rpm"
- void $ insertGroupKeyValue (TextKey "name") "noEpoch" Nothing gid_2
- void $ insertGroupKeyValue (TextKey "version") "1.0" Nothing gid_2
- void $ insertGroupKeyValue (TextKey "release") "1.el7" Nothing gid_2
- void $ insertGroupKeyValue (TextKey "arch") "x86_64" Nothing gid_2
+ initDb = void $ runMigrationSilent migrateAll
diff --git a/importer/tools/depsolve.hs b/importer/tools/depsolve.hs
new file mode 100644
index 0000000..f316a70
--- /dev/null
+++ b/importer/tools/depsolve.hs
@@ -0,0 +1,55 @@
+-- Copyright (C) 2017 Red Hat, Inc.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Lesser General Public
+-- License as published by the Free Software Foundation; either
+-- version 2.1 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+-- Lesser General Public License for more details.
+--
+-- You should have received a copy of the GNU Lesser General Public
+-- License along with this library; if not, see .
+
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.Monad(when)
+import Control.Monad.Except(runExceptT)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import Database.Persist.Sqlite(runSqlite)
+import System.Environment(getArgs)
+import System.Exit(exitFailure)
+
+import BDCS.Depclose(depclose)
+import BDCS.Depsolve(formulaToCNF, solveCNF)
+import BDCS.Groups(groupIdToNevra)
+import Utils.Monad(mapMaybeM)
+
+usage :: IO ()
+usage = do
+ putStrLn "Usage: depsolve metadata.db NEVRA [NEVRA ...]"
+ exitFailure
+
+main :: IO ()
+main = do
+ argv <- getArgs
+
+ when (length argv < 2) usage
+
+ let db = T.pack $ head argv
+ let things = map T.pack $ drop 1 argv
+ result <- runExceptT $ runSqlite db $ do
+ formula <- depclose ["x86_64"] things
+ solution <- solveCNF (formulaToCNF formula)
+
+ -- solveCNF returns a list of (groupId, bool) assignments. Discard the False ones,
+ -- and convert the True ids to nevras
+ mapMaybeM groupIdToNevra $ map fst $ filter snd solution
+
+ case result of
+ Left e -> print ("error: " ++ e) >> exitFailure
+ -- Print the NEVRAs one per line
+ Right assignments -> mapM_ TIO.putStrLn assignments