diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # libarchive +## 2.2.2.0 + + * Add `Ord` instance to `Entry`, `Symlink`, `EntryContent`, `Ownership` + * Make `content` field of `Entry` lazy + * Add `Eq` instance to `ArchiveEncryption` + ## 2.2.1.0 * Add `Exception` instance for `ArchiveResult` diff --git a/libarchive.cabal b/libarchive.cabal --- a/libarchive.cabal +++ b/libarchive.cabal @@ -1,12 +1,12 @@ cabal-version: 1.18 name: libarchive -version: 2.2.1.0 +version: 2.2.2.0 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018-2020 Vanessa McHale maintainer: vamchale@gmail.com author: Vanessa McHale -tested-with: ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.2 +tested-with: ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.3 bug-reports: https://github.com/vmchale/libarchive/issues synopsis: Haskell interface to libarchive description: @@ -33,6 +33,10 @@ default: False manual: True +flag low-memory + description: Run low-memory version of test suite + default: False + library exposed-modules: Codec.Archive @@ -79,15 +83,16 @@ ghc-options: -Wmissing-export-lists test-suite libarchive-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: cpphs:cpphs -any + hs-source-dirs: test other-modules: Codec.Archive.Roundtrip Codec.Archive.Test - default-language: Haskell2010 - other-extensions: OverloadedStrings + default-language: Haskell2010 + other-extensions: OverloadedStrings ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints @@ -104,6 +109,9 @@ dir-traverse -any, composition-prelude >=2.0.5.0, pathological-bytestrings -any + + if flag(low-memory) + cpp-options: -DLOW_MEMORY if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists diff --git a/src/Codec/Archive/Pack/Lazy.hs b/src/Codec/Archive/Pack/Lazy.hs --- a/src/Codec/Archive/Pack/Lazy.hs +++ b/src/Codec/Archive/Pack/Lazy.hs @@ -74,7 +74,7 @@ BSL.fromChunks . toList <$> liftIO (readIORef bsRef) <* liftIO (freeHaskellFunPtr cc) where writeBSL bsRef _ _ bufPtr sz = do - let bytesRead = min (fromIntegral sz) (32 * 1024) -- TODO: tweak this parameter + let bytesRead = min (fromIntegral sz) (32 * 1024) bsl <- packCStringLen (bufPtr, fromIntegral bytesRead) modifyIORef' bsRef (`DL.snoc` bsl) pure bytesRead diff --git a/src/Codec/Archive/Types.hs b/src/Codec/Archive/Types.hs --- a/src/Codec/Archive/Types.hs +++ b/src/Codec/Archive/Types.hs @@ -35,28 +35,29 @@ | NoEncryption | EncryptionUnsupported | EncryptionUnknown + deriving (Eq) -- TODO: support everything here: http://hackage.haskell.org/package/tar/docs/Codec-Archive-Tar-Entry.html#t:EntryContent data EntryContent = NormalFile !BS.ByteString | Directory | Symlink !FilePath !Symlink | Hardlink !FilePath - deriving (Show, Eq) + deriving (Show, Eq, Ord) data Entry = Entry { filepath :: !FilePath - , content :: !EntryContent + , content :: EntryContent , permissions :: !Permissions , ownership :: !Ownership , time :: !(Maybe ModTime) } - deriving (Show, Eq) + deriving (Show, Eq, Ord) data Ownership = Ownership { userName :: !(Maybe String) , groupName :: !(Maybe String) , ownerId :: !Id , groupId :: !Id } - deriving (Eq, Show) + deriving (Eq, Show, Ord) type Permissions = CMode type ModTime = (CTime, CLong) diff --git a/src/Codec/Archive/Types/Foreign.chs b/src/Codec/Archive/Types/Foreign.chs --- a/src/Codec/Archive/Types/Foreign.chs +++ b/src/Codec/Archive/Types/Foreign.chs @@ -62,13 +62,13 @@ , AE_IFBLK as FtBlock , AE_IFDIR as FtDirectory , AE_IFIFO as FtFifo - } deriving (Eq) + } deriving (Eq, Ord) #} {# enum define Symlink { AE_SYMLINK_TYPE_UNDEFINED as SymlinkUndefined , AE_SYMLINK_TYPE_FILE as SymlinkFile , AE_SYMLINK_TYPE_DIRECTORY as SymlinkDirectory - } deriving (Show, Eq) + } deriving (Show, Eq, Ord) #} {# enum define ArchiveFilter { ARCHIVE_FILTER_NONE as ArchiveFilterNone diff --git a/test/Spec.cpphs b/test/Spec.cpphs new file mode 100644 --- /dev/null +++ b/test/Spec.cpphs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main ( main ) where + +import Codec.Archive +import Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip, roundtripFreaky, roundtripStrict) +import Codec.Archive.Test +import Data.Either (isRight) +import Data.Foldable (traverse_) +import System.Directory (doesDirectoryExist, listDirectory) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + +testFp :: FilePath -> Spec +testFp fp = parallel $ it ("sucessfully unpacks/packs (" ++ fp ++ ")") $ + roundtrip fp >>= (`shouldSatisfy` isRight) + +testFpStrict :: FilePath -> Spec +testFpStrict fp = parallel $ it ("works on strict bytestring (" ++ fp ++ ")") $ + roundtripStrict fp >>= (`shouldSatisfy` isRight) + +testFpFreaky :: FilePath -> Spec +testFpFreaky fp = parallel $ it ("works on nonstandard bytestring (" ++ fp ++ ")") $ + roundtripFreaky fp >>= (`shouldSatisfy` isRight) + +unpack :: FilePath -> IO (Either ArchiveResult ()) +unpack fp = withSystemTempDirectory "libarchive" $ + \tmp -> runArchiveM $ unpackArchive fp tmp + +readArchiveFile' :: FilePath -> IO (Either ArchiveResult [Entry]) +readArchiveFile' = runArchiveM . readArchiveFile + +testUnpackLibarchive :: FilePath -> Spec +testUnpackLibarchive fp = parallel $ it ("unpacks " ++ fp) $ + unpack fp >>= (`shouldSatisfy` isRight) + +testReadArchiveFile :: FilePath -> Spec +testReadArchiveFile fp = parallel $ it ("reads " ++ fp) $ + readArchiveFile' fp >>= (`shouldSatisfy` isRight) + +main :: IO () +main = do + + dir <- doesDirectoryExist "test/data" + tarballs <- if dir then listDirectory "test/data" else pure [] + let tarPaths = ("test/data" ) <$> tarballs + + hspec $ + describe "roundtrip" $ do + + traverse_ testFp tarPaths +#ifndef LOW_MEMORY + traverse_ testFpFreaky tarPaths + traverse_ testFpStrict tarPaths +#endif + traverse_ testUnpackLibarchive tarPaths + traverse_ testReadArchiveFile tarPaths + + context "with symlinks" $ do + let entries = + [ simpleDir "x/" + , simpleFile "x/a.txt" (NormalFile "referenced") + , simpleFile "x/b.txt" (Symlink "a.txt" SymlinkUndefined) + ] + itPacksUnpacks entries + itPacksUnpacksViaFS entries + + context "with hardlinks" $ do + let entries = + [ simpleDir "x/" + , simpleFile "x/a.txt" (NormalFile "shared") + , simpleFile "x/b.txt" (Hardlink "x/a.txt") + ] + itPacksUnpacks entries + context "issue#4" $ itPacksUnpacksViaFS entries + + context "with forward referenced hardlinks" $ do + let entries = + [ simpleDir "x/" + , simpleFile "x/b.txt" (Hardlink "x/a.txt") + , simpleFile "x/a.txt" (NormalFile "shared") + ] + itPacksUnpacks entries + xcontext "re-ordering on unpack" $ itPacksUnpacksViaFS entries + + xcontext "having entry without ownership" . itPacksUnpacks $ + [ stripOwnership (simpleFile "a.txt" (NormalFile "text")) ] + xcontext "having entry without timestamp" . itPacksUnpacks $ + [ stripTime (simpleFile "a.txt" (NormalFile "text")) ] diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main ( main ) where - -import Codec.Archive -import Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip, roundtripFreaky, roundtripStrict) -import Codec.Archive.Test -import qualified Data.ByteString as BS -import Data.Either (isRight) -import Data.Foldable (traverse_) -import System.Directory (doesDirectoryExist, listDirectory) -import System.FilePath (()) -import System.IO.Temp (withSystemTempDirectory) -import Test.Hspec - -testFp :: FilePath -> Spec -testFp fp = parallel $ it ("sucessfully unpacks/packs (" ++ fp ++ ")") $ - roundtrip fp >>= (`shouldSatisfy` isRight) - -testFpStrict :: FilePath -> Spec -testFpStrict fp = parallel $ it ("works on strict bytestring (" ++ fp ++ ")") $ - roundtripStrict fp >>= (`shouldSatisfy` isRight) - -testFpFreaky :: FilePath -> Spec -testFpFreaky fp = parallel $ it ("works on nonstandard bytestring (" ++ fp ++ ")") $ - roundtripFreaky fp >>= (`shouldSatisfy` isRight) - -unpack :: FilePath -> IO (Either ArchiveResult ()) -unpack fp = withSystemTempDirectory "libarchive" $ - \tmp -> runArchiveM $ unpackArchive fp tmp - -readArchiveFile' :: FilePath -> IO (Either ArchiveResult [Entry]) -readArchiveFile' = runArchiveM . readArchiveFile - -testUnpackLibarchive :: FilePath -> Spec -testUnpackLibarchive fp = parallel $ it ("unpacks " ++ fp) $ - unpack fp >>= (`shouldSatisfy` isRight) - -testReadArchiveFile :: FilePath -> Spec -testReadArchiveFile fp = parallel $ it ("reads " ++ fp) $ - readArchiveFile' fp >>= (`shouldSatisfy` isRight) - -main :: IO () -main = do - - dir <- doesDirectoryExist "test/data" - tarballs <- if dir then listDirectory "test/data" else pure [] - let tarPaths = ("test/data" ) <$> tarballs - - hspec $ - describe "roundtrip" $ do - - traverse_ testFp tarPaths - traverse_ testFpFreaky tarPaths - traverse_ testFpStrict tarPaths - traverse_ testUnpackLibarchive tarPaths - traverse_ testReadArchiveFile tarPaths - - context "with symlinks" $ do - let entries = - [ simpleDir "x/" - , simpleFile "x/a.txt" (NormalFile "referenced") - , simpleFile "x/b.txt" (Symlink "a.txt" SymlinkUndefined) - ] - itPacksUnpacks entries - itPacksUnpacksViaFS entries - - context "with hardlinks" $ do - let entries = - [ simpleDir "x/" - , simpleFile "x/a.txt" (NormalFile "shared") - , simpleFile "x/b.txt" (Hardlink "x/a.txt") - ] - itPacksUnpacks entries - context "issue#4" $ itPacksUnpacksViaFS entries - - context "with forward referenced hardlinks" $ do - let entries = - [ simpleDir "x/" - , simpleFile "x/b.txt" (Hardlink "x/a.txt") - , simpleFile "x/a.txt" (NormalFile "shared") - ] - itPacksUnpacks entries - xcontext "re-ordering on unpack" $ itPacksUnpacksViaFS entries - - xcontext "having entry without ownership" . itPacksUnpacks $ - [ stripOwnership (simpleFile "a.txt" (NormalFile "text")) ] - xcontext "having entry without timestamp" . itPacksUnpacks $ - [ stripTime (simpleFile "a.txt" (NormalFile "text")) ]