diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # libarchive +## 3.0.1.1 + + * Add `Internal` modules + ## 3.0.0.0 * Use `ForeignPtr` over `Ptr` diff --git a/libarchive.cabal b/libarchive.cabal --- a/libarchive.cabal +++ b/libarchive.cabal @@ -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 diff --git a/src/Codec/Archive.hs b/src/Codec/Archive.hs --- a/src/Codec/Archive.hs +++ b/src/Codec/Archive.hs @@ -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 diff --git a/src/Codec/Archive/Common.hs b/src/Codec/Archive/Common.hs deleted file mode 100644 --- a/src/Codec/Archive/Common.hs +++ /dev/null @@ -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 diff --git a/src/Codec/Archive/Internal/Monad.hs b/src/Codec/Archive/Internal/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/Internal/Monad.hs @@ -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 diff --git a/src/Codec/Archive/Internal/Pack.hs b/src/Codec/Archive/Internal/Pack.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/Internal/Pack.hs @@ -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 diff --git a/src/Codec/Archive/Internal/Pack/Common.hs b/src/Codec/Archive/Internal/Pack/Common.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/Internal/Pack/Common.hs @@ -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 diff --git a/src/Codec/Archive/Internal/Pack/Lazy.hs b/src/Codec/Archive/Internal/Pack/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/Internal/Pack/Lazy.hs @@ -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) diff --git a/src/Codec/Archive/Internal/Unpack.hs b/src/Codec/Archive/Internal/Unpack.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/Internal/Unpack.hs @@ -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 diff --git a/src/Codec/Archive/Internal/Unpack/Lazy.hs b/src/Codec/Archive/Internal/Unpack/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/Internal/Unpack/Lazy.hs @@ -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 diff --git a/src/Codec/Archive/Monad.hs b/src/Codec/Archive/Monad.hs deleted file mode 100644 --- a/src/Codec/Archive/Monad.hs +++ /dev/null @@ -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) diff --git a/src/Codec/Archive/Pack.hs b/src/Codec/Archive/Pack.hs deleted file mode 100644 --- a/src/Codec/Archive/Pack.hs +++ /dev/null @@ -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 diff --git a/src/Codec/Archive/Pack/Common.hs b/src/Codec/Archive/Pack/Common.hs deleted file mode 100644 --- a/src/Codec/Archive/Pack/Common.hs +++ /dev/null @@ -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 - diff --git a/src/Codec/Archive/Pack/Lazy.hs b/src/Codec/Archive/Pack/Lazy.hs deleted file mode 100644 --- a/src/Codec/Archive/Pack/Lazy.hs +++ /dev/null @@ -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) diff --git a/src/Codec/Archive/Unpack.hs b/src/Codec/Archive/Unpack.hs deleted file mode 100644 --- a/src/Codec/Archive/Unpack.hs +++ /dev/null @@ -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 diff --git a/src/Codec/Archive/Unpack/Lazy.hs b/src/Codec/Archive/Unpack/Lazy.hs deleted file mode 100644 --- a/src/Codec/Archive/Unpack/Lazy.hs +++ /dev/null @@ -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 diff --git a/test/Spec.cpphs b/test/Spec.cpphs --- a/test/Spec.cpphs +++ b/test/Spec.cpphs @@ -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