libarchive 2.2.5.2 → 3.0.0.0
raw patch · 19 files changed
+399/−204 lines, 19 filesdep +semigroupsdep +transformersdep ~base
Dependencies added: semigroups, transformers
Dependency ranges changed: base
Files
- CHANGELOG.md +8/−0
- libarchive.cabal +46/−26
- mem/Mem.hs +16/−2
- src/Codec/Archive.hs +4/−0
- src/Codec/Archive/Common.hs +4/−21
- src/Codec/Archive/Foreign/Archive.chs +12/−10
- src/Codec/Archive/Foreign/ArchiveEntry.chs +2/−2
- src/Codec/Archive/Monad.hs +17/−0
- src/Codec/Archive/Pack.hs +60/−40
- src/Codec/Archive/Pack/Common.hs +3/−2
- src/Codec/Archive/Pack/Lazy.hs +52/−21
- src/Codec/Archive/Types.hs +13/−11
- src/Codec/Archive/Types/Foreign.chs +2/−0
- src/Codec/Archive/Unpack.hs +106/−47
- src/Codec/Archive/Unpack/Lazy.hs +21/−13
- test/Codec/Archive/Roundtrip.hs +8/−4
- test/Codec/Archive/Test.hs +3/−3
- test/Spec.cpphs +22/−2
- test/data/aarch64-linux-dist.tar too large to diff
CHANGELOG.md view
@@ -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
libarchive.cabal view
@@ -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
mem/Mem.hs view
@@ -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")
src/Codec/Archive.hs view
@@ -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 (..)
src/Codec/Archive/Common.hs view
@@ -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
src/Codec/Archive/Foreign/Archive.chs view
@@ -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 <archive.h>+#include <archive_entry.h> -{#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' #}
src/Codec/Archive/Foreign/ArchiveEntry.chs view
@@ -228,6 +228,7 @@ #include <archive_entry.h> +-- 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' #}
src/Codec/Archive/Monad.hs view
@@ -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
src/Codec/Archive/Pack.hs view
@@ -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 ->
src/Codec/Archive/Pack/Common.hs view
@@ -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
src/Codec/Archive/Pack/Lazy.hs view
@@ -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)
src/Codec/Archive/Types.hs view
@@ -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)
src/Codec/Archive/Types/Foreign.chs view
@@ -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
src/Codec/Archive/Unpack.hs view
@@ -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
src/Codec/Archive/Unpack/Lazy.hs view
@@ -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
test/Codec/Archive/Roundtrip.hs view
@@ -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
test/Codec/Archive/Test.hs view
@@ -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 }
test/Spec.cpphs view
@@ -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
+ test/data/aarch64-linux-dist.tar view
file too large to diff