streamly-archive (empty) → 0.0.1
raw patch · 10 files changed
+793/−0 lines, 10 filesdep +QuickCheckdep +basedep +bytestringsetup-changedbinary-added
Dependencies added: QuickCheck, base, bytestring, cryptonite, directory, filepath, streamly, streamly-archive, tar, tasty, tasty-hunit, tasty-quickcheck, temporary, zlib
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +71/−0
- Setup.hs +2/−0
- src/Streamly/External/Archive.hs +96/−0
- src/Streamly/External/Archive/Internal/Foreign.hs +300/−0
- streamly-archive.cabal +75/−0
- test/Streamly/External/Archive/Tests.hs +194/−0
- test/TestSuite.hs +22/−0
- test/data/sparse.tar binary
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for streamly-archive++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Shlok Datye (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Shlok Datye nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,71 @@+# streamly-archive++Stream data from archives (tar, tar.gz, zip, or any other format [supported by libarchive](https://github.com/libarchive/libarchive/wiki/LibarchiveFormats)) using the Haskell [streamly](https://hackage.haskell.org/package/streamly) library.++## Requirements++Install libarchive on your system.++* Debian Linux: `sudo apt-get install libarchive-dev`.+* macOS: `brew install libarchive`.++## Quick start++```haskell+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}++module Main where++import Crypto.Hash (hashFinalize, hashInit, hashUpdate)+import Crypto.Hash.Algorithms (SHA256)+import Data.ByteString (ByteString)+import Data.Either (isRight)+import Data.Function ((&))+import Data.Maybe (fromJust, fromMaybe)+import Data.Void (Void)+import Streamly.External.Archive (Header, headerPathName, readArchive)+import Streamly.Internal.Data.Fold.Types (Fold (..))+import Streamly.Internal.Data.Unfold.Types (Unfold)+import qualified Streamly.Prelude as S++main :: IO ()+main = do+ -- Obtain an unfold for the archive.+ -- For each entry in the archive, we will get a Header followed+ -- by zero or more ByteStrings containing chunks of file data.+ let unf :: Unfold IO Void (Either Header ByteString)+ = readArchive "/path/to/archive.tar.gz"++ -- Create a fold for converting each entry (which, as we saw+ -- above, is a Left followed by zero or more Rights) into a+ -- path and corresponding SHA-256 hash (Nothing for no data).+ let entryFold :: Fold IO (Either Header ByteString) (String, Maybe String)+ = Fold+ (\(mpath, mctx) e ->+ case e of+ Left h -> do+ mpath' <- headerPathName h+ return (mpath', mctx)+ Right bs ->+ return (mpath,+ Just . (`hashUpdate` bs) $+ fromMaybe (hashInit @SHA256) mctx))+ (return (Nothing, Nothing))+ (\(mpath, mctx) ->+ return (show $ fromJust mpath,+ show . hashFinalize <$> mctx))++ -- Execute the stream, grouping at the headers (the Lefts) using the+ -- above fold, and output the paths and SHA-256 hashes along the way.+ S.unfold unf undefined+ & S.groupsBy (\e _ -> isRight e) entryFold+ & S.mapM_ print+```++## Benchmarks++See `./bench/README.md`. We find on our machine<sup>†</sup> that (1) reading an archive using this library is just as fast as using plain Haskell `IO` code; and that (2) both are somewhere between 1.7x (large files) and 2.5x (many 1-byte files) slower than C.++The former fulfills the promise of [streamly](https://hackage.haskell.org/package/streamly) and stream fusion. The differences to C are presumably explained by the marshalling of data into the Haskell world and are currently small enough for our purposes.++<sup>†</sup> [Linode](https://linode.com); Debian 10, Dedicated 32GB: 16 CPU, 640GB Storage, 32GB RAM.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Streamly/External/Archive.hs view
@@ -0,0 +1,96 @@+--------------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}++--------------------------------------------------------------------------------++module Streamly.External.Archive+ (+ -- ** Read+ readArchive,++ -- ** Header+ Header,+ FileType (..),+ headerFileType,+ headerPathName,+ headerPathNameUtf8,+ headerSize) where++--------------------------------------------------------------------------------++import Control.Exception (mask_)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString)+import Data.Int (Int64)+import Data.Void (Void)+import Foreign (Ptr, free, malloc)+import Foreign.C.Types (CChar, CSize)+import Streamly.Internal.Data.Stream.StreamD.Type (Step (..))+import Streamly.Internal.Data.Unfold (supply)+import Streamly.Internal.Data.Unfold.Types (Unfold (..))++import qualified Data.ByteString as B+import qualified Streamly.Internal.Data.Stream.StreamD as D++import Streamly.External.Archive.Internal.Foreign (Entry, FileType (..),+ archive_entry_filetype, archive_entry_pathname, archive_entry_pathname_utf8, archive_entry_size,+ archive_read_data_block, archive_read_free, archive_read_new, archive_read_next_header,+ archive_read_open_filename, archive_read_support_filter_all, archive_read_support_format_all)++--------------------------------------------------------------------------------++-- | Header information for an entry in the archive.+newtype Header = Header Entry++{-# INLINE headerFileType #-}+headerFileType :: Header -> IO (Maybe FileType)+headerFileType (Header e) = archive_entry_filetype e++{-# INLINE headerPathName #-}+headerPathName :: Header -> IO (Maybe ByteString)+headerPathName (Header e) = archive_entry_pathname e++{-# INLINE headerPathNameUtf8 #-}+headerPathNameUtf8 :: Header -> IO (Maybe ByteString)+headerPathNameUtf8 (Header e) = archive_entry_pathname_utf8 e++{-# INLINE headerSize #-}+headerSize :: Header -> IO (Maybe Int)+headerSize (Header e) = archive_entry_size e++-- | Creates an unfold with which we can stream data out of the given archive.+{-# INLINE readArchive #-}+readArchive :: (MonadIO m) => FilePath -> Unfold m Void (Either Header ByteString)+readArchive fp = flip supply () $+ Unfold+ (\(arch, buf, sz, offs, pos, ref, readHeader) ->+ if readHeader then do+ me <- liftIO $ archive_read_next_header arch+ case me of+ Nothing -> do+ liftIO $ D.runIORefFinalizer ref+ return Stop+ Just e -> do+ return $ Yield (Left $ Header e) (arch, buf, sz, offs, 0, ref, False)+ else do+ (bs, done) <- liftIO $ archive_read_data_block arch buf sz offs pos+ return $+ if B.length bs > 0 then+ Yield (Right bs) (arch, buf, sz, offs, pos + fromIntegral (B.length bs), ref, done)+ else+ Skip (arch, buf, sz, offs, pos, ref, done))+ (\() -> do+ (arch, buf, sz, offs, ref) <- liftIO . mask_ $ do+ arch <- liftIO archive_read_new+ buf :: Ptr (Ptr CChar) <- liftIO malloc+ sz :: Ptr CSize <- liftIO malloc+ offs :: Ptr Int64 <- liftIO malloc+ ref <- D.newFinalizedIORef $ archive_read_free arch >> free buf >> free sz >> free offs+ return (arch, buf, sz, offs, ref)+ liftIO $ archive_read_support_filter_all arch+ liftIO $ archive_read_support_format_all arch+ liftIO $ archive_read_open_filename arch fp+ return (arch, buf, sz, offs, 0, ref, True))++--------------------------------------------------------------------------------
+ src/Streamly/External/Archive/Internal/Foreign.hs view
@@ -0,0 +1,300 @@+--------------------------------------------------------------------------------++module Streamly.External.Archive.Internal.Foreign+ ( Archive+ , Entry+ , FileType (..)+ , archive_read_new+ , archive_read_support_filter_all+ , archive_read_support_format_all+ , archive_read_support_format_gnutar+ , blockSize+ , archive_read_open_filename+ , archive_read_next_header+ , archive_entry_filetype+ , archive_entry_pathname+ , archive_entry_pathname_utf8+ , archive_entry_size+ , alloc_archive_read_data_buffer+ , archive_read_data+ , archive_read_data_block+ , archive_read_free ) where++--------------------------------------------------------------------------------++import Control.Exception (Exception, mask_, throw)+import Control.Monad (when)+import Data.Bits ((.&.))+import Data.ByteString (ByteString, packCString, packCStringLen)+import Data.Int (Int64)+import Foreign (FunPtr, Ptr, nullPtr, peek)+import Foreign.C.String (CString, peekCString, withCString)+import Foreign.C.Types (CChar, CInt (CInt), CSize (CSize))+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)+import Foreign.Marshal.Alloc (mallocBytes)+import System.Posix.Types (CSsize (CSsize), CMode (CMode))++import qualified Data.ByteString as B++--------------------------------------------------------------------------------++data CArchive+data CEntry++foreign import ccall unsafe "archive.h archive_errno"+ c_archive_errno :: Ptr CArchive -> IO CInt++foreign import ccall unsafe "archive.h archive_error_string"+ c_archive_error_string :: Ptr CArchive -> IO CString++foreign import ccall unsafe "archive.h archive_read_new"+ c_archive_read_new :: IO (Ptr CArchive)++foreign import ccall unsafe "archive.h archive_read_support_filter_all"+ c_archive_read_support_filter_all :: Ptr CArchive -> IO CInt++foreign import ccall unsafe "archive.h archive_read_support_format_all"+ c_archive_read_support_format_all :: Ptr CArchive -> IO CInt++foreign import ccall unsafe "archive.h archive_read_support_format_gnutar"+ c_archive_read_support_format_gnutar :: Ptr CArchive -> IO CInt++foreign import ccall unsafe "archive.h archive_read_open_filename"+ c_archive_read_open_filename :: Ptr CArchive -> CString -> CSize -> IO CInt++foreign import ccall unsafe "archive.h archive_read_next_header2"+ c_archive_read_next_header2 :: Ptr CArchive -> Ptr CEntry -> IO CInt++foreign import ccall unsafe "archive.h archive_read_data"+ c_archive_read_data :: Ptr CArchive -> Ptr CChar -> CSize -> IO CSsize -- Todo: Think about la_ssize_t on non-POSIX.++foreign import ccall unsafe "archive.h archive_read_data_block"+ c_archive_read_data_block :: Ptr CArchive -> Ptr (Ptr CChar) -> Ptr CSize -> Ptr Int64 -> IO CInt++foreign import ccall unsafe "archive.h archive_read_free"+ c_archive_read_free :: Ptr CArchive -> IO CInt++foreign import ccall unsafe "archive_entry.h archive_entry_filetype"+ c_archive_entry_filetype :: Ptr CEntry -> IO CMode -- Todo: Think about type on non-POSIX.++foreign import ccall unsafe "archive_entry.h archive_entry_new"+ c_archive_entry_new :: IO (Ptr CEntry)++-- Similar to c_free_finalizer from ByteString.+foreign import ccall unsafe "static archive_entry.h &archive_entry_free"+ c_archive_entry_free_finalizer :: FunPtr (Ptr CEntry -> IO ())++foreign import ccall unsafe "archive_entry.h archive_entry_pathname"+ c_archive_entry_pathname :: Ptr CEntry -> IO CString++foreign import ccall unsafe "archive_entry.h archive_entry_pathname_utf8"+ c_archive_entry_pathname_utf8 :: Ptr CEntry -> IO CString++foreign import ccall unsafe "archive_entry.h archive_entry_size"+ c_archive_entry_size :: Ptr CEntry -> IO Int64++foreign import ccall unsafe "archive_entry.h archive_entry_size_is_set"+ c_archive_entry_size_is_set :: Ptr CEntry -> IO CInt++--------------------------------------------------------------------------------++-- Documented libarchive return codes.+data RetCode+ = RetCodeEOF+ | RetCodeOK+ | RetCodeRETRY+ | RetCodeWARN+ | RetCodeFAILED+ | RetCodeFATAL+ deriving (Show)++retCodes :: [(CInt, RetCode)]+retCodes =+ [ (1, RetCodeEOF)+ , (0, RetCodeOK)+ , (-10, RetCodeRETRY)+ , (-20, RetCodeWARN)+ , (-25, RetCodeFAILED)+ , (-30, RetCodeFATAL) ]++data ArchiveError =+ ArchiveError { err_function :: !String+ , err_retcode :: !(Either CInt RetCode)+ , err_number :: !Int+ , err_string :: !String }+ deriving (Show)+instance Exception ArchiveError++newtype ErrorString = ErrorString String deriving (Show)+instance Exception ErrorString++archive_error_string :: Ptr CArchive -> IO String+archive_error_string aptr = do+ cstr <- c_archive_error_string aptr+ if cstr == nullPtr+ then return "archive_error_string returned NULL"+ else peekCString cstr++throwArchiveError :: String -> CInt -> Ptr CArchive -> IO noReturn+throwArchiveError fn rc aptr = do+ num <- fromIntegral <$> c_archive_errno aptr+ str <- archive_error_string aptr+ throw $ ArchiveError+ { err_function = fn+ , err_retcode = maybe (Left rc) Right (lookup rc retCodes)+ , err_number = num+ , err_string = str }++--------------------------------------------------------------------------------++newtype Archive = Archive (Ptr CArchive)++newtype Entry = Entry (ForeignPtr CEntry)++data FileType = FileTypeRegular+ | FileTypeSymlink+ | FileTypeSocket+ | FileTypeCharDevice+ | FileTypeBlockDevice+ | FileTypeDirectory+ | FileTypeNamedPipe+ deriving (Show, Eq)++archive_read_new :: IO Archive+archive_read_new = do+ aptr <- c_archive_read_new+ if aptr == nullPtr+ then throw $ ErrorString "archive_read_new returned NULL"+ else return $ Archive aptr++archive_read_support_filter_all :: Archive -> IO ()+archive_read_support_filter_all (Archive aptr) = do+ rc <- c_archive_read_support_filter_all aptr+ when (rc /= 0) $ throwArchiveError "archive_read_support_filter_all" rc aptr++archive_read_support_format_all :: Archive -> IO ()+archive_read_support_format_all (Archive aptr) = do+ rc <- c_archive_read_support_format_all aptr+ when (rc /= 0) $ throwArchiveError "archive_read_support_format_all" rc aptr++archive_read_support_format_gnutar :: Archive -> IO ()+archive_read_support_format_gnutar (Archive aptr) = do+ rc <- c_archive_read_support_format_gnutar aptr+ when (rc /= 0) $ throwArchiveError "archive_read_support_format_gnutar" rc aptr++-- Fixed block size for now.+{-# INLINE blockSize #-}+blockSize :: (Num a) => a+blockSize = 4096++archive_read_open_filename :: Archive -> FilePath -> IO ()+archive_read_open_filename (Archive aptr) fp =+ withCString fp $ \cstr -> do+ rc <- c_archive_read_open_filename aptr cstr blockSize+ when (rc /= 0) $ throwArchiveError "archive_read_open_filename" rc aptr++-- | Returns 'Nothing' if we have reached the end of the archive.+{-# INLINE archive_read_next_header #-}+archive_read_next_header :: Archive -> IO (Maybe Entry)+archive_read_next_header (Archive aptr) = do+ fpe <- mask_ $ c_archive_entry_new >>= newForeignPtr c_archive_entry_free_finalizer+ rc <- withForeignPtr fpe $ c_archive_read_next_header2 aptr+ if rc == 1 then -- EOF.+ return Nothing+ else if rc < 0 then+ throwArchiveError "archive_read_next_header" rc aptr+ else+ return . Just . Entry $ fpe++{-# INLINE fileTypeAeIFMT #-}+fileTypeAeIFMT :: CMode+fileTypeAeIFMT = 0o0170000++{-# INLINE fileTypes #-}+fileTypes :: [(CMode, FileType)]+fileTypes =+ [ (0o0100000, FileTypeRegular)+ , (0o0120000, FileTypeSymlink)+ , (0o0140000, FileTypeSocket)+ , (0o0020000, FileTypeCharDevice)+ , (0o0060000, FileTypeBlockDevice)+ , (0o0040000, FileTypeDirectory)+ , (0o0010000, FileTypeNamedPipe) ]++{-# INLINE archive_entry_filetype #-}+archive_entry_filetype :: Entry -> IO (Maybe FileType)+archive_entry_filetype (Entry feptr) = withForeignPtr feptr $ \eptr -> do+ i <- c_archive_entry_filetype eptr+ return $ lookup (i .&. fileTypeAeIFMT) fileTypes++{-# INLINE archive_entry_pathname #-}+archive_entry_pathname :: Entry -> IO (Maybe ByteString)+archive_entry_pathname (Entry feptr) = withForeignPtr feptr $ \eptr -> do+ cstr <- c_archive_entry_pathname eptr+ if cstr == nullPtr+ then return Nothing+ else Just <$> packCString cstr++{-# INLINE archive_entry_pathname_utf8 #-}+archive_entry_pathname_utf8 :: Entry -> IO (Maybe ByteString)+archive_entry_pathname_utf8 (Entry feptr) = withForeignPtr feptr $ \eptr -> do+ cstr <- c_archive_entry_pathname_utf8 eptr+ if cstr == nullPtr+ then return Nothing+ else Just <$> packCString cstr++{-# INLINE archive_entry_size #-}+archive_entry_size :: Entry -> IO (Maybe Int)+archive_entry_size (Entry feptr) = withForeignPtr feptr $ \eptr -> do+ size_is_set <- (/= 0) <$> c_archive_entry_size_is_set eptr+ if size_is_set then+ Just . fromIntegral <$> c_archive_entry_size eptr+ else+ return Nothing++-- | Please free after use.+alloc_archive_read_data_buffer :: IO (Ptr CChar)+alloc_archive_read_data_buffer = mallocBytes blockSize++-- | Returns 'Nothing' if there is no more data for the current entry.+-- Pass in a buffer allocated with 'alloc_archive_read_data_buffer'.+{-# INLINE archive_read_data #-}+archive_read_data :: Archive -> Ptr CChar -> IO (Maybe ByteString)+archive_read_data (Archive aptr) buf = do+ rb <- c_archive_read_data aptr buf blockSize+ if rb == 0 then+ return Nothing+ else if rb < 0 then+ throwArchiveError "archive_read_data" (fromIntegral rb) aptr+ else+ Just <$> packCStringLen (buf, fromIntegral rb)++{-# INLINE archive_read_data_block #-}+archive_read_data_block :: Archive -> Ptr (Ptr CChar) -> Ptr CSize -> Ptr Int64 -> Int64 -> IO (ByteString, Bool)+archive_read_data_block (Archive aptr) buf sz offs pos = do+ rc <- c_archive_read_data_block aptr buf sz offs+ if rc < 0 then+ throwArchiveError "archive_read_data_block" (fromIntegral rc) aptr+ else if rc == 0 || rc == 1 then do -- OK or EOF.+ bs <- peek buf >>= \buf' -> peek sz >>= \sz' -> packCStringLen (buf', fromIntegral sz')+ offs' <- peek offs+ -- pos: Where we are currently located and where the data goes normally (for non-sparse files).+ -- offs': Where libarchive is asking us to position the data.+ if offs' == pos then+ return (bs, rc == 1)+ else if offs' > pos then do+ -- For a sparse file, we need to prepend zeroes to the normal data.+ let diff = offs' - pos+ let bs' = B.replicate (fromIntegral diff) 0 `B.append` bs+ return (bs', rc == 1)+ else+ throw $ ErrorString "archive_read_data_block: unexpected offset"+ else+ throw $ ErrorString "archive_read_data_block: unexpected return code"++archive_read_free :: Archive -> IO ()+archive_read_free (Archive aptr) = do+ rc <- c_archive_read_free aptr+ when (rc /= 0) $ throwArchiveError "archive_read_free" rc aptr++--------------------------------------------------------------------------------
+ streamly-archive.cabal view
@@ -0,0 +1,75 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 5da7b897c9948b1a21fdedb2baab24ef18e4505b4cc95d4a80edb7ab6e4254b7++name: streamly-archive+version: 0.0.1+synopsis: Stream data from archives using the streamly library.+description: Please see the README on GitHub at <https://github.com/shlok/streamly-archive#readme>+category: Archive, Codec, Streaming, Streamly+homepage: https://github.com/shlok/streamly-archive#readme+bug-reports: https://github.com/shlok/streamly-archive/issues+author: Shlok Datye+maintainer: sd-haskell@quant.is+copyright: 2020 Shlok Datye+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md+data-files:+ test/data/sparse.tar++source-repository head+ type: git+ location: https://github.com/shlok/streamly-archive++library+ exposed-modules:+ Streamly.External.Archive+ Streamly.External.Archive.Internal.Foreign+ other-modules:+ Paths_streamly_archive+ hs-source-dirs:+ src+ ghc-options: -Wall+ extra-libraries:+ archive+ build-depends:+ base >=4.7 && <5+ , bytestring >=0.10 && <0.11+ , streamly >=0.7 && <0.8+ default-language: Haskell2010++test-suite streamly-archive-test+ type: exitcode-stdio-1.0+ main-is: TestSuite.hs+ other-modules:+ Streamly.External.Archive.Tests+ Paths_streamly_archive+ hs-source-dirs:+ test+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ extra-libraries:+ archive+ build-depends:+ QuickCheck >=2.13.2 && <2.14+ , base >=4.7 && <5+ , bytestring >=0.10 && <0.11+ , cryptonite >=0.26+ , directory >=1.3.6.0 && <1.4+ , filepath >=1.4.2.1 && <1.5+ , streamly >=0.7 && <0.8+ , streamly-archive ==0.0.1+ , tar >=0.5.1.1 && <0.6+ , tasty >=1.2.3 && <1.3+ , tasty-hunit >=0.10.0.2 && <0.11+ , tasty-quickcheck >=0.10.1.1 && <0.11+ , temporary >=1.3 && <1.4+ , zlib >=0.6.2.1 && <0.7+ default-language: Haskell2010
+ test/Streamly/External/Archive/Tests.hs view
@@ -0,0 +1,194 @@+--------------------------------------------------------------------------------++{-# LANGUAGE NumericUnderscores, OverloadedStrings #-}++--------------------------------------------------------------------------------++module Streamly.External.Archive.Tests (tests) where++--------------------------------------------------------------------------------++import Codec.Compression.GZip (compress)+import Control.Monad (forM)+import Crypto.Random.Entropy (getEntropy)+import Data.Bifunctor (first)+import Data.ByteString (ByteString, append)+import Data.ByteString.Char8 (unpack)+import Data.Char (chr, ord)+import Data.Either (isRight)+import Data.Function ((&))+import Data.List (nub, sort)+import Data.Maybe (fromJust)+import Streamly.Internal.Data.Fold.Types (Fold (..))+import System.Directory (createDirectoryIfMissing)+import System.FilePath (addTrailingPathSeparator, hasTrailingPathSeparator, joinPath, takeDirectory)+import System.IO.Temp (withSystemTempDirectory)+import Test.QuickCheck (Gen, choose, frequency, vectorOf)+import Test.QuickCheck.Monadic (monadicIO, pick, run)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)+import Test.Tasty.QuickCheck (testProperty)++import qualified Codec.Archive.Tar as Tar+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import qualified Streamly.Prelude as S++import Streamly.External.Archive (FileType (..), headerFileType, headerPathName, headerSize, readArchive)+import Streamly.External.Archive.Internal.Foreign (blockSize)++--------------------------------------------------------------------------------++tests :: [TestTree]+tests =+ [ testTar False+ , testTar True+ , testSparse ]++--------------------------------------------------------------------------------++-- | Use other libraries to create a tar (or tar.gz) file containing random data,+-- read the file back using our library, and check if the results are as expected.+testTar :: Bool -> TestTree+testTar gz = testProperty ("tar (" ++ (if gz then "gz" else "no gz") ++ ")") $ monadicIO $ do+ -- Generate a random file system hierarchy.+ hierarchy <- pick $ randomHierarchy "" 4 4 5++ -- Create a new temporary directory, write our hierarchy into+ -- a "files" subdirectory of the temporary directory, use other+ -- libraries to create files.tar (or files.tar.gz), read the file+ -- back using our library, and check if the results are as expected.+ run . withSystemTempDirectory "archive-streaming-testZip" $ \tmpDir -> do+ let filesDir = joinPath [tmpDir, "files"]+ createDirectoryIfMissing True filesDir+ pathsAndByteStrings <- writeHierarchy filesDir hierarchy++ let archFile = joinPath [tmpDir, "files.tar" ++ (if gz then ".gz" else "")]+ LB.writeFile archFile . (if gz then compress else id) . Tar.write =<< Tar.pack tmpDir ["files"]++ let fileFold = Fold+ (\(mfp, mtyp, msz, mbs) e ->+ case e of+ Left h -> do+ mfp_ <- headerPathName h+ mtyp_ <- headerFileType h+ msz_ <- headerSize h+ return (unpack <$> mfp_, mtyp_, msz_, mbs)+ Right bs -> return (mfp, mtyp, msz, case mbs of+ Nothing -> Just bs+ Just bs' -> Just $ bs' `append` bs))+ (return (Nothing, Nothing, Nothing, Nothing))+ return++ pathsFileTypesSizesAndByteStrings <-+ S.unfold (readArchive archFile) undefined+ & S.groupsBy (\a _ -> isRight a) fileFold+ & S.map (\(mfp, mtyp, msz, mbs) -> (fromJust mfp, fromJust mtyp, msz, mbs))+ & S.toList++ -- Make the file paths and ByteStrings comparable and compare them.+ let pathsAndByteStrings_ = sort $ map (first ("files/"++)) (("", Nothing) : pathsAndByteStrings)+ let pathAndByteStrings2_ = sort . map (\(x, _, _, y) -> (x, y)) $ pathsFileTypesSizesAndByteStrings+ let samePathsAndByteStrings = pathsAndByteStrings_ == pathAndByteStrings2_++ -- Check FileType.+ let fileTypesCorrect = all (\(fp, typ, _, _) ->+ if hasTrailingPathSeparator fp+ then typ == FileTypeDirectory+ else typ == FileTypeRegular) pathsFileTypesSizesAndByteStrings++ -- Check header file size.+ let fileSizeCorrect = all (\(_, _, msz, mbs) ->+ case (msz, mbs) of+ (Nothing, _) -> False -- The size is always available.+ (Just sz, Nothing) -> sz == 0 -- File or directory.+ (Just sz, Just bs) -> fromIntegral sz == B.length bs) pathsFileTypesSizesAndByteStrings++ return $ samePathsAndByteStrings && fileTypesCorrect && fileSizeCorrect++-- | Read a fixed sparse file (sparse.tar) using our library and make sure the results are as expected.+-- (The file was created manually on Linux with "cp --sparse=always" to create the sparse files and+-- "tar -Scvf" to create the archive. We were unable to do the equivalent thing on macOS Mojave / APFS.)+testSparse :: TestTree+testSparse = testCase "sparse" $ do+ let fileFold = Fold+ (\(mfp, mbs) e ->+ case e of+ Left h -> do+ mfp_ <- headerPathName h+ return (unpack <$> mfp_, mbs)+ Right bs -> return (mfp, case mbs of+ Nothing -> Just bs+ Just bs' -> Just $ bs' `append` bs))+ (return (Nothing, Nothing))+ return++ archive <-+ S.unfold (readArchive "test/data/sparse.tar") undefined+ & S.groupsBy (\a _ -> isRight a) fileFold+ & S.map (\(mfp, mbs) -> (fromJust mfp, fromJust mbs))+ & S.toList++ assertEqual "" (map fst archive) ["zero", "zeroZero", "zeroAsdf", "asdfZero"]++ let tenMb = 10_000_000+ let zero = B.replicate tenMb 0+ let asdf = "asdf"++ assertBool "unexpected bytestring (1)" $ (snd $ archive !! 0) == zero+ assertBool "unexpected bytestring (2)" $ (snd $ archive !! 1) == zero `B.append` zero+ assertBool "unexpected bytestring (3)" $ (snd $ archive !! 2) == zero `B.append` asdf+ assertBool "unexpected bytestring (4)" $ (snd $ archive !! 3) == asdf `B.append` zero++--------------------------------------------------------------------------------++-- | Writes a given hierarchy of relative paths (created with 'randomHierarchy') to disk+-- in the specified directory and returns the same hierarchy except with actual ByteStrings+-- instead of lengths. Note: The original relative paths are returned back unaltered.+writeHierarchy :: FilePath -> [(FilePath, Maybe Int)] -> IO [(FilePath, Maybe ByteString)]+writeHierarchy writeDir = mapM $ \(p, mBsLen) ->+ let fullp = joinPath [writeDir, p]+ in case mBsLen of+ Just bsLen -> do+ createDirectoryIfMissing True (takeDirectory fullp)+ bs <- getEntropy (fromIntegral bsLen)+ B.writeFile fullp bs+ return (p, if bsLen == 0+ then Nothing -- Our library yields no ByteString at all for empty files.+ else Just bs)+ Nothing -> createDirectoryIfMissing True fullp >> return (p, Nothing)++-- | Recursively generates a random hierarchy of relative paths to files and+-- directories. (Nothing is written to disk; only the paths are returned.)+-- The initial dirPath should be "". A random bytestring length is+-- provided in case of a file; 'Nothing' in the case of a directory.+randomHierarchy :: FilePath -> Int -> Int -> Int -> Gen [(FilePath, Maybe Int)]+randomHierarchy dirPath maxFiles maxDirs maxDepth = do+ numFiles <- choose (0, maxFiles)+ fileComps <- nub <$> vectorOf numFiles pathComponent+ let filePaths = map (\c -> joinPath [dirPath, c]) fileComps+ bsLengths <- map Just <$> vectorOf (length filePaths)+ ( frequency [ (1, choose (0, 5))+ , (1, choose (blockSize - 5, blockSize + 5))+ , (1, choose (0, 3 * blockSize)) ] )++ numDirs <- choose (0, maxDirs)+ dirComps <- nub . filter (not . (`elem` fileComps))+ <$> vectorOf (if maxDepth <= 0 then 0 else numDirs) pathComponent+ -- libarchive reads back directory paths with a trailing separator.+ let dirPaths = map (\c -> addTrailingPathSeparator $ joinPath [dirPath, c]) dirComps++ recursion <- concat <$> forM dirPaths (\dirPath' ->+ randomHierarchy dirPath' (maxFiles `div` 2) (maxDirs `div` 2) (maxDepth - 1))++ return $ zip filePaths bsLengths ++ zip dirPaths (repeat Nothing) ++ recursion++-- | Generates a random path component of length between 1 and 10, e.g., "HO53UVKQ".+-- For compatibility with case-insensitive file systems, uses only one case.+pathComponent :: Gen String+pathComponent = do+ len <- choose (1, 10)+ vectorOf len $ chr <$> frequency [ (1, choose (ord 'A', ord 'Z'))+ , (1, choose (ord '0', ord '9')) ]++--------------------------------------------------------------------------------
+ test/TestSuite.hs view
@@ -0,0 +1,22 @@+--------------------------------------------------------------------------------++module Main where++--------------------------------------------------------------------------------++import Test.Tasty (TestTree, defaultMain, testGroup)++import qualified Streamly.External.Archive.Tests++--------------------------------------------------------------------------------++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+ testGroup "Tests"+ [ testGroup "Streamly.External.Archive.Tests"+ Streamly.External.Archive.Tests.tests ]++--------------------------------------------------------------------------------
+ test/data/sparse.tar view
binary file changed (absent → 10240 bytes)