bdcs 0.5.0 → 0.6.0
raw patch · 14 files changed
+84/−241 lines, 14 filesdep +string-conversionsdep +typed-processdep −processdep ~lifted-base
Dependencies added: string-conversions, typed-process
Dependencies removed: process
Dependency ranges changed: lifted-base
Files
- ChangeLog.md +7/−0
- bdcs.cabal +20/−28
- schema.sql +1/−23
- src/BDCS/DB.hs +6/−19
- src/BDCS/Export/Ostree.hs +2/−2
- src/BDCS/Export/Qcow2.hs +1/−1
- src/BDCS/Export/Utils.hs +1/−1
- src/BDCS/Import/NPM.hs +1/−1
- src/BDCS/Import/RPM.hs +0/−14
- src/BDCS/RPM/Projects.hs +1/−4
- src/BDCS/RPM/Scripts.hs +0/−48
- src/BDCS/Scripts.hs +0/−71
- src/BDCS/Utils/Process.hs +28/−13
- src/tools/Utils/Subcommands.hs +16/−16
ChangeLog.md view
@@ -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,
bdcs.cabal view
@@ -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
schema.sql view
@@ -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
src/BDCS/DB.hs view
@@ -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
src/BDCS/Export/Ostree.hs view
@@ -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"
src/BDCS/Export/Qcow2.hs view
@@ -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"] )
src/BDCS/Export/Utils.hs view
@@ -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"
src/BDCS/Import/NPM.hs view
@@ -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
src/BDCS/Import/RPM.hs view
@@ -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
src/BDCS/RPM/Projects.hs view
@@ -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
− src/BDCS/RPM/Scripts.hs
@@ -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)
− src/BDCS/Scripts.hs
@@ -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)
src/BDCS/Utils/Process.hs view
@@ -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
src/tools/Utils/Subcommands.hs view
@@ -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)