diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,3 @@
+# Changelog for streamly-archive
+
+## Unreleased changes
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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† 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.
+
+† [Linode](https://linode.com); Debian 10, Dedicated 32GB: 16 CPU, 640GB Storage, 32GB RAM.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/src/Streamly/External/Archive.hs b/src/Streamly/External/Archive.hs
new file mode 100644
--- /dev/null
+++ b/src/Streamly/External/Archive.hs
@@ -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))
+
+--------------------------------------------------------------------------------
diff --git a/src/Streamly/External/Archive/Internal/Foreign.hs b/src/Streamly/External/Archive/Internal/Foreign.hs
new file mode 100644
--- /dev/null
+++ b/src/Streamly/External/Archive/Internal/Foreign.hs
@@ -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
+
+--------------------------------------------------------------------------------
diff --git a/streamly-archive.cabal b/streamly-archive.cabal
new file mode 100644
--- /dev/null
+++ b/streamly-archive.cabal
@@ -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
+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
diff --git a/test/Streamly/External/Archive/Tests.hs b/test/Streamly/External/Archive/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/Streamly/External/Archive/Tests.hs
@@ -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')) ]
+
+--------------------------------------------------------------------------------
diff --git a/test/TestSuite.hs b/test/TestSuite.hs
new file mode 100644
--- /dev/null
+++ b/test/TestSuite.hs
@@ -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 ]
+
+--------------------------------------------------------------------------------
diff --git a/test/data/sparse.tar b/test/data/sparse.tar
new file mode 100644
Binary files /dev/null and b/test/data/sparse.tar differ