bdcs 0.2.4 → 0.3.0
raw patch · 20 files changed
+279/−125 lines, 20 files
Files
- ChangeLog.md +13/−0
- bdcs.cabal +5/−3
- src/BDCS/DB.hs +6/−0
- src/BDCS/Export.hs +8/−6
- src/BDCS/Export/Customize.hs +10/−4
- src/BDCS/Export/Directory.hs +2/−1
- src/BDCS/Export/FSTree.hs +2/−2
- src/BDCS/Export/Ostree.hs +69/−53
- src/BDCS/Export/Qcow2.hs +10/−6
- src/BDCS/Export/Tar.hs +3/−2
- src/BDCS/Export/TmpFiles.hs +13/−11
- src/BDCS/Export/Utils.hs +31/−21
- src/BDCS/Groups.hs +37/−0
- src/BDCS/Import/NPM.hs +5/−5
- src/BDCS/Import/RPM.hs +3/−3
- src/BDCS/Import/Repodata.hs +2/−3
- src/BDCS/RPM/Groups.hs +3/−3
- src/BDCS/Utils/Process.hs +36/−0
- src/tests/BDCS/GroupsSpec.hs +19/−1
- src/tools/bdcs-tmpfiles.hs +2/−1
ChangeLog.md view
@@ -1,3 +1,16 @@+## 0.3.0++* Add BDCS.Groups.getGroupsLike, which returns groups whose names match the+ % and _ SQL wildcards.+* Add BDCS.Groups.getGroupsTotal, which returns the number of groups in the+ database.+* Add BDCS.DB.firstListResult, which returns the first value from the+ non-empty result list of an SQL query.+* The types of many export-related functions have been modified to include a+ constraint on MonadLoggerIO.+* Debug logging added to exportAndCustomize, runCustomizations, ostreeSink,+ qcow2Sink, and runHacks.+ ## 0.2.4 * Allow building with aeson-1.3 and unordered-containers-0.2.9.
bdcs.cabal view
@@ -1,5 +1,5 @@ name: bdcs-version: 0.2.4+version: 0.3.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@@ -110,7 +110,8 @@ BDCS.Utils.Error, BDCS.Utils.Filesystem, BDCS.Utils.Mode,- BDCS.Utils.Monad+ BDCS.Utils.Monad,+ BDCS.Utils.Process, BDCS.Version build-depends: aeson >= 1.0.0.0 && < 1.4.0.0,@@ -334,7 +335,8 @@ build-depends: bdcs, base >= 4.9 && < 5.0,- directory >= 1.3.0.0 && < 1.4.0.0+ directory >= 1.3.0.0 && < 1.4.0.0,+ monad-logger >= 0.3.20.2 && < 0.3.28.2 default-language: Haskell2010
src/BDCS/DB.hs view
@@ -229,6 +229,12 @@ firstKeyResult query = listToMaybe . map unValue <$> query +-- | Run an SQL query, returning the first value from the result list.+-- Use this when you want a single index out of the database and it is guaranteed not to be empty.+firstListResult :: Monad m => m [Value a] -> m a+firstListResult query =+ head . map unValue <$> query+ -- | Like 'maybe', but for keys. If the key is nothing, return the default value. Otherwise, -- run the function on the key and return that value. maybeKey :: MonadIO m =>
src/BDCS/Export.hs view
@@ -20,7 +20,7 @@ import Control.Conditional(cond) import Control.Monad.Except(MonadError, runExceptT, throwError)-import Control.Monad.IO.Class(MonadIO, liftIO)+import Control.Monad.Logger(MonadLoggerIO, logDebugN) import Control.Monad.Trans.Resource(MonadBaseControl, MonadResource) import Data.Conduit(Consumer, (.|), runConduit, runConduitRes) import qualified Data.Conduit.List as CL@@ -42,10 +42,10 @@ import BDCS.Files(groupIdToFilesC) import BDCS.Groups(getGroupIdC) -export :: (MonadBaseControl IO m, MonadError String m, MonadResource m) => FilePath -> FilePath -> [T.Text] -> SqlPersistT m ()+export :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m, MonadResource m) => FilePath -> FilePath -> [T.Text] -> SqlPersistT m () export repo out_path things = exportAndCustomize repo out_path things [] -exportAndCustomize :: (MonadBaseControl IO m, MonadError String m, MonadResource m) => FilePath -> FilePath -> [T.Text] -> [Customization] -> SqlPersistT m ()+exportAndCustomize :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m, MonadResource m) => FilePath -> FilePath -> [T.Text] -> [Customization] -> SqlPersistT m () exportAndCustomize repo out_path things custom | kernelMissing out_path things = throwError "ERROR: ostree exports need a kernel package included" | otherwise = do let objectSink = cond [(".tar" `isSuffixOf` out_path, CS.objectToTarEntry .| Tar.tarSink out_path),@@ -66,13 +66,15 @@ runConduitRes $ fstreeSource fstree' .| filesToObjectsC overlay' cs .| objectSink where- directoryOutput :: (MonadError String m, MonadIO m) => FilePath -> Consumer (Files, CS.Object) m ()+ directoryOutput :: (MonadError String m, MonadLoggerIO m) => FilePath -> Consumer (Files, CS.Object) m () directoryOutput path = do -- Apply tmpfiles.d to the directory first- liftIO $ runTmpfiles path+ logDebugN "Running tmpfiles"+ runTmpfiles path Directory.directorySink path- liftIO $ runHacks path+ logDebugN "Running standard hacks"+ runHacks path kernelMissing :: FilePath -> [T.Text] -> Bool kernelMissing out lst = ".repo" `isSuffixOf` out && not (any ("kernel-" `T.isPrefixOf`) lst)
src/BDCS/Export/Customize.hs view
@@ -11,6 +11,7 @@ import Control.Monad(foldM) import Control.Monad.Except(MonadError) import Control.Monad.IO.Class(MonadIO)+import Control.Monad.Logger(MonadLogger, MonadLoggerIO, logDebugN) import Crypto.Hash(Digest, hash) import Crypto.Hash.Algorithms(Blake2b_256) import Data.ByteArray(convert)@@ -18,6 +19,7 @@ import Data.Conduit(Conduit, awaitForever, yield) import Data.ContentStore(ContentStore) import qualified Data.Map.Strict as Map+import qualified Data.Text as T import BDCS.CS(Object(..), fileToObjectC) import BDCS.DB(Files(..))@@ -38,8 +40,10 @@ Nothing -> fileToObjectC repo f Just obj -> yield (f, obj) -addToOverlay :: MonadError String m => CSOverlay -> FSTree -> Files -> Maybe BS.ByteString -> m (CSOverlay, FSTree)+addToOverlay :: (MonadError String m, MonadLogger m) => CSOverlay -> FSTree -> Files -> Maybe BS.ByteString -> m (CSOverlay, FSTree) addToOverlay overlay tree file content = do+ logDebugN $ T.pack "Adding to overlay: " `T.append` filesPath file+ -- If the file has content, create a hash of it and add the content to the overlay. -- The digest type doesn't need to match the content store, it just needs to be something we can -- use as a hash key.@@ -58,8 +62,10 @@ let digest = hash input :: Digest Blake2b_256 in convert digest -runCustomizations :: (MonadError String m, MonadIO m) => CSOverlay -> ContentStore -> FSTree -> [Customization] -> m (CSOverlay, FSTree)-runCustomizations overlay _repo tree customizations = foldM runCustomization (overlay, tree) customizations+runCustomizations :: (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 where- runCustomization :: MonadError String m => (CSOverlay, FSTree) -> Customization -> m (CSOverlay, FSTree)+ 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
@@ -21,6 +21,7 @@ import Control.Conditional(unlessM) import Control.Monad.Except(MonadError, throwError) import Control.Monad.IO.Class(MonadIO, liftIO)+import Control.Monad.Logger(MonadLoggerIO) import qualified Data.ByteString as BS import Data.Conduit(Consumer, awaitForever) import qualified Data.Text as T@@ -40,7 +41,7 @@ -- -- 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, MonadIO m) => FilePath -> Consumer (Files, CS.Object) m ()+directorySink :: (MonadError String m, MonadLoggerIO m) => FilePath -> Consumer (Files, CS.Object) m () directorySink outPath = awaitForever $ \case (f, CS.SpecialObject) -> checkoutSpecial f (f, CS.FileObject bs) -> checkoutFile f bs
src/BDCS/Export/FSTree.hs view
@@ -27,7 +27,7 @@ import Control.Conditional(whenM) import Control.Monad(foldM) import Control.Monad.Except(MonadError, throwError)-import Control.Monad.State(StateT, evalStateT, get, withStateT)+import Control.Monad.State(StateT, evalStateT, gets, withStateT) import Data.Conduit(Sink, Source, yield) import qualified Data.Conduit.List as CL import Data.List.Safe(init, last)@@ -123,7 +123,7 @@ -- symlink. Follow it, recurse on the symlink target -- check and increment the symlink level so we don't get stuck in a loop Symlink link -> do- whenM ((>= maxSymlinks) <$> get) $+ whenM (gets (>= maxSymlinks)) $ throwError $ "Too many levels of symbolic links while resolving " ++ T.unpack (filesPath object) linkZipper <- withStateT (+1) $ resolveSymlink zipper link findDirectory linkZipper xs
src/BDCS/Export/Ostree.hs view
@@ -24,6 +24,7 @@ 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.Resource(MonadResource, runResourceT) import Crypto.Hash(SHA256(..), hashInitWith, hashFinalize, hashUpdate) import qualified Data.ByteString as BS (readFile)@@ -46,6 +47,7 @@ import BDCS.Export.Directory(directorySink) import BDCS.Export.Utils(runHacks) import BDCS.Utils.Conduit(awaitWith)+import BDCS.Utils.Process(callProcessLogged) import Paths_bdcs(getDataFileName) @@ -56,7 +58,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, MonadIO m, MonadResource m) => FilePath -> Consumer (Files, CS.Object) m ()+ostreeSink :: (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@@ -66,64 +68,70 @@ -- (e.g., /lib64/libaudit.so.1) dst_repo <- liftIO $ open outPath - bracketP (createTempDirectory (takeDirectory outPath) "export")+ void $ bracketP (createTempDirectory (takeDirectory outPath) "export") removePathForcibly (\tmpDir -> do -- Run the sink to export to a directory+ logDebugN "Exporting to directory" directorySink tmpDir - liftIO $ do- -- Add the standard hacks- runHacks tmpDir+ -- Add the standard hacks+ logDebugN "Running standard hacks"+ runHacks tmpDir - -- Compile the locale-archive file- let localeDir = tmpDir </> "usr" </> "lib" </> "locale"- whenM (doesFileExist $ localeDir </> "locale-archive.tmpl")- (callProcess "chroot" [tmpDir, "/usr/sbin/build-locale-archive"])+ -- 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"] - -- Add the kernel and initramfs- installKernelInitrd tmpDir+ -- Add the kernel and initramfs+ installKernelInitrd tmpDir - -- Replace /etc/nsswitch.conf with the altfiles version- getDataFileName "data/nsswitch-altfiles.conf" >>= readFile >>= writeFile (tmpDir </> "etc" </> "nsswitch.conf")+ -- Replace /etc/nsswitch.conf with the altfiles version+ logDebugN "Modifying /etc files"+ liftIO $ getDataFileName "data/nsswitch-altfiles.conf" >>= readFile >>= writeFile (tmpDir </> "etc" </> "nsswitch.conf") - -- Remove the fstab stub- removeFile $ tmpDir </> "etc" </> "fstab"+ -- Remove the fstab stub+ liftIO $ removeFile $ tmpDir </> "etc" </> "fstab" - -- Move things around how rpm-ostree wants them- renameDirs tmpDir+ -- Move things around how rpm-ostree wants them+ liftIO $ renameDirs tmpDir - -- Enable some systemd service- doSystemd tmpDir+ -- Enable some systemd service+ logDebugN "Enabling systemd services"+ doSystemd tmpDir - -- Convert /var to a tmpfiles entry- convertVar tmpDir+ -- Convert /var to a tmpfiles entry+ logDebugN "Running tmpfiles and creating symlinks"+ liftIO $ convertVar tmpDir - -- Add more tmpfiles entries- let tmpfilesDir = tmpDir </> "usr" </> "lib" </> "tmpfiles.d"- getDataFileName "data/tmpfiles-ostree.conf" >>= readFile >>= writeFile (tmpfilesDir </> "weldr-ostree.conf")+ -- Add more tmpfiles entries+ let tmpfilesDir = tmpDir </> "usr" </> "lib" </> "tmpfiles.d"+ liftIO $ getDataFileName "data/tmpfiles-ostree.conf" >>= readFile >>= writeFile (tmpfilesDir </> "weldr-ostree.conf") - -- Replace a bunch of top-level directories with symlinks- replaceDirs tmpDir+ -- Replace a bunch of top-level directories with symlinks+ liftIO $ replaceDirs tmpDir - -- Create a /sysroot directory- createDirectory (tmpDir </> "sysroot")+ -- Create a /sysroot directory+ liftIO $ createDirectory (tmpDir </> "sysroot") - -- Replace /usr/local with a symlink for some reason+ -- Replace /usr/local with a symlink for some reason+ liftIO $ do removePathForcibly $ tmpDir </> "usr" </> "local" createSymbolicLink "../var/usrlocal" $ tmpDir </> "usr" </> "local" - -- rpm-ostree moves /var/lib/rpm to /usr/share/rpm. We don't have a rpmdb to begin- -- with, so create an empty one at /usr/share/rpm.- -- rpmdb treats every path as absolute- rpmdbDir <- makeAbsolute $ tmpDir </> "usr" </> "share" </> "rpm"- createDirectoryIfMissing True rpmdbDir- callProcess "rpmdb" ["--initdb", "--dbpath=" ++ rpmdbDir]+ -- rpm-ostree moves /var/lib/rpm to /usr/share/rpm. We don't have a rpmdb to begin+ -- with, so create an empty one at /usr/share/rpm.+ -- rpmdb treats every path as absolute+ rpmdbDir <- liftIO $ makeAbsolute $ tmpDir </> "usr" </> "share" </> "rpm"+ liftIO $ createDirectoryIfMissing True rpmdbDir+ callProcessLogged "rpmdb" ["--initdb", "--dbpath=" ++ rpmdbDir] - -- import the directory as a new commit- void $ withTransaction dst_repo $ \r -> do- f <- storeDirectory r tmpDir- commit r f "Export commit" Nothing)+ -- import the directory as a new commit+ logDebugN "Storing results as a new commit"+ liftIO $ withTransaction dst_repo $ \r -> do+ f <- storeDirectory r tmpDir+ commit r f "Export commit" Nothing) -- Regenerate the summary, necessary for mirroring repoRegenerateSummary dst_repo Nothing noCancellable@@ -183,7 +191,7 @@ yield $ printf "d %s %#o %d %d - -" baseDirPath mode userId groupId - installKernelInitrd :: FilePath -> IO ()+ installKernelInitrd :: 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@@ -192,7 +200,7 @@ let bootDir = exportDir </> "boot" -- Find a vmlinuz- file.- kernelList <- filter ("vmlinuz-" `isPrefixOf`) <$> listDirectory bootDir+ kernelList <- filter ("vmlinuz-" `isPrefixOf`) <$> liftIO (listDirectory bootDir) let (kernel, kver) = case kernelList of -- Using fromJust is fine here - we've ensured they all have that -- prefix with the filter above.@@ -201,7 +209,14 @@ -- Create the initramfs let initramfs = bootDir </> "initramfs-" ++ kver- withTempDirectory exportDir "dracut"+ 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",@@ -212,16 +227,16 @@ kver]) -- Append the checksum to the filenames- kernelData <- BS.readFile kernel- initramfsData <- BS.readFile initramfs+ kernelData <- liftIO $ BS.readFile kernel+ initramfsData <- liftIO $ BS.readFile initramfs let ctx = hashInitWith SHA256 let update1 = hashUpdate ctx kernelData let update2 = hashUpdate update1 initramfsData let digest = show $ hashFinalize update2 - renameFile kernel (kernel ++ "-" ++ digest)- renameFile initramfs (initramfs ++ "-" ++ digest)+ liftIO $ renameFile kernel (kernel ++ "-" ++ digest)+ liftIO $ renameFile initramfs (initramfs ++ "-" ++ digest) renameDirs :: FilePath -> IO () renameDirs exportDir = do@@ -261,20 +276,21 @@ createSymbolicLink "var/srv" (exportDir </> "srv") createSymbolicLink "sysroot/tmp" (exportDir </> "tmp") - doSystemd :: FilePath -> IO ()+ doSystemd :: MonadLoggerIO m => FilePath -> m () doSystemd exportDir = do let systemdDir = exportDir </> "usr" </> "etc" </> "systemd" </> "system"- createDirectoryIfMissing True systemdDir+ liftIO $ createDirectoryIfMissing True systemdDir -- Set the default target to multi-user- createSymbolicLink "/usr/lib/systemd/system/multi-user.target" $ systemdDir </> "default.target"+ liftIO $ createSymbolicLink "/usr/lib/systemd/system/multi-user.target" $ systemdDir </> "default.target" -- Add some services that look important- createDirectoryIfMissing True $ systemdDir </> "getty.target.wants"- createDirectoryIfMissing True $ systemdDir </> "local-fs.target.wants"+ liftIO $ do+ createDirectoryIfMissing True $ systemdDir </> "getty.target.wants"+ createDirectoryIfMissing True $ systemdDir </> "local-fs.target.wants" - createSymbolicLink "/usr/lib/systemd/system/getty@.service" $ systemdDir </> "getty.target.wants" </> "getty@tty1.service"- createSymbolicLink "/usr/lib/systemd/system/ostree-remount.service" $ systemdDir </> "local-fs.target.wants" </> "ostree-remount.service"+ createSymbolicLink "/usr/lib/systemd/system/getty@.service" $ systemdDir </> "getty.target.wants" </> "getty@tty1.service"+ createSymbolicLink "/usr/lib/systemd/system/ostree-remount.service" $ systemdDir </> "local-fs.target.wants" </> "ostree-remount.service" -- Write the commit metadata object to an opened ostree repo, given the results of calling store. This -- function also requires a commit subject and optionally a commit body. The subject and body are
src/BDCS/Export/Qcow2.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-} -- | -- Module: BDCS.Export.Qcow2@@ -16,22 +17,22 @@ where import Control.Monad.Except(MonadError)-import Control.Monad.IO.Class(MonadIO, liftIO)+import Control.Monad.Logger(MonadLoggerIO, logDebugN) import Control.Monad.Trans.Resource(MonadResource) import Data.Conduit(Consumer, bracketP) import System.Directory(removePathForcibly) import System.FilePath(takeDirectory) import System.IO.Temp(createTempDirectory)-import System.Process(callProcess) import qualified BDCS.CS as CS import BDCS.DB(Files) import BDCS.Export.Directory(directorySink) import BDCS.Export.Utils(runHacks, runTmpfiles)+import BDCS.Utils.Process(callProcessLogged) -- | A 'Consumer' that writes objects into a temporary directory, and then converts that directory into -- a qcow2 image with virt-make-fs.-qcow2Sink :: (MonadResource m, MonadIO m, MonadError String m) => FilePath -> Consumer (Files, CS.Object) m ()+qcow2Sink :: (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).@@ -41,14 +42,17 @@ removePathForcibly (\tmpDir -> do -- Apply tmpfiles.d to the directory first- liftIO $ runTmpfiles tmpDir+ logDebugN "Running tmpfiles"+ runTmpfiles tmpDir -- Run the sink to create a directory export+ logDebugN "Exporting to directory" directorySink tmpDir -- Make the direcotry export something usable, hopefully- liftIO $ runHacks tmpDir+ logDebugN "Running standard hacks"+ runHacks tmpDir -- Run virt-make-fs to generate the qcow2- liftIO $ callProcess "virt-make-fs" [tmpDir, outPath, "--format=qcow2", "--label=composer"]+ callProcessLogged "virt-make-fs" [tmpDir, outPath, "--format=qcow2", "--label=composer"] )
src/BDCS/Export/Tar.hs view
@@ -16,7 +16,8 @@ where import qualified Codec.Archive.Tar as Tar-import Control.Monad.IO.Class(MonadIO, liftIO)+import Control.Monad.Logger(MonadLoggerIO)+import Control.Monad.IO.Class(liftIO) import Data.ByteString.Lazy(writeFile) import Data.Conduit(Consumer) import qualified Data.Conduit.List as CL@@ -24,7 +25,7 @@ -- | A 'Consumer' that writes objects (in the form of 'Tar.Entry' records) into a tar archive -- with the provided name. To convert objects into an Entry, see 'BDCS.CS.objectToTarEntry'.-tarSink :: MonadIO m => FilePath -> Consumer Tar.Entry m ()+tarSink :: MonadLoggerIO m => FilePath -> Consumer Tar.Entry m () tarSink out_path = do entries <- CL.consume liftIO $ writeFile out_path (Tar.write entries)
src/BDCS/Export/TmpFiles.hs view
@@ -33,6 +33,8 @@ where import Control.Conditional(ifM)+import Control.Monad.IO.Class(liftIO)+import Control.Monad.Logger(MonadLoggerIO) import Data.List(sort) import qualified Data.Text as T import System.Directory(createDirectoryIfMissing, doesPathExist, removePathForcibly)@@ -193,8 +195,8 @@ -- Create a new directory if there isn't already one present. -- Also sets the ownership and permissions-applyEntry :: FilePath -> TmpFileEntry -> IO ()-applyEntry outPath TmpFileEntry{tfeType=NewDirectory, ..} = do+applyEntry :: MonadLoggerIO m => FilePath -> TmpFileEntry -> m ()+applyEntry outPath TmpFileEntry{tfeType=NewDirectory, ..} = liftIO $ do createDirectoryIfMissing True dir setFileMode dir mode setOwnerAndGroup dir (owner tfeUid) (group tfeGid)@@ -206,7 +208,7 @@ -- Create a new file with optional contents. -- Also sets the ownership and permissions-applyEntry outPath entry@TmpFileEntry{tfeType=NewFile, ..} =+applyEntry outPath entry@TmpFileEntry{tfeType=NewFile, ..} = liftIO $ ifM (doesPathExist file) (printf "NewFile: %s already exists, skipping it." file) (writeNewFile outPath entry)@@ -215,10 +217,10 @@ -- Create or Truncate a file with optional contents. -- Also sets the ownership and permissions-applyEntry outPath entry@TmpFileEntry{tfeType=TruncateFile, ..} = writeNewFile outPath entry+applyEntry outPath entry@TmpFileEntry{tfeType=TruncateFile, ..} = liftIO $ writeNewFile outPath entry -- Modify an existing directory's ownership and permissions>-applyEntry outPath TmpFileEntry{tfeType=ModifyDirectory, ..} =+applyEntry outPath TmpFileEntry{tfeType=ModifyDirectory, ..} = liftIO $ ifM (doesPathExist dir) modify (printf "ModifyDirectory: %s doesn't exist, skipping it." dir)@@ -235,7 +237,7 @@ -- Create a new symlink. -- Does NOT create parents of the source file, they must already exist -- If no target arg is present it will link to the source filename under /usr/share/factory/-applyEntry outPath TmpFileEntry{tfeType=NewSymlink, ..} =+applyEntry outPath TmpFileEntry{tfeType=NewSymlink, ..} = liftIO $ ifM (doesPathExist source) (printf "NewSymlink: %s exists, skipping." source) (createSymbolicLink target source)@@ -247,7 +249,7 @@ -- Replace a symlink, if it exists or create a new one. -- If no target arg is present it will link to the source filename under /usr/share/factory/-applyEntry outPath TmpFileEntry{tfeType=ReplaceSymlink, ..} = do+applyEntry outPath TmpFileEntry{tfeType=ReplaceSymlink, ..} = liftIO $ do removePathForcibly source createSymbolicLink target source where@@ -260,10 +262,10 @@ -- | Read the tmpfiles.d snippet and apply it to the output directory-setupFilesystem :: FilePath -> FilePath -> IO ()+setupFilesystem :: MonadLoggerIO m => FilePath -> FilePath -> m () setupFilesystem outPath tmpFileConf = do- createDirectoryIfMissing True outPath- tmpfiles <- parseConfString <$> readFile tmpFileConf+ liftIO $ createDirectoryIfMissing True outPath+ tmpfiles <- parseConfString <$> liftIO (readFile tmpFileConf) case tmpfiles of Right entries -> mapM_ (applyEntry outPath) $ sort entries- Left err -> print err+ Left err -> liftIO $ print err
src/BDCS/Export/Utils.hs view
@@ -19,64 +19,74 @@ import Control.Conditional(whenM) import Control.Exception(tryJust) import Control.Monad(guard)+import Control.Monad.IO.Class(liftIO)+import Control.Monad.Logger(MonadLoggerIO, logDebugN) import Data.List(intercalate) import Data.List.Split(splitOn) import qualified Data.Text as T import System.Directory(createDirectoryIfMissing, doesFileExist, listDirectory, removePathForcibly, renameFile) import System.FilePath((</>)) import System.IO.Error(isDoesNotExistError)-import System.Process(callProcess) import BDCS.Export.TmpFiles(setupFilesystem)+import BDCS.Utils.Process(callProcessLogged) import Paths_bdcs(getDataFileName) -- | 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 :: FilePath -> IO ()+runHacks :: MonadLoggerIO m => FilePath -> m () runHacks exportPath = do -- set a root password -- pre-crypted from "redhat"- shadowRecs <- map (splitOn ":") <$> lines <$> readFile (exportPath </> "etc" </> "shadow")- let newRecs = map (\rec -> case rec of- "root":_:rest -> ["root", "$6$3VLMX3dyCGRa.JX3$RpveyimtrKjqcbZNTanUkjauuTRwqAVzRK8GZFkEinbjzklo7Yj9Z6FqXNlyajpgCdsLf4FEQQKH6tTza35xs/"] ++ rest- _ -> rec)- shadowRecs- writeFile (exportPath </> "etc" </> "shadow.new") (unlines $ map (intercalate ":") newRecs)- renameFile (exportPath </> "etc" </> "shadow.new") (exportPath </> "etc" </> "shadow")+ logDebugN "Setting root password"+ liftIO $ do+ shadowRecs <- map (splitOn ":") <$> lines <$> readFile (exportPath </> "etc" </> "shadow")+ let newRecs = map (\rec -> case rec of+ "root":_:rest -> ["root", "$6$3VLMX3dyCGRa.JX3$RpveyimtrKjqcbZNTanUkjauuTRwqAVzRK8GZFkEinbjzklo7Yj9Z6FqXNlyajpgCdsLf4FEQQKH6tTza35xs/"] ++ rest+ _ -> rec)+ shadowRecs+ writeFile (exportPath </> "etc" </> "shadow.new") (unlines $ map (intercalate ":") newRecs)+ renameFile (exportPath </> "etc" </> "shadow.new") (exportPath </> "etc" </> "shadow") -- create an empty machine-id- writeFile (exportPath </> "etc" </> "machine-id") ""+ logDebugN "Creating empty /etc/machine-id"+ liftIO $ writeFile (exportPath </> "etc" </> "machine-id") "" -- Install a sysusers.d config file, and run systemd-sysusers to implement it let sysusersDir = exportPath </> "usr" </> "lib" </> "sysusers.d"- createDirectoryIfMissing True sysusersDir- getDataFileName "data/sysusers-default.conf" >>= readFile >>= writeFile (sysusersDir </> "weldr.conf")- callProcess "systemd-sysusers" ["--root", exportPath]+ liftIO $ do+ createDirectoryIfMissing True sysusersDir+ getDataFileName "data/sysusers-default.conf" >>= readFile >>= writeFile (sysusersDir </> "weldr.conf") + callProcessLogged "systemd-sysusers" ["--root", exportPath]+ -- Run depmod on any kernel modules that might be present let modDir = exportPath </> "usr" </> "lib" </> "modules"- modVers <- tryJust (guard . isDoesNotExistError) (listDirectory modDir)- mapM_ (\ver -> callProcess "depmod" ["-b", exportPath, "-a", ver]) $ either (const []) id modVers+ modVers <- liftIO $ tryJust (guard . isDoesNotExistError) (listDirectory modDir)+ mapM_ (\ver -> callProcessLogged "depmod" ["-b", exportPath, "-a", ver]) $ either (const []) id modVers -- Create a fstab stub- writeFile (exportPath </> "etc" </> "fstab") "LABEL=composer / ext2 defaults 0 0"+ logDebugN "Creating stub /etc/fstab"+ liftIO $ writeFile (exportPath </> "etc" </> "fstab") "LABEL=composer / ext2 defaults 0 0" -- Clean up /run -- Some packages create directories in /var/run, which a symlink to /run, which is a tmpfs.- (map ((exportPath </> "run") </>) <$> listDirectory (exportPath </> "run")) >>= mapM_ removePathForcibly+ logDebugN "Removing directories in /run"+ liftIO $ (map ((exportPath </> "run") </>) <$> listDirectory (exportPath </> "run")) >>= mapM_ removePathForcibly -- EXTRA HACKY: turn off mod_ssl let sslConf = exportPath </> "etc" </> "httpd" </> "conf.d" </> "ssl.conf"- whenM (doesFileExist sslConf)- (renameFile sslConf (sslConf ++ ".off"))+ whenM (liftIO $ doesFileExist sslConf) $ do+ logDebugN "Disabling mod_ssl"+ liftIO $ renameFile sslConf (sslConf ++ ".off") -- | 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 :: FilePath -> IO ()+runTmpfiles :: MonadLoggerIO m => FilePath -> m () runTmpfiles exportPath = do- configPath <- getDataFileName "data/tmpfiles-default.conf"+ configPath <- liftIO $ getDataFileName "data/tmpfiles-default.conf" setupFilesystem exportPath configPath -- | List the supported output formats.
src/BDCS/Groups.hs view
@@ -16,6 +16,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module BDCS.Groups(findGroupRequirements, findRequires,@@ -23,6 +24,8 @@ getGroupId, getGroupIdC, getGroup,+ getGroupsLike,+ getGroupsTotal, getGroupRequirements, getRequirementsForGroup, groups,@@ -38,6 +41,7 @@ import Data.Bifunctor(bimap) import Data.Conduit((.|), Conduit, Source) import qualified Data.Conduit.List as CL+import Data.Int(Int64) import qualified Data.Text as T import Database.Esqueleto @@ -100,6 +104,39 @@ where_ $ group ^. GroupsId ==. val key limit 1 return group++-- | Get the groups matching a name+-- Optionally limit the results with limit and offset+-- Also returns the total number of results, before offset and limit are applied+getGroupsLike :: MonadIO m => Maybe Int64 -> Maybe Int64 -> T.Text -> SqlPersistT m ([(Key Groups, T.Text)], Int64)+getGroupsLike (Just ofst) (Just lmt) name = do+ results <- select $ from $ \group -> do+ where_ $ group ^. GroupsName `like` val name+ orderBy [asc (group ^. GroupsName)]+ offset ofst+ limit lmt+ return (group ^. GroupsId, group ^. GroupsName)+ total <- firstListResult $+ select $ from $ \group -> do+ where_ $ group ^. GroupsName `like` val name+ return countRows+ return (map (bimap unValue unValue) results, total)++getGroupsLike _ _ name = do+ results <- select $ from $ \group -> do+ where_ $ group ^. GroupsName `like` val name+ orderBy [asc (group ^. GroupsName)]+ return (group ^. GroupsId, group ^. GroupsName)+ total <- firstListResult $+ select $ from $ \group -> do+ where_ $ group ^. GroupsName `like` val name+ return countRows+ return (map (bimap unValue unValue) results, total)++-- | Return the total number of groups+getGroupsTotal :: MonadIO m => SqlPersistT m Int64+getGroupsTotal = firstListResult $+ select . from $ \(_ :: SqlExpr (Entity Groups)) -> return countRows groups :: MonadIO m => SqlPersistT m [(Key Groups, T.Text)] groups = do
src/BDCS/Import/NPM.hs view
@@ -21,8 +21,8 @@ import Control.Monad.Catch(MonadThrow) import Control.Monad.Except(MonadError, runExceptT, throwError) import Control.Monad.IO.Class(MonadIO, liftIO)-import Control.Monad.Reader(ReaderT, ask)-import Control.Monad.State(MonadState, get, modify)+import Control.Monad.Reader(ReaderT, asks)+import Control.Monad.State(MonadState, gets, modify) import Control.Monad.Trans.Resource(MonadBaseControl, MonadResource) import Data.Aeson(FromJSON(..), Object, Value(..), (.:), (.:?), (.!=), eitherDecode, withObject, withText) import Data.Aeson.Types(Parser, typeMismatch)@@ -253,8 +253,8 @@ -- screen. loadFromURI :: URI -> ReaderT ImportState IO () loadFromURI uri@URI{..} = do- db <- stDB <$> ask- repo <- stRepo <$> ask+ db <- asks stDB+ repo <- asks stRepo result <- runExceptT $ do -- Fetch the JSON describing the package@@ -356,7 +356,7 @@ handleHardLink baseFile = do -- Use the same ByteString -> FilePath unpacking that headerFilePath uses target <- S8.unpack <$> CC.fold- (HM.lookup target <$> get) >>=+ gets (HM.lookup target) >>= maybe (throwError $ "Broken hard link to " ++ target) (\(digest, size) -> return $ baseFile {filesSize = fromIntegral size, filesCs_object = Just $ convert digest})
src/BDCS/Import/RPM.hs view
@@ -30,7 +30,7 @@ import Control.Monad(guard, void) import Control.Monad.Except import Control.Monad.IO.Class(liftIO)-import Control.Monad.Reader(ReaderT, ask)+import Control.Monad.Reader(ReaderT, asks) import Control.Monad.Trans(lift) import Control.Monad.Trans.Control(MonadBaseControl) import Control.Monad.Trans.Resource(MonadResource, MonadThrow)@@ -197,8 +197,8 @@ -- screen. loadFromURI :: URI -> ReaderT ImportState IO () loadFromURI uri = do- db <- stDB <$> ask- repo <- stRepo <$> ask+ db <- asks stDB+ repo <- asks stRepo result <- runExceptT $ runConduitRes $ getFromURI uri
src/BDCS/Import/Repodata.hs view
@@ -21,6 +21,7 @@ import Control.Applicative((<|>)) import Control.Exception(Exception, throw)+import Control.Monad(forM_) import Control.Monad.IO.Class(MonadIO) import Control.Monad.Reader(ReaderT) import Control.Monad.Trans.Resource(MonadBaseControl, MonadThrow)@@ -99,9 +100,7 @@ -- Try group_gz, then group. If neither exists group will be Nothing, which is fine, just skip it let group = extractType repomd "group_gz" <|> extractType repomd "group" let groupURI = fmap appendOrThrow group- case groupURI of- Just u -> Comps.loadFromURI u- Nothing -> return ()+ forM_ groupURI Comps.loadFromURI where appendOrThrow :: T.Text -> URI
src/BDCS/RPM/Groups.hs view
@@ -19,7 +19,7 @@ import Control.Conditional((<&&>), whenM) import Control.Monad(forM_, when) import Control.Monad.IO.Class(MonadIO)-import Control.Monad.State(State, execState, get, modify)+import Control.Monad.State(State, execState, gets, modify) import Data.Bits(testBit) import Data.Maybe(isJust) import qualified Data.Text as T@@ -89,7 +89,7 @@ when (flags `testBit` 13) (modify (RT.ScriptVerify:)) -- Check for a bare RPMSENSE_INTERP- whenM ((null <$> get) <&&> return (flags `testBit` 8)) $ do+ whenM (gets null <&&> 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:))@@ -101,7 +101,7 @@ when (flags `testBit` 24) (modify (RT.Feature:)) -- If nothing else set, return Runtime- whenM (null <$> get) (modify (RT.Runtime:))+ whenM (gets null) (modify (RT.Runtime:)) withPRCO :: Monad m => T.Text -> [Tag] -> ((Word32, T.Text) -> m a) -> m () withPRCO ty tags fn =
+ src/BDCS/Utils/Process.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: BDCS.Utils.Process+-- Copyright: (c) 2018 Red Hat, Inc.+-- License: LGPL+--+-- Maintainer: https://github.com/weldr+-- Stability: alpha+-- Portability: portable+--+-- Functions for running external commands with logging.++module BDCS.Utils.Process(callProcessLogged)+ where++import Control.Monad.IO.Class(liftIO)+import Control.Monad.Logger(MonadLoggerIO, logInfoN, logErrorN)+import qualified Data.Text as T+import GHC.IO.Exception(IOErrorType(..))+import System.Exit(ExitCode(..))+import System.IO.Error(mkIOError)+import System.Process(readProcessWithExitCode)++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 ""+ logInfoN $ T.pack stdout++ case rc of+ ExitFailure x -> do logErrorN $ T.pack stderr+ liftIO $ ioError (mkIOError OtherError (cmd ++ unwords args ++ " (" ++ show x ++ ")")+ Nothing Nothing)+ _ -> return ()
src/tests/BDCS/GroupsSpec.hs view
@@ -20,7 +20,7 @@ where import BDCS.DB(Groups(..))-import BDCS.Groups(groupIdToNevra, nevraToGroupId)+import BDCS.Groups(groupIdToNevra, nevraToGroupId, getGroupsLike, getGroupsTotal, groups) import BDCS.GroupKeyValue(insertGroupKeyValue) import BDCS.KeyType(KeyType(..)) @@ -69,6 +69,24 @@ it "groupIdToNevra, no epoch" $ withNevras (groupIdToNevra $ toSqlKey 2) >>= (`shouldBe` Just "noEpoch-1.0-1.el7.x86_64")++ it "getGroupsLike with % wildcard" $+ withNevras (getGroupsLike Nothing Nothing "%Epoch%") >>= (`shouldBe` ([(toSqlKey 1, "hasEpoch"), (toSqlKey 2, "noEpoch")], 2))++ it "getGroupsLike without % wildcard returns empty list" $+ withNevras (getGroupsLike Nothing Nothing "Epoch") >>= (`shouldBe` ([], 0))++ it "getGroupsLike with % and limited to 2" $+ withNevras (getGroupsLike (Just 0) (Just 1) "%") >>= (`shouldBe` ([(toSqlKey 1, "hasEpoch")], 2))++ it "getGroupsLike with % and offset of 1" $+ withNevras (getGroupsLike (Just 1) (Just 10) "%") >>= (`shouldBe` ([(toSqlKey 2, "noEpoch")], 2))++ it "groups returns all existing records" $+ withNevras groups >>= (`shouldBe` [(toSqlKey 1, "hasEpoch"), (toSqlKey 2, "noEpoch")])++ it "getGroupsTotal" $+ withNevras getGroupsTotal >>= (`shouldBe` 2) where addNevras :: MonadIO m => SqlPersistT m ()
src/tools/bdcs-tmpfiles.hs view
@@ -15,6 +15,7 @@ -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, see <http://www.gnu.org/licenses/>. +import Control.Monad.Logger(runNoLoggingT) import System.Directory(createDirectoryIfMissing) import System.Environment(getArgs) import System.Exit(exitFailure)@@ -33,5 +34,5 @@ main :: IO () main = getArgs >>= \case cfg:dir:_ -> do createDirectoryIfMissing True dir- setupFilesystem dir cfg+ runNoLoggingT $ setupFilesystem dir cfg _ -> usage