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