{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module BDCS.Depclose(DepFormula,
depcloseGroupIds,
depcloseNEVRAs,
depcloseNames)
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, nameToGroupIds)
import BDCS.GroupKeyValue(getGroupsByKeyVal, getKeyValuesForGroup, getValueForGroup)
import BDCS.KeyType
import qualified BDCS.ReqType as RT
import BDCS.Utils.Error(errorToMaybe)
import BDCS.Utils.Monad(concatMapM, foldMaybeM, mapMaybeM)
data ParentItem = GroupId (Key Groups)
| Provides DepRequirement
deriving (Eq, Ord)
type DepParents = Set.Set ParentItem
type DepFormula = Formula (Key Groups)
depcloseNEVRAs :: (MonadError String m, MonadIO m) => [T.Text] -> [T.Text] -> SqlPersistT m DepFormula
depcloseNEVRAs arches nevras = do
groupIds <- mapM getGroupId nevras
depcloseGroupIds arches groupIds
depcloseNames :: (MonadError String m, MonadIO m) => [T.Text] -> [T.Text] -> SqlPersistT m DepFormula
depcloseNames arches names = do
groupIds <- concatMapM nameToGroupIds names
depcloseGroupIds arches groupIds
depcloseGroupIds :: (MonadError String m, MonadIO m) => [T.Text] -> [Key Groups] -> SqlPersistT m DepFormula
depcloseGroupIds arches groupIds = do
(formulas, _) <- foldM foldIdToFormula ([], Set.empty) groupIds
return $ And formulas
where
foldIdToFormula :: (MonadError String m, MonadIO m) => ([DepFormula], DepParents) -> Key Groups -> SqlPersistT m ([DepFormula], DepParents)
foldIdToFormula (formulaAcc, parents) groupId = first (:formulaAcc) <$> groupIdToFormula parents groupId
groupIdToFormula :: (MonadError String m, MonadIO m) => DepParents -> Key Groups -> SqlPersistT m (DepFormula, DepParents)
groupIdToFormula parents groupId = do
let parents' = Set.insert (GroupId groupId) parents
conflicts <- getKeyValuesForGroup groupId (Just $ TextKey "rpm-conflict") >>= mapM kvToDep
obsoletes <- getKeyValuesForGroup groupId (Just $ TextKey "rpm-obsolete") >>= mapM kvToDep
conflictIds <- concatMapM providerIds conflicts
obsoleteIds <- concatMapM nameReqIds obsoletes
let obsConflictFormulas = map Not (conflictIds ++ obsoleteIds)
providesSet <- Set.union parents'
<$> Set.fromList
<$> map Provides
<$> (getKeyValuesForGroup groupId (Just $ TextKey "rpm-provide") >>= mapM kvToDep)
requirements <- getRequirementsForGroup groupId RT.Runtime >>= mapM reqToDep
requirementIds <- zip requirements <$> mapM providerIds requirements
(requirementFormulas, requirementParents) <- foldMaybeM resolveOneReq ([], providesSet) requirementIds
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 (`Set.member` parentAcc) (map GroupId idlist) -> return Nothing
| Set.member (Provides req) parentAcc -> return Nothing
| otherwise -> do
(formulaList, parentList) <- unzip <$> mapMaybeM (errorToMaybe . groupIdToFormula parentAcc) idlist
when (null formulaList) $ throwError $ "Unable to resolve requirement: " ++ show req
let reqFormula = Or formulaList
let reqParents = foldr1 Set.intersection parentList
return $ Just (reqFormula : formulaAcc, Set.union parentAcc reqParents)
providerIds :: (MonadError String m, MonadIO m) => DepRequirement -> SqlPersistT m [Key Groups]
providerIds req = do
let DepRequirement reqname _ = req
vals <- getGroupsByKeyVal "rpm" (TextKey "rpm-provide") (Just reqname)
valsVersion <- filterM (fmap (`satisfies` req) . kvToDep . snd) vals
let valsVersionIds = map fst valsVersion
providerVals <- filterM matchesArch valsVersionIds
fileVals <- if "/" `T.isPrefixOf` reqname then pathToGroupId reqname >>= filterM matchesArch
else return []
return $ providerVals ++ fileVals
nameReqIds :: MonadIO m => DepRequirement -> SqlPersistT m [Key Groups]
nameReqIds req = do
let DepRequirement reqname _ = req
vals <- map fst <$> getGroupsByKeyVal "rpm" (TextKey "name") (Just reqname)
valsArch <- filterM matchesArch vals
case req of
DepRequirement _ Nothing -> return valsArch
DepRequirement _ (Just _) -> filterM (\gid -> do
providerReq <- groupIdToDep reqname gid
return $ req `satisfies` providerReq)
valsArch
where
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})
matchesArch :: MonadIO m => Key Groups -> SqlPersistT m Bool
matchesArch groupId = do
kvArches <- mapMaybe keyValVal_value <$> getKeyValuesForGroup groupId (Just $ TextKey "arch")
return $ (not . null) (("noarch":arches) `intersect` kvArches)
parseDepRequirementError :: MonadError String m => T.Text -> m DepRequirement
parseDepRequirementError req = either (throwError . show) return $ parseDepRequirement req
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
reqToDep :: MonadError String m => Requirements -> m DepRequirement
reqToDep Requirements{..} = parseDepRequirementError requirementsReq_expr