diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,14 @@ +## 0.2.2 + +* Add BDCS.CS.fileToObjectC, which, when used as part of a conduit, fetches + the data for a single file from a ContentStore. +* Add BDCS.Export.Customize, which provides types and functions for modifying + the data exported from a ContentStore. +* Add BDCS.Export.exportAndCustomize, which includes Customization data in an + export. +* Include schema.sql in the data-files. +* Bug fixes related to FSTree and symlinks. + ## 0.2.1 * Add BDCS.Export.export, which is the bulk of the "bdcs export" command diff --git a/bdcs.cabal b/bdcs.cabal --- a/bdcs.cabal +++ b/bdcs.cabal @@ -1,5 +1,5 @@ name: bdcs -version: 0.2.1 +version: 0.2.2 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 @@ -10,16 +10,13 @@ category: Distribution author: Chris Lumens maintainer: clumens@redhat.com -license: LGPL +license: LGPL-2.1 license-file: LICENSE build-type: Custom cabal-version: >= 1.10 -data-dir: data -data-files: sysusers-default.conf, - tmpfiles-default.conf, - tmpfiles-ostree.conf, - nsswitch-altfiles.conf +data-files: schema.sql, + data/*.conf extra-source-files: ChangeLog.md, Dockerfile, @@ -30,7 +27,6 @@ Makefile, queries, README.md - schema.sql, src/tests/*.hs, src/tests/BDCS/*.hs, src/tests/BDCS/Export/*.hs, @@ -61,6 +57,7 @@ BDCS.Depsolve, BDCS.Exceptions, BDCS.Export, + BDCS.Export.Customize, BDCS.Export.Directory, BDCS.Export.FSTree, BDCS.Export.Qcow2, @@ -119,18 +116,18 @@ build-depends: aeson >= 1.0.0.0 && < 1.3.0.0, base >= 4.9 && < 5.0, bytestring >= 0.10 && < 0.11, - codec-rpm >= 0.2.0 && < 0.3, + codec-rpm >= 0.2.1 && < 0.3, cond >= 0.4.1.1 && < 0.5.0.0, conduit >= 1.2.8 && < 1.3, conduit-combinators >= 1.1.0 && < 1.2, conduit-extra >= 1.1.0 && < 1.3, containers >= 0.5.7.1 && < 0.6, - content-store >= 0.2.0 && < 0.3.0, + content-store >= 0.2.1 && < 0.3.0, cpio-conduit >= 0.7.0 && < 0.8.0, cryptonite >= 0.22 && < 0.30, directory >= 1.3.0.0 && < 1.4.0.0, esqueleto >= 2.5.3 && < 2.6.0, - exceptions >= 0.8.0 && < 0.9.0, + exceptions >= 0.8.0 && < 0.11.0, filepath >= 1.4.1.1 && < 1.5.0.0, gi-gio >= 2.0.14 && < 2.1.0, gi-glib >= 2.0.14 && < 2.1.0, @@ -140,7 +137,7 @@ 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, - monad-logger >= 0.3.20.2 && < 0.4.0, + monad-logger >= 0.3.20.2 && < 0.3.28.2, mtl >= 2.2.1 && < 2.3, network-uri >= 2.6.0 && < 2.7.0, parsec >= 3.1.10 && < 3.2.0, @@ -369,7 +366,7 @@ aeson >= 1.0.0.0 && < 1.3.0.0, base >= 4.8 && < 5.0, bytestring >= 0.10 && < 0.11, - codec-rpm >= 0.2.0 && < 0.3, + codec-rpm >= 0.2.1 && < 0.3, cond >= 0.4.1.1 && < 0.5.0.0, conduit >= 1.2.8 && < 1.3, conduit-combinators >= 1.1.0 && < 1.2, @@ -380,7 +377,7 @@ gi-gio >= 2.0.14 && < 2.1.0, gi-glib >= 2.0.14 && < 2.1.0, listsafe >= 0.1.0.1 && < 0.2.0, - monad-logger >= 0.3.20.2 && < 0.4.0, + monad-logger >= 0.3.20.2 && < 0.3.28.2, mtl >= 2.2.1 && < 2.3, parsec >= 3.1.10 && < 3.2.0, parsec-numbers >= 0.1.0 && < 0.2.0, diff --git a/src/BDCS/CS.hs b/src/BDCS/CS.hs --- a/src/BDCS/CS.hs +++ b/src/BDCS/CS.hs @@ -18,6 +18,7 @@ -- Conduit-based interface between BDCS and its underlying content store. module BDCS.CS(Object(..), + fileToObjectC, filesToObjectsC, objectToTarEntry) where @@ -44,12 +45,10 @@ -- by a 'Files' record so its metadata can be tracked | FileObject BS.ByteString -- ^ A file object with its contents --- | Read 'Files' records from a 'Conduit', find the object in the content store, and return the --- matching 'Object' if found. An error is thrown if the object does not exist, or if there is --- any other error interacting with the content store. In addition, the 'Files' object is also --- returned as part of the result tuple so its metadata can be used by downstream consumers. -filesToObjectsC :: (MonadError String m, MonadIO m) => ContentStore -> Conduit Files m (Files, Object) -filesToObjectsC repo = awaitForever $ \f@Files{..} -> +-- | For a given 'Files' record, find the object in the content store, and return the corresponding object. +-- This is a version of 'filesToObjectsC' suitable as an argument for 'awaitForever'. +fileToObjectC :: (MonadError String m, MonadIO m) => ContentStore -> Files -> Conduit Files m (Files, Object) +fileToObjectC repo f@Files{..} = let isRegular = fromIntegral filesMode `intersectFileModes` fileTypeModes == regularFileMode in case (isRegular, filesCs_object) of -- Not a regular file @@ -61,6 +60,13 @@ liftIO (runCsMonad $ fetchByteString repo digest) >>= \case Left e -> throwError (show e) Right obj -> yield (f, FileObject obj) + +-- | Read 'Files' records from a 'Conduit', find the object in the content store, and return the +-- matching 'Object' if found. An error is thrown if the object does not exist, or if there is +-- any other error interacting with the content store. In addition, the 'Files' object is also +-- returned as part of the result tuple so its metadata can be used by downstream consumers. +filesToObjectsC :: (MonadError String m, MonadIO m) => ContentStore -> Conduit Files m (Files, Object) +filesToObjectsC repo = awaitForever (fileToObjectC repo) -- | Read tuples from a 'Conduit' and convert each into a 'Codec.Archive.Tar.Entry' suitable for -- streaming into an archive. Metadata such as permissions and ownerships will be set correctly. diff --git a/src/BDCS/Export.hs b/src/BDCS/Export.hs --- a/src/BDCS/Export.hs +++ b/src/BDCS/Export.hs @@ -14,7 +14,8 @@ -- -- Top-level function for exporting objects from the BDCS. -module BDCS.Export(export) +module BDCS.Export(export, + exportAndCustomize) where import Control.Conditional(cond) @@ -22,15 +23,17 @@ import Control.Monad.IO.Class(MonadIO, liftIO) import Control.Monad.Trans.Resource(MonadBaseControl, MonadResource) import Data.Conduit(Consumer, (.|), runConduit, runConduitRes) -import Data.Conduit.List as CL +import qualified Data.Conduit.List as CL import Data.ContentStore(openContentStore) import Data.List(isSuffixOf) +import qualified Data.Map.Strict as Map import qualified Data.Text as T import Database.Esqueleto(SqlPersistT) import qualified BDCS.CS as CS import BDCS.DB(Files) import qualified BDCS.Export.Directory as Directory +import BDCS.Export.Customize(Customization, filesToObjectsC, runCustomizations) import BDCS.Export.FSTree(filesToTree, fstreeSource) import qualified BDCS.Export.Ostree as Ostree import qualified BDCS.Export.Qcow2 as Qcow2 @@ -39,9 +42,12 @@ import BDCS.Files(groupIdToFilesC) import BDCS.Groups(getGroupIdC) -export :: (MonadBaseControl IO m, MonadError String m, MonadIO m, MonadResource m) => FilePath -> FilePath -> [T.Text] -> SqlPersistT m () -export repo out_path things | kernelMissing out_path things = throwError "ERROR: ostree exports need a kernel package included" - | otherwise = do +export :: (MonadBaseControl IO m, MonadError String 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 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), (".qcow2" `isSuffixOf` out_path, Qcow2.qcow2Sink out_path), (".repo" `isSuffixOf` out_path, Ostree.ostreeSink out_path), @@ -54,7 +60,11 @@ .| getGroupIdC .| groupIdToFilesC .| filesToTree - runConduitRes $ fstreeSource fstree .| CS.filesToObjectsC cs .| objectSink + + let overlay = Map.empty + (overlay', fstree') <- runCustomizations overlay cs fstree custom + + runConduitRes $ fstreeSource fstree' .| filesToObjectsC overlay' cs .| objectSink where directoryOutput :: (MonadError String m, MonadIO m) => FilePath -> Consumer (Files, CS.Object) m () directoryOutput path = do diff --git a/src/BDCS/Export/Customize.hs b/src/BDCS/Export/Customize.hs new file mode 100644 --- /dev/null +++ b/src/BDCS/Export/Customize.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +module BDCS.Export.Customize(CSOverlay, + Customization(..), + addToOverlay, + filesToObjectsC, + runCustomizations) + where + +import Control.Monad(foldM) +import Control.Monad.Except(MonadError) +import Control.Monad.IO.Class(MonadIO) +import Crypto.Hash(Digest, hash) +import Crypto.Hash.Algorithms(Blake2b_256) +import Data.ByteArray(convert) +import qualified Data.ByteString as BS +import Data.Conduit(Conduit, awaitForever, yield) +import Data.ContentStore(ContentStore) +import qualified Data.Map.Strict as Map + +import BDCS.CS(Object(..), fileToObjectC) +import BDCS.DB(Files(..)) +import BDCS.Export.FSTree(FSTree, addFileToTree) + +type CSOverlay = Map.Map BS.ByteString Object + +-- Just one type of customization for now, more to come later +{-# ANN module "HLint: ignore Use newtype instead of data" #-} +data Customization = WriteFile Files (Maybe BS.ByteString) + deriving (Eq, Show) + +-- Not everything looks good as an operator, hlint +{-# ANN filesToObjectsC "HLint: ignore Use section" #-} +filesToObjectsC :: (MonadError String m, MonadIO m) => CSOverlay -> ContentStore -> Conduit Files m (Files, Object) +filesToObjectsC overlay repo = awaitForever $ \f@Files{..} -> + case maybe Nothing (flip Map.lookup overlay) filesCs_object of + Nothing -> fileToObjectC repo f + Just obj -> yield (f, obj) + +addToOverlay :: MonadError String m => CSOverlay -> FSTree -> Files -> Maybe BS.ByteString -> m (CSOverlay, FSTree) +addToOverlay overlay tree file content = do + -- 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. + let (newFile, newOverlay) = case content of + Nothing-> (file{filesCs_object = Nothing}, overlay) + Just c -> let digest = makeDigest c + in (file{filesCs_object = Just digest}, Map.insert digest (FileObject c) overlay) + + -- Add the metadata to the FSTree + newTree <- addFileToTree True tree newFile + + return (newOverlay, newTree) + where + makeDigest :: BS.ByteString -> BS.ByteString + makeDigest input = + 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 + where + runCustomization :: MonadError String m => (CSOverlay, FSTree) -> Customization -> m (CSOverlay, FSTree) + runCustomization (o, t) (WriteFile file content) = addToOverlay o t file content diff --git a/src/BDCS/Export/FSTree.hs b/src/BDCS/Export/FSTree.hs --- a/src/BDCS/Export/FSTree.hs +++ b/src/BDCS/Export/FSTree.hs @@ -19,6 +19,7 @@ module BDCS.Export.FSTree(FSEntry, FSTree, + addFileToTree, filesToTree, fstreeSource) where @@ -26,7 +27,7 @@ import Control.Conditional(whenM) import Control.Monad(foldM) import Control.Monad.Except(MonadError, throwError) -import Control.Monad.State(StateT, evalStateT, get, modify, withStateT) +import Control.Monad.State(StateT, evalStateT, get, withStateT) import Data.Conduit(Sink, Source, yield) import qualified Data.Conduit.List as CL import Data.List.Safe(init, last) @@ -61,10 +62,16 @@ -- Create an empty tree. This tree starts one level above "/" rootTree = Node{rootLabel=("", Nothing), subForest=[]} in - CL.foldM addFileToTree rootTree + CL.foldM (addFileToTree False) rootTree -addFileToTree :: MonadError String m => FSTree -> Files -> m FSTree -addFileToTree root object = do +-- | Add a 'Files' object to a 'FSTree'. Will optionally replace existing paths, or throw an error. +-- This function cannot replace a directory with a regular file, or vice versa. +addFileToTree :: MonadError String m => + Bool -- ^ Whether to replace the file if the path already exists + -> FSTree -- ^ The original tree + -> Files -- ^ The file to add + -> m FSTree +addFileToTree replace root object = do let rootZipper = (root, []) let pathComponents = splitDirectories $ T.unpack $ filesPath object @@ -76,7 +83,7 @@ -- Wrap the new file in a tree node and add it to the directory let newEntry = Node (lastComponent, Just object) [] - getTree <$> evalStateT (addEntryToTree dirZipper newEntry) 0 + getTree <$> addEntryToTree dirZipper newEntry where -- Given a directory path, split into components, return a new zipper focused on this path -- If the directory or any parent directories do not exist, create placeholders for them @@ -136,7 +143,7 @@ findDirectory startZipper pathComponents - addEntryToTree :: MonadError String m => FSZipper -> FSTree -> StateT Int m FSZipper + addEntryToTree :: MonadError String m => FSZipper -> FSTree -> m FSZipper addEntryToTree zipper newEntry = do -- At this point, we have a directory to stick the new entry into, and the first thing to do is see -- if the directory already contains an entry with the same name. If it does: @@ -152,8 +159,6 @@ -- - The existing entry is a directory: -- * are we adding a placeholder? Add the new placeholder's children to the existing directory. -- * otherwise, conflict - -- - The existing entry is a symlink: - -- * Resolve the symlink target, add the new entry as a child of the target -- -- The scenarios that involve adding new placeholders may seem a little odd, but they can arise -- when moving things around due to replacing placeholder directories with symlinks. @@ -187,44 +192,61 @@ -- The context for relative links is the directory, so one level above the new symlink (Placeholder, Symlink s) -> do let newZipper = (newEntry, crumbs) - targetZipper <- withStateT (+1) $ resolveSymlink (goUp newZipper) s + targetZipper <- evalStateT (resolveSymlink (goUp newZipper) s) 0 addChildren targetZipper self + -- Attempting to replace a placeholder directory with a regular file, that's an error (Placeholder, _) -> throwError $ "Unable to add " ++ T.unpack (filesPath object) ++ ", directory added at path" + -- existing directory, new placeholder. Leave the directory, but take the placeholder's children (Directory _, Placeholder) -> addChildren existing newEntry - -- Allow this if the same Files object is being added twice - (Directory d1, Directory d2) -> if compareDirs d1 d2 then addChildren existing newEntry - else throwError $ "Unable to add " ++ T.unpack (filesPath object) ++ - ", file already added at this location" + -- Replacing a directory with a directory, only valid if the Files objects are the same + -- or if "replace" is true. + (Directory d1, Directory d2) -> if | compareDirs d1 d2 -> addChildren existing newEntry + | replace -> addChildren (newEntry, crumbs) self + | otherwise -> throwError $ "Unable to add " ++ + T.unpack (filesPath object) ++ + ", directory already added at this location" (Directory _, _) -> throwError $ "Unable to to add " ++ T.unpack (filesPath object) ++ - ", file already added at this location" + ", directory already added at this location" - -- Follow the symlink, and repeat addEntryToTree with the symlink target as the new directory - -- to add into. - (Symlink s, _) -> do - -- Check and increment the link count - whenM ((>= maxSymlinks) <$> get) $ - throwError $ "Too many levels of symbolic links while resolving " ++ T.unpack (filesPath object) - modify (+1) + -- Allow a symlink to be added twice if it's the same symlink + (Symlink s1, Symlink s2) -> if compareLinks s1 s2 then return existing + else throwError $ "Unable to add " ++ T.unpack (filesPath object) ++ + ", symlink already added at this location" - targetZipper <- resolveSymlink zipper s - addEntryToTree targetZipper newEntry + -- Follow the symlink, and move the placeholder's children to the destination directory + (Symlink s, Placeholder) -> do + targetZipper <- evalStateT (resolveSymlink zipper s) 0 + addChildren targetZipper newEntry - -- Otherwise, we have two non-directory, non-placeholder files, see if they match - _ -> if self == newEntry then return existing - else throwError $ "Unable to add " ++ T.unpack (filesPath object) ++ - ", file already added at this location" + -- Replacing a file with a directory, no good + (Other _, Directory _) -> throwError $ "Unable to add " ++ T.unpack (filesPath object) ++ + ", file already added at this location" + (Other _, Placeholder) -> throwError $ "Unable to add " ++ T.unpack (filesPath object) ++ + ", file already added at this location" - addChildren :: MonadError String m => FSZipper -> FSTree -> StateT Int m FSZipper + -- Otherwise, we have two non-directory, non-placeholder files, see if they match, + -- or if we should explicitly replace. + _ -> if | self == newEntry -> return existing + | replace -> return (newEntry, crumbs) + | otherwise -> throwError $ "Unable to add " ++ + T.unpack (filesPath object) ++ + ", file already added at this location" + + addChildren :: MonadError String m => FSZipper -> FSTree -> m FSZipper addChildren dirZipper newEntry = foldM (\z e -> goUp <$> addEntryToTree z e) dirZipper (subForest newEntry) -- Compare files, ignoring size and mtime, because the data for these is basically made up compareDirs :: Files -> Files -> Bool compareDirs f1 f2 = f1{filesMtime=0, filesSize=0} == f2{filesMtime=0, filesSize=0} + + -- For symlinks, the only parts that count are the path and the target + compareLinks :: Files -> Files -> Bool + compareLinks f1 f2 = (filesPath f1 == filesPath f2) && (filesTarget f1 == filesTarget f2) -- Walk a tree and emit the Files entries in order, modifying the paths as we go -- to match the final, symlink-resolved results 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 @@ -85,7 +85,7 @@ installKernelInitrd tmpDir -- Replace /etc/nsswitch.conf with the altfiles version - getDataFileName "nsswitch-altfiles.conf" >>= readFile >>= writeFile (tmpDir "etc" "nsswitch.conf") + getDataFileName "data/nsswitch-altfiles.conf" >>= readFile >>= writeFile (tmpDir "etc" "nsswitch.conf") -- Remove the fstab stub removeFile $ tmpDir "etc" "fstab" @@ -101,7 +101,7 @@ -- Add more tmpfiles entries let tmpfilesDir = tmpDir "usr" "lib" "tmpfiles.d" - getDataFileName "tmpfiles-ostree.conf" >>= readFile >>= writeFile (tmpfilesDir "weldr-ostree.conf") + getDataFileName "data/tmpfiles-ostree.conf" >>= readFile >>= writeFile (tmpfilesDir "weldr-ostree.conf") -- Replace a bunch of top-level directories with symlinks replaceDirs tmpDir 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 @@ -52,7 +52,7 @@ -- Install a sysusers.d config file, and run systemd-sysusers to implement it let sysusersDir = exportPath "usr" "lib" "sysusers.d" createDirectoryIfMissing True sysusersDir - getDataFileName "sysusers-default.conf" >>= readFile >>= writeFile (sysusersDir "weldr.conf") + getDataFileName "data/sysusers-default.conf" >>= readFile >>= writeFile (sysusersDir "weldr.conf") callProcess "systemd-sysusers" ["--root", exportPath] -- Run depmod on any kernel modules that might be present @@ -76,7 +76,7 @@ -- it is not generally useful and should be avoided. runTmpfiles :: FilePath -> IO () runTmpfiles exportPath = do - configPath <- getDataFileName "tmpfiles-default.conf" + configPath <- getDataFileName "data/tmpfiles-default.conf" setupFilesystem exportPath configPath -- | List the supported output formats. diff --git a/src/tests/BDCS/Export/FSTreeSpec.hs b/src/tests/BDCS/Export/FSTreeSpec.hs --- a/src/tests/BDCS/Export/FSTreeSpec.hs +++ b/src/tests/BDCS/Export/FSTreeSpec.hs @@ -121,6 +121,50 @@ ]) ) + it "Symlinks moving placeholders to symlinks" $ + let dir_a = directoryTemplate{filesPath="/a/b/c"} + dir_b = directoryTemplate{filesPath="/x/b"} + link_d = symlinkTemplate{filesPath="/d", filesTarget = Just "/x"} + link_a = symlinkTemplate{filesPath="/a", filesTarget = Just "/d"} + in addFiles [dir_a, dir_b, link_d, link_a] >>= (`shouldBe` Right ( + Node ("", Nothing) [ + Node ("/", Nothing) [ + Node ("a", Just link_a) [], + Node ("x", Nothing) [ + Node ("b", Just dir_b) [ + Node ("c", Just dir_a) [] + ] + ], + Node ("d", Just link_d) [] + ] + ]) + ) + + it "Symlinks moving placeholders to replace symlinks" $ + let dir_a = directoryTemplate{filesPath="/a/b/c"} + link_b = symlinkTemplate{filesPath="/x/b", filesTarget = Just "/e"} + link_a = symlinkTemplate{filesPath="/a", filesTarget = Just "/x"} + in addFiles [dir_a, link_b, link_a] >>= (`shouldBe` Right ( + Node ("", Nothing) [ + Node ("/", Nothing) [ + Node ("a", Just link_a) [], + Node ("x", Nothing) [ + Node ("b", Just link_b) [] + ], + Node ("e", Nothing) [ + Node ("c", Just dir_a) [] + ] + ] + ]) + ) + + it "Symlinks moving placeholders to replace symlinks, but with another symlink in the way" $ + let dir_a = directoryTemplate{filesPath="/a/b/c"} + link_b = symlinkTemplate{filesPath="/x/b", filesTarget = Just "/e"} + link_e = symlinkTemplate{filesPath="/e/c", filesTarget = Just "/y"} + link_a = symlinkTemplate{filesPath="/a", filesTarget = Just "/x"} + in addFiles [dir_a, link_b, link_e, link_a] >>= (`shouldSatisfy` isLeft) + it "Symlink loop" $ let link_a = symlinkTemplate{filesPath="/a", filesTarget=Just "b"} link_b = symlinkTemplate{filesPath="/b", filesTarget=Just "a"} @@ -163,10 +207,108 @@ let link = symlinkTemplate{filesPath="/a", filesTarget=Just "."} file = regularTemplate{filesPath="/a"} in addFiles [link, file] >>= (`shouldSatisfy` isLeft) + + it "Adding a file twice" $ + let file = regularTemplate{filesPath="/a"} + in addFiles [file, file] >>= (`shouldBe` Right ( + Node ("", Nothing) [ + Node ("/", Nothing) [ + Node ("a", Just file) [] + ] + ]) + ) + + it "Adding a symlink twice" $ + let symlink = symlinkTemplate{filesPath="/a", filesTarget=Just "regular"} + in addFiles [symlink, symlink] >>= (`shouldBe` Right ( + Node ("", Nothing) [ + Node ("/", Nothing) [ + Node ("a", Just symlink) [] + ] + ]) + ) + + it "addFileToTree, replace file with self, replace=False" $ + runExceptT (addFileToTree False existingFileTree existingFile) >>= (`shouldBe` Right existingFileTree) + + it "addFileToTre, replace file with self, replace=True" $ + runExceptT (addFileToTree True existingFileTree existingFile) >>= (`shouldBe` Right existingFileTree) + + it "addFileToTree, replace file with directory, replace=False" $ + runExceptT (addFileToTree False existingFileTree existingDir) >>= (`shouldSatisfy` isLeft) + + it "addFileToTree, replace file with directory, replace=True" $ + runExceptT (addFileToTree True existingFileTree existingDir) >>= (`shouldSatisfy` isLeft) + + it "addFileToTree, replace file with a different file, replace=False" $ + runExceptT (addFileToTree False existingFileTree newFile) >>= (`shouldSatisfy` isLeft) + + it "addFileToTree, replace file with a different file, replace=True" $ + runExceptT (addFileToTree True existingFileTree newFile) >>= (`shouldBe` Right ( + Node ("", Nothing) [ + Node ("/", Nothing) [ + Node ("existing", Just newFile) [] + ] + ]) + ) + + it "addFileToTree, replace directory with self, replace=False" $ + runExceptT (addFileToTree False existingDirTree existingDir) >>= (`shouldBe` Right existingDirTree) + + it "addFileToTree, replace directory with self, replace=True" $ + runExceptT (addFileToTree True existingDirTree existingDir) >>= (`shouldBe` Right existingDirTree) + + it "addFileToTree, replace directory with file, replace=False" $ + runExceptT (addFileToTree False existingDirTree existingFile) >>= (`shouldSatisfy` isLeft) + + it "addFileToTree, replace directory with file, replace=True" $ + runExceptT (addFileToTree True existingDirTree existingFile) >>= (`shouldSatisfy` isLeft) + + it "addFileToTree, replace directory with different directory, replace=False" $ + runExceptT (addFileToTree False existingDirTree newDir) >>= (`shouldSatisfy` isLeft) + + it "addFileToTree, replace directory with different directory, replace=True" $ + runExceptT (addFileToTree True existingDirTree newDir) >>= (`shouldBe` Right ( + Node ("", Nothing) [ + Node ("/", Nothing) [ + Node ("existing", Just newDir) [ + Node ("file", Just regularTemplate{filesPath="/existing/file"}) [] + ] + ] + ]) + ) where -- Add a list of files and return the tree addFiles :: Monad m => [Files] -> m (Either String FSTree) addFiles files = runExceptT $ runConduit $ CL.sourceList files .| filesToTree + + existingDir :: Files + existingDir = directoryTemplate{filesPath="/existing"} + + newDir :: Files + newDir = existingDir{filesMode = fromIntegral $ directoryMode .|. 0o700} + + existingDirTree :: FSTree + existingDirTree = Node ("", Nothing) [ + Node ("/", Nothing) [ + Node ("existing", Just existingDir) [ + Node ("file", Just regularTemplate{filesPath="/existing/file"}) [] + ] + ] + ] + + existingFile :: Files + existingFile = regularTemplate{filesPath="/existing", filesCs_object=Just "abcd"} + + newFile :: Files + newFile = existingFile{filesCs_object=Just "defg"} + + existingFileTree :: FSTree + existingFileTree = Node ("", Nothing) [ + Node ("/", Nothing) [ + Node ("existing", Just existingFile) [] + ] + ] -- Just fill in the paths regularTemplate :: Files diff --git a/tests/test_export.sh b/tests/test_export.sh --- a/tests/test_export.sh +++ b/tests/test_export.sh @@ -134,7 +134,7 @@ # libcmpiCppImpl.so is a symlink to libcmpiCppImpl.so.1 OUTPUT=`$BDCS export $METADATA_DB $CS_REPO $EXPORT_DIR filesystem-3.2-21.el7.x86_64 setup-2.8.71-7.el7.noarch libcmpiCppImpl0-2.0.3-5.el7.x86_64 tog-pegasus-libs-2:2.14.1-5.el7.x86_64` rlAssertNotEquals "On error exit code should not be zero" $? 0 - rlAssertEquals "On error output is as expected" "$OUTPUT" '"Unable to resolve path /usr/lib64/libcmpiCppImpl.so, non-directory object exists at /usr/lib64/libcmpiCppImpl.so.0.0.0"' + rlAssertEquals "On error output is as expected" "$OUTPUT" '"Unable to add /usr/lib64/libcmpiCppImpl.so, symlink already added at this location"' sudo rm -rf $EXPORT_DIR rlPhaseEnd