module BDCS.API.Depsolve(PackageNEVRA(..),
mkPackageNEVRA,
depsolveProjects,
depsolveRecipe)
where
import BDCS.Depclose(depcloseNames)
import BDCS.Depsolve(formulaToCNF, solveCNF)
import BDCS.Groups(groupIdToNevra)
import BDCS.RPM.Utils(splitFilename)
import BDCS.Utils.Monad(mapMaybeM)
import Control.Monad.Except(runExceptT)
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Trans.Resource(MonadBaseControl)
import Data.Aeson((.=), (.:), FromJSON(..), ToJSON(..), object, withObject)
import Data.List(find)
import Data.Maybe(fromMaybe, mapMaybe)
import Data.String.Conversions(cs)
import qualified Data.Text as T
import Database.Persist.Sql(ConnectionPool, runSqlPool)
import BDCS.API.Recipe(Recipe(..), getAllRecipeProjects)
data PackageNEVRA = PackageNEVRA {
pnName :: T.Text
, pnEpoch :: Maybe Int
, pnVersion :: T.Text
, pnRelease :: T.Text
, pnArch :: T.Text
} deriving (Show, Eq)
instance ToJSON PackageNEVRA where
toJSON PackageNEVRA{..} = object [
"name" .= pnName
, "epoch" .= fromMaybe 0 pnEpoch
, "version" .= pnVersion
, "release" .= pnRelease
, "arch" .= pnArch ]
instance FromJSON PackageNEVRA where
parseJSON = withObject "package NEVRA" $ \o ->
PackageNEVRA <$> o .: "name"
<*> o .: "epoch"
<*> o .: "version"
<*> o .: "release"
<*> o .: "arch"
mkPackageNEVRA :: (T.Text, Maybe T.Text, T.Text, T.Text, T.Text) -> PackageNEVRA
mkPackageNEVRA (name, epoch, version, release, arch) = PackageNEVRA name (epoch' epoch) version release arch
where
epoch' Nothing = Nothing
epoch' (Just e) = Just ((read $ T.unpack e) :: Int)
depsolveProjects :: (MonadBaseControl IO m, MonadIO m) => ConnectionPool -> [T.Text] -> m (Either String [PackageNEVRA])
depsolveProjects pool project_name_list = do
result <- runExceptT $ flip runSqlPool pool $ do
formula <- depcloseNames ["x86_64"] project_name_list
solution <- solveCNF (formulaToCNF formula)
mapMaybeM groupIdToNevra $ map fst $ filter snd solution
case result of
Left e -> return $ Left (show e)
Right assignments -> return $ Right (map (mkPackageNEVRA . splitFilename) assignments)
depsolveRecipe :: (MonadBaseControl IO m, MonadIO m) => ConnectionPool -> Recipe -> m (Either T.Text ([PackageNEVRA], [PackageNEVRA]))
depsolveRecipe pool recipe@Recipe{..} = do
let projects_name_list = map cs $ getAllRecipeProjects recipe
depsolveProjects pool projects_name_list >>= \case
Left err -> return $ Left (cs err)
Right dep_nevras -> do
let project_nevras = getProjectNEVRAs projects_name_list dep_nevras
return $ Right (dep_nevras, project_nevras)
where
getProjectNEVRAs :: [T.Text] -> [PackageNEVRA] -> [PackageNEVRA]
getProjectNEVRAs project_names all_nevras = mapMaybe lookupProject project_names
where
lookupProject project_name = find (\e -> pnName e == project_name) all_nevras