streamly-archive 0.1.0 → 0.2.0
raw patch · 8 files changed
+485/−400 lines, 8 filesdep +streamly-coredep ~bytestringdep ~streamly
Dependencies added: streamly-core
Dependency ranges changed: bytestring, streamly
Files
- ChangeLog.md +6/−1
- LICENSE +1/−1
- README.md +49/−35
- src/Streamly/External/Archive.hs +85/−50
- src/Streamly/External/Archive/Internal/Foreign.hs +165/−158
- streamly-archive.cabal +14/−15
- test/Streamly/External/Archive/Tests.hs +158/−127
- test/TestSuite.hs +7/−13
ChangeLog.md view
@@ -1,6 +1,11 @@+## 0.2.0++* Updated for Streamly 0.9.0.+* Added `groupByHeader` convenience function.+ ## 0.1.0 -* Updated for streamly 0.8.0.+* Updated for Streamly 0.8.0. ## 0.0.2
LICENSE view
@@ -1,4 +1,4 @@-Copyright Shlok Datye (c) 2020+Copyright Shlok Datye (c) 2023 All rights reserved.
README.md view
@@ -15,54 +15,68 @@ ## Quick start ```haskell-{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE 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+import qualified Streamly.Data.Fold as F+import qualified Streamly.Data.Stream.Prelude as S+import Streamly.External.Archive+ ( Header,+ groupByHeader,+ headerPathName,+ readArchive,+ )+import Streamly.Internal.Data.Fold.Type (Fold (Fold), Step (Partial))+import Streamly.Internal.Data.Unfold.Type (Unfold) 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"+ -- 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))+ -- 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 $ Partial (mpath', mctx)+ Right bs ->+ return $+ Partial+ ( mpath,+ Just . (`hashUpdate` bs) $+ fromMaybe (hashInit @SHA256) mctx+ )+ )+ (return $ Partial (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+ -- 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+ & groupByHeader entryFold+ & S.mapM print+ & S.fold F.drain ``` ## Benchmarks@@ -71,4 +85,4 @@ 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.+<sup>†</sup> April 2023; [Linode](https://linode.com); Debian 11, Dedicated 32GB: 16 CPU, 640GB Storage, 32GB RAM.
src/Streamly/External/Archive.hs view
@@ -1,13 +1,11 @@-----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}----------------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} module Streamly.External.Archive- (- -- ** Read+ ( -- ** Read readArchive,+ groupByHeader, -- ** Header Header,@@ -15,31 +13,44 @@ headerFileType, headerPathName, headerPathNameUtf8,- headerSize) where----------------------------------------------------------------------------------+ headerSize,+ )+where import Control.Exception (mask_) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Either+import Data.Function import Data.Int (Int64) import Data.Void (Void) import Foreign (Ptr, free, malloc) import Foreign.C.Types (CChar, CSize)+import Streamly.Data.Fold (Fold)+import qualified Streamly.Data.Parser as P+import Streamly.Data.Stream.Prelude (Stream)+import qualified Streamly.Data.Stream.Prelude as S+import Streamly.Data.Unfold (lmap)+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,+ ) import Streamly.Internal.Data.IOFinalizer (newIOFinalizer, runIOFinalizer) import Streamly.Internal.Data.Stream.StreamD.Type (Step (..))-import Streamly.Internal.Data.Unfold (supply) import Streamly.Internal.Data.Unfold.Type (Unfold (..)) -import qualified Data.ByteString as B--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 @@ -59,38 +70,62 @@ headerSize :: Header -> IO (Maybe Int) headerSize (Header e) = archive_entry_size e +-- | A convenience function for grouping @Either Header ByteString@s, usually obtained with+-- 'readArchive', by the headers. The input @Fold@ processes a single entry (a 'Header' followed by+-- zero or more @ByteString@s).+{-# INLINE groupByHeader #-}+groupByHeader ::+ (Monad m) =>+ Fold m (Either Header ByteString) b ->+ Stream m (Either Header ByteString) ->+ Stream m b+groupByHeader itemFold str =+ str+ & S.parseMany (P.groupBy (\_ e -> isRight e) itemFold)+ & fmap+ ( \case+ Left _ ->+ -- groupBy is documented to never fail.+ error "unexpected parseMany/groupBy error"+ Right b -> b+ )+ -- | 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 = supply () $+readArchive fp =+ (lmap . const) () $ 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 $ runIOFinalizer ref- return Stop- Just e -> do- return $ Yield (Left $ Header e) (arch, buf, sz, offs, 0, ref, False)+ ( \(arch, buf, sz, offs, pos, ref, readHeader) ->+ if readHeader+ then do+ me <- liftIO $ archive_read_next_header arch+ case me of+ Nothing -> do+ liftIO $ runIOFinalizer 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 <- newIOFinalizer $ 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))----------------------------------------------------------------------------------+ (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 <- newIOFinalizer $ 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
@@ -1,186 +1,186 @@---------------------------------------------------------------------------------- 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----------------------------------------------------------------------------------+ ( 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 qualified Data.ByteString as B 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----------------------------------------------------------------------------------+import System.Posix.Types (CMode (CMode), CSsize (CSsize)) data CArchive+ data CEntry foreign import ccall unsafe "archive.h archive_errno"- c_archive_errno :: Ptr CArchive -> IO CInt+ c_archive_errno :: Ptr CArchive -> IO CInt foreign import ccall unsafe "archive.h archive_error_string"- c_archive_error_string :: Ptr CArchive -> IO CString+ c_archive_error_string :: Ptr CArchive -> IO CString foreign import ccall unsafe "archive.h archive_read_new"- c_archive_read_new :: IO (Ptr CArchive)+ 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+ 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+ 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+ 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+ 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+ 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.+ -- Todo: Think about la_ssize_t on non-POSIX.+ c_archive_read_data :: Ptr CArchive -> Ptr CChar -> CSize -> IO CSsize 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+ 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+ 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.+ 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)+ 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 ())+ 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+ 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+ 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+ 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----------------------------------------------------------------------------------+ c_archive_entry_size_is_set :: Ptr CEntry -> IO CInt -- Documented libarchive return codes. data RetCode- = RetCodeEOF- | RetCodeOK- | RetCodeRETRY- | RetCodeWARN- | RetCodeFAILED- | RetCodeFATAL- deriving (Show)+ = RetCodeEOF+ | RetCodeOK+ | RetCodeRETRY+ | RetCodeWARN+ | RetCodeFAILED+ | RetCodeFATAL+ deriving (Show) retCodes :: [(CInt, RetCode)] retCodes =- [ (1, RetCodeEOF)- , (0, RetCodeOK)- , (-10, RetCodeRETRY)- , (-20, RetCodeWARN)- , (-25, RetCodeFAILED)- , (-30, RetCodeFATAL) ]+ [ (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)+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+ 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 }----------------------------------------------------------------------------------+ 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)+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+ 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+ 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+ 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+ 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 #-}@@ -189,22 +189,22 @@ 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+ 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+ fpe <- mask_ $ c_archive_entry_new >>= newForeignPtr c_archive_entry_free_finalizer+ rc <- withForeignPtr fpe $ c_archive_read_next_header2 aptr+ if rc == 1 -- EOF.+ then return Nothing else- return . Just . Entry $ fpe+ if rc < 0+ then throwArchiveError "archive_read_next_header" rc aptr+ else return . Just . Entry $ fpe {-# INLINE fileTypeAeIFMT #-} fileTypeAeIFMT :: CMode@@ -213,44 +213,44 @@ {-# INLINE fileTypes #-} fileTypes :: [(CMode, FileType)] fileTypes =- [ (0o0100000, FileTypeRegular)- , (0o0120000, FileTypeSymlink)- , (0o0140000, FileTypeSocket)- , (0o0020000, FileTypeCharDevice)- , (0o0060000, FileTypeBlockDevice)- , (0o0040000, FileTypeDirectory)- , (0o0010000, FileTypeNamedPipe) ]+ [ (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+ 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+ 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+ 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+ 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)@@ -261,40 +261,47 @@ {-# 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+ rb <- c_archive_read_data aptr buf blockSize+ if rb == 0+ then return Nothing else- Just <$> packCStringLen (buf, fromIntegral rb)+ 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 ->+ 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"+ rc <- c_archive_read_data_block aptr buf sz offs+ if rc < 0+ then throwArchiveError "archive_read_data_block" (fromIntegral rc) aptr else- throw $ ErrorString "archive_read_data_block: unexpected return code"+ 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----------------------------------------------------------------------------------+ rc <- c_archive_read_free aptr+ when (rc /= 0) $ throwArchiveError "archive_read_free" rc aptr
streamly-archive.cabal view
@@ -1,13 +1,6 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.34.4.------ see: https://github.com/sol/hpack------ hash: 3fcf39b51710099491d88d24c7309b32d8799b3ab5c85856dddb8b74361e25be-+cabal-version: 3.0 name: streamly-archive-version: 0.1.0+version: 0.2.0 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@@ -15,8 +8,8 @@ bug-reports: https://github.com/shlok/streamly-archive/issues author: Shlok Datye maintainer: sd-haskell@quant.is-copyright: 2021 Shlok Datye-license: BSD3+copyright: 2023 Shlok Datye+license: BSD-3-Clause license-file: LICENSE build-type: Simple extra-source-files:@@ -35,6 +28,8 @@ Streamly.External.Archive.Internal.Foreign other-modules: Paths_streamly_archive+ autogen-modules:+ Paths_streamly_archive hs-source-dirs: src ghc-options: -Wall@@ -42,8 +37,9 @@ archive build-depends: base >=4.7 && <5- , bytestring ==0.10.*- , streamly ==0.8.*+ , bytestring ==0.11.*+ , streamly ==0.9.*+ , streamly-core ==0.1.* default-language: Haskell2010 test-suite streamly-archive-test@@ -52,6 +48,8 @@ other-modules: Streamly.External.Archive.Tests Paths_streamly_archive+ autogen-modules:+ Paths_streamly_archive hs-source-dirs: test ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N@@ -60,11 +58,12 @@ build-depends: QuickCheck >=2.13.2 && <2.15 , base >=4.7 && <5- , bytestring ==0.10.*+ , bytestring ==0.11.* , cryptonite >=0.26 , directory >=1.3.6.0 && <1.4 , filepath >=1.4.2.1 && <1.5- , streamly ==0.8.*+ , streamly ==0.9.*+ , streamly-core ==0.1.* , streamly-archive , tar >=0.5.1.1 && <0.6 , tasty >=1.2.3 && <1.5
test/Streamly/External/Archive/Tests.hs view
@@ -1,24 +1,24 @@-----------------------------------------------------------------------------------{-# LANGUAGE NumericUnderscores, OverloadedStrings #-}----------------------------------------------------------------------------------+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-} module Streamly.External.Archive.Tests (tests) where ----------------------------------------------------------------------------------+import qualified Codec.Archive.Tar as Tar import Codec.Compression.GZip (compress) import Control.Monad (forM) import Crypto.Random.Entropy (getEntropy) import Data.Bifunctor (first) import Data.ByteString (ByteString, append)+import qualified Data.ByteString as B import Data.ByteString.Char8 (unpack)+import qualified Data.ByteString.Lazy as LB import Data.Char (chr, ord)-import Data.Either (isRight) import Data.Function ((&)) import Data.List (nub, sort) import Data.Maybe (fromJust)+import qualified Streamly.Data.Stream.Prelude as S+import Streamly.External.Archive+import Streamly.External.Archive.Internal.Foreign (blockSize) import Streamly.Internal.Data.Fold.Type (Fold (Fold), Step (Partial)) import System.Directory (createDirectoryIfMissing) import System.FilePath (addTrailingPathSeparator, hasTrailingPathSeparator, joinPath, takeDirectory)@@ -29,134 +29,151 @@ 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 ]----------------------------------------------------------------------------------+ [ 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+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+ -- 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 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 $ Partial (unpack <$> mfp_, mtyp_, msz_, mbs)- Right bs -> return $ Partial (mfp, mtyp, msz, case mbs of+ let fileFold =+ Fold+ ( \(mfp, mtyp, msz, mbs) e ->+ case e of+ Left h -> do+ mfp_ <- headerPathName h+ mtyp_ <- headerFileType h+ msz_ <- headerSize h+ return $ Partial (unpack <$> mfp_, mtyp_, msz_, mbs)+ Right bs ->+ return $+ Partial+ ( mfp,+ mtyp,+ msz,+ case mbs of Nothing -> Just bs- Just bs' -> Just $ bs' `append` bs))- (return $ Partial (Nothing, Nothing, Nothing, Nothing))- return+ Just bs' -> Just $ bs' `append` bs+ )+ )+ (return $ Partial (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+ pathsFileTypesSizesAndByteStrings <-+ S.unfold (readArchive archFile) undefined+ & groupByHeader fileFold+ & fmap (\(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_+ -- 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, _, _) ->+ -- Check FileType.+ let fileTypesCorrect =+ all+ ( \(fp, typ, _, _) -> if hasTrailingPathSeparator fp- then typ == FileTypeDirectory- else typ == FileTypeRegular) pathsFileTypesSizesAndByteStrings+ then typ == FileTypeDirectory+ else typ == FileTypeRegular+ )+ pathsFileTypesSizesAndByteStrings - -- Check header file size.- let fileSizeCorrect = all (\(_, _, msz, mbs) ->+ -- 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+ (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+ 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.)+-- | 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 $ Partial (unpack <$> mfp_, mbs)- Right bs -> return $ Partial (mfp, case mbs of- Nothing -> Just bs- Just bs' -> Just $ bs' `append` bs))- (return $ Partial (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+ let fileFold =+ Fold+ ( \(mfp, mbs) e ->+ case e of+ Left h -> do+ mfp_ <- headerPathName h+ return $ Partial (unpack <$> mfp_, mbs)+ Right bs ->+ return $+ Partial+ ( mfp,+ case mbs of+ Nothing -> Just bs+ Just bs' -> Just $ bs' `append` bs+ )+ )+ (return $ Partial (Nothing, Nothing))+ return - assertEqual "" (map fst archive) ["zero", "zeroZero", "zeroAsdf", "asdfZero"]+ archive <-+ S.unfold (readArchive "test/data/sparse.tar") undefined+ & groupByHeader fileFold+ & fmap (\(mfp, mbs) -> (fromJust mfp, fromJust mbs))+ & S.toList - let tenMb = 10_000_000- let zero = B.replicate tenMb 0- let asdf = "asdf"+ assertEqual "" (map fst archive) ["zero", "zeroZero", "zeroAsdf", "asdfZero"] - assertBool "unexpected bytestring (1)" $ snd (head archive) == 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+ let tenMb = 10_000_000+ let zero = B.replicate tenMb 0+ let asdf = "asdf" ---------------------------------------------------------------------------------+ assertBool "unexpected bytestring (1)" $ snd (head archive) == 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 :: 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)+ 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.)@@ -164,31 +181,45 @@ -- 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)) ] )+ 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+ 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))+ recursion <-+ concat+ <$> forM+ dirPaths+ ( \dirPath' ->+ randomHierarchy dirPath' (maxFiles `div` 2) (maxDirs `div` 2) (maxDepth - 1)+ ) - return $ zip filePaths bsLengths ++ zip dirPaths (repeat Nothing) ++ recursion+ 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')) ]----------------------------------------------------------------------------------+ len <- choose (1, 10)+ vectorOf len $+ chr+ <$> frequency+ [ (1, choose (ord 'A', ord 'Z')),+ (1, choose (ord '0', ord '9'))+ ]
test/TestSuite.hs view
@@ -1,22 +1,16 @@---------------------------------------------------------------------------------- module Main where -----------------------------------------------------------------------------------import Test.Tasty (TestTree, defaultMain, testGroup)- import qualified Streamly.External.Archive.Tests----------------------------------------------------------------------------------+import Test.Tasty (TestTree, defaultMain, testGroup) main :: IO () main = defaultMain tests tests :: TestTree tests =- testGroup "Tests"- [ testGroup "Streamly.External.Archive.Tests"- Streamly.External.Archive.Tests.tests ]----------------------------------------------------------------------------------+ testGroup+ "Tests"+ [ testGroup+ "Streamly.External.Archive.Tests"+ Streamly.External.Archive.Tests.tests+ ]