{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module BDCS.Import.RPM(consume,
loadIntoMDDB,
loadFromURI,
rpmExistsInMDDB)
where
import Codec.RPM.Conduit(parseRPMC, payloadContentsC)
import Codec.RPM.Tags
import Codec.RPM.Types
import Control.Conditional(ifM)
import Control.Exception(evaluate, tryJust)
import Control.Monad(guard, void)
import Control.Monad.Except
import Control.Monad.IO.Class(liftIO)
import Control.Monad.Reader(ReaderT, ask)
import Control.Monad.Trans(lift)
import Control.Monad.Trans.Control(MonadBaseControl)
import Control.Monad.Trans.Resource(MonadResource, MonadThrow)
import qualified Data.ByteString.Char8 as C8
import Data.CPIO(Entry(..))
import Data.Conduit((.|), Conduit, Consumer, ZipConduit(..), await, awaitForever, mapOutput, runConduit, runConduitRes, transPipe, yield)
import Data.Conduit.Combinators(sinkList)
import qualified Data.Conduit.List as CL
import Data.ContentStore(ContentStore, CsError(..), runCsMonad, storeLazyByteStringC)
import Data.ContentStore.Digest(ObjectDigest)
import Database.Esqueleto
import Data.Foldable(toList)
import qualified Data.Text as T
import Data.Text.Encoding(decodeUtf8)
import Network.URI(URI(..))
import System.Posix.Files(fileTypeModes, intersectFileModes, regularFileMode)
import BDCS.Builds(associateBuildWithPackage, insertBuild)
import BDCS.DB
import BDCS.Exceptions(DBException(..), isMissingRPMTagException, throwIfNothing)
import BDCS.Files(associateFilesWithBuild, associateFilesWithPackage, insertFiles)
import BDCS.Import.Conduit(getFromURI)
import BDCS.Import.State(ImportState(..))
import BDCS.Label.FileLabels(apply)
import BDCS.Packages(insertPackageName)
import BDCS.Projects(insertProject)
import BDCS.RPM.Builds(mkBuild)
import BDCS.RPM.Files(mkFiles)
import BDCS.RPM.Groups(createGroup)
import BDCS.RPM.Projects(mkProject)
import BDCS.RPM.Signatures(mkRSASignature, mkSHASignature)
import BDCS.RPM.Sources(mkSource)
import BDCS.Signatures(insertBuildSignatures)
import BDCS.Sources(insertSource)
import BDCS.Utils.Error(mapError)
#ifdef SCRIPTS
import BDCS.RPM.Scripts(mkScripts, mkTriggerScripts)
import BDCS.Scripts(insertScript)
#endif
buildImported :: MonadResource m => [Tag] -> SqlPersistT m Bool
buildImported sigs =
case findStringTag "SHA1Header" sigs of
Just sha -> do ndx <- select $ from $ \signatures -> do
where_ $ signatures ^. BuildSignaturesSignature_type ==. val "SHA1" &&.
signatures ^. BuildSignaturesSignature_data ==. val (C8.pack sha)
return $ signatures ^. BuildSignaturesId
return $ not $ null ndx
Nothing -> return False
consume :: (MonadBaseControl IO m, MonadIO m, MonadThrow m, MonadError CsError m) => ContentStore -> FilePath -> Consumer RPM m Bool
consume repo db = await >>= \case
Just rpm ->
lift (runExceptT $ checkAndRunSqlite (T.pack db) (rpmExistsInMDDB rpm)) >>= \case
Left e -> throwError (CsError $ show e)
Right True -> return False
Right False -> unsafeConsume repo db rpm
Nothing -> return False
unsafeConsume :: (MonadIO m, MonadBaseControl IO m, MonadThrow m, MonadError CsError m) => ContentStore -> FilePath -> RPM -> Consumer RPM m Bool
unsafeConsume repo db rpm = do
let src = yield rpm .| payloadContentsC
filenames = CL.map (T.dropWhile (== '.') . decodeUtf8 . cpioFileName) .| sinkList
digests = maybeStore .| sinkList
result <- liftIO $ runCsMonad $ runConduit $ src
.| getZipConduit ((,) <$> ZipConduit filenames
<*> ZipConduit digests)
checksums <- either throwError (return . uncurry zip) result
lift (runExceptT $ checkAndRunSqlite (T.pack db) (loadIntoMDDB rpm checksums)) >>= \case
Left e -> throwError (CsError $ show e)
Right v -> return v
where
maybeStore :: (MonadResource m, MonadError CsError m) => Conduit Entry m (Maybe ObjectDigest)
maybeStore = awaitForever $ \Entry{..} ->
if fromIntegral cpioMode `intersectFileModes` fileTypeModes == regularFileMode then
mapOutput Just $ yield cpioFileData .| storeLazyByteStringC repo
else
yield Nothing
loadIntoMDDB :: (MonadBaseControl IO m, MonadResource m) => RPM -> [(T.Text, Maybe ObjectDigest)] -> SqlPersistT m Bool
loadIntoMDDB rpm checksums =
ifM (rpmExistsInMDDB rpm)
(return False)
(unsafeLoadIntoMDDB rpm checksums)
unsafeLoadIntoMDDB :: (MonadBaseControl IO m, MonadResource m) => RPM -> [(T.Text, Maybe ObjectDigest)] -> SqlPersistT m Bool
unsafeLoadIntoMDDB RPM{rpmSignatures=[], ..} _ = return False
unsafeLoadIntoMDDB RPM{rpmHeaders=[], ..} _ = return False
unsafeLoadIntoMDDB RPM{rpmSignatures=fstSignature:_, rpmHeaders=fstHeader:_, ..} checksums = do
let sigHeaders = headerTags fstSignature
let tagHeaders = headerTags fstHeader
projectId <- insertProject $ mkProject tagHeaders
sourceId <- insertSource $ mkSource tagHeaders projectId
buildId <- insertBuild $ mkBuild tagHeaders sourceId
rsaSignature <- liftIO $ toList <$> tryJust (guard . isMissingRPMTagException) (evaluate $ mkRSASignature sigHeaders buildId)
void $ insertBuildSignatures (mkSHASignature sigHeaders buildId:rsaSignature)
pkgNameId <- insertPackageName $ T.pack $ findStringTag "Name" tagHeaders `throwIfNothing` MissingRPMTag "Name"
files <- mkFiles tagHeaders checksums
filesIds <- insertFiles files
void $ apply (zip files filesIds)
void $ associateFilesWithBuild filesIds buildId
void $ associateFilesWithPackage filesIds pkgNameId
void $ associateBuildWithPackage buildId pkgNameId
#ifdef SCRIPTS
groupId <- createGroup filesIds tagHeaders
mapM_ (insertScript groupId) (mkScripts tagHeaders ++ mkTriggerScripts tagHeaders)
#else
void $ createGroup filesIds tagHeaders
#endif
return True
loadFromURI :: URI -> ReaderT ImportState IO ()
loadFromURI uri = do
db <- stDB <$> ask
repo <- stRepo <$> ask
result <- runExceptT $ runConduitRes $
getFromURI uri
.| transPipe (mapError showParseError) parseRPMC
.| transPipe (mapError showCsError) (consume repo db)
case result of
Left e -> liftIO $ putStrLn e
Right True -> liftIO $ putStrLn $ "Imported " ++ uriPath uri
_ -> return ()
where
showParseError e = "Error fetching " ++ uriPath uri ++ ": " ++ show e
showCsError e = "Error importing " ++ uriPath uri ++ ": " ++ show e
rpmExistsInMDDB :: MonadResource m => RPM -> SqlPersistT m Bool
rpmExistsInMDDB RPM{rpmSignatures=[], ..} = return False
rpmExistsInMDDB RPM{rpmSignatures=hd:_, ..} = do
let sigHeaders = headerTags hd
buildImported sigHeaders