diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # libarchive +## 2.1.1.0 + + * Remove weeds, export things that were missing from past releases + ## 2.1.0.1 * `packEntries` and friends now detect hardlinks diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ To run the test suite, first run ``` -./bash/setup +make -j ``` so that you have appropriate test data downloaded. diff --git a/libarchive.cabal b/libarchive.cabal --- a/libarchive.cabal +++ b/libarchive.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: libarchive -version: 2.1.0.1 +version: 2.1.1.0 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018-2019 Vanessa McHale @@ -82,6 +82,10 @@ type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test + other-modules: + Codec.Archive.Roundtrip + Codec.Archive.Test + default-language: Haskell2010 other-extensions: OverloadedStrings ghc-options: @@ -97,7 +101,7 @@ filepath -any, temporary -any, mtl >=2.2.2, - dir-traverse, + dir-traverse -any, composition-prelude >=2.0.5.0 if impl(ghc >=8.4) diff --git a/src/Codec/Archive/Foreign/Archive.chs b/src/Codec/Archive/Foreign/Archive.chs --- a/src/Codec/Archive/Foreign/Archive.chs +++ b/src/Codec/Archive/Foreign/Archive.chs @@ -203,6 +203,8 @@ , archiveReadDiskSetBehavior , archiveReadDiskSetMatching , archiveReadDiskSetMetadataFilterCallback + , archiveReadDiskNoAcl + , archiveReadDiskNoFFlags -- * Version macros , archiveVersionNumberMacro , archiveVersionOnlyString diff --git a/src/Codec/Archive/Foreign/Archive/Macros.chs b/src/Codec/Archive/Foreign/Archive/Macros.chs --- a/src/Codec/Archive/Foreign/Archive/Macros.chs +++ b/src/Codec/Archive/Foreign/Archive/Macros.chs @@ -142,11 +142,11 @@ archiveReadDiskNoXattr :: ReadDiskFlags archiveReadDiskNoXattr = ReadDiskFlags {# const ARCHIVE_READDISK_NO_XATTR #} --- | @since 2.0.0.0 +-- | @since 2.1.1.0 archiveReadDiskNoAcl :: ReadDiskFlags archiveReadDiskNoAcl = ReadDiskFlags {# const ARCHIVE_READDISK_NO_ACL #} --- | @since 2.0.0.0 +-- | @since 2.1.1.0 archiveReadDiskNoFFlags :: ReadDiskFlags archiveReadDiskNoFFlags = ReadDiskFlags {# const ARCHIVE_READDISK_NO_FFLAGS #} diff --git a/src/Codec/Archive/Foreign/ArchiveEntry.chs b/src/Codec/Archive/Foreign/ArchiveEntry.chs --- a/src/Codec/Archive/Foreign/ArchiveEntry.chs +++ b/src/Codec/Archive/Foreign/ArchiveEntry.chs @@ -196,6 +196,10 @@ , archiveEntryACLEveryone , archiveEntryACLStyleExtraID , archiveEntryACLStyleMarkDefault + , archiveEntryACLEntryInherited + , archiveEntryACLStyleCompact + , archiveEntryACLStyleSeparatorComma + , archiveEntryACLStyleSolaris -- * Abstract types , ArchiveEntry , Stat diff --git a/src/Codec/Archive/Foreign/ArchiveEntry/Macros.chs b/src/Codec/Archive/Foreign/ArchiveEntry/Macros.chs --- a/src/Codec/Archive/Foreign/ArchiveEntry/Macros.chs +++ b/src/Codec/Archive/Foreign/ArchiveEntry/Macros.chs @@ -105,7 +105,7 @@ archiveEntryACLSynchronize :: EntryACL archiveEntryACLSynchronize = EntryACL {# const ARCHIVE_ENTRY_ACL_SYNCHRONIZE #} --- | @since 2.0.0.0 +-- | @since 2.1.1.0 archiveEntryACLEntryInherited :: EntryACL archiveEntryACLEntryInherited = EntryACL {# const ARCHIVE_ENTRY_ACL_ENTRY_INHERITED #} @@ -172,14 +172,14 @@ archiveEntryACLStyleMarkDefault :: EntryACL archiveEntryACLStyleMarkDefault = EntryACL {# const ARCHIVE_ENTRY_ACL_STYLE_MARK_DEFAULT #} --- | @since 2.0.0.0 +-- | @since 2.1.1.0 archiveEntryACLStyleSolaris :: EntryACL archiveEntryACLStyleSolaris = EntryACL {# const ARCHIVE_ENTRY_ACL_STYLE_SOLARIS #} --- | @since 2.0.0.0 +-- | @since 2.1.1.0 archiveEntryACLStyleSeparatorComma :: EntryACL archiveEntryACLStyleSeparatorComma = EntryACL {# const ARCHIVE_ENTRY_ACL_STYLE_SEPARATOR_COMMA #} --- | @since 2.0.0.0 +-- | @since 2.1.1.0 archiveEntryACLStyleCompact :: EntryACL archiveEntryACLStyleCompact = EntryACL {# const ARCHIVE_ENTRY_ACL_STYLE_COMPACT #} diff --git a/src/Codec/Archive/Monad.hs b/src/Codec/Archive/Monad.hs --- a/src/Codec/Archive/Monad.hs +++ b/src/Codec/Archive/Monad.hs @@ -4,7 +4,6 @@ -- * Bracketed resources within 'ArchiveM' , withCStringArchiveM , useAsCStringLenArchiveM - , allocaArchiveM , allocaBytesArchiveM , ArchiveM ) where @@ -49,9 +48,6 @@ -> (b -> ExceptT c IO d) -- ^ The action -> ExceptT c IO d genBracket f x = flipExceptIO . f x . (runExceptT .) - -allocaArchiveM :: Storable a => (Ptr a -> ExceptT b IO c) -> ExceptT b IO c -allocaArchiveM = genBracket (pure alloca) () allocaBytesArchiveM :: Int -> (Ptr a -> ExceptT b IO c) -> ExceptT b IO c allocaBytesArchiveM = genBracket allocaBytes diff --git a/src/Codec/Archive/Pack/Common.hs b/src/Codec/Archive/Pack/Common.hs --- a/src/Codec/Archive/Pack/Common.hs +++ b/src/Codec/Archive/Pack/Common.hs @@ -2,15 +2,14 @@ import Codec.Archive.Types import qualified Data.ByteString as BS -import System.PosixCompat.Files (fileGroup, fileMode, fileOwner, - getFileStatus, isDirectory, - isRegularFile, isSymbolicLink, - linkCount, readSymbolicLink) +import System.PosixCompat.Files (FileStatus, fileGroup, fileMode, fileOwner, getFileStatus, isDirectory, isRegularFile, isSymbolicLink, linkCount, + readSymbolicLink) -mkContent :: FilePath -> IO EntryContent -mkContent fp = do - status <- getFileStatus fp +mkContent :: FilePath -> FileStatus -> IO EntryContent +mkContent fp status = let res = (isRegularFile status, isDirectory status, isSymbolicLink status, linkCount status) + in + case res of (True, False, False, 1) -> NormalFile <$> BS.readFile fp (True, False, False, _) -> pure $ Hardlink fp @@ -21,6 +20,6 @@ mkEntry :: FilePath -> IO Entry mkEntry fp = do status <- getFileStatus fp - content' <- mkContent fp + content' <- mkContent fp status pure $ Entry fp content' (fileMode status) (Ownership Nothing Nothing (fromIntegral $ fileOwner status) (fromIntegral $ fileGroup status)) Nothing diff --git a/src/Codec/Archive/Unpack.hs b/src/Codec/Archive/Unpack.hs --- a/src/Codec/Archive/Unpack.hs +++ b/src/Codec/Archive/Unpack.hs @@ -74,17 +74,17 @@ <*> readTimes entry -- | Yield the next entry in an archive -getHsEntry :: MonadIO m => Ptr Archive -> m (Maybe Entry) +getHsEntry :: Ptr Archive -> IO (Maybe Entry) getHsEntry a = do - entry <- liftIO $ getEntry a + entry <- getEntry a case entry of Nothing -> pure Nothing - Just x -> Just <$> liftIO (readEntry a x) + Just x -> Just <$> readEntry a x -- | Return a list of 'Entry's. hsEntries :: MonadIO m => Ptr Archive -> m [Entry] hsEntries a = do - next <- getHsEntry a + next <- liftIO $ getHsEntry a case next of Nothing -> pure [] Just x -> (x:) <$> hsEntries a diff --git a/test/Codec/Archive/Roundtrip.hs b/test/Codec/Archive/Roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Codec/Archive/Roundtrip.hs @@ -0,0 +1,75 @@ +module Codec.Archive.Roundtrip ( itPacksUnpacks + , itPacksUnpacksViaFS + , roundtrip + ) where + +import Codec.Archive +import Control.Composition (thread, (.@)) +import Control.Monad.Except (liftEither) +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.List (intersperse, sort) +import System.Directory (withCurrentDirectory) +import System.Directory.Recursive (getDirRecursive) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + +newtype TestEntries = TestEntries [Entry] + deriving (Eq) + +instance Show TestEntries where + showsPrec _ (TestEntries entries) = ("(TestEntries [" ++) . joinBy (", "++) (map showsEntry entries) . ("])" ++) where + showsEntry entry = ("Entry " ++) . + ("{filepath=" ++) . shows (filepath entry) . + (", content=" ++) . showsContent (content entry) . + (", permissions=" ++) . shows (permissions entry) . + (", ownership=" ++) . shows (ownership entry) . + (", time=" ++) . shows (time entry) . + ("}" ++) + showsContent (NormalFile bytes) = ("(NormalFile $ " ++) . shows (BS.take 10 bytes) . (" <> undefined)" ++) + showsContent Directory = ("Directory" ++) + showsContent (Symlink target) = ("(Symlink " ++) . shows target . (')':) + showsContent (Hardlink target) = ("(Hardlink " ++) . shows target . (')':) + joinBy :: ShowS -> [ShowS] -> ShowS + joinBy sep = thread . intersperse sep + +roundtrip :: FilePath -> IO (Either ArchiveResult BSL.ByteString) +roundtrip = fmap (fmap entriesToBSL . readArchiveBSL) . BSL.readFile + +itPacksUnpacks :: [Entry] -> Spec +itPacksUnpacks entries = parallel $ it "packs/unpacks successfully without loss" $ + let + packed = entriesToBSL entries + unpacked = readArchiveBSL packed + in + (TestEntries <$> unpacked) `shouldBe` Right (TestEntries entries) + +itPacksUnpacksViaFS :: [Entry] -> Spec +itPacksUnpacksViaFS entries = parallel $ unpackedFromFS $ it "packs/unpacks on filesystem successfully without loss" $ \unpacked -> + fmap (fmap stripDotSlash . testEntries) unpacked `shouldBe` Right (testEntries entries) + + where + + -- Use this to test content as well + -- testEntries = TestEntries . sortOn filepath . map (stripOwnership . stripPermissions) + testEntries = sort . map filepath + unpackedFromFS = around $ \action -> + withSystemTempDirectory "spec-" $ \tmpdir -> do + unpacked <- {- withCurrentDirectory tmpdir . -} runArchiveM $ do + entriesToDir tmpdir entries + packed <- liftIO . withCurrentDirectory tmpdir $ do + files <- getDirRecursive "." + packFiles files + liftEither $ readArchiveBSL packed + + action unpacked + + stripDotSlash :: FilePath -> FilePath + stripDotSlash ('.':'/':fp) = fp + stripDotSlash fp = fp + +-- TODO: expose something like this via archive_write_disk +-- entriesToDir :: Foldable t => FilePath -> t Entry -> ArchiveM () +entriesToDir :: FilePath -> [Entry] -> ArchiveM () +entriesToDir = entriesToBSL .@ unpackToDirLazy diff --git a/test/Codec/Archive/Test.hs b/test/Codec/Archive/Test.hs new file mode 100644 --- /dev/null +++ b/test/Codec/Archive/Test.hs @@ -0,0 +1,20 @@ +module Codec.Archive.Test ( simpleFile + , simpleDir + , stripOwnership + , stripTime + ) where + +import Codec.Archive + +simpleFile :: FilePath -> EntryContent -> Entry +simpleFile name what = Entry name what standardPermissions (Ownership (Just "root") (Just "root") 0 0) (Just (0, 0)) + +simpleDir :: FilePath -> Entry +simpleDir name = Entry name Directory dirPermissions (Ownership (Just "root") (Just "root") 0 0) (Just (0, 0)) + +dirPermissions :: Permissions +dirPermissions = executablePermissions + +stripOwnership, stripTime :: Entry -> Entry +stripOwnership entry = entry { ownership = Ownership Nothing Nothing 0 0 } +stripTime entry = entry { time = Nothing } diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,81 +2,29 @@ module Main ( main ) where import Codec.Archive -import Control.Composition (thread, (.@)) -import Control.Monad.Except -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import Data.Either (isRight) -import Data.Foldable (traverse_) -import Data.List (intersperse, sort) -import System.Directory (doesDirectoryExist, listDirectory, withCurrentDirectory) -import System.Directory.Recursive (getDirRecursive) -import System.FilePath (()) -import System.IO.Temp (withSystemTempDirectory) +import Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip) +import Codec.Archive.Test +import Data.Either (isRight) +import Data.Foldable (traverse_) +import System.Directory (doesDirectoryExist, listDirectory) +import System.FilePath (()) import Test.Hspec - -newtype TestEntries = TestEntries [Entry] - deriving (Eq) - -instance Show TestEntries where - showsPrec _ (TestEntries entries) = ("(TestEntries [" ++) . joinBy (", "++) (map showsEntry entries) . ("])" ++) where - showsEntry entry = ("Entry " ++) . - ("{filepath=" ++) . shows (filepath entry) . - (", content=" ++) . showsContent (content entry) . - (", permissions=" ++) . shows (permissions entry) . - (", ownership=" ++) . shows (ownership entry) . - (", time=" ++) . shows (time entry) . - ("}" ++) - showsContent (NormalFile bytes) = ("(NormalFile $ " ++) . shows (BS.take 10 bytes) . (" <> undefined)" ++) - showsContent Directory = ("Directory" ++) - showsContent (Symlink target) = ("(Symlink " ++) . shows target . (')':) - showsContent (Hardlink target) = ("(Hardlink " ++) . shows target . (')':) - joinBy :: ShowS -> [ShowS] -> ShowS - joinBy sep = thread . intersperse sep - -roundtrip :: FilePath -> IO (Either ArchiveResult BSL.ByteString) -roundtrip = fmap (fmap entriesToBSL . readArchiveBSL) . BSL.readFile - -itPacksUnpacks :: HasCallStack => [Entry] -> Spec -itPacksUnpacks entries = parallel $ it "packs/unpacks successfully without loss" $ - (TestEntries <$> unpacked) `shouldBe` Right (TestEntries entries) - where - packed = entriesToBSL entries - unpacked = readArchiveBSL packed - -itPacksUnpacksViaFS :: HasCallStack => [Entry] -> Spec -itPacksUnpacksViaFS entries = parallel $ unpackedFromFS $ it "packs/unpacks on filesystem successfully without loss" $ \unpacked -> - fmap (fmap stripDotSlash . testEntries) unpacked `shouldBe` Right (testEntries entries) - where - -- Use this to test content as well - -- testEntries = TestEntries . sortOn filepath . map (stripOwnership . stripPermissions) - testEntries = sort . map filepath - unpackedFromFS = around $ \action -> - withSystemTempDirectory "spec-" $ \tmpdir -> do - unpacked <- {- withCurrentDirectory tmpdir . -} runArchiveM $ do - entriesToDir tmpdir entries - packed <- liftIO . withCurrentDirectory tmpdir $ do - files <- getDirRecursive "." - packFiles files - liftEither $ readArchiveBSL packed - - action unpacked - stripDotSlash :: FilePath -> FilePath - stripDotSlash ('.':'/':fp) = fp - stripDotSlash fp = fp - testFp :: HasCallStack => FilePath -> Spec testFp fp = parallel $ it ("sucessfully unpacks/packs (" ++ fp ++ ")") $ roundtrip fp >>= (`shouldSatisfy` isRight) main :: IO () main = do + dir <- doesDirectoryExist "test/data" tarballs <- if dir then listDirectory "test/data" else pure [] + hspec $ describe "roundtrip" $ do + traverse_ testFp (("test/data" ) <$> tarballs) + context "with symlinks" $ do let entries = [ simpleDir "x/" @@ -108,21 +56,3 @@ [ stripOwnership (simpleFile "a.txt" (NormalFile "text")) ] xcontext "having entry without timestamp" . itPacksUnpacks $ [ stripTime (simpleFile "a.txt" (NormalFile "text")) ] - -simpleFile :: FilePath -> EntryContent -> Entry -simpleFile name what = Entry name what standardPermissions (Ownership (Just "root") (Just "root") 0 0) (Just (0,0)) - -simpleDir :: FilePath -> Entry -simpleDir name = Entry name Directory dirPermissions (Ownership (Just "root") (Just "root") 0 0) (Just (0,0)) - -dirPermissions :: Permissions -dirPermissions = executablePermissions - --- TODO: expose something like this via archive_write_disk --- entriesToDir :: Foldable t => FilePath -> t Entry -> ArchiveM () -entriesToDir :: FilePath -> [Entry] -> ArchiveM () -entriesToDir = entriesToBSL .@ unpackToDirLazy - -stripOwnership, stripTime :: Entry -> Entry -stripOwnership entry = entry { ownership = Ownership Nothing Nothing 0 0 } -stripTime entry = entry { time = Nothing }