diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # libarchive +## 3.0.0.0 + + * Use `ForeignPtr` over `Ptr` + * Fix `.cpio` and `.zip` functions + * Add `.shar` functions + * The `Entry` and `EntryContent` are now higher-kinded. This allows one to use + the types with e.g. `RawFilePath`s. + ## 2.2.5.2 * Patch from upstream to work with pathological archives containing files that diff --git a/libarchive.cabal b/libarchive.cabal --- a/libarchive.cabal +++ b/libarchive.cabal @@ -1,12 +1,15 @@ cabal-version: 3.0 name: libarchive -version: 2.2.5.2 +version: 3.0.0.0 license: BSD-3-Clause license-file: LICENSE copyright: Copyright: (c) 2018-2020 Vanessa McHale maintainer: vamchale@gmail.com author: Vanessa McHale -tested-with: ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.3 ghc ==8.10.1 +tested-with: + ghc ==8.0.2 ghc ==8.2.2 ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.4 + ghc ==8.10.2 + bug-reports: https://github.com/vmchale/libarchive/issues synopsis: Haskell interface to libarchive description: @@ -20,6 +23,7 @@ c/autoconf-freebsd/config.h c/*.c c/*.h + test/data/aarch64-linux-dist.tar extra-doc-files: README.md @@ -44,10 +48,9 @@ description: Run low-memory version of test suite default: False -flag static - description: Use the bundled sources - default: False - manual: True +flag system-libarchive + description: + Use libarchive found with pkg-config rather than the bundled sources library exposed-modules: @@ -73,12 +76,9 @@ default-language: Haskell2010 other-extensions: DeriveGeneric DeriveAnyClass - ghc-options: - -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints - + ghc-options: -Wall build-depends: - base >=4.9 && <5, + base >=4.8 && <5, bytestring -any, composition-prelude >=2.0.5.0, dlist -any, @@ -90,14 +90,24 @@ if !flag(cross) build-tool-depends: c2hs:c2hs >=0.26.1 + if !impl(ghc >=8.0) + build-depends: + semigroups -any, + transformers -any + + if impl(ghc >=8.0) + ghc-options: + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints + if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists if impl(ghc >=8.10) ghc-options: -Wunused-packages - if flag(static) - cc-options: -std=gnu99 -DHAVE_CONFIG_H + if !flag(system-libarchive) + cc-options: -std=c11 -DHAVE_CONFIG_H c-sources: c/archive_acl.c c/archive_blake2sp_ref.c @@ -259,10 +269,7 @@ default-language: Haskell2010 other-extensions: OverloadedStrings - ghc-options: - -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N - + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall build-depends: base -any, libarchive -any, @@ -279,6 +286,14 @@ if flag(low-memory) cpp-options: -DLOW_MEMORY + if !impl(ghc >=8.0) + build-depends: transformers -any + + if impl(ghc >=8.0) + ghc-options: + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints + if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists @@ -290,10 +305,7 @@ main-is: Bench.hs hs-source-dirs: bench default-language: Haskell2010 - ghc-options: - -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints - + ghc-options: -Wall build-depends: base -any, libarchive -any, @@ -303,6 +315,11 @@ tar-conduit >=0.2.5, temporary -any + if impl(ghc >=8.0) + ghc-options: + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints + if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists @@ -314,13 +331,16 @@ main-is: Mem.hs hs-source-dirs: mem default-language: Haskell2010 - ghc-options: - -Wall -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints - + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base -any, - libarchive -any + libarchive -any, + bytestring -any + + if impl(ghc >=8.0) + ghc-options: + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists diff --git a/mem/Mem.hs b/mem/Mem.hs --- a/mem/Mem.hs +++ b/mem/Mem.hs @@ -1,14 +1,28 @@ module Main ( main ) where import Codec.Archive -import Control.Exception (throw) +import Control.Exception (throw) +import qualified Data.ByteString.Lazy as BSL forceList :: [a] -> IO () forceList = (`seq` mempty) . last main :: IO () -main = readArc +main = + sequence_ + [ readArc + , readWriteArc + , readArcBS + ] readArc :: IO () readArc = forceList =<< throwArchiveM (readArchiveFile "test/data/llvm-9.0.0.src.tar") + +readArcBS :: IO () +readArcBS = forceList =<< fmap (either throw id) + (readArchiveBSL <$> BSL.readFile "test/data/llvm-9.0.0.src.tar") + +readWriteArc :: IO () +readWriteArc = forceList . BSL.toChunks =<< throwArchiveM + (entriesToBSL <$> readArchiveFile "test/data/llvm-9.0.0.src.tar") diff --git a/src/Codec/Archive.hs b/src/Codec/Archive.hs --- a/src/Codec/Archive.hs +++ b/src/Codec/Archive.hs @@ -11,6 +11,7 @@ , entriesToFile7Zip , entriesToFileCpio , entriesToFileXar + , entriesToFileShar , entriesToBS , entriesToBS7zip , entriesToBSzip @@ -19,6 +20,7 @@ , entriesToBSL7zip , entriesToBSLCpio , entriesToBSLXar + , entriesToBSLShar , readArchiveFile , readArchiveBS , readArchiveBSL @@ -27,11 +29,13 @@ , packFiles7zip , packFilesCpio , packFilesXar + , packFilesShar , packToFile , packToFileZip , packToFile7Zip , packToFileCpio , packToFileXar + , packToFileShar -- * Concrete (Haskell) types , ArchiveResult (..) , Entry (..) 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 @@ -1,14 +1,9 @@ -module Codec.Archive.Common ( actFree - , actFreeCallback - , hmemcpy +module Codec.Archive.Common ( hmemcpy ) where -import Codec.Archive.Foreign -import Codec.Archive.Monad (ArchiveM, bracketM) -import Control.Composition ((.**)) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO (..)) -import Foreign.C.Types (CSize (..)) +import Control.Composition ((.**)) +import Control.Monad (void) +import Foreign.C.Types (CSize (..)) import Foreign.Ptr foreign import ccall memcpy :: Ptr a -- ^ Destination @@ -18,15 +13,3 @@ hmemcpy :: Ptr a -> Ptr b -> CSize -> IO () hmemcpy = void .** memcpy - --- | Do something with an 'Archive' and then free it -actFree :: IO (Ptr Archive) - -> (Ptr Archive -> ArchiveM a) - -> ArchiveM a -actFree get = bracketM get archiveFree - -actFreeCallback :: MonadIO m - => (Ptr Archive -> m a) - -> (Ptr Archive, IO ()) -- ^ 'Ptr' to an 'Archive' and an 'IO' action to clean up when done - -> m a -actFreeCallback fact (a, freeAct) = fact a <* liftIO (archiveFree a) <* liftIO freeAct diff --git a/src/Codec/Archive/Foreign/Archive.chs b/src/Codec/Archive/Foreign/Archive.chs --- a/src/Codec/Archive/Foreign/Archive.chs +++ b/src/Codec/Archive/Foreign/Archive.chs @@ -245,6 +245,7 @@ , archiveReadDiskNoTraverseMounts , archiveReadDiskNoXattr , archiveFree + , archiveEntryFree , archiveMatchExcluded , archiveMatchPathExcluded , archiveMatchSetInclusionRecursion @@ -349,7 +350,7 @@ foreign import ccall "wrapper" mkCloseCallbackRaw :: ArchiveCloseCallbackRaw a -> IO (FunPtr (ArchiveCloseCallbackRaw a)) foreign import ccall "wrapper" mkSwitchCallbackRaw :: ArchiveSwitchCallbackRaw a b -> IO (FunPtr (ArchiveSwitchCallbackRaw a b)) foreign import ccall "wrapper" mkPassphraseCallback :: ArchivePassphraseCallback a -> IO (FunPtr (ArchivePassphraseCallback a)) -foreign import ccall "wrapper" mkExcludedCallback :: (ArchivePtr -> Ptr a -> ArchiveEntryPtr -> IO ()) -> IO (FunPtr (ArchivePtr -> Ptr a -> ArchiveEntryPtr -> IO ())) +foreign import ccall "wrapper" mkExcludedCallback :: (Ptr Archive -> Ptr a -> Ptr ArchiveEntry -> IO ()) -> IO (FunPtr (Ptr Archive -> Ptr a -> Ptr ArchiveEntry -> IO ())) -- | Don't use an open callback. This is the recommended argument to 'archiveReadOpen' noOpenCallback :: FunPtr (ArchiveOpenCallbackRaw a) @@ -380,9 +381,10 @@ boolToInt True = 1 #include +#include -{#pointer *archive as ArchivePtr -> Archive #} -{#pointer *archive_entry as ArchiveEntryPtr -> ArchiveEntry #} +{#pointer *archive as ArchivePtr foreign -> Archive #} +{#pointer *archive_entry as ArchiveEntryPtr foreign finalizer archive_entry_free as ^ -> ArchiveEntry #} {#pointer *stat as StatPtr -> Stat #} -- | @FILE*@ in C {#pointer *FILE as FilePtr newtype#} @@ -416,8 +418,10 @@ {# fun archive_filter_code as ^ { `ArchivePtr', `CInt' } -> `Int' #} {# fun archive_filter_name as ^ { `ArchivePtr', `CInt' } -> `CString' #} -{# fun archive_read_new as ^ {} -> `ArchivePtr' #} +{# fun archive_read_new as ^ {} -> `Ptr Archive' id #} +{# fun archive_free as ^ { id `Ptr Archive' } -> `CInt' #} + {# fun archive_match_excluded as ^ { `ArchivePtr', `ArchiveEntryPtr' } -> `Bool' #} {# fun archive_match_path_excluded as ^ { `ArchivePtr', `ArchiveEntryPtr' } -> `Bool' #} {# fun archive_match_exclude_pattern as ^ { `ArchivePtr', `CString' } -> `ArchiveResult' #} @@ -476,7 +480,7 @@ {# fun archive_read_open_memory as ^ { `ArchivePtr', castPtr `Ptr a', `CSize' } -> `ArchiveResult' #} {# fun archive_read_open_fd as ^ { `ArchivePtr', coerce `Fd', `CSize' } -> `ArchiveResult' #} {# fun archive_read_open_FILE as ^ { `ArchivePtr', `FilePtr' } -> `ArchiveResult' #} -{# fun archive_read_next_header as ^ { `ArchivePtr', alloca- `ArchiveEntryPtr' peek* } -> `ArchiveResult' #} +{# fun archive_read_next_header as ^ { `ArchivePtr', alloca- `Ptr ArchiveEntry' peek* } -> `ArchiveResult' #} {# fun archive_read_next_header2 as ^ { `ArchivePtr', `ArchiveEntryPtr' } -> `ArchiveResult' #} {# fun archive_read_header_position as ^ { `ArchivePtr' } -> `LaInt64' #} {# fun archive_read_has_encrypted_entries as ^ { `ArchivePtr' } -> `ArchiveEncryption' encryptionResult #} @@ -501,7 +505,7 @@ {# fun archive_read_close as ^ { `ArchivePtr' } -> `ArchiveResult' #} {# fun archive_read_free as ^ { `ArchivePtr' } -> `ArchiveResult' #} -{# fun archive_write_new as ^ {} -> `ArchivePtr' #} +{# fun archive_write_new as ^ {} -> `Ptr Archive' id #} {# fun archive_write_set_bytes_per_block as ^ { `ArchivePtr', `CInt' } -> `ArchiveResult' #} {# fun archive_write_get_bytes_per_block as ^ { `ArchivePtr' } -> `CInt' #} {# fun archive_write_set_bytes_in_last_block as ^ { `ArchivePtr', `CInt' } -> `ArchiveResult' #} @@ -578,7 +582,7 @@ {# fun archive_write_set_passphrase_callback as ^ { `ArchivePtr', castPtr `Ptr a', castFunPtr `FunPtr (ArchivePassphraseCallback a)' } -> `ArchiveResult' #} {# fun archive_write_disk_set_options as ^ { `ArchivePtr', coerce `Flags' } -> `ArchiveResult' #} -{# fun archive_write_disk_new as ^ {} -> `ArchivePtr' #} +{# fun archive_write_disk_new as ^ {} -> `Ptr Archive' id #} {# fun archive_write_disk_set_skip_file as ^ { `ArchivePtr', `LaInt64', `LaInt64' } -> `ArchiveResult' #} {# fun archive_write_disk_set_standard_lookup as ^ { `ArchivePtr' } -> `ArchiveResult' #} @@ -595,7 +599,7 @@ {# fun archive_write_disk_gid as ^ { `ArchivePtr', `CString', `LaInt64' } -> `LaInt64' #} {# fun archive_write_disk_uid as ^ { `ArchivePtr', `CString', `LaInt64' } -> `LaInt64' #} -{# fun archive_read_disk_new as ^ {} -> `ArchivePtr' #} +{# fun archive_read_disk_new as ^ {} -> `Ptr Archive' id #} {# fun archive_read_disk_set_symlink_logical as ^ { `ArchivePtr' } -> `ArchiveResult' #} {# fun archive_read_disk_set_symlink_physical as ^ { `ArchivePtr' } -> `ArchiveResult' #} {# fun archive_read_disk_set_symlink_hybrid as ^ { `ArchivePtr' } -> `ArchiveResult' #} @@ -632,8 +636,6 @@ , castFunPtr `FunPtr (ArchivePtr -> Ptr a -> ArchiveEntry -> IO CInt)' , castPtr `Ptr a' } -> `ArchiveResult' #} - -{# fun archive_free as ^ { `ArchivePtr' } -> `ArchiveResult' #} {# fun archive_match_include_gname_w as ^ { `ArchivePtr', `CWString' } -> `ArchiveResult' #} {# fun archive_match_include_gname as ^ { `ArchivePtr', `CString' } -> `ArchiveResult' #} diff --git a/src/Codec/Archive/Foreign/ArchiveEntry.chs b/src/Codec/Archive/Foreign/ArchiveEntry.chs --- a/src/Codec/Archive/Foreign/ArchiveEntry.chs +++ b/src/Codec/Archive/Foreign/ArchiveEntry.chs @@ -228,6 +228,7 @@ #include +-- TODO: foreign ptr {#pointer *archive_entry_linkresolver as LinkResolverPtr -> LinkResolver #} {#typedef size_t CSize#} @@ -250,7 +251,6 @@ {# fun archive_entry_clear as ^ { `ArchiveEntryPtr' } -> `ArchiveEntryPtr' #} {# fun archive_entry_clone as ^ { `ArchiveEntryPtr' } -> `ArchiveEntryPtr' #} {# fun archive_entry_new as ^ {} -> `ArchiveEntryPtr' #} -{# fun archive_entry_free as ^ { `ArchiveEntryPtr' } -> `()' #} {# fun archive_entry_new2 as ^ { `ArchivePtr' } -> `ArchiveEntryPtr' #} {# fun archive_entry_atime as ^ { `ArchiveEntryPtr' } -> `CTime' #} {# fun archive_entry_atime_nsec as ^ { `ArchiveEntryPtr' } -> `CLong' #} @@ -385,7 +385,7 @@ {# fun archive_entry_linkresolver_new as ^ {} -> `LinkResolverPtr' #} {# fun archive_entry_linkresolver_set_strategy as ^ { `LinkResolverPtr', `ArchiveFormat' } -> `()' #} {# fun archive_entry_linkresolver_free as ^ { `LinkResolverPtr' } -> `()' #} -{# fun archive_entry_linkify as ^ { `LinkResolverPtr', id `Ptr ArchiveEntryPtr', id `Ptr ArchiveEntryPtr' } -> `()' #} +{# fun archive_entry_linkify as ^ { `LinkResolverPtr', id `Ptr (Ptr ArchiveEntry)', id `Ptr (Ptr ArchiveEntry)' } -> `()' #} {# fun archive_entry_partial_links as ^ { `LinkResolverPtr', id `Ptr CUInt' } -> `Ptr ArchiveEntry' id #} {# fun archive_entry_atime_is_set as ^ { `ArchiveEntryPtr' } -> `Bool' #} diff --git a/src/Codec/Archive/Monad.hs b/src/Codec/Archive/Monad.hs --- a/src/Codec/Archive/Monad.hs +++ b/src/Codec/Archive/Monad.hs @@ -1,5 +1,7 @@ module Codec.Archive.Monad ( handle , ignore + , lenient + , touchForeignPtrM , runArchiveM , throwArchiveM -- * Bracketed resources within 'ArchiveM' @@ -18,11 +20,15 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import Foreign.C.String +import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr) import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (Ptr) type ArchiveM = ExceptT ArchiveResult IO +touchForeignPtrM :: ForeignPtr a -> ArchiveM () +touchForeignPtrM = liftIO . touchForeignPtr + -- for things we don't think is going to fail ignore :: IO ArchiveResult -> ArchiveM () ignore = void . liftIO @@ -36,12 +42,23 @@ runArchiveM :: ArchiveM a -> IO (Either ArchiveResult a) runArchiveM = runExceptT +-- TODO: ArchiveFailed Writer monad? +-- archive_clear_error +lenient :: IO ArchiveResult -> ArchiveM () +lenient act = do + res <- liftIO act + case res of + ArchiveFatal -> throw res + ArchiveEOF -> throw res + _ -> pure () + handle :: IO ArchiveResult -> ArchiveM () handle act = do res <- liftIO act case res of ArchiveOk -> pure () ArchiveRetry -> pure () + -- FIXME: ArchiveFailed may be ok x -> throwError x flipExceptIO :: IO (Either a b) -> ExceptT a IO b 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 @@ -3,6 +3,7 @@ , entriesToFile7Zip , entriesToFileCpio , entriesToFileXar + , entriesToFileShar , entriesToBS , entriesToBSzip , entriesToBS7zip @@ -13,54 +14,62 @@ , packToFile7Zip , packToFileCpio , packToFileXar + , packToFileShar ) where import Codec.Archive.Foreign import Codec.Archive.Monad import Codec.Archive.Pack.Common import Codec.Archive.Types -import Control.Monad (void) +import Control.Monad (forM_, void) import Control.Monad.IO.Class (MonadIO (..)) import Data.ByteString (packCStringLen) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import Data.Coerce (coerce) import Data.Foldable (sequenceA_, traverse_) import Data.Semigroup (Sum (..)) import Foreign.C.String import Foreign.C.Types (CLLong (..), CLong (..)) -import Foreign.Ptr (Ptr) +import Foreign.Concurrent (newForeignPtr) +import Foreign.ForeignPtr (castForeignPtr) +import Foreign.Ptr (castPtr) import System.IO.Unsafe (unsafeDupablePerformIO) maybeDo :: Applicative f => Maybe (f ()) -> f () maybeDo = sequenceA_ -contentAdd :: EntryContent -> Ptr Archive -> Ptr ArchiveEntry -> ArchiveM () +-- archive_error_string +contentAdd :: EntryContent FilePath BS.ByteString -> ArchivePtr -> ArchiveEntryPtr -> ArchiveM () contentAdd (NormalFile contents) a entry = do liftIO $ archiveEntrySetFiletype entry (Just FtRegular) liftIO $ archiveEntrySetSize entry (fromIntegral (BS.length contents)) handle $ archiveWriteHeader a entry + -- forM_ (BSL.toChunks contents) $ \b -> useAsCStringLenArchiveM contents $ \(buff, sz) -> liftIO $ void $ archiveWriteData a buff (fromIntegral sz) contentAdd Directory a entry = do liftIO $ archiveEntrySetFiletype entry (Just FtDirectory) - handle $ archiveWriteHeader a entry + lenient $ archiveWriteHeader a entry + liftIO $ archiveClearError a contentAdd (Symlink fp st) a entry = do liftIO $ archiveEntrySetFiletype entry (Just FtLink) liftIO $ archiveEntrySetSymlinkType entry st liftIO $ withCString fp $ \fpc -> archiveEntrySetSymlink entry fpc - handle $ archiveWriteHeader a entry + lenient $ archiveWriteHeader a entry + liftIO $ archiveClearError a contentAdd (Hardlink fp) a entry = do liftIO $ archiveEntrySetFiletype entry Nothing liftIO $ withCString fp $ \fpc -> archiveEntrySetHardlink entry fpc - handle $ archiveWriteHeader a entry + lenient $ archiveWriteHeader a entry withMaybeCString :: Maybe String -> (Maybe CString -> IO a) -> IO a withMaybeCString (Just x) f = withCString x (f . Just) withMaybeCString Nothing f = f Nothing -setOwnership :: Ownership -> Ptr ArchiveEntry -> IO () +setOwnership :: Ownership -> ArchiveEntryPtr -> IO () setOwnership (Ownership uname gname uid gid) entry = withMaybeCString uname $ \unameC -> withMaybeCString gname $ \gnameC -> @@ -71,14 +80,14 @@ , Just (archiveEntrySetGid entry (coerce gid)) ] -setTime :: ModTime -> Ptr ArchiveEntry -> IO () +setTime :: ModTime -> ArchiveEntryPtr -> IO () setTime (time', nsec) entry = archiveEntrySetMtime entry time' nsec -packEntries :: (Foldable t) => Ptr Archive -> t Entry -> ArchiveM () +packEntries :: (Foldable t) => ArchivePtr -> t (Entry FilePath BS.ByteString) -> ArchiveM () packEntries a = traverse_ (archiveEntryAdd a) -- Get a number of bytes appropriate for creating the archive. -entriesSz :: (Foldable t, Integral a) => t Entry -> a +entriesSz :: (Foldable t, Integral a) => t (Entry FilePath BS.ByteString) -> a entriesSz = getSum . foldMap (Sum . entrySz) where entrySz e = 512 + 512 * (contentSz (content e) `div` 512 + 1) contentSz (NormalFile str) = fromIntegral $ BS.length str @@ -89,21 +98,21 @@ -- | 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 :: Foldable t => t (Entry FilePath BS.ByteString) -> BS.ByteString entriesToBS = unsafeDupablePerformIO . noFail . entriesToBSGeneral archiveWriteSetFormatPaxRestricted {-# 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 :: Foldable t => t (Entry FilePath BS.ByteString) -> BS.ByteString entriesToBS7zip = unsafeDupablePerformIO . noFail . entriesToBSGeneral archiveWriteSetFormat7zip {-# 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 :: Foldable t => t (Entry FilePath BS.ByteString) -> BS.ByteString entriesToBSzip = unsafeDupablePerformIO . noFail . entriesToBSGeneral archiveWriteSetFormatZip {-# NOINLINE entriesToBSzip #-} @@ -114,26 +123,26 @@ res <- runArchiveM act case res of Right x -> pure x + -- FIXME: ArchiveFailed is recoverable and whatnot Left _ -> error "Should not fail." -- | Internal function to be used with 'archive_write_set_format_pax' etc. -entriesToBSGeneral :: (Foldable t) => (Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM BS.ByteString +entriesToBSGeneral :: (Foldable t) => (ArchivePtr -> IO ArchiveResult) -> t (Entry FilePath BS.ByteString) -> ArchiveM BS.ByteString entriesToBSGeneral modifier hsEntries' = do - a <- liftIO archiveWriteNew + preA <- liftIO archiveWriteNew + a <- liftIO $ castForeignPtr <$> newForeignPtr (castPtr preA) (void $ archiveFree preA) ignore $ modifier a allocaBytesArchiveM bufSize $ \buffer -> do (err, usedSz) <- liftIO $ archiveWriteOpenMemory a buffer bufSize handle (pure err) packEntries a hsEntries' handle $ archiveWriteClose a - res <- liftIO $ curry packCStringLen buffer (fromIntegral usedSz) - ignore $ archiveFree a - pure res + liftIO $ curry packCStringLen buffer (fromIntegral usedSz) where bufSize :: Integral a => a bufSize = entriesSz hsEntries' -filePacker :: (Traversable t) => (FilePath -> t Entry -> ArchiveM ()) -> FilePath -> t FilePath -> ArchiveM () +filePacker :: (Traversable t) => (FilePath -> t (Entry FilePath BS.ByteString) -> ArchiveM ()) -> FilePath -> t FilePath -> ArchiveM () filePacker f tar fps = f tar =<< liftIO (traverse mkEntry fps) -- | @since 2.0.0.0 @@ -171,6 +180,13 @@ -> ArchiveM () packToFileXar = filePacker entriesToFileXar +-- | @since 3.0.0.0 +packToFileShar :: Traversable t + => FilePath + -> t FilePath + -> ArchiveM () +packToFileShar = filePacker entriesToFileShar + -- | Write some entries to a file, creating a tar archive. This is more -- efficient than -- @@ -179,52 +195,56 @@ -- @ -- -- @since 1.0.0.0 -entriesToFile :: Foldable t => FilePath -> t Entry -> ArchiveM () +entriesToFile :: Foldable t => FilePath -> t (Entry FilePath BS.ByteString) -> ArchiveM () entriesToFile = entriesToFileGeneral archiveWriteSetFormatPaxRestricted -- 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 -> ArchiveM () +entriesToFileZip :: Foldable t => FilePath -> t (Entry FilePath BS.ByteString) -> ArchiveM () entriesToFileZip = entriesToFileGeneral archiveWriteSetFormatZip -- | Write some entries to a file, creating a @.7z@ archive. -- -- @since 1.0.0.0 -entriesToFile7Zip :: Foldable t => FilePath -> t Entry -> ArchiveM () +entriesToFile7Zip :: Foldable t => FilePath -> t (Entry FilePath BS.ByteString) -> ArchiveM () entriesToFile7Zip = entriesToFileGeneral archiveWriteSetFormat7zip -- | Write some entries to a file, creating a @.cpio@ archive. -- -- @since 2.2.3.0 -entriesToFileCpio :: Foldable t => FilePath -> t Entry -> ArchiveM () +entriesToFileCpio :: Foldable t => FilePath -> t (Entry FilePath BS.ByteString) -> ArchiveM () entriesToFileCpio = entriesToFileGeneral archiveWriteSetFormatCpio -- | Write some entries to a file, creating a @.xar@ archive. -- -- @since 2.2.4.0 -entriesToFileXar :: Foldable t => FilePath -> t Entry -> ArchiveM () +entriesToFileXar :: Foldable t => FilePath -> t (Entry FilePath BS.ByteString) -> ArchiveM () entriesToFileXar = entriesToFileGeneral archiveWriteSetFormatXar -entriesToFileGeneral :: Foldable t => (Ptr Archive -> IO ArchiveResult) -> FilePath -> t Entry -> ArchiveM () -entriesToFileGeneral modifier fp hsEntries' = - bracketM - archiveWriteNew - archiveFree - (\a -> do - ignore $ modifier a - withCStringArchiveM fp $ \fpc -> - handle $ archiveWriteOpenFilename a fpc - packEntries a hsEntries') +-- | Write some entries to a file, creating a @.shar@ archive. +-- +-- @since 3.0.0.0 +entriesToFileShar :: Foldable t => FilePath -> t (Entry FilePath BS.ByteString) -> ArchiveM () +entriesToFileShar = entriesToFileGeneral archiveWriteSetFormatShar -withArchiveEntry :: (Ptr ArchiveEntry -> ArchiveM a) -> ArchiveM a -withArchiveEntry = - bracketM - archiveEntryNew - archiveEntryFree +entriesToFileGeneral :: Foldable t => (ArchivePtr -> IO ArchiveResult) -> FilePath -> t (Entry FilePath BS.ByteString) -> ArchiveM () +entriesToFileGeneral modifier fp hsEntries' = do + p <- liftIO archiveWriteNew + fptr <- liftIO $ castForeignPtr <$> newForeignPtr (castPtr p) (void $ archiveFree p) + act fptr -archiveEntryAdd :: Ptr Archive -> Entry -> ArchiveM () + where act a = do + ignore $ modifier a + withCStringArchiveM fp $ \fpc -> + handle $ archiveWriteOpenFilename a fpc + packEntries a hsEntries' + +withArchiveEntry :: (ArchiveEntryPtr -> ArchiveM a) -> ArchiveM a +withArchiveEntry = (=<< liftIO archiveEntryNew) + +archiveEntryAdd :: ArchivePtr -> Entry FilePath BS.ByteString -> ArchiveM () archiveEntryAdd a (Entry fp contents perms owner mtime) = withArchiveEntry $ \entry -> do liftIO $ withCString fp $ \fpc -> diff --git a/src/Codec/Archive/Pack/Common.hs b/src/Codec/Archive/Pack/Common.hs --- a/src/Codec/Archive/Pack/Common.hs +++ b/src/Codec/Archive/Pack/Common.hs @@ -2,10 +2,11 @@ import Codec.Archive.Types import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import System.PosixCompat.Files (FileStatus, fileGroup, fileMode, fileOwner, getFileStatus, isDirectory, isRegularFile, isSymbolicLink, linkCount, readSymbolicLink) -mkContent :: FilePath -> FileStatus -> IO EntryContent +mkContent :: FilePath -> FileStatus -> IO (EntryContent FilePath BS.ByteString) mkContent fp status = let res = (isRegularFile status, isDirectory status, isSymbolicLink status, linkCount status) in @@ -17,7 +18,7 @@ (False, False, True, _) -> Symlink <$> readSymbolicLink fp <*> pure SymlinkUndefined (_, _, _, _) -> error "inconsistent read result" -mkEntry :: FilePath -> IO Entry +mkEntry :: FilePath -> IO (Entry FilePath BS.ByteString) mkEntry fp = do status <- getFileStatus fp content' <- mkContent fp status diff --git a/src/Codec/Archive/Pack/Lazy.hs b/src/Codec/Archive/Pack/Lazy.hs --- a/src/Codec/Archive/Pack/Lazy.hs +++ b/src/Codec/Archive/Pack/Lazy.hs @@ -3,11 +3,13 @@ , entriesToBSLzip , entriesToBSLCpio , entriesToBSLXar + , entriesToBSLShar , packFiles , packFilesZip , packFiles7zip , packFilesCpio , packFilesXar + , packFilesShar ) where import Codec.Archive.Foreign @@ -18,20 +20,25 @@ import Control.Composition ((.@)) import Control.Monad.IO.Class (liftIO) import Data.ByteString (packCStringLen) +import qualified Data.ByteString as BS 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.Concurrent (newForeignPtr) +import Foreign.ForeignPtr (castForeignPtr, finalizeForeignPtr) import Foreign.Marshal.Alloc (free, mallocBytes) -import Foreign.Ptr +import Foreign.Ptr (castPtr, freeHaskellFunPtr) import System.IO.Unsafe (unsafeDupablePerformIO) -packer :: (Traversable t) => (t Entry -> BSL.ByteString) -> t FilePath -> IO BSL.ByteString +packer :: (Traversable t) => (t (Entry FilePath BS.ByteString) -> BSL.ByteString) -> t FilePath -> IO BSL.ByteString packer = traverse mkEntry .@ fmap --- | Pack files into a tar archive +-- | Pack files into a tar archive. This will be more efficient than -- +-- @BSL.writeFile fp . entriesToBSL@ +-- -- @since 2.0.0.0 packFiles :: Traversable t => t FilePath -- ^ Filepaths relative to the current directory @@ -54,51 +61,75 @@ packFilesXar :: Traversable t => t FilePath -> IO BSL.ByteString packFilesXar = packer entriesToBSLXar +-- | @since 3.0.0.0 +packFilesShar :: Traversable t => t FilePath -> IO BSL.ByteString +packFilesShar = packer entriesToBSLShar + -- | @since 1.0.5.0 -entriesToBSLzip :: Foldable t => t Entry -> BSL.ByteString +entriesToBSLzip :: Foldable t => t (Entry FilePath BS.ByteString) -> BSL.ByteString entriesToBSLzip = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatZip {-# NOINLINE entriesToBSLzip #-} -- | @since 1.0.5.0 -entriesToBSL7zip :: Foldable t => t Entry -> BSL.ByteString +entriesToBSL7zip :: Foldable t => t (Entry FilePath BS.ByteString) -> BSL.ByteString entriesToBSL7zip = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormat7zip {-# NOINLINE entriesToBSL7zip #-} -- | @since 2.2.3.0 -entriesToBSLCpio :: Foldable t => t Entry -> BSL.ByteString +entriesToBSLCpio :: Foldable t => t (Entry FilePath BS.ByteString) -> BSL.ByteString entriesToBSLCpio = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatCpio {-# NOINLINE entriesToBSLCpio #-} --- | @since 2.2.4.0 -entriesToBSLXar :: Foldable t => t Entry -> BSL.ByteString +-- | Won't work when built with @-system-libarchive@ or when libarchive is not +-- built with zlib support. +-- +-- @since 2.2.4.0 +entriesToBSLXar :: Foldable t => t (Entry FilePath BS.ByteString) -> BSL.ByteString entriesToBSLXar = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatXar {-# NOINLINE entriesToBSLXar #-} +-- | @since 3.0.0.0 +entriesToBSLShar :: Foldable t => t (Entry FilePath BS.ByteString) -> BSL.ByteString +entriesToBSLShar = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatShar +{-# NOINLINE entriesToBSLShar #-} + -- | In general, this will be more efficient than 'entriesToBS' -- -- @since 1.0.5.0 -entriesToBSL :: Foldable t => t Entry -> BSL.ByteString +entriesToBSL :: Foldable t => t (Entry FilePath BS.ByteString) -> BSL.ByteString entriesToBSL = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatPaxRestricted {-# NOINLINE entriesToBSL #-} -entriesToBSLGeneral :: Foldable t => (Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM BSL.ByteString -entriesToBSLGeneral modifier hsEntries' = do - a <- liftIO archiveWriteNew - bsRef <- liftIO $ newIORef mempty +entriesToIOChunks :: Foldable t + => (ArchivePtr -> IO ArchiveResult) -- ^ Action to set format of archive + -> t (Entry FilePath BS.ByteString) + -> (BS.ByteString -> IO ()) -- ^ 'IO' Action to process the chunks + -> ArchiveM () +entriesToIOChunks modifier hsEntries' chunkAct = do + preA <- liftIO archiveWriteNew oc <- liftIO $ mkOpenCallback doNothing - wc <- liftIO $ mkWriteCallback (writeBSL bsRef) + wc <- liftIO $ mkWriteCallback chunkHelper cc <- liftIO $ mkCloseCallback (\_ ptr -> freeHaskellFunPtr oc *> freeHaskellFunPtr wc *> free ptr $> ArchiveOk) + a <- liftIO $ castForeignPtr <$> newForeignPtr (castPtr preA) (archiveFree preA *> freeHaskellFunPtr cc) nothingPtr <- liftIO $ mallocBytes 0 ignore $ modifier a handle $ archiveWriteOpen a nothingPtr oc wc cc packEntries a hsEntries' - ignore $ archiveFree a - BSL.fromChunks . toList <$> liftIO (readIORef bsRef) <* liftIO (freeHaskellFunPtr cc) + liftIO $ finalizeForeignPtr a - where writeBSL bsRef _ _ bufPtr sz = do + where doNothing _ _ = pure ArchiveOk + chunkHelper _ _ bufPtr sz = do let bytesRead = min (fromIntegral sz) (32 * 1024) - bsl <- packCStringLen (bufPtr, fromIntegral bytesRead) - modifyIORef' bsRef (`DL.snoc` bsl) + bs <- packCStringLen (bufPtr, fromIntegral bytesRead) + chunkAct bs pure bytesRead - doNothing _ _ = pure ArchiveOk - -- FIXME: this part isn't sufficiently lazy + +entriesToBSLGeneral :: Foldable t => (ArchivePtr -> IO ArchiveResult) -> t (Entry FilePath BS.ByteString) -> ArchiveM BSL.ByteString +entriesToBSLGeneral modifier hsEntries' = do + preRef <- liftIO $ newIORef mempty + let chunkAct = writeBSL preRef + entriesToIOChunks modifier hsEntries' chunkAct + BSL.fromChunks . toList <$> liftIO (readIORef preRef) + + where writeBSL bsRef chunk = + modifyIORef' bsRef (`DL.snoc` chunk) diff --git a/src/Codec/Archive/Types.hs b/src/Codec/Archive/Types.hs --- a/src/Codec/Archive/Types.hs +++ b/src/Codec/Archive/Types.hs @@ -18,7 +18,6 @@ ) where import Codec.Archive.Types.Foreign -import qualified Data.ByteString as BS import Data.Int (Int64) import Foreign.C.Types (CInt, CLong, CTime) import Foreign.Ptr (Ptr) @@ -38,18 +37,21 @@ deriving (Eq) -- TODO: support everything here: http://hackage.haskell.org/package/tar/docs/Codec-Archive-Tar-Entry.html#t:EntryContent -data EntryContent = NormalFile !BS.ByteString - | Directory - | Symlink !FilePath !Symlink - | Hardlink !FilePath +data EntryContent fp e = NormalFile e + | Directory + | Symlink !fp !Symlink + | Hardlink !fp deriving (Show, Eq, Ord) -data Entry = Entry { filepath :: !FilePath - , content :: EntryContent - , permissions :: !Permissions - , ownership :: !Ownership - , time :: !(Maybe ModTime) - } +-- | @e@ is the type of entry contents, for instance 'BSL.ByteString' +-- +-- @fp@ is the type of file paths, for instance 'FilePath' +data Entry fp e = Entry { filepath :: !fp -- TODO: bytestring? functorial? + , content :: EntryContent fp e + , permissions :: !Permissions + , ownership :: !Ownership + , time :: !(Maybe ModTime) + } deriving (Show, Eq, Ord) data Ownership = Ownership { userName :: !(Maybe String) diff --git a/src/Codec/Archive/Types/Foreign.chs b/src/Codec/Archive/Types/Foreign.chs --- a/src/Codec/Archive/Types/Foreign.chs +++ b/src/Codec/Archive/Types/Foreign.chs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +-- see http://hackage.haskell.org/package/Cabal-3.2.0.0/docs/Distribution-Simple-PreProcess.html#t:PPSuffixHandler + module Codec.Archive.Types.Foreign ( -- * Callbacks ArchiveReadCallback , ArchiveSkipCallback 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 @@ -1,36 +1,45 @@ -module Codec.Archive.Unpack ( hsEntries +module Codec.Archive.Unpack ( hsEntriesAbs , unpackEntriesFp , unpackArchive , readArchiveFile , readArchiveBS , unpackToDir + , readBS ) where import Codec.Archive.Common import Codec.Archive.Foreign import Codec.Archive.Monad import Codec.Archive.Types -import Control.Monad (void, (<=<)) -import Control.Monad.IO.Class (liftIO) -import Data.Bifunctor (first) -import qualified Data.ByteString as BS +import Control.Monad ((<=<)) +import Control.Monad.IO.Class (liftIO) +import qualified Control.Monad.ST.Lazy as LazyST +import qualified Control.Monad.ST.Lazy.Unsafe as LazyST +import Data.Bifunctor (first) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Functor (void, ($>)) import Foreign.C.String -import Foreign.Marshal.Alloc (allocaBytes, free, mallocBytes) -import Foreign.Ptr (Ptr, nullPtr) -import System.FilePath (()) -import System.IO.Unsafe (unsafeDupablePerformIO) +import Foreign.Concurrent (newForeignPtr) +import Foreign.ForeignPtr (castForeignPtr, newForeignPtr_) +import Foreign.Marshal.Alloc (allocaBytes, free, mallocBytes) +import Foreign.Ptr (castPtr, nullPtr) +import System.FilePath (()) +import System.IO.Unsafe (unsafeDupablePerformIO) -- | Read an archive contained in a 'BS.ByteString'. The format of the archive is -- automatically detected. -- -- @since 1.0.0.0 -readArchiveBS :: BS.ByteString -> Either ArchiveResult [Entry] -readArchiveBS = unsafeDupablePerformIO . runArchiveM . (actFreeCallback hsEntries <=< bsToArchive) +readArchiveBS :: BS.ByteString -> Either ArchiveResult [Entry FilePath BS.ByteString] +readArchiveBS = unsafeDupablePerformIO . runArchiveM . (go hsEntries <=< bsToArchive) + where go f (y, act) = f y <* liftIO act {-# NOINLINE readArchiveBS #-} -bsToArchive :: BS.ByteString -> ArchiveM (Ptr Archive, IO ()) +bsToArchive :: BS.ByteString -> ArchiveM (ArchivePtr, IO ()) bsToArchive bs = do - a <- liftIO archiveReadNew + preA <- liftIO archiveReadNew + a <- liftIO $ castForeignPtr <$> newForeignPtr (castPtr preA) (void $ archiveFree preA) ignore $ archiveReadSupportFormatAll a bufPtr <- useAsCStringLenArchiveM bs $ \(buf, sz) -> do @@ -44,11 +53,15 @@ -- detected. -- -- @since 1.0.0.0 -readArchiveFile :: FilePath -> ArchiveM [Entry] -readArchiveFile fp = actFree archiveReadNew (\a -> archiveFile fp a *> hsEntries a) --- actFree hsEntries <=< a dorchiveFile +readArchiveFile :: FilePath -> ArchiveM [Entry FilePath BS.ByteString] +readArchiveFile fp = act =<< liftIO (do + pre <- archiveReadNew + castForeignPtr <$> newForeignPtr (castPtr pre) (void $ archiveFree pre)) -archiveFile :: FilePath -> Ptr Archive -> ArchiveM () + where act a = + archiveFile fp a $> LazyST.runST (hsEntriesST a) + +archiveFile :: FilePath -> ArchivePtr -> ArchiveM () archiveFile fp a = withCStringArchiveM fp $ \cpath -> ignore (archiveReadSupportFormatAll a) *> handle (archiveReadOpenFilename a cpath 10240) @@ -61,41 +74,65 @@ unpackArchive :: FilePath -- ^ Filepath pointing to archive -> FilePath -- ^ Dirctory to unpack in -> ArchiveM () -unpackArchive tarFp dirFp = - bracketM - archiveReadNew - archiveFree - (\a -> +unpackArchive tarFp dirFp = do + preA <- liftIO archiveReadNew + a <- liftIO $ castForeignPtr <$> newForeignPtr (castPtr preA) (void $ archiveFree preA) + act a + + where act a = archiveFile tarFp a *> - unpackEntriesFp a dirFp) + unpackEntriesFp a dirFp -readEntry :: Ptr Archive -> Ptr ArchiveEntry -> IO Entry -readEntry a entry = +readEntry :: Integral a + => (ArchivePtr -> a -> IO e) + -> ArchivePtr + -> ArchiveEntryPtr + -> IO (Entry FilePath e) +readEntry read' a entry = Entry <$> (peekCString =<< archiveEntryPathname entry) - <*> readContents a entry + <*> readContents read' a entry <*> archiveEntryPerm entry <*> readOwnership entry <*> readTimes entry -- | Yield the next entry in an archive -getHsEntry :: Ptr Archive -> IO (Maybe Entry) -getHsEntry a = do +getHsEntry :: Integral a + => (ArchivePtr -> a -> IO e) + -> ArchivePtr + -> IO (Maybe (Entry FilePath e)) +getHsEntry read' a = do entry <- getEntry a case entry of Nothing -> pure Nothing - Just x -> Just <$> readEntry a x + Just x -> Just <$> readEntry read' a x -- | Return a list of 'Entry's. -hsEntries :: Ptr Archive -> ArchiveM [Entry] -hsEntries a = do - next <- liftIO $ getHsEntry a +hsEntries :: ArchivePtr -> ArchiveM [Entry FilePath BS.ByteString] +hsEntries = hsEntriesAbs readBS + +hsEntriesAbs :: Integral a + => (ArchivePtr -> a -> IO e) + -> ArchivePtr + -> ArchiveM [Entry FilePath e] +hsEntriesAbs read' p = pure (LazyST.runST $ hsEntriesSTAbs read' p) + +-- | Return a list of 'Entry's. +hsEntriesST :: ArchivePtr -> LazyST.ST s [Entry FilePath BS.ByteString] +hsEntriesST = hsEntriesSTAbs readBS + +hsEntriesSTAbs :: Integral a + => (ArchivePtr -> a -> IO e) + -> ArchivePtr + -> LazyST.ST s [Entry FilePath e] +hsEntriesSTAbs read' a = do + next <- LazyST.unsafeIOToST (getHsEntry read' a) case next of Nothing -> pure [] - Just x -> (x:) <$> hsEntries a + Just x -> (x:) <$> hsEntriesSTAbs read' a -- | Unpack an archive in a given directory -unpackEntriesFp :: Ptr Archive -> FilePath -> ArchiveM () +unpackEntriesFp :: ArchivePtr -> FilePath -> ArchiveM () unpackEntriesFp a fp = do res <- liftIO $ getEntry a case res of @@ -119,36 +156,59 @@ ignore $ archiveReadDataSkip a unpackEntriesFp a fp -readBS :: Ptr Archive -> Int -> IO BS.ByteString +{-# INLINE readBS #-} +readBS :: ArchivePtr -> Int -> IO BS.ByteString readBS a sz = allocaBytes sz $ \buff -> archiveReadData a buff (fromIntegral sz) *> BS.packCStringLen (buff, sz) -readContents :: Ptr Archive -> Ptr ArchiveEntry -> IO EntryContent -readContents a entry = go =<< archiveEntryFiletype entry +-- TODO: sanity check by comparing to archiveEntrySize? +readBSL :: ArchivePtr -> IO BSL.ByteString +readBSL a = BSL.fromChunks <$> loop + where step = + allocaBytes bufSz $ \bufPtr -> do + bRead <- archiveReadData a bufPtr (fromIntegral bufSz) + if bRead == 0 + then pure Nothing + else Just <$> BS.packCStringLen (bufPtr, fromIntegral bRead) + + loop = do + res <- step + case res of + Just b -> (b:) <$> loop + Nothing -> pure [] + + bufSz = 32 * 1024 -- read in 32k blocks + +readContents :: Integral a + => (ArchivePtr -> a -> IO e) + -> ArchivePtr + -> ArchiveEntryPtr + -> IO (EntryContent FilePath e) +readContents read' a entry = go =<< archiveEntryFiletype entry where go Nothing = Hardlink <$> (peekCString =<< archiveEntryHardlink entry) - go (Just FtRegular) = NormalFile <$> (readBS a =<< sz) + go (Just FtRegular) = NormalFile <$> (read' a =<< sz) go (Just FtLink) = Symlink <$> (peekCString =<< archiveEntrySymlink entry) <*> archiveEntrySymlinkType entry go (Just FtDirectory) = pure Directory go (Just _) = error "Unsupported filetype" sz = fromIntegral <$> archiveEntrySize entry -archiveGetterHelper :: (Ptr ArchiveEntry -> IO a) -> (Ptr ArchiveEntry -> IO Bool) -> Ptr ArchiveEntry -> IO (Maybe a) +archiveGetterHelper :: (ArchiveEntryPtr -> IO a) -> (ArchiveEntryPtr -> IO Bool) -> ArchiveEntryPtr -> IO (Maybe a) archiveGetterHelper get check entry = do check' <- check entry if check' then Just <$> get entry else pure Nothing -archiveGetterNull :: (Ptr ArchiveEntry -> IO CString) -> Ptr ArchiveEntry -> IO (Maybe String) +archiveGetterNull :: (ArchiveEntryPtr -> IO CString) -> ArchiveEntryPtr -> IO (Maybe String) archiveGetterNull get entry = do res <- get entry if res == nullPtr then pure Nothing else fmap Just (peekCString res) -readOwnership :: Ptr ArchiveEntry -> IO Ownership +readOwnership :: ArchiveEntryPtr -> IO Ownership readOwnership entry = Ownership <$> archiveGetterNull archiveEntryUname entry @@ -156,21 +216,21 @@ <*> (fromIntegral <$> archiveEntryUid entry) <*> (fromIntegral <$> archiveEntryGid entry) -readTimes :: Ptr ArchiveEntry -> IO (Maybe ModTime) +readTimes :: ArchiveEntryPtr -> IO (Maybe ModTime) readTimes = archiveGetterHelper go archiveEntryMtimeIsSet where go entry = (,) <$> archiveEntryMtime entry <*> archiveEntryMtimeNsec entry -- | Get the next 'ArchiveEntry' in an 'Archive' -getEntry :: Ptr Archive -> IO (Maybe (Ptr ArchiveEntry)) +getEntry :: ArchivePtr -> IO (Maybe ArchiveEntryPtr) getEntry a = do let done ArchiveOk = False done ArchiveRetry = False done _ = True (stop, res) <- first done <$> archiveReadNextHeader a - pure $ if stop - then Nothing - else Just res + if stop + then pure Nothing + else Just . castForeignPtr <$> newForeignPtr_ (castPtr res) unpackToDir :: FilePath -- ^ Directory to unpack in -> BS.ByteString -- ^ 'BS.ByteString' containing archive @@ -179,4 +239,3 @@ (a, act) <- bsToArchive bs unpackEntriesFp a fp liftIO act - void $ liftIO $ archiveFree a 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 @@ -9,13 +9,16 @@ import Codec.Archive.Unpack import Control.Monad ((<=<)) import Control.Monad.IO.Class +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Unsafe as BS import Data.Foldable (traverse_) import Data.Functor (($>)) -import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) +import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) +import Foreign.Concurrent (newForeignPtr) +import Foreign.ForeignPtr (castForeignPtr) import Foreign.Marshal.Alloc (free, mallocBytes, reallocBytes) -import Foreign.Ptr +import Foreign.Ptr (castPtr, freeHaskellFunPtr) import Foreign.Storable (poke) import System.IO.Unsafe (unsafeDupablePerformIO) @@ -26,10 +29,8 @@ -> BSL.ByteString -- ^ 'BSL.ByteString' containing archive -> ArchiveM () unpackToDirLazy fp bs = do - (a, act) <- bslToArchive bs + a <- bslToArchive bs unpackEntriesFp a fp - ignore $ archiveFree a - liftIO act -- | Read an archive lazily. The format of the archive is automatically -- detected. @@ -37,22 +38,29 @@ -- In general, this will be more efficient than 'readArchiveBS' -- -- @since 1.0.4.0 -readArchiveBSL :: BSL.ByteString -> Either ArchiveResult [Entry] -readArchiveBSL = unsafeDupablePerformIO . runArchiveM . (actFreeCallback hsEntries <=< bslToArchive) -{-# NOINLINE readArchiveBSL #-} +readArchiveBSL :: BSL.ByteString -> Either ArchiveResult [Entry FilePath BS.ByteString] +readArchiveBSL = readArchiveBSLAbs readBS +readArchiveBSLAbs :: Integral a + => (ArchivePtr -> a -> IO e) + -> BSL.ByteString + -> Either ArchiveResult [Entry FilePath e] +readArchiveBSLAbs read' = unsafeDupablePerformIO . runArchiveM . (hsEntriesAbs read' <=< bslToArchive) +{-# NOINLINE readArchiveBSLAbs #-} + -- | Lazily stream a 'BSL.ByteString' bslToArchive :: BSL.ByteString - -> ArchiveM (Ptr Archive, IO ()) -- ^ Returns an 'IO' action to be used to clean up after we're done with the archive + -> ArchiveM ArchivePtr bslToArchive bs = do - a <- liftIO archiveReadNew - ignore $ archiveReadSupportFormatAll a + preA <- liftIO archiveReadNew bufPtr <- liftIO $ mallocBytes (32 * 1024) -- default to 32k byte chunks bufPtrRef <- liftIO $ newIORef bufPtr bsChunksRef <- liftIO $ newIORef bsChunks bufSzRef <- liftIO $ newIORef (32 * 1024) rc <- liftIO $ mkReadCallback (readBSL bsChunksRef bufSzRef bufPtrRef) cc <- liftIO $ mkCloseCallback (\_ ptr -> freeHaskellFunPtr rc *> free ptr $> ArchiveOk) + a <- liftIO $ castForeignPtr <$> newForeignPtr (castPtr preA) (archiveFree preA *> freeHaskellFunPtr cc *> (free =<< readIORef bufPtrRef)) + ignore $ archiveReadSupportFormatAll a nothingPtr <- liftIO $ mallocBytes 0 let seqErr = traverse_ handle seqErr [ archiveReadSetReadCallback a rc @@ -60,14 +68,14 @@ , archiveReadSetCallbackData a nothingPtr , archiveReadOpen1 a ] - pure (a, freeHaskellFunPtr cc *> (free =<< readIORef bufPtrRef)) + pure a where readBSL bsRef bufSzRef bufPtrRef _ _ dataPtr = do bs' <- readIORef bsRef case bs' of [] -> pure 0 (x:_) -> do - modifyIORef bsRef tail + modifyIORef' bsRef tail BS.unsafeUseAsCStringLen x $ \(charPtr, sz) -> do bufSz <- readIORef bufSzRef bufPtr <- readIORef bufPtrRef diff --git a/test/Codec/Archive/Roundtrip.hs b/test/Codec/Archive/Roundtrip.hs --- a/test/Codec/Archive/Roundtrip.hs +++ b/test/Codec/Archive/Roundtrip.hs @@ -2,6 +2,7 @@ , itPacksUnpacksViaFS , roundtrip , roundtripStrict + , roundtripStrict' , roundtripFreaky ) where @@ -18,7 +19,7 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec -newtype TestEntries = TestEntries [Entry] +newtype TestEntries = TestEntries [Entry FilePath BS.ByteString] deriving (Eq) instance Show TestEntries where @@ -40,6 +41,9 @@ roundtripStrict :: FilePath -> IO (Either ArchiveResult BS.ByteString) roundtripStrict = fmap (fmap entriesToBS . readArchiveBSL . BSL.fromStrict) . BS.readFile +roundtripStrict' :: FilePath -> IO (Either ArchiveResult BS.ByteString) +roundtripStrict' = fmap (fmap entriesToBS . readArchiveBS) . BS.readFile + roundtripRead :: (FilePath -> IO BSL.ByteString) -> FilePath -> IO (Either ArchiveResult BSL.ByteString) roundtripRead = (fmap (fmap entriesToBSL . readArchiveBSL) .) @@ -49,7 +53,7 @@ roundtripFreaky :: FilePath -> IO (Either ArchiveResult BSL.ByteString) roundtripFreaky = roundtripRead nonstandardRead -itPacksUnpacks :: [Entry] -> Spec +itPacksUnpacks :: [Entry FilePath BS.ByteString] -> Spec itPacksUnpacks entries = parallel $ it "packs/unpacks successfully without loss" $ let packed = entriesToBSL entries @@ -57,7 +61,7 @@ in (TestEntries <$> unpacked) `shouldBe` Right (TestEntries entries) -itPacksUnpacksViaFS :: [Entry] -> Spec +itPacksUnpacksViaFS :: [Entry FilePath BS.ByteString] -> Spec itPacksUnpacksViaFS entries = parallel $ unpackedFromFS $ it "packs/unpacks on filesystem successfully without loss" $ \unpacked -> fmap (fmap stripDotSlash . testEntries) unpacked `shouldBe` Right (testEntries entries) @@ -83,5 +87,5 @@ -- TODO: expose something like this via archive_write_disk -- entriesToDir :: Foldable t => FilePath -> t Entry -> ArchiveM () -entriesToDir :: FilePath -> [Entry] -> ArchiveM () +entriesToDir :: FilePath -> [Entry FilePath BS.ByteString] -> ArchiveM () entriesToDir = entriesToBSL .@ unpackToDirLazy diff --git a/test/Codec/Archive/Test.hs b/test/Codec/Archive/Test.hs --- a/test/Codec/Archive/Test.hs +++ b/test/Codec/Archive/Test.hs @@ -6,15 +6,15 @@ import Codec.Archive -simpleFile :: FilePath -> EntryContent -> Entry +simpleFile :: FilePath -> EntryContent FilePath e -> Entry FilePath e simpleFile name what = Entry name what standardPermissions (Ownership (Just "root") (Just "root") 0 0) (Just (0, 0)) -simpleDir :: FilePath -> Entry +simpleDir :: FilePath -> Entry FilePath e simpleDir name = Entry name Directory dirPermissions (Ownership (Just "root") (Just "root") 0 0) (Just (0, 0)) dirPermissions :: Permissions dirPermissions = executablePermissions -stripOwnership, stripTime :: Entry -> Entry +stripOwnership, stripTime :: Entry fp e -> Entry fp e stripOwnership entry = entry { ownership = Ownership Nothing Nothing 0 0 } stripTime entry = entry { time = Nothing } diff --git a/test/Spec.cpphs b/test/Spec.cpphs --- a/test/Spec.cpphs +++ b/test/Spec.cpphs @@ -2,8 +2,10 @@ module Main ( main ) where import Codec.Archive -import Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip, roundtripFreaky, roundtripStrict) +import Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip, roundtripFreaky, roundtripStrict, roundtripStrict') import Codec.Archive.Test +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import Data.Either (isRight) import Data.Foldable (traverse_) import System.Directory (doesDirectoryExist, listDirectory) @@ -19,6 +21,10 @@ testFpStrict fp = parallel $ it ("works on strict bytestring (" ++ fp ++ ")") $ roundtripStrict fp >>= (`shouldSatisfy` isRight) +testFpStrict' :: FilePath -> Spec +testFpStrict' fp = parallel $ it ("works on strict bytestring (" ++ fp ++ ")") $ + roundtripStrict' fp >>= (`shouldSatisfy` isRight) + testFpFreaky :: FilePath -> Spec testFpFreaky fp = parallel $ it ("works on nonstandard bytestring (" ++ fp ++ ")") $ roundtripFreaky fp >>= (`shouldSatisfy` isRight) @@ -27,7 +33,7 @@ unpack fp = withSystemTempDirectory "libarchive" $ \tmp -> runArchiveM $ unpackArchive fp tmp -readArchiveFile' :: FilePath -> IO (Either ArchiveResult [Entry]) +readArchiveFile' :: FilePath -> IO (Either ArchiveResult [Entry FilePath BS.ByteString]) readArchiveFile' = runArchiveM . readArchiveFile testUnpackLibarchive :: FilePath -> Spec @@ -38,6 +44,14 @@ testReadArchiveFile fp = parallel $ it ("reads " ++ fp) $ readArchiveFile' fp >>= (`shouldSatisfy` isRight) +repack :: ([Entry FilePath BS.ByteString] -> BSL.ByteString) -> String -> FilePath -> Spec +repack packer str fp = parallel $ it ("should repack (" ++ str ++ ")") $ do + res <- runArchiveM $ packer <$> readArchiveFile fp + res `shouldSatisfy` bsValid + +bsValid :: Either a BSL.ByteString -> Bool +bsValid = \x -> case x of { Left{} -> False; Right b -> not $ BSL.null b } + main :: IO () main = do @@ -50,8 +64,14 @@ traverse_ testFp tarPaths #ifndef LOW_MEMORY + traverse_ (repack entriesToBSLzip "zip") tarPaths + traverse_ (repack entriesToBSLCpio "cpio") tarPaths + traverse_ (repack entriesToBSLXar "xar") tarPaths + traverse_ (repack entriesToBSLShar "shar") tarPaths + traverse_ (repack entriesToBSL7zip "7zip") tarPaths traverse_ testFpFreaky tarPaths traverse_ testFpStrict tarPaths + traverse_ testFpStrict' tarPaths #endif traverse_ testUnpackLibarchive tarPaths traverse_ testReadArchiveFile tarPaths diff --git a/test/data/aarch64-linux-dist.tar b/test/data/aarch64-linux-dist.tar new file mode 100644 # file too large to diff: test/data/aarch64-linux-dist.tar