libarchive 3.0.0.0 → 3.0.1.1
raw patch · 17 files changed
+866/−869 lines, 17 files
Files
- CHANGELOG.md +4/−0
- libarchive.cabal +7/−8
- src/Codec/Archive.hs +5/−5
- src/Codec/Archive/Common.hs +0/−15
- src/Codec/Archive/Internal/Monad.hs +78/−0
- src/Codec/Archive/Internal/Pack.hs +260/−0
- src/Codec/Archive/Internal/Pack/Common.hs +26/−0
- src/Codec/Archive/Internal/Pack/Lazy.hs +138/−0
- src/Codec/Archive/Internal/Unpack.hs +254/−0
- src/Codec/Archive/Internal/Unpack/Lazy.hs +93/−0
- src/Codec/Archive/Monad.hs +0/−92
- src/Codec/Archive/Pack.hs +0/−255
- src/Codec/Archive/Pack/Common.hs +0/−26
- src/Codec/Archive/Pack/Lazy.hs +0/−135
- src/Codec/Archive/Unpack.hs +0/−241
- src/Codec/Archive/Unpack/Lazy.hs +0/−91
- test/Spec.cpphs +1/−1
CHANGELOG.md view
@@ -1,5 +1,9 @@ # libarchive +## 3.0.1.1++ * Add `Internal` modules+ ## 3.0.0.0 * Use `ForeignPtr` over `Ptr`
libarchive.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: libarchive-version: 3.0.0.0+version: 3.0.1.1 license: BSD-3-Clause license-file: LICENSE copyright: Copyright: (c) 2018-2020 Vanessa McHale@@ -58,21 +58,20 @@ Codec.Archive.Foreign Codec.Archive.Foreign.Archive Codec.Archive.Foreign.ArchiveEntry+ Codec.Archive.Internal.Pack+ Codec.Archive.Internal.Pack.Lazy+ Codec.Archive.Internal.Pack.Common+ Codec.Archive.Internal.Unpack.Lazy+ Codec.Archive.Internal.Unpack+ Codec.Archive.Internal.Monad hs-source-dirs: src other-modules: Codec.Archive.Foreign.Archive.Macros Codec.Archive.Foreign.ArchiveEntry.Macros- Codec.Archive.Pack- Codec.Archive.Pack.Lazy- Codec.Archive.Pack.Common- Codec.Archive.Unpack.Lazy- Codec.Archive.Unpack Codec.Archive.Types Codec.Archive.Types.Foreign Codec.Archive.Permissions- Codec.Archive.Common- Codec.Archive.Monad default-language: Haskell2010 other-extensions: DeriveGeneric DeriveAnyClass
src/Codec/Archive.hs view
@@ -54,10 +54,10 @@ , executablePermissions ) where -import Codec.Archive.Monad-import Codec.Archive.Pack-import Codec.Archive.Pack.Lazy+import Codec.Archive.Internal.Monad+import Codec.Archive.Internal.Pack+import Codec.Archive.Internal.Pack.Lazy import Codec.Archive.Permissions import Codec.Archive.Types-import Codec.Archive.Unpack-import Codec.Archive.Unpack.Lazy+import Codec.Archive.Internal.Unpack+import Codec.Archive.Internal.Unpack.Lazy
− src/Codec/Archive/Common.hs
@@ -1,15 +0,0 @@-module Codec.Archive.Common ( hmemcpy- ) where--import Control.Composition ((.**))-import Control.Monad (void)-import Foreign.C.Types (CSize (..))-import Foreign.Ptr--foreign import ccall memcpy :: Ptr a -- ^ Destination- -> Ptr b -- ^ Source- -> CSize -- ^ Size- -> IO (Ptr a) -- ^ Pointer to destination--hmemcpy :: Ptr a -> Ptr b -> CSize -> IO ()-hmemcpy = void .** memcpy
+ src/Codec/Archive/Internal/Monad.hs view
@@ -0,0 +1,78 @@+module Codec.Archive.Internal.Monad ( handle+ , ignore+ , lenient+ , runArchiveM+ , throwArchiveM+ -- * Bracketed resources within 'ArchiveM'+ , withCStringArchiveM+ , useAsCStringLenArchiveM+ , allocaBytesArchiveM+ , ArchiveM+ ) where++import Codec.Archive.Types+import Control.Exception (throw)+import Control.Monad (void)+import Control.Monad.Except (ExceptT, runExceptT, throwError)+import Control.Monad.IO.Class+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS+import Foreign.C.String+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (Ptr)++type ArchiveM = ExceptT ArchiveResult IO++-- for things we don't think is going to fail+ignore :: IO ArchiveResult -> ArchiveM ()+ignore = void . liftIO++-- | Throws 'ArchiveResult' on error.+--+-- @since 2.2.5.0+throwArchiveM :: ArchiveM a -> IO a+throwArchiveM = fmap (either throw id) . runArchiveM++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+flipExceptIO act = do+ res <- liftIO act+ case res of+ Right x -> pure x+ Left y -> throwError y++genBracket :: (a -> (b -> IO (Either c d)) -> IO (Either c d)) -- ^ Function like 'withCString' we are trying to lift+ -> a -- ^ Fed to @b@+ -> (b -> ExceptT c IO d) -- ^ The action+ -> ExceptT c IO d+genBracket f x = flipExceptIO . f x . (runExceptT .)++allocaBytesArchiveM :: Int -> (Ptr a -> ExceptT b IO c) -> ExceptT b IO c+allocaBytesArchiveM = genBracket allocaBytes++withCStringArchiveM :: String -> (CString -> ExceptT a IO b) -> ExceptT a IO b+withCStringArchiveM = genBracket withCString++useAsCStringLenArchiveM :: BS.ByteString -> (CStringLen -> ExceptT a IO b) -> ExceptT a IO b+useAsCStringLenArchiveM = genBracket BS.unsafeUseAsCStringLen
+ src/Codec/Archive/Internal/Pack.hs view
@@ -0,0 +1,260 @@+module Codec.Archive.Internal.Pack ( entriesToFile+ , entriesToFileZip+ , entriesToFile7Zip+ , entriesToFileCpio+ , entriesToFileXar+ , entriesToFileShar+ , entriesToFileGeneral+ , entriesToBS+ , entriesToBSGeneral+ , entriesToBSzip+ , entriesToBS7zip+ , filePacker+ , packEntries+ , noFail+ , packToFile+ , packToFileZip+ , packToFile7Zip+ , packToFileCpio+ , packToFileXar+ , packToFileShar+ , archiveEntryAdd+ , contentAdd+ ) where++import Codec.Archive.Foreign+import Codec.Archive.Internal.Monad+import Codec.Archive.Internal.Pack.Common+import Codec.Archive.Types+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.Concurrent (newForeignPtr)+import Foreign.ForeignPtr (castForeignPtr)+import Foreign.Ptr (castPtr)+import System.IO.Unsafe (unsafeDupablePerformIO)++maybeDo :: Applicative f => Maybe (f ()) -> f ()+maybeDo = sequenceA_++-- 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)+ 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+ lenient $ archiveWriteHeader a entry+ liftIO $ archiveClearError a+contentAdd (Hardlink fp) a entry = do+ liftIO $ archiveEntrySetFiletype entry Nothing+ liftIO $ withCString fp $ \fpc ->+ archiveEntrySetHardlink entry fpc+ 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 -> ArchiveEntryPtr -> IO ()+setOwnership (Ownership uname gname uid gid) entry =+ withMaybeCString uname $ \unameC ->+ withMaybeCString gname $ \gnameC ->+ traverse_ maybeDo+ [ archiveEntrySetUname entry <$> unameC+ , archiveEntrySetGname entry <$> gnameC+ , Just (archiveEntrySetUid entry (coerce uid))+ , Just (archiveEntrySetGid entry (coerce gid))+ ]++setTime :: ModTime -> ArchiveEntryPtr -> IO ()+setTime (time', nsec) entry = archiveEntrySetMtime entry time' nsec++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 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+ contentSz Directory = 0+ contentSz (Symlink fp _) = 1 + fromIntegral (length fp)+ contentSz (Hardlink fp) = fromIntegral $ length fp --idk if this is right++-- | Returns a 'BS.ByteString' containing a tar archive with the 'Entry's+--+-- @since 1.0.0.0+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 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 FilePath BS.ByteString) -> BS.ByteString+entriesToBSzip = unsafeDupablePerformIO . noFail . entriesToBSGeneral archiveWriteSetFormatZip+{-# NOINLINE entriesToBSzip #-}++-- This is for things we don't think will fail. When making a 'BS.ByteString'+-- from a bunch of 'Entry's, for instance, we don't anticipate any errors+noFail :: ArchiveM a -> IO a+noFail act = do+ 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) => (ArchivePtr -> IO ArchiveResult) -> t (Entry FilePath BS.ByteString) -> ArchiveM BS.ByteString+entriesToBSGeneral modifier hsEntries' = do+ 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+ liftIO $ curry packCStringLen buffer (fromIntegral usedSz)++ where bufSize :: Integral a => a+ bufSize = entriesSz hsEntries'++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+packToFile :: Traversable t+ => FilePath -- ^ @.tar@ archive to be created+ -> t FilePath -- ^ Files to include+ -> ArchiveM ()+packToFile = filePacker entriesToFile++-- | @since 2.0.0.0+packToFileZip :: Traversable t+ => FilePath+ -> t FilePath+ -> ArchiveM ()+packToFileZip = filePacker entriesToFileZip++-- | @since 2.0.0.0+packToFile7Zip :: Traversable t+ => FilePath+ -> t FilePath+ -> ArchiveM ()+packToFile7Zip = filePacker entriesToFile7Zip++-- | @since 2.2.3.0+packToFileCpio :: Traversable t+ => FilePath+ -> t FilePath+ -> ArchiveM ()+packToFileCpio = filePacker entriesToFileCpio++-- | @since 2.2.4.0+packToFileXar :: Traversable t+ => FilePath+ -> t FilePath+ -> 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+--+-- @+-- BS.writeFile "file.tar" (entriesToBS entries)+-- @+--+-- @since 1.0.0.0+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 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 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 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 FilePath BS.ByteString) -> ArchiveM ()+entriesToFileXar = entriesToFileGeneral archiveWriteSetFormatXar++-- | 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++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++ 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 ->+ archiveEntrySetPathname entry fpc+ liftIO $ archiveEntrySetPerm entry perms+ liftIO $ setOwnership owner entry+ liftIO $ maybeDo (setTime <$> mtime <*> pure entry)+ contentAdd contents a entry
+ src/Codec/Archive/Internal/Pack/Common.hs view
@@ -0,0 +1,26 @@+module Codec.Archive.Internal.Pack.Common ( mkEntry+ , mkContent+ ) where++import Codec.Archive.Types+import qualified Data.ByteString as BS+import System.PosixCompat.Files (FileStatus, fileGroup, fileMode, fileOwner, getFileStatus, isDirectory, isRegularFile, isSymbolicLink, linkCount,+ readSymbolicLink)++mkContent :: FilePath -> FileStatus -> IO (EntryContent FilePath BS.ByteString)+mkContent fp status =+ let res = (isRegularFile status, isDirectory status, isSymbolicLink status, linkCount status)+ in++ case res of+ (True, False, False, 1) -> NormalFile <$> BS.readFile fp+ (True, False, False, _) -> pure $ Hardlink fp+ (False, True, False, _) -> pure Directory+ (False, False, True, _) -> Symlink <$> readSymbolicLink fp <*> pure SymlinkUndefined+ (_, _, _, _) -> error "inconsistent read result"++mkEntry :: FilePath -> IO (Entry FilePath BS.ByteString)+mkEntry fp = do+ status <- getFileStatus fp+ content' <- mkContent fp status+ pure $ Entry fp content' (fileMode status) (Ownership Nothing Nothing (fromIntegral $ fileOwner status) (fromIntegral $ fileGroup status)) Nothing
+ src/Codec/Archive/Internal/Pack/Lazy.hs view
@@ -0,0 +1,138 @@+module Codec.Archive.Internal.Pack.Lazy ( entriesToBSL+ , entriesToBSL7zip+ , entriesToBSLzip+ , entriesToBSLCpio+ , entriesToBSLXar+ , entriesToBSLShar+ , entriesToBSLGeneral+ , entriesToIOChunks+ , packer+ , packFiles+ , packFilesZip+ , packFiles7zip+ , packFilesCpio+ , packFilesXar+ , packFilesShar+ ) where++import Codec.Archive.Foreign+import Codec.Archive.Internal.Monad+import Codec.Archive.Internal.Pack+import Codec.Archive.Internal.Pack.Common+import Codec.Archive.Types+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 (castPtr, freeHaskellFunPtr)+import System.IO.Unsafe (unsafeDupablePerformIO)++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. 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+ -> IO BSL.ByteString+packFiles = packer entriesToBSL++-- | @since 2.0.0.0+packFilesZip :: Traversable t => t FilePath -> IO BSL.ByteString+packFilesZip = packer entriesToBSLzip++-- | @since 2.0.0.0+packFiles7zip :: Traversable t => t FilePath -> IO BSL.ByteString+packFiles7zip = packer entriesToBSL7zip++-- | @since 2.2.3.0+packFilesCpio :: Traversable t => t FilePath -> IO BSL.ByteString+packFilesCpio = packer entriesToBSLCpio++-- | @since 2.2.4.0+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 FilePath BS.ByteString) -> BSL.ByteString+entriesToBSLzip = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatZip+{-# NOINLINE entriesToBSLzip #-}++-- | @since 1.0.5.0+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 FilePath BS.ByteString) -> BSL.ByteString+entriesToBSLCpio = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatCpio+{-# NOINLINE entriesToBSLCpio #-}++-- | 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 FilePath BS.ByteString) -> BSL.ByteString+entriesToBSL = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatPaxRestricted+{-# NOINLINE entriesToBSL #-}++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 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'+ liftIO $ finalizeForeignPtr a++ where doNothing _ _ = pure ArchiveOk+ chunkHelper _ _ bufPtr sz = do+ let bytesRead = min (fromIntegral sz) (32 * 1024)+ bs <- packCStringLen (bufPtr, fromIntegral bytesRead)+ chunkAct bs+ pure bytesRead++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/Internal/Unpack.hs view
@@ -0,0 +1,254 @@+module Codec.Archive.Internal.Unpack ( hsEntriesAbs+ , unpackEntriesFp+ , unpackArchive+ , readArchiveFile+ , readArchiveBS+ , archiveFile+ , bsToArchive+ , unpackToDir+ , readBS+ , readBSL+ , readEntry+ , readContents+ , getHsEntry+ , hsEntries+ , hsEntriesST+ , hsEntriesSTLazy+ , hsEntriesSTAbs+ ) where++import Codec.Archive.Foreign+import Codec.Archive.Internal.Monad+import Codec.Archive.Types+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.Concurrent (newForeignPtr)+import Foreign.ForeignPtr (castForeignPtr, newForeignPtr_)+import Foreign.Marshal.Alloc (allocaBytes, free, mallocBytes)+import Foreign.Marshal.Utils (copyBytes)+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 FilePath BS.ByteString]+readArchiveBS = unsafeDupablePerformIO . runArchiveM . (go hsEntries <=< bsToArchive)+ where go f (y, act) = f y <* liftIO act+{-# NOINLINE readArchiveBS #-}++bsToArchive :: BS.ByteString -> ArchiveM (ArchivePtr, IO ())+bsToArchive bs = do+ preA <- liftIO archiveReadNew+ a <- liftIO $ castForeignPtr <$> newForeignPtr (castPtr preA) (void $ archiveFree preA)+ ignore $ archiveReadSupportFormatAll a+ bufPtr <- useAsCStringLenArchiveM bs $+ \(buf, sz) -> do+ buf' <- liftIO $ mallocBytes sz+ _ <- liftIO $ copyBytes buf' buf sz+ handle $ archiveReadOpenMemory a buf (fromIntegral sz)+ pure buf'+ pure (a, free bufPtr)++-- | Read an archive from a file. The format of the archive is automatically+-- detected.+--+-- @since 1.0.0.0+readArchiveFile :: FilePath -> ArchiveM [Entry FilePath BS.ByteString]+readArchiveFile fp = act =<< liftIO (do+ pre <- archiveReadNew+ castForeignPtr <$> newForeignPtr (castPtr pre) (void $ archiveFree pre))++ 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)++-- | This is more efficient than+--+-- @+-- unpackToDir "llvm" =<< BS.readFile "llvm.tar"+-- @+unpackArchive :: FilePath -- ^ Filepath pointing to archive+ -> FilePath -- ^ Dirctory to unpack in+ -> ArchiveM ()+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++readEntry :: Integral a+ => (ArchivePtr -> a -> IO e)+ -> ArchivePtr+ -> ArchiveEntryPtr+ -> IO (Entry FilePath e)+readEntry read' a entry =+ Entry+ <$> (peekCString =<< archiveEntryPathname entry)+ <*> readContents read' a entry+ <*> archiveEntryPerm entry+ <*> readOwnership entry+ <*> readTimes entry++-- | Yield the next entry in an archive+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 read' a x++-- | Return a list of 'Entry's.+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++hsEntriesSTLazy :: ArchivePtr -> LazyST.ST s [Entry FilePath BSL.ByteString]+hsEntriesSTLazy = hsEntriesSTAbs readBSL++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:) <$> hsEntriesSTAbs read' a++-- | Unpack an archive in a given directory+unpackEntriesFp :: ArchivePtr -> FilePath -> ArchiveM ()+unpackEntriesFp a fp = do+ res <- liftIO $ getEntry a+ case res of+ Nothing -> pure ()+ Just x -> do+ preFile <- liftIO $ archiveEntryPathname x+ file <- liftIO $ peekCString preFile+ let file' = fp </> file+ liftIO $ withCString file' $ \fileC ->+ archiveEntrySetPathname x fileC+ ft <- liftIO $ archiveEntryFiletype x+ case ft of+ Just{} ->+ ignore $ archiveReadExtract a x archiveExtractTime+ Nothing -> do+ hardlink <- liftIO $ peekCString =<< archiveEntryHardlink x+ let hardlink' = fp </> hardlink+ liftIO $ withCString hardlink' $ \hl ->+ archiveEntrySetHardlink x hl+ ignore $ archiveReadExtract a x archiveExtractTime+ ignore $ archiveReadDataSkip a+ unpackEntriesFp a fp++{-# INLINE readBS #-}+readBS :: ArchivePtr -> Int -> IO BS.ByteString+readBS a sz =+ allocaBytes sz $ \buff ->+ archiveReadData a buff (fromIntegral sz) *>+ BS.packCStringLen (buff, sz)++-- TODO: sanity check by comparing to archiveEntrySize?+readBSL :: ArchivePtr -> Int -> 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 <$> (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 :: (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 :: (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 :: ArchiveEntryPtr -> IO Ownership+readOwnership entry =+ Ownership+ <$> archiveGetterNull archiveEntryUname entry+ <*> archiveGetterNull archiveEntryGname entry+ <*> (fromIntegral <$> archiveEntryUid entry)+ <*> (fromIntegral <$> archiveEntryGid entry)++readTimes :: ArchiveEntryPtr -> IO (Maybe ModTime)+readTimes = archiveGetterHelper go archiveEntryMtimeIsSet+ where go entry =+ (,) <$> archiveEntryMtime entry <*> archiveEntryMtimeNsec entry++-- | Get the next 'ArchiveEntry' in an 'Archive'+getEntry :: ArchivePtr -> IO (Maybe ArchiveEntryPtr)+getEntry a = do+ let done ArchiveOk = False+ done ArchiveRetry = False+ done _ = True+ (stop, res) <- first done <$> archiveReadNextHeader a+ if stop+ then pure Nothing+ else Just . castForeignPtr <$> newForeignPtr_ (castPtr res)++unpackToDir :: FilePath -- ^ Directory to unpack in+ -> BS.ByteString -- ^ 'BS.ByteString' containing archive+ -> ArchiveM ()+unpackToDir fp bs = do+ (a, act) <- bsToArchive bs+ unpackEntriesFp a fp+ liftIO act
+ src/Codec/Archive/Internal/Unpack/Lazy.hs view
@@ -0,0 +1,93 @@+module Codec.Archive.Internal.Unpack.Lazy ( readArchiveBSL+ , readArchiveBSLAbs+ , unpackToDirLazy+ , bslToArchive+ ) where++import Codec.Archive.Foreign+import Codec.Archive.Internal.Monad+import Codec.Archive.Internal.Unpack+import Codec.Archive.Types+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 Foreign.Concurrent (newForeignPtr)+import Foreign.ForeignPtr (castForeignPtr)+import Foreign.Marshal.Alloc (free, mallocBytes, reallocBytes)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.Ptr (castPtr, freeHaskellFunPtr)+import Foreign.Storable (poke)+import System.IO.Unsafe (unsafeDupablePerformIO)++-- | In general, this will be more efficient than 'unpackToDir'+--+-- @since 1.0.4.0+unpackToDirLazy :: FilePath -- ^ Directory to unpack in+ -> BSL.ByteString -- ^ 'BSL.ByteString' containing archive+ -> ArchiveM ()+unpackToDirLazy fp bs = do+ a <- bslToArchive bs+ unpackEntriesFp a fp++-- | Read an archive lazily. The format of the archive is automatically+-- detected.+--+-- In general, this will be more efficient than 'readArchiveBS'+--+-- @since 1.0.4.0+readArchiveBSL :: BSL.ByteString -> 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 ArchivePtr+bslToArchive bs = do+ 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+ , archiveReadSetCloseCallback a cc+ , archiveReadSetCallbackData a nothingPtr+ , archiveReadOpen1 a+ ]+ pure a++ where readBSL' bsRef bufSzRef bufPtrRef _ _ dataPtr = do+ bs' <- readIORef bsRef+ case bs' of+ [] -> pure 0+ (x:_) -> do+ modifyIORef' bsRef tail+ BS.unsafeUseAsCStringLen x $ \(charPtr, sz) -> do+ bufSz <- readIORef bufSzRef+ bufPtr <- readIORef bufPtrRef+ bufPtr' <- if sz > bufSz+ then do+ writeIORef bufSzRef sz+ newBufPtr <- reallocBytes bufPtr sz+ writeIORef bufPtrRef newBufPtr+ pure newBufPtr+ else readIORef bufPtrRef+ copyBytes bufPtr' charPtr sz+ poke dataPtr bufPtr' $> fromIntegral sz+ bsChunks = BSL.toChunks bs
− src/Codec/Archive/Monad.hs
@@ -1,92 +0,0 @@-module Codec.Archive.Monad ( handle- , ignore- , lenient- , touchForeignPtrM- , runArchiveM- , throwArchiveM- -- * Bracketed resources within 'ArchiveM'- , withCStringArchiveM- , useAsCStringLenArchiveM- , allocaBytesArchiveM- , bracketM- , ArchiveM- ) where--import Codec.Archive.Types-import Control.Exception (bracket, throw)-import Control.Monad (void)-import Control.Monad.Except (ExceptT, runExceptT, throwError)-import Control.Monad.IO.Class-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---- | Throws 'ArchiveResult' on error.------ @since 2.2.5.0-throwArchiveM :: ArchiveM a -> IO a-throwArchiveM = fmap (either throw id) . runArchiveM--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-flipExceptIO act = do- res <- liftIO act- case res of- Right x -> pure x- Left y -> throwError y--genBracket :: (a -> (b -> IO (Either c d)) -> IO (Either c d)) -- ^ Function like 'withCString' we are trying to lift- -> a -- ^ Fed to @b@- -> (b -> ExceptT c IO d) -- ^ The action- -> ExceptT c IO d-genBracket f x = flipExceptIO . f x . (runExceptT .)--allocaBytesArchiveM :: Int -> (Ptr a -> ExceptT b IO c) -> ExceptT b IO c-allocaBytesArchiveM = genBracket allocaBytes--withCStringArchiveM :: String -> (CString -> ExceptT a IO b) -> ExceptT a IO b-withCStringArchiveM = genBracket withCString--useAsCStringLenArchiveM :: BS.ByteString -> (CStringLen -> ExceptT a IO b) -> ExceptT a IO b-useAsCStringLenArchiveM = genBracket BS.unsafeUseAsCStringLen--bracketM :: IO a -- ^ Allocate/aquire a resource- -> (a -> IO b) -- ^ Free/release a resource (assumed not to fail)- -> (a -> ArchiveM c)- -> ArchiveM c-bracketM get free act =- flipExceptIO $- bracket get free (runArchiveM.act)
− src/Codec/Archive/Pack.hs
@@ -1,255 +0,0 @@-module Codec.Archive.Pack ( entriesToFile- , entriesToFileZip- , entriesToFile7Zip- , entriesToFileCpio- , entriesToFileXar- , entriesToFileShar- , entriesToBS- , entriesToBSzip- , entriesToBS7zip- , packEntries- , noFail- , packToFile- , packToFileZip- , 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 (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.Concurrent (newForeignPtr)-import Foreign.ForeignPtr (castForeignPtr)-import Foreign.Ptr (castPtr)-import System.IO.Unsafe (unsafeDupablePerformIO)--maybeDo :: Applicative f => Maybe (f ()) -> f ()-maybeDo = sequenceA_---- 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)- 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- lenient $ archiveWriteHeader a entry- liftIO $ archiveClearError a-contentAdd (Hardlink fp) a entry = do- liftIO $ archiveEntrySetFiletype entry Nothing- liftIO $ withCString fp $ \fpc ->- archiveEntrySetHardlink entry fpc- 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 -> ArchiveEntryPtr -> IO ()-setOwnership (Ownership uname gname uid gid) entry =- withMaybeCString uname $ \unameC ->- withMaybeCString gname $ \gnameC ->- traverse_ maybeDo- [ archiveEntrySetUname entry <$> unameC- , archiveEntrySetGname entry <$> gnameC- , Just (archiveEntrySetUid entry (coerce uid))- , Just (archiveEntrySetGid entry (coerce gid))- ]--setTime :: ModTime -> ArchiveEntryPtr -> IO ()-setTime (time', nsec) entry = archiveEntrySetMtime entry time' nsec--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 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- contentSz Directory = 0- contentSz (Symlink fp _) = 1 + fromIntegral (length fp)- contentSz (Hardlink fp) = fromIntegral $ length fp --idk if this is right---- | Returns a 'BS.ByteString' containing a tar archive with the 'Entry's------ @since 1.0.0.0-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 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 FilePath BS.ByteString) -> BS.ByteString-entriesToBSzip = unsafeDupablePerformIO . noFail . entriesToBSGeneral archiveWriteSetFormatZip-{-# NOINLINE entriesToBSzip #-}---- This is for things we don't think will fail. When making a 'BS.ByteString'--- from a bunch of 'Entry's, for instance, we don't anticipate any errors-noFail :: ArchiveM a -> IO a-noFail act = do- 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) => (ArchivePtr -> IO ArchiveResult) -> t (Entry FilePath BS.ByteString) -> ArchiveM BS.ByteString-entriesToBSGeneral modifier hsEntries' = do- 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- liftIO $ curry packCStringLen buffer (fromIntegral usedSz)-- where bufSize :: Integral a => a- bufSize = entriesSz hsEntries'--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-packToFile :: Traversable t- => FilePath -- ^ @.tar@ archive to be created- -> t FilePath -- ^ Files to include- -> ArchiveM ()-packToFile = filePacker entriesToFile---- | @since 2.0.0.0-packToFileZip :: Traversable t- => FilePath- -> t FilePath- -> ArchiveM ()-packToFileZip = filePacker entriesToFileZip---- | @since 2.0.0.0-packToFile7Zip :: Traversable t- => FilePath- -> t FilePath- -> ArchiveM ()-packToFile7Zip = filePacker entriesToFile7Zip---- | @since 2.2.3.0-packToFileCpio :: Traversable t- => FilePath- -> t FilePath- -> ArchiveM ()-packToFileCpio = filePacker entriesToFileCpio---- | @since 2.2.4.0-packToFileXar :: Traversable t- => FilePath- -> t FilePath- -> 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------ @--- BS.writeFile "file.tar" (entriesToBS entries)--- @------ @since 1.0.0.0-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 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 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 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 FilePath BS.ByteString) -> ArchiveM ()-entriesToFileXar = entriesToFileGeneral archiveWriteSetFormatXar---- | 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--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-- 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 ->- archiveEntrySetPathname entry fpc- liftIO $ archiveEntrySetPerm entry perms- liftIO $ setOwnership owner entry- liftIO $ maybeDo (setTime <$> mtime <*> pure entry)- contentAdd contents a entry
− src/Codec/Archive/Pack/Common.hs
@@ -1,26 +0,0 @@-module Codec.Archive.Pack.Common ( mkEntry ) where--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 FilePath BS.ByteString)-mkContent fp status =- let res = (isRegularFile status, isDirectory status, isSymbolicLink status, linkCount status)- in-- case res of- (True, False, False, 1) -> NormalFile <$> BS.readFile fp- (True, False, False, _) -> pure $ Hardlink fp- (False, True, False, _) -> pure Directory- (False, False, True, _) -> Symlink <$> readSymbolicLink fp <*> pure SymlinkUndefined- (_, _, _, _) -> error "inconsistent read result"--mkEntry :: FilePath -> IO (Entry FilePath BS.ByteString)-mkEntry fp = do- status <- getFileStatus fp- content' <- mkContent fp status- pure $ Entry fp content' (fileMode status) (Ownership Nothing Nothing (fromIntegral $ fileOwner status) (fromIntegral $ fileGroup status)) Nothing-
− src/Codec/Archive/Pack/Lazy.hs
@@ -1,135 +0,0 @@-module Codec.Archive.Pack.Lazy ( entriesToBSL- , entriesToBSL7zip- , entriesToBSLzip- , entriesToBSLCpio- , entriesToBSLXar- , entriesToBSLShar- , packFiles- , packFilesZip- , packFiles7zip- , packFilesCpio- , packFilesXar- , packFilesShar- ) where--import Codec.Archive.Foreign-import Codec.Archive.Monad-import Codec.Archive.Pack-import Codec.Archive.Pack.Common-import Codec.Archive.Types-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 (castPtr, freeHaskellFunPtr)-import System.IO.Unsafe (unsafeDupablePerformIO)--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. 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- -> IO BSL.ByteString-packFiles = packer entriesToBSL---- | @since 2.0.0.0-packFilesZip :: Traversable t => t FilePath -> IO BSL.ByteString-packFilesZip = packer entriesToBSLzip---- | @since 2.0.0.0-packFiles7zip :: Traversable t => t FilePath -> IO BSL.ByteString-packFiles7zip = packer entriesToBSL7zip---- | @since 2.2.3.0-packFilesCpio :: Traversable t => t FilePath -> IO BSL.ByteString-packFilesCpio = packer entriesToBSLCpio---- | @since 2.2.4.0-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 FilePath BS.ByteString) -> BSL.ByteString-entriesToBSLzip = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatZip-{-# NOINLINE entriesToBSLzip #-}---- | @since 1.0.5.0-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 FilePath BS.ByteString) -> BSL.ByteString-entriesToBSLCpio = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatCpio-{-# NOINLINE entriesToBSLCpio #-}---- | 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 FilePath BS.ByteString) -> BSL.ByteString-entriesToBSL = unsafeDupablePerformIO . noFail . entriesToBSLGeneral archiveWriteSetFormatPaxRestricted-{-# NOINLINE entriesToBSL #-}--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 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'- liftIO $ finalizeForeignPtr a-- where doNothing _ _ = pure ArchiveOk- chunkHelper _ _ bufPtr sz = do- let bytesRead = min (fromIntegral sz) (32 * 1024)- bs <- packCStringLen (bufPtr, fromIntegral bytesRead)- chunkAct bs- pure bytesRead--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/Unpack.hs
@@ -1,241 +0,0 @@-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 ((<=<))-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.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 FilePath BS.ByteString]-readArchiveBS = unsafeDupablePerformIO . runArchiveM . (go hsEntries <=< bsToArchive)- where go f (y, act) = f y <* liftIO act-{-# NOINLINE readArchiveBS #-}--bsToArchive :: BS.ByteString -> ArchiveM (ArchivePtr, IO ())-bsToArchive bs = do- preA <- liftIO archiveReadNew- a <- liftIO $ castForeignPtr <$> newForeignPtr (castPtr preA) (void $ archiveFree preA)- ignore $ archiveReadSupportFormatAll a- bufPtr <- useAsCStringLenArchiveM bs $- \(buf, sz) -> do- buf' <- liftIO $ mallocBytes sz- _ <- liftIO $ hmemcpy buf' buf (fromIntegral sz)- handle $ archiveReadOpenMemory a buf (fromIntegral sz)- pure buf'- pure (a, free bufPtr)---- | Read an archive from a file. The format of the archive is automatically--- detected.------ @since 1.0.0.0-readArchiveFile :: FilePath -> ArchiveM [Entry FilePath BS.ByteString]-readArchiveFile fp = act =<< liftIO (do- pre <- archiveReadNew- castForeignPtr <$> newForeignPtr (castPtr pre) (void $ archiveFree pre))-- 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)---- | This is more efficient than------ @--- unpackToDir "llvm" =<< BS.readFile "llvm.tar"--- @-unpackArchive :: FilePath -- ^ Filepath pointing to archive- -> FilePath -- ^ Dirctory to unpack in- -> ArchiveM ()-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--readEntry :: Integral a- => (ArchivePtr -> a -> IO e)- -> ArchivePtr- -> ArchiveEntryPtr- -> IO (Entry FilePath e)-readEntry read' a entry =- Entry- <$> (peekCString =<< archiveEntryPathname entry)- <*> readContents read' a entry- <*> archiveEntryPerm entry- <*> readOwnership entry- <*> readTimes entry---- | Yield the next entry in an archive-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 read' a x---- | Return a list of 'Entry's.-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:) <$> hsEntriesSTAbs read' a---- | Unpack an archive in a given directory-unpackEntriesFp :: ArchivePtr -> FilePath -> ArchiveM ()-unpackEntriesFp a fp = do- res <- liftIO $ getEntry a- case res of- Nothing -> pure ()- Just x -> do- preFile <- liftIO $ archiveEntryPathname x- file <- liftIO $ peekCString preFile- let file' = fp </> file- liftIO $ withCString file' $ \fileC ->- archiveEntrySetPathname x fileC- ft <- liftIO $ archiveEntryFiletype x- case ft of- Just{} ->- ignore $ archiveReadExtract a x archiveExtractTime- Nothing -> do- hardlink <- liftIO $ peekCString =<< archiveEntryHardlink x- let hardlink' = fp </> hardlink- liftIO $ withCString hardlink' $ \hl ->- archiveEntrySetHardlink x hl- ignore $ archiveReadExtract a x archiveExtractTime- ignore $ archiveReadDataSkip a- unpackEntriesFp a fp--{-# INLINE readBS #-}-readBS :: ArchivePtr -> Int -> IO BS.ByteString-readBS a sz =- allocaBytes sz $ \buff ->- archiveReadData a buff (fromIntegral sz) *>- BS.packCStringLen (buff, sz)---- 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 <$> (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 :: (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 :: (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 :: ArchiveEntryPtr -> IO Ownership-readOwnership entry =- Ownership- <$> archiveGetterNull archiveEntryUname entry- <*> archiveGetterNull archiveEntryGname entry- <*> (fromIntegral <$> archiveEntryUid entry)- <*> (fromIntegral <$> archiveEntryGid entry)--readTimes :: ArchiveEntryPtr -> IO (Maybe ModTime)-readTimes = archiveGetterHelper go archiveEntryMtimeIsSet- where go entry =- (,) <$> archiveEntryMtime entry <*> archiveEntryMtimeNsec entry---- | Get the next 'ArchiveEntry' in an 'Archive'-getEntry :: ArchivePtr -> IO (Maybe ArchiveEntryPtr)-getEntry a = do- let done ArchiveOk = False- done ArchiveRetry = False- done _ = True- (stop, res) <- first done <$> archiveReadNextHeader a- if stop- then pure Nothing- else Just . castForeignPtr <$> newForeignPtr_ (castPtr res)--unpackToDir :: FilePath -- ^ Directory to unpack in- -> BS.ByteString -- ^ 'BS.ByteString' containing archive- -> ArchiveM ()-unpackToDir fp bs = do- (a, act) <- bsToArchive bs- unpackEntriesFp a fp- liftIO act
− src/Codec/Archive/Unpack/Lazy.hs
@@ -1,91 +0,0 @@-module Codec.Archive.Unpack.Lazy ( readArchiveBSL- , unpackToDirLazy- ) where--import Codec.Archive.Common-import Codec.Archive.Foreign-import Codec.Archive.Monad-import Codec.Archive.Types-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 Foreign.Concurrent (newForeignPtr)-import Foreign.ForeignPtr (castForeignPtr)-import Foreign.Marshal.Alloc (free, mallocBytes, reallocBytes)-import Foreign.Ptr (castPtr, freeHaskellFunPtr)-import Foreign.Storable (poke)-import System.IO.Unsafe (unsafeDupablePerformIO)---- | In general, this will be more efficient than 'unpackToDir'------ @since 1.0.4.0-unpackToDirLazy :: FilePath -- ^ Directory to unpack in- -> BSL.ByteString -- ^ 'BSL.ByteString' containing archive- -> ArchiveM ()-unpackToDirLazy fp bs = do- a <- bslToArchive bs- unpackEntriesFp a fp---- | Read an archive lazily. The format of the archive is automatically--- detected.------ In general, this will be more efficient than 'readArchiveBS'------ @since 1.0.4.0-readArchiveBSL :: BSL.ByteString -> 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 ArchivePtr-bslToArchive bs = do- 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- , archiveReadSetCloseCallback a cc- , archiveReadSetCallbackData a nothingPtr- , archiveReadOpen1 a- ]- pure a-- where readBSL bsRef bufSzRef bufPtrRef _ _ dataPtr = do- bs' <- readIORef bsRef- case bs' of- [] -> pure 0- (x:_) -> do- modifyIORef' bsRef tail- BS.unsafeUseAsCStringLen x $ \(charPtr, sz) -> do- bufSz <- readIORef bufSzRef- bufPtr <- readIORef bufPtrRef- bufPtr' <- if sz > bufSz- then do- writeIORef bufSzRef sz- newBufPtr <- reallocBytes bufPtr sz- writeIORef bufPtrRef newBufPtr- pure newBufPtr- else readIORef bufPtrRef- hmemcpy bufPtr' charPtr (fromIntegral sz)- poke dataPtr bufPtr' $> fromIntegral sz- bsChunks = BSL.toChunks bs
test/Spec.cpphs view
@@ -64,7 +64,7 @@ traverse_ testFp tarPaths #ifndef LOW_MEMORY- traverse_ (repack entriesToBSLzip "zip") tarPaths+ traverse_ (\fp -> repack entriesToBSLzip ("zip/" ++ fp) fp) tarPaths traverse_ (repack entriesToBSLCpio "cpio") tarPaths traverse_ (repack entriesToBSLXar "xar") tarPaths traverse_ (repack entriesToBSLShar "shar") tarPaths