diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # libarchive +## 1.0.5.0 + + * Add facilities for lazy packing, e.g. `entriesToBSL` + * Minor documentation fixes + ## 1.0.4.0 * Add `noOpenCallback` diff --git a/libarchive.cabal b/libarchive.cabal --- a/libarchive.cabal +++ b/libarchive.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: libarchive -version: 1.0.4.0 +version: 1.0.5.0 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018-2019 Vanessa McHale @@ -33,6 +33,7 @@ hs-source-dirs: src other-modules: Codec.Archive.Pack + Codec.Archive.Pack.Lazy Codec.Archive.Unpack.Lazy Codec.Archive.Unpack Codec.Archive.Foreign.Common @@ -44,8 +45,9 @@ build-depends: base >=4.9 && <5, bytestring -any, - filepath -any, - composition-prelude -any + composition-prelude -any, + dlist -any, + filepath -any if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists diff --git a/src/Codec/Archive.hs b/src/Codec/Archive.hs --- a/src/Codec/Archive.hs +++ b/src/Codec/Archive.hs @@ -12,6 +12,9 @@ , entriesToBS , entriesToBS7zip , entriesToBSzip + , entriesToBSL + , entriesToBSLzip + , entriesToBSL7zip , readArchiveFile , readArchiveBS , readArchiveBSL @@ -28,6 +31,7 @@ ) where import Codec.Archive.Pack +import Codec.Archive.Pack.Lazy import Codec.Archive.Types import Codec.Archive.Unpack import Codec.Archive.Unpack.Lazy diff --git a/src/Codec/Archive/Common.hs b/src/Codec/Archive/Common.hs --- a/src/Codec/Archive/Common.hs +++ b/src/Codec/Archive/Common.hs @@ -3,7 +3,6 @@ ) where import Codec.Archive.Foreign -import Foreign.Marshal.Alloc (free) import Foreign.Ptr -- | Read from an 'Archive' and then free it diff --git a/src/Codec/Archive/Pack.hs b/src/Codec/Archive/Pack.hs --- a/src/Codec/Archive/Pack.hs +++ b/src/Codec/Archive/Pack.hs @@ -4,6 +4,7 @@ , entriesToBS , entriesToBSzip , entriesToBS7zip + , packEntries ) where import Codec.Archive.Foreign @@ -61,23 +62,26 @@ contentSz (Symlink fp) = fromIntegral $ length fp -- | Returns a 'BS.ByteString' containing a tar archive with the 'Entry's +-- +-- @since 1.0.0.0 entriesToBS :: Foldable t => t Entry -> BS.ByteString entriesToBS = unsafePerformIO . entriesToBSGeneral archive_write_set_format_pax_restricted {-# NOINLINE entriesToBS #-} -- | Returns a 'BS.ByteString' containing a @.7z@ archive with the 'Entry's +-- +-- @since 1.0.0.0 entriesToBS7zip :: Foldable t => t Entry -> BS.ByteString entriesToBS7zip = unsafePerformIO . entriesToBSGeneral archive_write_set_format_7zip {-# NOINLINE entriesToBS7zip #-} -- | Returns a 'BS.ByteString' containing a zip archive with the 'Entry's +-- +-- @since 1.0.0.0 entriesToBSzip :: Foldable t => t Entry -> BS.ByteString entriesToBSzip = unsafePerformIO . entriesToBSGeneral archive_write_set_format_zip {-# NOINLINE entriesToBSzip #-} --- entriesToBSLGeneral :: Foldable t => (Ptr Archive -> IO ArchiveError) -> t Entry -> IO BSL.ByteString --- entriesToBSLGeneral = - -- | Internal function to be used with 'archive_write_set_format_pax' etc. entriesToBSGeneral :: (Foldable t) => (Ptr Archive -> IO ArchiveError) -> t Entry -> IO BS.ByteString entriesToBSGeneral modifier hsEntries' = do @@ -102,15 +106,21 @@ -- @ -- BS.writeFile "file.tar" (entriesToBS entries) -- @ +-- +-- @since 1.0.0.0 entriesToFile :: Foldable t => FilePath -> t Entry -> IO () entriesToFile = entriesToFileGeneral archive_write_set_format_pax_restricted -- this is the recommended format; it is a tar archive -- | Write some entries to a file, creating a zip archive. +-- +-- @since 1.0.0.0 entriesToFileZip :: Foldable t => FilePath -> t Entry -> IO () entriesToFileZip = entriesToFileGeneral archive_write_set_format_zip -- | Write some entries to a file, creating a @.7z@ archive. +-- +-- @since 1.0.0.0 entriesToFile7Zip :: Foldable t => FilePath -> t Entry -> IO () entriesToFile7Zip = entriesToFileGeneral archive_write_set_format_7zip diff --git a/src/Codec/Archive/Pack/Lazy.hs b/src/Codec/Archive/Pack/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/Pack/Lazy.hs @@ -0,0 +1,57 @@ +module Codec.Archive.Pack.Lazy ( entriesToBSL + , entriesToBSL7zip + , entriesToBSLzip + ) where + +import Codec.Archive.Foreign +import Codec.Archive.Pack +import Codec.Archive.Types +import Control.Monad (void) +import Data.ByteString (packCStringLen) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.DList as DL +import Data.Foldable (toList) +import Data.Functor (($>)) +import Data.IORef (modifyIORef', newIORef, readIORef) +import Foreign.Marshal.Alloc (free, mallocBytes) +import Foreign.Ptr +import System.IO.Unsafe (unsafePerformIO) + +-- | @since 1.0.5.0 +entriesToBSLzip :: Foldable t => t Entry -> BSL.ByteString +entriesToBSLzip = unsafePerformIO . entriesToBSLGeneral archive_write_set_format_zip +{-# NOINLINE entriesToBSLzip #-} + +-- | @since 1.0.5.0 +entriesToBSL7zip :: Foldable t => t Entry -> BSL.ByteString +entriesToBSL7zip = unsafePerformIO . entriesToBSLGeneral archive_write_set_format_7zip +{-# NOINLINE entriesToBSL7zip #-} + +-- | In general, this will be more efficient than 'entriesToBS' +-- +-- @since 1.0.5.0 +entriesToBSL :: Foldable t => t Entry -> BSL.ByteString +entriesToBSL = unsafePerformIO . entriesToBSLGeneral archive_write_set_format_pax_restricted +{-# NOINLINE entriesToBSL #-} + +-- I'm not sure if this actually streams anything or not but like... +entriesToBSLGeneral :: Foldable t => (Ptr Archive -> IO ArchiveError) -> t Entry -> IO BSL.ByteString +entriesToBSLGeneral modifier hsEntries' = do + a <- archive_write_new + bsRef <- newIORef mempty + oc <- mkOpenCallback doNothing + wc <- mkWriteCallback (writeBSL bsRef) + cc <- mkCloseCallback (\_ ptr -> freeHaskellFunPtr oc *> freeHaskellFunPtr wc *> free ptr $> archiveOk) + nothingPtr <- mallocBytes 0 + void $ modifier a + void $ archive_write_open a nothingPtr oc wc cc + packEntries a hsEntries' + void $ archive_write_free a + BSL.fromChunks . toList <$> readIORef bsRef + + where writeBSL bsRef _ _ bufPtr sz = do + let bytesRead = min sz (32 * 1024) + bsl <- packCStringLen (bufPtr, fromIntegral bytesRead) + modifyIORef' bsRef (`DL.snoc` bsl) + pure bytesRead + doNothing _ _ = pure archiveOk diff --git a/src/Codec/Archive/Unpack.hs b/src/Codec/Archive/Unpack.hs --- a/src/Codec/Archive/Unpack.hs +++ b/src/Codec/Archive/Unpack.hs @@ -22,6 +22,8 @@ -- | Read an archive contained in a 'BS.ByteString'. The format of the archive is -- automatically detected. +-- +-- @since 1.0.0.0 readArchiveBS :: BS.ByteString -> [Entry] readArchiveBS = unsafePerformIO . (actFree hsEntries <=< bsToArchive) {-# NOINLINE readArchiveBS #-} @@ -37,6 +39,8 @@ -- | Read an archive from a file. The format of the archive is automatically -- detected. +-- +-- @since 1.0.0.0 readArchiveFile :: FilePath -> IO [Entry] readArchiveFile = actFree hsEntries <=< archiveFile diff --git a/src/Codec/Archive/Unpack/Lazy.hs b/src/Codec/Archive/Unpack/Lazy.hs --- a/src/Codec/Archive/Unpack/Lazy.hs +++ b/src/Codec/Archive/Unpack/Lazy.hs @@ -1,5 +1,4 @@ module Codec.Archive.Unpack.Lazy ( readArchiveBSL - , bslToArchive , unpackToDirLazy ) where @@ -23,6 +22,9 @@ -> CSize -- ^ Size -> IO (Ptr a) -- ^ Pointer to destination +-- | In general, this will be more efficient than 'unpackToDir' +-- +-- @since 1.0.4.0 unpackToDirLazy :: FilePath -- ^ Directory to unpack in -> BSL.ByteString -- ^ 'BSL.ByteString' containing archive -> IO () @@ -34,15 +36,17 @@ -- | Read an archive lazily. The format of the archive is automatically -- detected. +-- +-- In general, this will be more efficient than 'readArchiveBS' +-- +-- @since 1.0.4.0 readArchiveBSL :: BSL.ByteString -> [Entry] readArchiveBSL = unsafePerformIO . (actFreeCallback hsEntries <=< bslToArchive) -freeBits :: FunPtr a -> Ptr b -> IO () -freeBits fp ptr = freeHaskellFunPtr fp *> free ptr - -- | Lazily stream a 'BSL.ByteString' +-- @since 1.0.4.0 bslToArchive :: BSL.ByteString - -> IO (Ptr Archive, IO ()) -- ^ Returns an 'IO' action that can be used to free things after we're done with the archive + -> IO (Ptr Archive, IO ()) -- ^ Returns an 'IO' action to be used to clean up after we're done with the archive bslToArchive bs = do a <- archive_read_new void $ archive_read_support_format_all a @@ -56,8 +60,8 @@ , archive_read_set_callback_data a nothingPtr , archive_read_open1 a ] - let act = freeBits cc bufPtr - pure (a, act) + pure (a, freeHaskellFunPtr cc *> free bufPtr) + where readBSL bsRef bufPtr _ _ dataPtr = do bs' <- readIORef bsRef case bs' of