bdcs 0.4.0 → 0.5.0
raw patch · 13 files changed
+124/−61 lines, 13 filesdep +lifted-base
Dependencies added: lifted-base
Files
- ChangeLog.md +11/−0
- bdcs.cabal +2/−1
- src/BDCS/Export.hs +14/−5
- src/BDCS/Export/Customize.hs +10/−3
- src/BDCS/Export/Directory.hs +5/−3
- src/BDCS/Export/Ostree.hs +29/−25
- src/BDCS/Export/Qcow2.hs +5/−3
- src/BDCS/Export/Utils.hs +28/−6
- src/BDCS/Utils/Process.hs +4/−1
- src/tools/inspect/Utils/Exceptions.hs +1/−1
- src/tools/inspect/subcommands/groups.hs +2/−2
- src/tools/inspect/subcommands/ls.hs +11/−9
- src/tools/inspect/subcommands/nevras.hs +2/−2
ChangeLog.md view
@@ -1,3 +1,14 @@+## 0.5.0++* Add logging of exceptions in directorySink, runCustomizations, runHacks,+ and runTmpfiles. This requires adding MonadBaseControl constraints to+ all these functions and MonadError constrains to those functions that+ did not already have it.+* Require a filesystem package in the list of things to export.+* Require a dracut package in the list of things to export for ostree.+* Don't assume /etc/shadow exists in the output artifact.+* Log the call to dracut in ostreeSink.+ ## 0.4.0 * Add BDCS.Projects.getProjectsLike, which returns projects whose names match
bdcs.cabal view
@@ -1,5 +1,5 @@ name: bdcs-version: 0.4.0+version: 0.5.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@@ -136,6 +136,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, 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,
src/BDCS/Export.hs view
@@ -20,6 +20,7 @@ import Control.Monad.Except(MonadError, runExceptT, throwError) import Control.Monad.Logger(MonadLoggerIO, logDebugN)+import Control.Monad.Trans(lift) import Control.Monad.Trans.Resource(MonadBaseControl, MonadResource) import Data.Conduit(Consumer, (.|), runConduit, runConduitRes) import qualified Data.Conduit.List as CL@@ -56,8 +57,10 @@ -> [T.Text] -> [Customization] -> SqlPersistT m ()-exportAndCustomize repo out_path ty things custom | kernelMissing ty things = throwError "ERROR: ostree exports need a kernel package included"- | otherwise = do+exportAndCustomize repo out_path ty things custom | kernelMissing ty things = throwError "ERROR: ostree exports need a kernel package included"+ | dracutMissing ty things = throwError "ERROR: ostree exports need a dract package included"+ | filesystemMissing things = throwError "ERROR: exports need a filesystem package included"+ | otherwise = do let objectSink = case ty of ExportTar -> CS.objectToTarEntry .| Tar.tarSink out_path ExportQcow2 -> Qcow2.qcow2Sink out_path@@ -77,15 +80,21 @@ runConduitRes $ fstreeSource fstree' .| filesToObjectsC overlay' cs .| objectSink where- directoryOutput :: (MonadError String m, MonadLoggerIO m) => FilePath -> Consumer (Files, CS.Object) m ()+ directoryOutput :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m) => FilePath -> Consumer (Files, CS.Object) m () directoryOutput path = do -- Apply tmpfiles.d to the directory first logDebugN "Running tmpfiles"- runTmpfiles path+ lift $ runTmpfiles path Directory.directorySink path logDebugN "Running standard hacks"- runHacks path+ lift $ runHacks path kernelMissing :: ExportType -> [T.Text] -> Bool kernelMissing exportTy lst = exportTy == ExportOstree && not (any ("kernel-" `T.isPrefixOf`) lst)++ dracutMissing :: ExportType -> [T.Text] -> Bool+ dracutMissing exportTy lst = exportTy == ExportOstree && not (any ("dracut-" `T.isPrefixOf`) lst)++ filesystemMissing :: [T.Text] -> Bool+ filesystemMissing lst = not (any ("filesystem-" `T.isPrefixOf`) lst)
src/BDCS/Export/Customize.hs view
@@ -8,10 +8,12 @@ runCustomizations) where +import qualified Control.Exception.Lifted as CEL import Control.Monad(foldM)-import Control.Monad.Except(MonadError)+import Control.Monad.Except(MonadError, throwError) import Control.Monad.IO.Class(MonadIO) import Control.Monad.Logger(MonadLogger, MonadLoggerIO, logDebugN)+import Control.Monad.Trans.Control(MonadBaseControl) import Crypto.Hash(Digest, hash) import Crypto.Hash.Algorithms(Blake2b_256) import Data.ByteArray(convert)@@ -62,10 +64,15 @@ let digest = hash input :: Digest Blake2b_256 in convert digest -runCustomizations :: (MonadError String m, MonadLoggerIO m) => CSOverlay -> ContentStore -> FSTree -> [Customization] -> m (CSOverlay, FSTree)+runCustomizations :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m) =>+ CSOverlay+ -> ContentStore+ -> FSTree+ -> [Customization]+ -> m (CSOverlay, FSTree) runCustomizations overlay _repo tree customizations = do logDebugN $ T.pack "Running customizations"- foldM runCustomization (overlay, tree) customizations+ foldM runCustomization (overlay, tree) customizations `CEL.catch` \e -> throwError $ show (e :: CEL.IOException) where runCustomization :: (MonadError String m, MonadLoggerIO m) => (CSOverlay, FSTree) -> Customization -> m (CSOverlay, FSTree) runCustomization (o, t) (WriteFile file content) = addToOverlay o t file content
src/BDCS/Export/Directory.hs view
@@ -19,11 +19,13 @@ where import Control.Conditional(unlessM)+import Control.Exception(IOException) import Control.Monad.Except(MonadError, throwError) import Control.Monad.IO.Class(MonadIO, liftIO) import Control.Monad.Logger(MonadLoggerIO)+import Control.Monad.Trans.Control(MonadBaseControl) import qualified Data.ByteString as BS-import Data.Conduit(Consumer, awaitForever)+import Data.Conduit(Consumer, awaitForever, handleC) import qualified Data.Text as T import Data.Time.Clock.POSIX(posixSecondsToUTCTime) import System.Directory(createDirectoryIfMissing, setModificationTime)@@ -41,8 +43,8 @@ -- -- It is expected that the caller will decide whether the destination directory should be empty -- or not. This function does nothing to enforce that.-directorySink :: (MonadError String m, MonadLoggerIO m) => FilePath -> Consumer (Files, CS.Object) m ()-directorySink outPath = awaitForever $ \case+directorySink :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m) => FilePath -> Consumer (Files, CS.Object) m ()+directorySink outPath = handleC (\e -> throwError $ show (e :: IOException)) $ awaitForever $ \case (f, CS.SpecialObject) -> checkoutSpecial f (f, CS.FileObject bs) -> checkoutFile f bs where
src/BDCS/Export/Ostree.hs view
@@ -20,11 +20,13 @@ import Conduit(Conduit, Consumer, Producer, (.|), bracketP, runConduit, sourceDirectory, yield) import Control.Conditional(condM, otherwiseM, whenM)-import Control.Exception(SomeException, bracket_, catch)+import qualified Control.Exception.Lifted as CEL import Control.Monad(void) import Control.Monad.Except(MonadError) import Control.Monad.IO.Class(MonadIO, liftIO) import Control.Monad.Logger(MonadLoggerIO, logDebugN, logInfoN)+import Control.Monad.Trans(lift)+import Control.Monad.Trans.Control(MonadBaseControl, liftBaseOp) import Control.Monad.Trans.Resource(MonadResource, runResourceT) import Crypto.Hash(SHA256(..), hashInitWith, hashFinalize, hashUpdate) import qualified Data.ByteString as BS (readFile)@@ -34,9 +36,8 @@ import qualified Data.Text as T import System.Directory import System.FilePath((</>), takeDirectory, takeFileName)-import System.IO.Temp(createTempDirectory, withTempDirectory)+import System.IO.Temp(createTempDirectory) import System.Posix.Files(createSymbolicLink, fileGroup, fileMode, fileOwner, getFileStatus, readSymbolicLink)-import System.Process(callProcess) import Text.Printf(printf) import GI.Gio(File, fileNewForPath, noCancellable)@@ -58,7 +59,7 @@ -- required to make the destination a valid ostree repo is also done by this function - setting up -- symlinks and directories, pruning unneeded directories, installing an initrd, building an -- RPM database, and so forth.-ostreeSink :: (MonadError String m, MonadLoggerIO m, MonadResource m) => FilePath -> Consumer (Files, CS.Object) m ()+ostreeSink :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m, MonadResource m) => FilePath -> Consumer (Files, CS.Object) m () ostreeSink outPath = do -- While it's possible to copy objects from one OstreeRepo to another, we can't create our own objects, meaning -- we can't add the dirtree objects we would need to tie all of the files together. So to export to a new@@ -77,7 +78,7 @@ -- Add the standard hacks logDebugN "Running standard hacks"- runHacks tmpDir+ lift $ runHacks tmpDir -- Compile the locale-archive file let localeDir = tmpDir </> "usr" </> "lib" </> "locale"@@ -85,7 +86,7 @@ callProcessLogged "chroot" [tmpDir, "/usr/sbin/build-locale-archive"] -- Add the kernel and initramfs- installKernelInitrd tmpDir+ lift $ installKernelInitrd tmpDir -- Replace /etc/nsswitch.conf with the altfiles version logDebugN "Modifying /etc files"@@ -191,7 +192,7 @@ yield $ printf "d %s %#o %d %d - -" baseDirPath mode userId groupId - installKernelInitrd :: MonadLoggerIO m => FilePath -> m ()+ installKernelInitrd :: (MonadBaseControl IO m, MonadLoggerIO m) => FilePath -> m () installKernelInitrd exportDir = do -- The kernel and initramfs need to be named /boot/vmlinuz-<CHECKSUM> -- and /boot/initramfs-<CHECKSUM>, where CHECKSUM is the sha256@@ -212,19 +213,14 @@ logInfoN $ "Installing kernel " `T.append` T.pack kernel logInfoN $ "Installing initrd " `T.append` T.pack initramfs - -- FIXME: This one isn't getting logged, but withTempDirectory makes that hard. Using that- -- function means scattering MonadMask constraints around in bdcs and bdcs-api, which I'm not- -- sure if that's a good thing or not. Rewriting withTempDirectory to avoid that means using- -- bracket and the IO monad, and the types become very complicated.- liftIO $ withTempDirectory exportDir "dracut"- (\tmpDir -> callProcess "chroot"- [exportDir,- "dracut",- "--add", "ostree",- "--no-hostonly",- "--tmpdir=/" ++ takeFileName tmpDir,- "-f", "/boot/" ++ takeFileName initramfs,- kver])+ withTempDirectory' exportDir "dracut" $ \tmpDir ->+ callProcessLogged "chroot" [exportDir,+ "dracut",+ "--add", "ostree",+ "--no-hostonly",+ "--tmpdir=/" ++ takeFileName tmpDir,+ "-f", "/boot/" ++ takeFileName initramfs,+ kver] -- Append the checksum to the filenames kernelData <- liftIO $ BS.readFile kernel@@ -238,6 +234,14 @@ liftIO $ renameFile kernel (kernel ++ "-" ++ digest) liftIO $ renameFile initramfs (initramfs ++ "-" ++ digest) + -- This is like withTempDirectory from the temporary package, but without the requirement on+ -- MonadThrow and MonadMask. This allows logging the call to dracut like we do everything+ -- else without having to think about adding those constraints to quite a lot of code.+ withTempDirectory' :: (MonadBaseControl IO m, MonadLoggerIO m) => FilePath -> String -> (FilePath -> m a) -> m a+ withTempDirectory' target template = liftBaseOp $+ CEL.bracket (createTempDirectory target template)+ (\path -> removePathForcibly path `CEL.catch` (\(_ :: CEL.SomeException) -> return ()))+ renameDirs :: FilePath -> IO () renameDirs exportDir = do -- ostree mandates /usr/etc, and fails if /etc also exists.@@ -320,8 +324,8 @@ -- Given a commit, return the parent of it or Nothing if no parent exists. parentCommit :: IsRepo a => a -> T.Text -> IO (Maybe T.Text) parentCommit repo commitSum =- catch (Just <$> repoResolveRev repo commitSum False)- (\(_ :: SomeException) -> return Nothing)+ CEL.catch (Just <$> repoResolveRev repo commitSum False)+ (\(_ :: CEL.SomeException) -> return Nothing) -- Same as store, but takes a path to a directory to import storeDirectory :: IsRepo a => a -> FilePath -> IO File@@ -336,6 +340,6 @@ -- Returns the checksum of the commit. withTransaction :: IsRepo a => a -> (a -> IO b) -> IO b withTransaction repo fn =- bracket_ (repoPrepareTransaction repo noCancellable)- (repoCommitTransaction repo noCancellable)- (fn repo)+ CEL.bracket_ (repoPrepareTransaction repo noCancellable)+ (repoCommitTransaction repo noCancellable)+ (fn repo)
src/BDCS/Export/Qcow2.hs view
@@ -18,6 +18,8 @@ import Control.Monad.Except(MonadError) import Control.Monad.Logger(MonadLoggerIO, logDebugN)+import Control.Monad.Trans(lift)+import Control.Monad.Trans.Control(MonadBaseControl) import Control.Monad.Trans.Resource(MonadResource) import Data.Conduit(Consumer, bracketP) import System.Directory(removePathForcibly)@@ -32,7 +34,7 @@ -- | A 'Consumer' that writes objects into a temporary directory, and then converts that directory into -- a qcow2 image with virt-make-fs.-qcow2Sink :: (MonadError String m, MonadLoggerIO m, MonadResource m) => FilePath -> Consumer (Files, CS.Object) m ()+qcow2Sink :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m, MonadResource m) => FilePath -> Consumer (Files, CS.Object) m () qcow2Sink outPath = -- Writing and importing a tar file probably will not work, because some rpms contain paths -- with symlinks (e.g., /lib64/libaudit.so.1 is expected to be written to /usr/lib64).@@ -43,7 +45,7 @@ (\tmpDir -> do -- Apply tmpfiles.d to the directory first logDebugN "Running tmpfiles"- runTmpfiles tmpDir+ lift $ runTmpfiles tmpDir -- Run the sink to create a directory export logDebugN "Exporting to directory"@@ -51,7 +53,7 @@ -- Make the direcotry export something usable, hopefully logDebugN "Running standard hacks"- runHacks tmpDir+ lift $ runHacks tmpDir -- Run virt-make-fs to generate the qcow2 callProcessLogged "virt-make-fs" [tmpDir, outPath, "--format=qcow2", "--label=composer"]
src/BDCS/Export/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- |@@ -15,11 +16,14 @@ runTmpfiles) where -import Control.Conditional(whenM)+import Control.Conditional(ifM, whenM) import Control.Exception(tryJust)+import qualified Control.Exception.Lifted as CEL import Control.Monad(guard)+import Control.Monad.Except(MonadError, throwError) import Control.Monad.IO.Class(liftIO) import Control.Monad.Logger(MonadLoggerIO, logDebugN)+import Control.Monad.Trans.Control(MonadBaseControl) import Data.List(intercalate) import Data.List.Split(splitOn) import System.Directory(createDirectoryIfMissing, doesFileExist, listDirectory, removePathForcibly, renameFile)@@ -34,13 +38,23 @@ -- | Run filesystem hacks needed to make a directory tree bootable. Any exporter that produces a -- finished image should call this function. Otherwise, it is not generally useful and should be -- avoided. The exact hacks required is likely to change over time.-runHacks :: MonadLoggerIO m => FilePath -> m ()-runHacks exportPath = do+--+-- Any exceptions from 'Control.Exception' will be convered into 'Control.Monad.Except' style+-- exceptions, which can then be handled via catchError from that module.+runHacks :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m) => FilePath -> m ()+runHacks exportPath = runHacks' exportPath `CEL.catch` \e -> throwError $ show (e :: CEL.IOException)++-- 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' exportPath = do -- set a root password -- pre-crypted from "redhat" logDebugN "Setting root password" liftIO $ do- shadowRecs <- map (splitOn ":") <$> lines <$> readFile (exportPath </> "etc" </> "shadow")+ shadowRecs <- map (splitOn ":") <$> lines <$> ifM (doesFileExist (exportPath </> "etc" </> "shadow"))+ (readFile (exportPath </> "etc" </> "shadow"))+ (return "") let newRecs = map (\rec -> case rec of "root":_:rest -> ["root", "$6$3VLMX3dyCGRa.JX3$RpveyimtrKjqcbZNTanUkjauuTRwqAVzRK8GZFkEinbjzklo7Yj9Z6FqXNlyajpgCdsLf4FEQQKH6tTza35xs/"] ++ rest _ -> rec)@@ -82,7 +96,15 @@ -- | Run tmpfiles.d snippet on the new directory. Most exporters should call this function. Otherwise, -- it is not generally useful and should be avoided.-runTmpfiles :: MonadLoggerIO m => FilePath -> m ()-runTmpfiles exportPath = do+--+-- Any exceptions from 'Control.Exception' will be convered into 'Control.Monad.Except' style+-- exceptions, which can then be handled via catchError from that module.+runTmpfiles :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m) => FilePath -> m ()+runTmpfiles exportPath = runTmpfiles' exportPath `CEL.catch` \e -> throwError $ show (e :: CEL.IOException)++-- This is a helper for runTmpfiles that does all the hard work. It exists separately so the main+-- function can handle any exceptions without making a mess of the code.+runTmpfiles' :: MonadLoggerIO m => FilePath -> m ()+runTmpfiles' exportPath = do configPath <- liftIO $ getDataFileName "data/tmpfiles-default.conf" setupFilesystem exportPath configPath
src/BDCS/Utils/Process.hs view
@@ -15,6 +15,7 @@ module BDCS.Utils.Process(callProcessLogged) where +import Control.Monad(unless) import Control.Monad.IO.Class(liftIO) import Control.Monad.Logger(MonadLoggerIO, logInfoN, logErrorN) import qualified Data.Text as T@@ -27,7 +28,9 @@ callProcessLogged cmd args = do logInfoN $ T.intercalate " " $ T.pack cmd : map T.pack args (rc, stdout, stderr) <- liftIO $ readProcessWithExitCode cmd args ""- logInfoN $ T.pack stdout++ unless (T.null $ T.strip $ T.pack stdout) $+ logInfoN $ T.pack stdout case rc of ExitFailure x -> do logErrorN $ T.pack stderr
src/tools/inspect/Utils/Exceptions.hs view
@@ -3,7 +3,7 @@ import Control.Exception(Exception) -data InspectErrors = InvalidLabelError String+data InspectErrors = InvalidLabelError | MissingCSError | MissingDBError deriving(Eq, Show)
src/tools/inspect/subcommands/groups.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} import Control.Conditional(unlessM)-import Control.Exception(Handler(..), catches, throw)+import Control.Exception(Handler(..), catches, throwIO) import Control.Monad.Except(runExceptT) import Data.Aeson((.=), ToJSON, object, toJSON) import Data.Aeson.Encode.Pretty(encodePretty)@@ -117,7 +117,7 @@ Nothing -> usage Just (db, repo, args) -> do unlessM (doesFileExist db) $- throw MissingDBError+ throwIO MissingDBError result <- runCommand (T.pack db) repo args whenLeft result (\e -> print $ "error: " ++ e)
src/tools/inspect/subcommands/ls.hs view
@@ -5,15 +5,15 @@ {-# LANGUAGE ScopedTypeVariables #-} import Control.Conditional(unlessM)-import Control.Exception(Handler(..), catches, throw)+import Control.Exception(Handler(..), catches, throwIO) import Control.Monad(forM_)-import Control.Monad.Except(runExceptT)+import Control.Monad.Except(runExceptT, when) import Data.Aeson((.=), ToJSON, object, toJSON) import Data.Aeson.Encode.Pretty(encodePretty) import Data.ByteString.Lazy(toStrict) import Data.Conduit((.|), runConduit) import qualified Data.Conduit.List as CL-import Data.Maybe(catMaybes, fromMaybe, isJust, mapMaybe)+import Data.Maybe(catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import qualified Data.Text as T import Data.Text.Encoding(decodeUtf8) import Data.Time.Clock.POSIX(getCurrentTime, posixSecondsToUTCTime)@@ -23,6 +23,7 @@ import System.Environment(getArgs) import System.Exit(exitFailure) import Text.Printf(printf)+import Text.Read(readMaybe) import Text.Regex.PCRE((=~)) import BDCS.DB(Files(..), KeyVal(..), checkAndRunSqlite)@@ -116,6 +117,9 @@ runCommand db args = do (opts, _) <- compilerOpts options defaultLsOptions args "ls" + when (isNothing $ lsLabelMatches opts) $+ throwIO InvalidLabelError+ printer <- if | lsJSONOutput opts -> return $ liftedPutStrLn . jsonPrinter | lsVerbose opts -> do currentYear <- formatTime defaultTimeLocale "%Y" <$> getCurrentTime return $ liftedPutStrLn . verbosePrinter currentYear@@ -158,9 +162,7 @@ (NoArg (\opts -> opts { lsVerbose = True })) "use a long listing format", Option [] ["label"]- (ReqArg (\d opts -> case reads d :: [(Label, String)] of- [(lbl, _)] -> opts { lsLabelMatches = Just lbl }- _ -> throw $ InvalidLabelError d) "LABEL")+ (ReqArg (\d opts -> opts { lsLabelMatches = readMaybe d }) "LABEL") "return only results with the given LABEL", Option ['m'] ["matches"] (ReqArg (\d opts -> opts { lsMatches = d }) "REGEX")@@ -203,7 +205,7 @@ Nothing -> usage Just (db, _, args) -> do unlessM (doesFileExist db) $- throw MissingDBError+ throwIO MissingDBError result <- runCommand (T.pack db) args whenLeft result print@@ -215,8 +217,8 @@ where -- And then add handlers for the various kinds of InspectErrors here. handleInspectErrors :: InspectErrors -> IO ()- handleInspectErrors (InvalidLabelError lbl) = do- putStrLn $ lbl ++ " is not a recognized file label\n"+ handleInspectErrors InvalidLabelError = do+ putStrLn "Unrecognized file label given.\n" putStrLn "Recognized labels:\n" forM_ labelDescriptions $ \(l, d) -> putStrLn $ " " ++ l ++ " - " ++ d
src/tools/inspect/subcommands/nevras.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} import Control.Conditional(unlessM)-import Control.Exception(Handler(..), catches, throw)+import Control.Exception(Handler(..), catches, throwIO) import Control.Monad.Except(runExceptT) import Data.Conduit((.|), runConduit) import qualified Data.Conduit.List as CL@@ -65,7 +65,7 @@ Nothing -> usage Just (db, repo, args) -> do unlessM (doesFileExist db) $- throw MissingDBError+ throwIO MissingDBError result <- runCommand (T.pack db) repo args whenLeft result (\e -> print $ "error: " ++ e)