From 3db203b04ef25a48e4e3046df4362db3c338d778 Mon Sep 17 00:00:00 2001 From: David Shea Date: Mon, 21 Aug 2017 10:26:18 -0400 Subject: [PATCH 01/17] Add a couple of util functions for handling errors. These can make it easier to use MonadError in some situations. --- importer/Utils/Error.hs | 15 +++++++++++++++ importer/bdcs.cabal | 1 + 2 files changed, 16 insertions(+) create mode 100644 importer/Utils/Error.hs 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/bdcs.cabal b/importer/bdcs.cabal index a1eab9c..9c42c04 100644 --- a/importer/bdcs.cabal +++ b/importer/bdcs.cabal @@ -90,6 +90,7 @@ library Import.URI, Utils.Conduit, Utils.Either, + Utils.Error, Utils.Mode, Utils.Monad From bc3f6975674326c3c648fc1748d6db29eecca989 Mon Sep 17 00:00:00 2001 From: David Shea Date: Mon, 21 Aug 2017 10:45:04 -0400 Subject: [PATCH 02/17] Add a non-conduit version of getGroupId Add a function to convert NEVRA strings to group IDs without involving Conduit, and implement getGroupIdC as a conduit mapM on to of that. --- importer/BDCS/Groups.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/importer/BDCS/Groups.hs b/importer/BDCS/Groups.hs index 4feaaa9..f93ce1c 100644 --- a/importer/BDCS/Groups.hs +++ b/importer/BDCS/Groups.hs @@ -19,6 +19,7 @@ module BDCS.Groups(findGroupRequirements, findRequires, + getGroupId, getGroupIdC, groups, groupsC, @@ -29,10 +30,9 @@ module BDCS.Groups(findGroupRequirements, 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 +43,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 +62,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 From 5432f881ca990c418c5b38bf8f9437c96c4ad6f6 Mon Sep 17 00:00:00 2001 From: David Shea Date: Tue, 30 May 2017 16:25:56 -0400 Subject: [PATCH 03/17] Replace depclose with the algorithm from bdcs-api-rs. This includes several new functions in BDCS for fetching various forms of group data from the mddb. --- importer/BDCS/Depclose.hs | 227 +++++++++++++++++++++++++++++++++ importer/BDCS/Files.hs | 12 +- importer/BDCS/GroupKeyValue.hs | 16 ++- importer/BDCS/Groups.hs | 34 +++-- importer/Utils/Monad.hs | 20 ++- importer/bdcs.cabal | 1 + 6 files changed, 295 insertions(+), 15 deletions(-) create mode 100644 importer/BDCS/Depclose.hs diff --git a/importer/BDCS/Depclose.hs b/importer/BDCS/Depclose.hs new file mode 100644 index 0000000..1d2cc96 --- /dev/null +++ b/importer/BDCS/Depclose.hs @@ -0,0 +1,227 @@ +-- 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) + +-- 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 (Key Groups) + +-- 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 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) + + -- 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 ([], parents') requirementIds + + -- add an atom for the groupId itself, And it all together + return (And (Atom groupId : obsConflictFormulas ++ requirementFormulas), Set.insert groupId 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) idlist then return Nothing + else 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/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 f93ce1c..c3bb0bb 100644 --- a/importer/BDCS/Groups.hs +++ b/importer/BDCS/Groups.hs @@ -21,10 +21,11 @@ module BDCS.Groups(findGroupRequirements, findRequires, getGroupId, getGroupIdC, + getRequirementsForGroup, groups, groupsC, groupIdToNevra, - nameToGroupId, + nameToGroupIds, nevraToGroupId) where @@ -97,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/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 9c42c04..0f99b59 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, From 9bb1cb24aedfb18d9ef5acec7871e2eccbab1dc3 Mon Sep 17 00:00:00 2001 From: David Shea Date: Fri, 4 Aug 2017 15:19:30 -0400 Subject: [PATCH 04/17] Move test data to the tests that actually use it Pare withDb down to just the creation of the database schema, and move all of the test data used by nevraToGroupId into the function that tests nevraToGroupId. --- importer/tests/BDCS/GroupsSpec.hs | 54 ++++++++++++++++++++++++------- importer/tests/Utils.hs | 25 ++------------ 2 files changed, 44 insertions(+), 35 deletions(-) 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 From 541fc37f8aba29e1042153ec850eadebe6ac7ec9 Mon Sep 17 00:00:00 2001 From: David Shea Date: Wed, 9 Aug 2017 12:15:24 -0400 Subject: [PATCH 05/17] Add tests for depclose --- importer/bdcs.cabal | 2 + importer/tests/BDCS/DepcloseSpec.hs | 673 ++++++++++++++++++++++++++++ 2 files changed, 675 insertions(+) create mode 100644 importer/tests/BDCS/DepcloseSpec.hs diff --git a/importer/bdcs.cabal b/importer/bdcs.cabal index 0f99b59..94370ed 100644 --- a/importer/bdcs.cabal +++ b/importer/bdcs.cabal @@ -281,9 +281,11 @@ Test-Suite test-bdcs base >= 4.8 && < 5.0, codec-rpm >= 0.1.1 && < 0.2, monad-logger, + mtl >= 2.2.1, persistent, persistent-sqlite, resourcet, + text, bdcs default-language: Haskell2010 diff --git a/importer/tests/BDCS/DepcloseSpec.hs b/importer/tests/BDCS/DepcloseSpec.hs new file mode 100644 index 0000000..a442b08 --- /dev/null +++ b/importer/tests/BDCS/DepcloseSpec.hs @@ -0,0 +1,673 @@ +-- 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) + + 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 + addRealDeps :: MonadIO m => SqlPersistT m () + addRealDeps = do + 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.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 + + 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) From 40f9d79ca1f2e2bbf57bb25309eddb807572781b Mon Sep 17 00:00:00 2001 From: David Shea Date: Fri, 25 Aug 2017 15:04:03 -0400 Subject: [PATCH 06/17] Add provides data to the parents set. This will prevent repeated depclosing of a requirement in the case that more than group satisfies the requirement. --- importer/BDCS/Depclose.hs | 31 +++-- importer/tests/BDCS/DepcloseSpec.hs | 168 ++++++++++++++++++++++++++++ 2 files changed, 192 insertions(+), 7 deletions(-) diff --git a/importer/BDCS/Depclose.hs b/importer/BDCS/Depclose.hs index 1d2cc96..8a0ae4f 100644 --- a/importer/BDCS/Depclose.hs +++ b/importer/BDCS/Depclose.hs @@ -45,6 +45,10 @@ 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: -- @@ -53,7 +57,7 @@ import Utils.Monad(concatMapM, foldMaybeM, mapMaybeM) -- C Requires A -- -- When depclose gets to C Requires A it can stop, since that has already been resolved. -type DepParents = Set.Set (Key Groups) +type DepParents = Set.Set ParentItem -- type of the depclose results type DepFormula = Formula (Key Groups) @@ -92,7 +96,7 @@ depclose arches nevras = do 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 parents + let parents' = Set.insert (GroupId groupId) parents -- grab the key/value based data conflicts <- getKeyValuesForGroup groupId (TextKey "rpm-conflict") >>= mapM kvToDep @@ -108,6 +112,17 @@ depclose arches nevras = do 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. @@ -121,16 +136,18 @@ depclose arches nevras = do -- 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 ([], parents') requirementIds + (requirementFormulas, requirementParents) <- foldMaybeM resolveOneReq ([], providesSet) requirementIds -- add an atom for the groupId itself, And it all together - return (And (Atom groupId : obsConflictFormulas ++ requirementFormulas), Set.insert groupId requirementParents) + 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) idlist then return Nothing - else do + -- 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 diff --git a/importer/tests/BDCS/DepcloseSpec.hs b/importer/tests/BDCS/DepcloseSpec.hs index a442b08..947e313 100644 --- a/importer/tests/BDCS/DepcloseSpec.hs +++ b/importer/tests/BDCS/DepcloseSpec.hs @@ -169,6 +169,25 @@ spec = describe "BDCS.Depclose Tests" $ do 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"] @@ -272,8 +291,13 @@ spec = describe "BDCS.Depclose Tests" $ do -- 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 @@ -329,6 +353,7 @@ spec = describe "BDCS.Depclose Tests" $ do 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 @@ -632,6 +657,59 @@ spec = describe "BDCS.Depclose Tests" $ do 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") @@ -671,3 +749,93 @@ spec = describe "BDCS.Depclose Tests" $ do 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) From ff137a70f7025446fdae86ca798e7390afdf0ba1 Mon Sep 17 00:00:00 2001 From: David Shea Date: Mon, 28 Aug 2017 14:38:30 -0400 Subject: [PATCH 07/17] Require codec-rpm >= 0.1.3 This version is needed in order to use DepRequirement as Ord. --- importer/bdcs.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/importer/bdcs.cabal b/importer/bdcs.cabal index 94370ed..8c7bbf0 100644 --- a/importer/bdcs.cabal +++ b/importer/bdcs.cabal @@ -97,7 +97,7 @@ library 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, @@ -279,7 +279,7 @@ Test-Suite test-bdcs build-depends: hspec, base >= 4.8 && < 5.0, - codec-rpm >= 0.1.1 && < 0.2, + codec-rpm >= 0.1.3 && < 0.2, monad-logger, mtl >= 2.2.1, persistent, From d9f94fa9ce88654ccfd88f96a1518537e4028826 Mon Sep 17 00:00:00 2001 From: David Shea Date: Thu, 10 Aug 2017 15:04:52 -0400 Subject: [PATCH 08/17] Compile the tests with -Wall --- importer/bdcs.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/importer/bdcs.cabal b/importer/bdcs.cabal index 8c7bbf0..1a6a1b8 100644 --- a/importer/bdcs.cabal +++ b/importer/bdcs.cabal @@ -288,4 +288,6 @@ Test-Suite test-bdcs text, bdcs + ghc-options: -Wall + default-language: Haskell2010 From e28473cc304acc052d8f3b30f32612359274ad74 Mon Sep 17 00:00:00 2001 From: David Shea Date: Thu, 10 Aug 2017 11:29:45 -0400 Subject: [PATCH 09/17] Make it possible to test unexported symbols. Change test-bdcs so that, instead of linking to the bdcs library, it recompiles the modules it needs with -DTEST. Rearrange depsolve so that private symbols are exported when compiled with -DTEST. The disadvantage of this is that the tests now recompile every module they use, but this allows for otherwise private symbols to be accessible to hspec without breaking the optimizability of the code or exporting extra symbols in the release version of the library. --- importer/BDCS/Depsolve.hs | 169 ++++++++++++++++++++------------------ importer/bdcs.cabal | 18 +++- 2 files changed, 104 insertions(+), 83 deletions(-) diff --git a/importer/BDCS/Depsolve.hs b/importer/BDCS/Depsolve.hs index 8107d9d..0110eda 100644 --- a/importer/BDCS/Depsolve.hs +++ b/importer/BDCS/Depsolve.hs @@ -13,6 +13,7 @@ -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, see . +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} @@ -22,7 +23,13 @@ module BDCS.Depsolve(Formula(..), CNFAtom(..), CNFFormula, formulaToCnf, - solveCNF) + solveCNF +-- export private symbols for testing +#ifdef TEST + , pureLiteralEliminate + , unitPropagate +#endif + ) where import Control.Applicative((<|>)) @@ -206,77 +213,6 @@ solveCNF formula = evalState (solveCNF' formula) Map.empty 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) @@ -286,16 +222,87 @@ solveCNF formula = evalState (solveCNF' formula) Map.empty -- 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 - - atomToBool :: CNFAtom a -> Bool - atomToBool (CNFAtom _) = True - atomToBool (CNFNot _) = False - -- unwrap original values, discard substitutes literalToOriginal :: CNFLiteral a -> Maybe a literalToOriginal (CNFOriginal x) = Just x 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) -> 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 + +-- 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.cabal b/importer/bdcs.cabal index 1a6a1b8..d398a34 100644 --- a/importer/bdcs.cabal +++ b/importer/bdcs.cabal @@ -274,20 +274,34 @@ executable bdcs-tmpfiles 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, + 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, text, - bdcs + time, + unix ghc-options: -Wall + cpp-options: -DTEST default-language: Haskell2010 From 859b00369911a410f67651726e5f727b86fce083 Mon Sep 17 00:00:00 2001 From: David Shea Date: Wed, 9 Aug 2017 15:36:03 -0400 Subject: [PATCH 10/17] Always capitalize "CNF" Rename a couple depsolve functions for consistency. --- importer/BDCS/Depsolve.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/importer/BDCS/Depsolve.hs b/importer/BDCS/Depsolve.hs index 0110eda..f7b5a5e 100644 --- a/importer/BDCS/Depsolve.hs +++ b/importer/BDCS/Depsolve.hs @@ -22,7 +22,7 @@ module BDCS.Depsolve(Formula(..), CNFLiteral(..), CNFAtom(..), CNFFormula, - formulaToCnf, + formulaToCNF, solveCNF -- export private symbols for testing #ifdef TEST @@ -66,16 +66,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. @@ -93,7 +93,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. @@ -127,21 +127,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 From c3ab41247800332ea5a30d91a023b1e1d305611d Mon Sep 17 00:00:00 2001 From: David Shea Date: Thu, 10 Aug 2017 14:54:08 -0400 Subject: [PATCH 11/17] Run solveCNF in MonadError and remove the Maybe. Use MonadError instead of Nothing to indicate unsolvable expressions, which makes failure cases more clear. As a happy side-effect, this also makes it clear that a couple of those Nothing returns were bugs, so fix those. --- importer/BDCS/Depsolve.hs | 84 +++++++++++++++++++-------------------- 1 file changed, 41 insertions(+), 43 deletions(-) diff --git a/importer/BDCS/Depsolve.hs b/importer/BDCS/Depsolve.hs index f7b5a5e..457246e 100644 --- a/importer/BDCS/Depsolve.hs +++ b/importer/BDCS/Depsolve.hs @@ -14,6 +14,7 @@ -- License along with this library; if not, see . {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} @@ -32,8 +33,8 @@ module BDCS.Depsolve(Formula(..), ) where -import Control.Applicative((<|>)) -import Control.Monad.State(State, evalState, get, state) +import Control.Monad.Except(MonadError, catchError, throwError) +import Control.Monad.State(State, StateT, evalState, evalStateT, get, put, state) import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map import Data.Maybe(isNothing, mapMaybe) @@ -154,7 +155,7 @@ 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) +type AssignmentStateT a m = StateT (AssignmentMap a) m -- if the formula is unsolvable, returns Nothing, other Just the list of assignments @@ -173,47 +174,48 @@ 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 = evalStateT (solveCNF' formula) Map.empty where -- helper function that takes an assignment map and a formula - solveCNF' :: Ord a => CNFFormula a -> AssignmentState a (Maybe [DepAssignment a]) + solveCNF' :: (MonadError String m, Ord a) => CNFFormula a -> AssignmentStateT a m [DepAssignment a] solveCNF' f = -- simplify the formula. simplify will recurse as necessary simplify f >>= \case - -- if things failed during simplify, the formula is unsatisfiable - Nothing -> return Nothing -- All clauses have been satisfied, we're done. Return the assignments - Just [] -> Just <$> assignmentsToList + [] -> assignmentsToList -- otherwise, try an assignment, or if that fails try the opposite assignment - Just formula' -> guessAndCheck formula' + formula' -> guessAndCheck formula' - guessAndCheck :: Ord a => CNFFormula a -> AssignmentState a (Maybe [DepAssignment a]) + guessAndCheck :: (MonadError String m, Ord a) => CNFFormula a -> AssignmentStateT a m [DepAssignment a] guessAndCheck f@((firstLiteral:_):_) = do assignments <- get - return $ try assignments True <|> try assignments False + try assignments True `catchError` const (try assignments 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 + evalStateT (solveCNF' f) tryAssignments - simplify :: Ord a => CNFFormula a -> AssignmentState a (Maybe (CNFFormula a)) + -- No variables left, so we're done + guessAndCheck _ = return [] + + simplify :: (MonadError String m, Ord a) => CNFFormula a -> AssignmentStateT a m (CNFFormula a) simplify 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 + upFormula <- unitPropagate f + + -- repeat until the formula doesn't change + if f == upFormula then + return upFormula + else + simplify upFormula - assignmentsToList :: Ord a => AssignmentState a [DepAssignment a] + assignmentsToList :: (Monad m, Ord a) => AssignmentStateT a m [DepAssignment a] assignmentsToList = do -- start by getting everything out of the map as a list of (CNFLiteral, Bool) assignments <- get @@ -230,7 +232,7 @@ solveCNF formula = evalState (solveCNF' formula) Map.empty -- 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 () +pureLiteralEliminate :: (Monad m, Ord a) => Set (CNFLiteral a) -> CNFFormula a -> AssignmentStateT a m () -- end of recursion pureLiteralEliminate _ [] = return () @@ -259,28 +261,24 @@ pureLiteralEliminate unpure ((x:xs):ys) = do -- 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)) +unitPropagate :: (MonadError String m, Ord a) => CNFFormula a -> AssignmentStateT a m (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) + assignments <- get + 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. + if | isNothing literalLookup -> put $ Map.insert literalX boolX assignments + -- old literal, matches + | Just boolX == literalLookup -> return () + -- old literal, does not match + | otherwise -> throwError "Unable to solve expression" + + unitPropagate 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 @@ -293,10 +291,10 @@ unitPropagate (clause:ys) = do let clauseFiltered = filter (\atom -> Just (not (atomToBool atom)) == Map.lookup (atomToLiteral atom) assignments) clause if | clauseTrue -> unitPropagate ys - | null clauseFiltered -> return Nothing + | null clauseFiltered -> throwError "Unable to solve expression" | otherwise -> (unitPropagate <$> (clauseFiltered:)) ys -unitPropagate _ = return Nothing +unitPropagate [] = return [] -- unwrap an atom atomToLiteral :: CNFAtom a -> CNFLiteral a From 62339bab4b3b8e4c726a321b52f0a5dd0431a6c9 Mon Sep 17 00:00:00 2001 From: David Shea Date: Mon, 28 Aug 2017 14:08:20 -0400 Subject: [PATCH 12/17] Use Map.assocs instead of reimplementing it. --- importer/BDCS/Depsolve.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/importer/BDCS/Depsolve.hs b/importer/BDCS/Depsolve.hs index 457246e..678970f 100644 --- a/importer/BDCS/Depsolve.hs +++ b/importer/BDCS/Depsolve.hs @@ -219,7 +219,7 @@ solveCNF formula = evalStateT (solveCNF' formula) Map.empty 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 literalList = Map.assocs assignments -- map each (literal, bool) to Maybe (orig, bool), mapMaybe will filter out the Nothings return $ mapMaybe (\(literal, value) -> (,value) <$> literalToOriginal literal) literalList From 2581cb847a5dcaa7f3e81f48c37c15f43fe84b6c Mon Sep 17 00:00:00 2001 From: David Shea Date: Mon, 28 Aug 2017 14:31:46 -0400 Subject: [PATCH 13/17] Remove the internal StateT in solveCNF The assignments map is reset by guessAndCheck, so having it stored in a state isn't really useful. Move it to a regular argument. --- importer/BDCS/Depsolve.hs | 117 +++++++++++++++++++------------------- 1 file changed, 57 insertions(+), 60 deletions(-) diff --git a/importer/BDCS/Depsolve.hs b/importer/BDCS/Depsolve.hs index 678970f..448e0fd 100644 --- a/importer/BDCS/Depsolve.hs +++ b/importer/BDCS/Depsolve.hs @@ -17,7 +17,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} module BDCS.Depsolve(Formula(..), CNFLiteral(..), @@ -34,7 +33,7 @@ module BDCS.Depsolve(Formula(..), where import Control.Monad.Except(MonadError, catchError, throwError) -import Control.Monad.State(State, StateT, evalState, evalStateT, get, put, state) +import Control.Monad.State(State, evalState, state) import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map import Data.Maybe(isNothing, mapMaybe) @@ -155,8 +154,6 @@ type DepAssignment a = (a, Bool) -- internal types for the variable=bool assignments type AssignmentMap a = Map (CNFLiteral a) Bool -type AssignmentStateT a m = StateT (AssignmentMap a) m - -- 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: @@ -175,75 +172,76 @@ type AssignmentStateT a m = StateT (AssignmentMap a) m -- -- Repeat until solved. solveCNF :: (MonadError String m, Ord a) => CNFFormula a -> m [DepAssignment a] -solveCNF formula = evalStateT (solveCNF' formula) Map.empty +solveCNF formula = solveCNF' Map.empty formula where -- helper function that takes an assignment map and a formula - solveCNF' :: (MonadError String m, Ord a) => CNFFormula a -> AssignmentStateT a m [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 + simplify assignments f >>= \case -- All clauses have been satisfied, we're done. Return the assignments - [] -> assignmentsToList + (assignments', []) -> return $ assignmentsToList assignments' -- otherwise, try an assignment, or if that fails try the opposite assignment - formula' -> guessAndCheck formula' + (assignments', formula') -> guessAndCheck assignments' formula' - guessAndCheck :: (MonadError String m, Ord a) => CNFFormula a -> AssignmentStateT a m [DepAssignment a] - guessAndCheck f@((firstLiteral:_):_) = do - assignments <- get - try assignments True `catchError` const (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 - evalStateT (solveCNF' f) tryAssignments + 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 [] + guessAndCheck _ [] = return [] - simplify :: (MonadError String m, Ord a) => CNFFormula a -> AssignmentStateT a m (CNFFormula a) - simplify f = do + 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 + let pleAssignments = pureLiteralEliminate Set.empty assignments f - upFormula <- unitPropagate f + (upAssignments, upFormula) <- unitPropagate pleAssignments f -- repeat until the formula doesn't change if f == upFormula then - return upFormula + return (upAssignments, upFormula) else - simplify upFormula + simplify upAssignments upFormula - assignmentsToList :: (Monad m, Ord a) => AssignmentStateT a m [DepAssignment a] - assignmentsToList = do + assignmentsToList :: Ord a => AssignmentMap a -> [DepAssignment a] + assignmentsToList assignments = let -- start by getting everything out of the map as a list of (CNFLiteral, Bool) - assignments <- get - let literalList = Map.assocs assignments - + literalList = Map.assocs assignments + in -- map each (literal, bool) to Maybe (orig, bool), mapMaybe will filter out the Nothings - return $ mapMaybe (\(literal, value) -> (,value) <$> literalToOriginal literal) literalList - - -- unwrap original values, discard substitutes - literalToOriginal :: CNFLiteral a -> Maybe a - literalToOriginal (CNFOriginal x) = Just x - literalToOriginal _ = Nothing + 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 :: (Monad m, Ord a) => Set (CNFLiteral a) -> CNFFormula a -> AssignmentStateT a m () +pureLiteralEliminate :: Ord a => Set (CNFLiteral a) -> AssignmentMap a -> CNFFormula a -> AssignmentMap a -- end of recursion -pureLiteralEliminate _ [] = return () +pureLiteralEliminate _ assignments [] = assignments -- end of a clause, move on to the next one -pureLiteralEliminate unpure ([]:ys) = pureLiteralEliminate unpure ys +pureLiteralEliminate unpure assignments ([]:ys) = pureLiteralEliminate unpure assignments ys -pureLiteralEliminate unpure ((x:xs):ys) = do - unpure' <- state updateAssignments - pureLiteralEliminate unpure' (xs: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 assignments = let + updateAssignments = let literalX = atomToLiteral x in case (x, Map.lookup literalX assignments, Set.member literalX unpure) of @@ -261,40 +259,39 @@ pureLiteralEliminate unpure ((x:xs):ys) = do -- 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) => CNFFormula a -> AssignmentStateT a m (CNFFormula a) +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 ([x]:ys) = do - assignments <- get +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. - if | isNothing literalLookup -> put $ Map.insert literalX boolX assignments - -- old literal, matches - | Just boolX == literalLookup -> return () - -- old literal, does not match - | otherwise -> throwError "Unable to solve expression" + -- 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 ys + 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 (clause:ys) = do - assignments <- get - +unitPropagate assignments (clause:ys) = do 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 + if | clauseTrue -> unitPropagate assignments ys | null clauseFiltered -> throwError "Unable to solve expression" - | otherwise -> (unitPropagate <$> (clauseFiltered:)) ys + | otherwise -> do + (assignments', formula') <- unitPropagate assignments ys + return (assignments', clauseFiltered:formula') -unitPropagate [] = return [] +unitPropagate assignments [] = return (assignments, []) -- unwrap an atom atomToLiteral :: CNFAtom a -> CNFLiteral a From 9b1cd78365b36bee288b313b11ff9dbff8ba2113 Mon Sep 17 00:00:00 2001 From: David Shea Date: Mon, 28 Aug 2017 14:34:17 -0400 Subject: [PATCH 14/17] Export the DepAssignment type used by solveCNF --- importer/BDCS/Depsolve.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/importer/BDCS/Depsolve.hs b/importer/BDCS/Depsolve.hs index 448e0fd..e5bd9dc 100644 --- a/importer/BDCS/Depsolve.hs +++ b/importer/BDCS/Depsolve.hs @@ -22,6 +22,7 @@ module BDCS.Depsolve(Formula(..), CNFLiteral(..), CNFAtom(..), CNFFormula, + DepAssignment, formulaToCNF, solveCNF -- export private symbols for testing From 5e17cf4f6f2f4d08c27e52834f25e9329e80f2bb Mon Sep 17 00:00:00 2001 From: David Shea Date: Thu, 10 Aug 2017 17:36:23 -0400 Subject: [PATCH 15/17] Fix a bug in unitPropagate The part of unitPropagate that propagates the assignments across existing clauses was eliminating the wrong propositions. Rewrite the lambda to be more clear than clever and fix it. --- importer/BDCS/Depsolve.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/importer/BDCS/Depsolve.hs b/importer/BDCS/Depsolve.hs index e5bd9dc..9403b9e 100644 --- a/importer/BDCS/Depsolve.hs +++ b/importer/BDCS/Depsolve.hs @@ -284,7 +284,9 @@ unitPropagate assignments ([x]:ys) = do -- 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 -> Just (not (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" From 63406c8d77203b70d967dc6fdc0b430fa4b6fd2f Mon Sep 17 00:00:00 2001 From: David Shea Date: Fri, 11 Aug 2017 14:00:16 -0400 Subject: [PATCH 16/17] Add the start of some depsolve tests --- importer/tests/BDCS/DepsolveSpec.hs | 189 ++++++++++++++++++++++++++++ 1 file changed, 189 insertions(+) create mode 100644 importer/tests/BDCS/DepsolveSpec.hs 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) From 764f5960e7fb1ee41d48fa543a31fe70e52a4ad0 Mon Sep 17 00:00:00 2001 From: David Shea Date: Thu, 10 Aug 2017 17:35:46 -0400 Subject: [PATCH 17/17] Add a depsolve program --- importer/bdcs.cabal | 14 ++++++++++ importer/tools/depsolve.hs | 55 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+) create mode 100644 importer/tools/depsolve.hs diff --git a/importer/bdcs.cabal b/importer/bdcs.cabal index d398a34..4beb245 100644 --- a/importer/bdcs.cabal +++ b/importer/bdcs.cabal @@ -272,6 +272,20 @@ 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 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