diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ +## 0.6.0 + +* Use the typed-process module instead of process. +* Build all programs with -threaded. All users of bdcs will need to do the same. +* Remove script support from the database. This wasn't being used anyway. +* Make the upstream_vcs field in the projects table optional. + ## 0.5.0 * Add logging of exceptions in directorySink, runCustomizations, runHacks, diff --git a/bdcs.cabal b/bdcs.cabal --- a/bdcs.cabal +++ b/bdcs.cabal @@ -1,5 +1,5 @@ name: bdcs -version: 0.5.0 +version: 0.6.0 synopsis: Tools for managing a content store of software packages description: This module provides a library and various tools for managing a content store and metadata database. These store the contents of software packages that make up a @@ -42,10 +42,6 @@ type: git location: https://github.com/weldr/bdcs -flag scripts - description: Enable importing package scripts to the database - default: False - library hs-source-dirs: src @@ -97,13 +93,11 @@ BDCS.RPM.Groups, BDCS.RPM.Projects, BDCS.RPM.Requirements, - BDCS.RPM.Scripts, BDCS.RPM.Signatures, BDCS.RPM.Sources, BDCS.RPM.Utils, BDCS.ReqType, BDCS.Requirements, - BDCS.Scripts, BDCS.Signatures, BDCS.Sources, BDCS.Utils.Conduit, @@ -136,7 +130,7 @@ gi-ostree >= 1.0.3 && < 1.1.0, gitrev >= 1.3.1 && < 1.4.0, http-conduit >= 2.2.3 && < 2.3.0, - lifted-base, + lifted-base < 0.3.0.0, listsafe >= 0.1.0.1 && < 0.2.0, memory >= 0.14.3 && < 0.15.0, monad-control >= 1.0.1.0 && < 1.1.0.0, @@ -148,10 +142,11 @@ persistent >= 2.7.0 && < 2.8.0, persistent-sqlite >= 2.6.0 && < 2.7.0, persistent-template >= 2.5.0 && < 2.6.0, - process >= 1.4.3.0 && < 2.0, + typed-process >= 0.1.0.0 && < 0.3.0.0, regex-pcre >= 0.94 && < 0.95, resourcet >= 1.1.9 && < 1.2, split >= 0.2.3 && < 0.3, + string-conversions < 0.5.0.0, tar >= 0.5 && < 0.6, tar-conduit >= 0.1.0 && < 0.2.0, temporary >= 1.2.0.4 && < 1.3.0.0, @@ -166,12 +161,7 @@ other-modules: Paths_bdcs default-language: Haskell2010 - if flag(scripts) - cpp-options: -DSCRIPTS - cc-options: "-DSCRIPTS" - ghc-options: -Wall - else - ghc-options: -Wall + ghc-options: -Wall executable bdcs main-is: bdcs.hs @@ -186,13 +176,14 @@ cond >= 0.4.1.1 && < 0.5.0.0, directory >= 1.3.0.0 && < 1.4.0.0, filepath >= 1.4.1.1 && < 1.5.0.0, + lifted-base < 0.3.0.0, monad-loops >= 0.4.0 && < 0.5, - process >= 1.4.3.0 && < 2.0, - text >= 1.2.2.0 && < 1.3 + text >= 1.2.2.0 && < 1.3, + typed-process >= 0.1.0.0 && < 0.3.0.0 default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded executable bdcs-import main-is: import.hs @@ -211,7 +202,7 @@ default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded executable bdcs-inspect main-is: inspect.hs @@ -228,13 +219,14 @@ cond >= 0.4.1.1 && < 0.5.0.0, directory >= 1.3.0.0 && < 1.4.0.0, filepath >= 1.4.1.1 && < 1.5.0.0, + lifted-base < 0.3.0.0, monad-loops >= 0.4.0 && < 0.5, - process >= 1.4.3.0 && < 2.0, - text >= 1.2.2.0 && < 1.3 + text >= 1.2.2.0 && < 1.3, + typed-process >= 0.1.0.0 && < 0.3.0.0 default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded executable inspect-groups main-is: groups.hs @@ -261,7 +253,7 @@ text >= 1.2.2.0 && < 1.3 default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded executable inspect-ls main-is: ls.hs @@ -288,7 +280,7 @@ time >= 1.6.0.1 && < 2.0 default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded executable inspect-nevras main-is: nevras.hs @@ -310,7 +302,7 @@ text >= 1.2.2.0 && < 1.3 default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded executable bdcs-export main-is: export.hs @@ -329,7 +321,7 @@ default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded executable bdcs-tmpfiles main-is: bdcs-tmpfiles.hs @@ -342,7 +334,7 @@ default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded executable bdcs-depsolve main-is: depsolve.hs @@ -357,7 +349,7 @@ default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded Test-Suite test-bdcs type: exitcode-stdio-1.0 diff --git a/schema.sql b/schema.sql --- a/schema.sql +++ b/schema.sql @@ -53,7 +53,7 @@ summary text not null, description text not null, homepage text, - upstream_vcs text not null + upstream_vcs text ); -- A source represents a release of a single upstream project (hence the @@ -303,27 +303,5 @@ ); create index group_requirements_group_id_idx on group_requirements(group_id); create index group_requirements_req_id_idx on group_requirements(req_id); - --- These things are temporary and should not be relied upon. We will be getting --- rid of them once we have an idea how common scriptlets are. - -create table scripts ( - id integer primary key, - ty text not null, - body text not null, - trigger_prog text, - trigger_index integer, - trigger_name text, - trigger_version text, - trigger_flags integer -); - -create table group_scripts ( - id integer primary key, - group_id integer references groups(id) not null, - script_id integer references scripts(id) not null -); -create index group_scripts_group_id_idx on group_scripts(group_id); -create index group_scripts_script_id_idx on group_scripts(script_id); .quit diff --git a/src/BDCS/DB.hs b/src/BDCS/DB.hs --- a/src/BDCS/DB.hs +++ b/src/BDCS/DB.hs @@ -30,10 +30,10 @@ import Control.Monad.Logger(NoLoggingT) import Control.Monad.Trans.Resource(MonadBaseControl, ResourceT) import qualified Data.Aeson as Aeson -import Data.Aeson((.:), (.=)) +import Data.Aeson((.:), (.:?), (.=)) import Data.ByteString(ByteString) import Data.Int(Int64) -import Data.Maybe(fromMaybe, listToMaybe) +import Data.Maybe(listToMaybe) import qualified Data.Text as T import Data.Time(UTCTime) import Database.Esqueleto(Esqueleto, Entity, Key, PersistEntity, PersistField, SqlBackend, SqlPersistT, ToBackendKey, Value, @@ -84,7 +84,7 @@ summary T.Text description T.Text homepage T.Text Maybe - upstream_vcs T.Text + upstream_vcs T.Text Maybe NameKey name deriving Eq Show Sources @@ -174,19 +174,6 @@ group_id GroupsId req_id RequirementsId deriving Eq Show - Scripts - ty T.Text - body T.Text - trigger_prog T.Text Maybe - trigger_index Int Maybe - trigger_name T.Text Maybe - trigger_version T.Text Maybe - trigger_flags Int Maybe - deriving Eq Show - GroupScripts - group_id GroupsId - script_id ScriptsId - deriving Eq Show |] -- Implement JSON functions for Projects @@ -195,7 +182,7 @@ "name" .= projectsName , "summary" .= projectsSummary , "description" .= projectsDescription - , "homepage" .= fromMaybe "" projectsHomepage + , "homepage" .= projectsHomepage , "upstream_vcs" .= projectsUpstream_vcs ] instance Aeson.FromJSON Projects where @@ -203,8 +190,8 @@ projectsName <- o .: "name" projectsSummary <- o .: "summary" projectsDescription <- o .: "description" - projectsHomepage <- o .: "homepage" - projectsUpstream_vcs <- o .: "upstream_vcs" + projectsHomepage <- o .:? "homepage" + projectsUpstream_vcs <- o .:? "upstream_vcs" return Projects{..} instance Aeson.ToJSON KeyVal where diff --git a/src/BDCS/Export/Ostree.hs b/src/BDCS/Export/Ostree.hs --- a/src/BDCS/Export/Ostree.hs +++ b/src/BDCS/Export/Ostree.hs @@ -83,7 +83,7 @@ -- Compile the locale-archive file let localeDir = tmpDir "usr" "lib" "locale" whenM (liftIO $ doesFileExist $ localeDir "locale-archive.tmpl") $ - callProcessLogged "chroot" [tmpDir, "/usr/sbin/build-locale-archive"] + lift $ callProcessLogged "chroot" [tmpDir, "/usr/sbin/build-locale-archive"] -- Add the kernel and initramfs lift $ installKernelInitrd tmpDir @@ -126,7 +126,7 @@ -- rpmdb treats every path as absolute rpmdbDir <- liftIO $ makeAbsolute $ tmpDir "usr" "share" "rpm" liftIO $ createDirectoryIfMissing True rpmdbDir - callProcessLogged "rpmdb" ["--initdb", "--dbpath=" ++ rpmdbDir] + lift $ callProcessLogged "rpmdb" ["--initdb", "--dbpath=" ++ rpmdbDir] -- import the directory as a new commit logDebugN "Storing results as a new commit" diff --git a/src/BDCS/Export/Qcow2.hs b/src/BDCS/Export/Qcow2.hs --- a/src/BDCS/Export/Qcow2.hs +++ b/src/BDCS/Export/Qcow2.hs @@ -56,5 +56,5 @@ lift $ runHacks tmpDir -- Run virt-make-fs to generate the qcow2 - callProcessLogged "virt-make-fs" [tmpDir, outPath, "--format=qcow2", "--label=composer"] + lift $ callProcessLogged "virt-make-fs" [tmpDir, outPath, "--format=qcow2", "--label=composer"] ) diff --git a/src/BDCS/Export/Utils.hs b/src/BDCS/Export/Utils.hs --- a/src/BDCS/Export/Utils.hs +++ b/src/BDCS/Export/Utils.hs @@ -46,7 +46,7 @@ -- This is a helper for runHacks that does all the hard work. It exists separately so the main -- function can handle any exceptions without making a mess of the code. -runHacks' :: MonadLoggerIO m => FilePath -> m () +runHacks' :: (MonadBaseControl IO m, MonadLoggerIO m) => FilePath -> m () runHacks' exportPath = do -- set a root password -- pre-crypted from "redhat" diff --git a/src/BDCS/Import/NPM.hs b/src/BDCS/Import/NPM.hs --- a/src/BDCS/Import/NPM.hs +++ b/src/BDCS/Import/NPM.hs @@ -179,7 +179,7 @@ -- Create the project/source/build entries from the package.json data -- npm doesn't provide separate descriptions and summaries, so just leave projects.description blank -- upstream_vcs is usually the same as homepage, but we can't tell automatically so leave that blank too - projectId <- insertProject $ Projects packageName description "" homepage "" + projectId <- insertProject $ Projects packageName description "" homepage Nothing sourceId <- insertSource $ Sources projectId license packageVersion "" fileIds <- insertFiles files diff --git a/src/BDCS/Import/RPM.hs b/src/BDCS/Import/RPM.hs --- a/src/BDCS/Import/RPM.hs +++ b/src/BDCS/Import/RPM.hs @@ -67,11 +67,6 @@ import BDCS.Sources(insertSource) import BDCS.Utils.Error(mapError) -#ifdef SCRIPTS -import BDCS.RPM.Scripts(mkScripts, mkTriggerScripts) -import BDCS.Scripts(insertScript) -#endif - {-# ANN buildImported ("HLint: ignore Use ." :: String) #-} buildImported :: MonadResource m => [Tag] -> SqlPersistT m Bool @@ -178,16 +173,7 @@ void $ associateFilesWithPackage filesIds pkgNameId void $ associateBuildWithPackage buildId pkgNameId -#ifdef SCRIPTS - -- groups and reqs - groupId <- createGroup filesIds tagHeaders - - -- scripts - These are here temporarily, just so we can figure out how widely they are - -- used. Once we are done, they are going away. - mapM_ (insertScript groupId) (mkScripts tagHeaders ++ mkTriggerScripts tagHeaders) -#else void $ createGroup filesIds tagHeaders -#endif return True diff --git a/src/BDCS/RPM/Projects.hs b/src/BDCS/RPM/Projects.hs --- a/src/BDCS/RPM/Projects.hs +++ b/src/BDCS/RPM/Projects.hs @@ -36,11 +36,8 @@ (MissingRPMTag "Description") decodeUtf8 homepage = fmap T.pack (findStringTag "URL" tags) - - -- FIXME: Where to get this from? - upstream_vcs = "UPSTREAM_VCS" in - Projects projectName summary description homepage upstream_vcs + Projects projectName summary description homepage Nothing where -- the closest to a project name we have is the srpm name, e.g., pykickstart-2.32-1.fc26.src.rpm -- This is essentially N-V-R.A.rpm. rpm does not allow hyphens in version of release, and epoch is diff --git a/src/BDCS/RPM/Scripts.hs b/src/BDCS/RPM/Scripts.hs deleted file mode 100644 --- a/src/BDCS/RPM/Scripts.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module: BDCS.RPM.Scripts --- Copyright: (c) 2016-2017 Red Hat, Inc. --- License: LGPL --- --- Maintainer: https://github.com/weldr --- Stability: alpha --- Portability: portable --- --- 'Scripts' record support for RPM packages. - -module BDCS.RPM.Scripts(mkScripts, - mkTriggerScripts) - where - -import Codec.RPM.Tags(Tag, findStringListTag, findTag, findWord32ListTag, tagValue) -import Data.List(zip6) -import Data.Maybe(catMaybes) -import Data.Text(pack) - -import BDCS.DB(Scripts(..)) - --- | Return a list of 'Scripts' records -mkScripts :: [Tag] -> [Scripts] -mkScripts tags = catMaybes [ - findTag "PreIn" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PreIn" (pack body) Nothing Nothing Nothing Nothing Nothing, - findTag "PostIn" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PostIn" (pack body) Nothing Nothing Nothing Nothing Nothing, - findTag "PreUn" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PreUn" (pack body) Nothing Nothing Nothing Nothing Nothing, - findTag "PostUn" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PostUn" (pack body) Nothing Nothing Nothing Nothing Nothing, - - findTag "PreTrans" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PreTrans" (pack body) Nothing Nothing Nothing Nothing Nothing, - findTag "PostTrans" tags >>= \t -> (tagValue t :: Maybe String) >>= \body -> Just $ Scripts "PostTrans" (pack body) Nothing Nothing Nothing Nothing Nothing - ] - --- | Return a list of trigger scripts -mkTriggerScripts :: [Tag] -> [Scripts] -mkTriggerScripts tags = let - bodies = map pack $ findStringListTag "TriggerScripts" tags - names = map pack $ findStringListTag "TriggerName" tags - vers = map pack $ findStringListTag "TriggerVersion" tags - flags = map fromIntegral $ findWord32ListTag "TriggerFlags" tags - ndxs = map fromIntegral $ findWord32ListTag "TriggerIndex" tags - progs = map pack $ findStringListTag "TriggerScriptProg" tags - in - map (\(b, n, v, f, x, p) -> Scripts "Trigger" b (Just p) (Just x) (Just n) (Just v) (Just f)) - (zip6 bodies names vers flags ndxs progs) diff --git a/src/BDCS/Scripts.hs b/src/BDCS/Scripts.hs deleted file mode 100644 --- a/src/BDCS/Scripts.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | --- Module: BDCS.Scripts --- Copyright: (c) 2017 Red Hat, Inc. --- License: LGPL --- --- Maintainer: https://github.com/weldr --- Stability: alpha --- Portability: portable --- --- Manage 'Scripts' records in the database. This record keeps track of a single --- script that is associated with a 'Groups' record. A script is some arbitrary --- program that can be run at various points when installing, upgrading, or removing --- a piece of software. Not all packaging systems support this concept, and the --- BDCS only somewhat supports them at the moment. - -module BDCS.Scripts(findScript, - getScript, - insertScript) - where - -import Control.Monad.IO.Class(MonadIO) -import qualified Data.Text as T -import Database.Esqueleto - -import BDCS.DB - -{-# ANN findScript ("HLint: ignore Use ." :: String) #-} - --- | Find a single script in the database, returning the key for that script if it --- exists. It is possible for multiple very similar scripts to exist in the same --- database (or even, scripts with identical bodies but that differ in other ways) --- so additional information must be provided. -findScript :: MonadIO m => - T.Text -- ^ The script type (generally, when it runs). - -- This value is highly packaging system dependent. - -> T.Text -- ^ The script body - -> Maybe T.Text -- ^ The name of any trigger required to fire - -- off this script. Most scripts do not use this, - -- and many packaging systems do not support it. - -> Maybe T.Text -- ^ The script version, currently unused - -> Maybe Int -- ^ The script index, currently unused - -> Maybe Int -- ^ The script flags, currently unused - -> SqlPersistT m (Maybe (Key Scripts)) -findScript ty body name _ver _ndx _flags = firstKeyResult $ - select $ from $ \script -> do - where_ $ script ^. ScriptsTy ==. val ty &&. - script ^. ScriptsBody ==. val body &&. - script ^. ScriptsTrigger_name ==? name - limit 1 - return $ script ^. ScriptsId - --- | Given a key to a 'Scripts' record in the database, return that record. This function is --- suitable for using on the result of 'findScript'. -getScript :: MonadIO m => Key Scripts -> SqlPersistT m (Maybe Scripts) -getScript key = firstEntityResult $ - select $ from $ \script -> do - where_ $ script ^. ScriptsId ==. val key - limit 1 - return script - --- | Conditionally add a new 'Scripts' record to the database and associate a 'Groups' record --- with it. If the association already exists, it is reused in creating the association. --- The database key of the association is returned. A single group can potentially have zero --- or many 'Scripts' associated with it. -insertScript :: MonadIO m => Key Groups -> Scripts -> SqlPersistT m (Key GroupScripts) -insertScript groupId script@Scripts{..} = - maybeKey (insert script >>= insert . GroupScripts groupId) - (insert . GroupScripts groupId) - (findScript scriptsTy scriptsBody scriptsTrigger_name scriptsTrigger_version scriptsTrigger_index scriptsTrigger_flags) diff --git a/src/BDCS/Utils/Process.hs b/src/BDCS/Utils/Process.hs --- a/src/BDCS/Utils/Process.hs +++ b/src/BDCS/Utils/Process.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module: BDCS.Utils.Process @@ -15,25 +17,38 @@ module BDCS.Utils.Process(callProcessLogged) where +import qualified Control.Exception.Lifted as CEL import Control.Monad(unless) import Control.Monad.IO.Class(liftIO) import Control.Monad.Logger(MonadLoggerIO, logInfoN, logErrorN) +import Control.Monad.Trans.Control(MonadBaseControl) +import Data.String.Conversions(cs) import qualified Data.Text as T import GHC.IO.Exception(IOErrorType(..)) -import System.Exit(ExitCode(..)) import System.IO.Error(mkIOError) -import System.Process(readProcessWithExitCode) +import System.Process.Typed(ExitCodeException(..), proc, readProcess_) -callProcessLogged :: MonadLoggerIO m => String -> [String] -> m () -callProcessLogged cmd args = do - logInfoN $ T.intercalate " " $ T.pack cmd : map T.pack args - (rc, stdout, stderr) <- liftIO $ readProcessWithExitCode cmd args "" +callProcessLogged :: (MonadBaseControl IO m, MonadLoggerIO m) => String -> [String] -> m () +callProcessLogged cmd args = + doit `CEL.catches` [CEL.Handler (\(e :: ExitCodeException) -> handleProcessFailed e), + CEL.Handler (\(e :: CEL.SomeException) -> handleOtherErrors e)] + where + handleProcessFailed :: (MonadBaseControl IO m, MonadLoggerIO m) => ExitCodeException -> m () + handleProcessFailed ExitCodeException{..} = do + logErrorN $ cs eceStderr + liftIO $ ioError (mkIOError OtherError (cmd ++ unwords args ++ " (" ++ show eceExitCode ++ ")") + Nothing Nothing) - unless (T.null $ T.strip $ T.pack stdout) $ - logInfoN $ T.pack stdout + handleOtherErrors :: (MonadBaseControl IO m, MonadLoggerIO m, CEL.Exception e) => e -> m () + handleOtherErrors e = do + logErrorN $ cs $ show e + liftIO $ ioError (mkIOError OtherError (cmd ++ unwords args ++ " (" ++ show e ++ ")") + Nothing Nothing) - case rc of - ExitFailure x -> do logErrorN $ T.pack stderr - liftIO $ ioError (mkIOError OtherError (cmd ++ unwords args ++ " (" ++ show x ++ ")") - Nothing Nothing) - _ -> return () + doit :: (MonadBaseControl IO m, MonadLoggerIO m) => m () + doit = do + logInfoN $ T.intercalate " " $ T.pack cmd : map T.pack args + (stdout, _) <- liftIO $ readProcess_ (proc cmd args) + + unless (T.null $ T.strip $ cs stdout) $ + logInfoN $ cs stdout diff --git a/src/tools/Utils/Subcommands.hs b/src/tools/Utils/Subcommands.hs --- a/src/tools/Utils/Subcommands.hs +++ b/src/tools/Utils/Subcommands.hs @@ -5,15 +5,15 @@ module Utils.Subcommands(runSubcommand) where -import Control.Conditional(condM, ifM, otherwiseM) -import Control.Exception(SomeException, catch) -import Control.Monad.Loops(firstM) -import Data.Text(pack, splitOn, unpack) -import System.Directory(doesFileExist) -import System.Environment(lookupEnv) -import System.Exit(exitFailure) -import System.FilePath(()) -import System.Process(callProcess) +import Control.Conditional(condM, ifM, otherwiseM) +import qualified Control.Exception.Lifted as CEL +import Control.Monad.Loops(firstM) +import Data.Text(pack, splitOn, unpack) +import System.Directory(doesFileExist) +import System.Environment(lookupEnv) +import System.Exit(exitFailure) +import System.FilePath(()) +import System.Process.Typed(proc, runProcess_) import Paths_bdcs(getLibexecDir) @@ -61,10 +61,10 @@ (tryCallProcess cmd1 subcmdArgs) (putStrLn ("subcommand " ++ subcmd ++ " does not exist\n") >> usage) where - tryCallProcess cmd args = catch (callProcess cmd args) - -- We handled the case where an unknown subcommand was - -- given on the command line. For now, the only other - -- errors possible are when the subcommand ran, but - -- failed for some reason. Those are handled inside - -- the subcommand. Just quit. - (\(_ :: SomeException) -> exitFailure) + tryCallProcess cmd args = CEL.catch (runProcess_ (proc cmd args)) + -- We handled the case where an unknown subcommand was + -- given on the command line. For now, the only other + -- errors possible are when the subcommand ran, but + -- failed for some reason. Those are handled inside + -- the subcommand. Just quit. + (\(_ :: CEL.SomeException) -> exitFailure)