{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
module BDCS.RPM.Groups(createGroup)
where
import Codec.RPM.Tags(Tag, findStringTag, findStringListTag, findTag, findWord32ListTag, tagValue)
import Control.Conditional((<&&>), whenM)
import Control.Monad(forM_, when)
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.State(State, execState, get, modify)
import Data.Bits(testBit)
import Data.Maybe(isJust)
import qualified Data.Text as T
import Data.Word(Word32)
import Database.Persist.Sql(SqlPersistT, insert)
import BDCS.DB
import BDCS.GroupKeyValue(insertGroupKeyValue)
import BDCS.KeyType
import BDCS.Requirements(insertGroupRequirement, insertRequirement)
import qualified BDCS.ReqType as RT
import BDCS.RPM.Requirements(mkGroupRequirement, mkRequirement)
addPRCO :: MonadIO m => [Tag] -> Key Groups -> T.Text -> T.Text -> SqlPersistT m ()
addPRCO tags groupId tagBase keyName =
withPRCO tagBase tags $ \(_, expr) -> let
exprBase = T.takeWhile (/= ' ') expr
in
insertGroupKeyValue (TextKey keyName) exprBase (Just expr) groupId
prcoExpressions :: T.Text -> [Tag] -> [(Word32, T.Text)]
prcoExpressions ty tags = let
ty' = T.toTitle ty
names = map T.pack $ findStringListTag (T.unpack ty' ++ "Name") tags
flags = findWord32ListTag (T.unpack ty' ++ "Flags") tags
vers = map T.pack $ findStringListTag (T.unpack ty' ++ "Version") tags
in
zip flags $ map (\(n, f, v) -> T.stripEnd $ T.concat [n, " ", rpmFlagsToOperator f, " ", v])
(zip3 names flags vers)
rpmFlagsToOperator :: Word32 -> T.Text
rpmFlagsToOperator f =
if | f `testBit` 1 && f `testBit` 3 -> "<="
| f `testBit` 1 -> "<"
| f `testBit` 2 && f `testBit` 3 -> ">="
| f `testBit` 2 -> ">"
| f `testBit` 3 -> "="
| otherwise -> ""
rpmFlagsToContexts :: [Tag] -> Word32 -> [RT.ReqContext]
rpmFlagsToContexts tags flags =
execState rpmFlagsToContextsState []
where
rpmFlagsToContextsState :: State [RT.ReqContext] ()
rpmFlagsToContextsState = do
when (flags `testBit` 9) (modify (RT.ScriptPre:))
when (flags `testBit` 10) (modify (RT.ScriptPost:))
when (flags `testBit` 11) (modify (RT.ScriptPreUn:))
when (flags `testBit` 12) (modify (RT.ScriptPostUn:))
when (flags `testBit` 7) (modify (RT.ScriptPreTrans:))
when (flags `testBit` 5) (modify (RT.ScriptPostTrans:))
when (flags `testBit` 13) (modify (RT.ScriptVerify:))
whenM ((null <$> get) <&&> return (flags `testBit` 8)) $ do
when ((isJust . findTag "PreIn") tags) (modify (RT.ScriptPre:))
when ((isJust . findTag "PostIn") tags) (modify (RT.ScriptPost:))
when ((isJust . findTag "PreUn") tags) (modify (RT.ScriptPreUn:))
when ((isJust . findTag "PostUn") tags) (modify (RT.ScriptPost:))
when ((isJust . findTag "PreTrans") tags) (modify (RT.ScriptPreTrans:))
when ((isJust . findTag "PostTrans") tags) (modify (RT.ScriptPostTrans:))
when ((isJust . findTag "VerifyScript") tags) (modify (RT.ScriptVerify:))
when (flags `testBit` 24) (modify (RT.Feature:))
whenM (null <$> get) (modify (RT.Runtime:))
withPRCO :: Monad m => T.Text -> [Tag] -> ((Word32, T.Text) -> m a) -> m ()
withPRCO ty tags fn =
mapM_ fn (prcoExpressions ty tags)
{-# ANN createGroup ("HLint: ignore Avoid lambda" :: String) #-}
createGroup :: MonadIO m => [Key Files] -> [Tag] -> SqlPersistT m (Key Groups)
createGroup fileIds rpm = do
let epoch = findTag "Epoch" rpm >>= \t -> (tagValue t :: Maybe Word32) >>= Just . T.pack . show
let name = maybe "" T.pack (findStringTag "Name" rpm)
let version = maybe "" T.pack (findStringTag "Version" rpm)
let release = maybe "" T.pack (findStringTag "Release" rpm)
let arch = maybe "" T.pack (findStringTag "Arch" rpm)
groupId <- insert $ Groups name "rpm" Nothing
mapM_ (\fId -> insert $ GroupFiles groupId fId) fileIds
forM_ [(TextKey "name", name), (TextKey "version", version), (TextKey "release", release), (TextKey "arch", arch)] $ \tup ->
uncurry insertGroupKeyValue tup Nothing groupId
forM_ epoch $ \e -> insertGroupKeyValue (TextKey "epoch") e Nothing groupId
forM_ [("Provide", "rpm-provide"), ("Conflict", "rpm-conflict"), ("Obsolete", "rpm-obsolete"), ("Order", "rpm-install-after")] $ \tup ->
uncurry (addPRCO rpm groupId) tup
forM_ [("Require", RT.Must), ("Recommend", RT.Should), ("Suggest", RT.May),
("Supplement", RT.ShouldIfInstalled), ("Enhance", RT.MayIfInstalled)] $ \tup ->
withPRCO (fst tup) rpm $ \(flags, expr) ->
forM_ (rpmFlagsToContexts rpm flags) $ \context -> do
reqId <- insertRequirement $ mkRequirement context (snd tup) expr
insertGroupRequirement $ mkGroupRequirement groupId reqId
return groupId