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 Data.ByteString (useAsCStringLen)
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable (traverse_)
import Data.Functor (($>))
import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef)
import Foreign.Marshal.Alloc (free, mallocBytes, reallocBytes)
import Foreign.Ptr
import Foreign.Storable (poke)
import System.IO.Unsafe (unsafeDupablePerformIO)
unpackToDirLazy :: FilePath
-> BSL.ByteString
-> ArchiveM ()
unpackToDirLazy fp bs = do
(a, act) <- bslToArchive bs
unpackEntriesFp a fp
ignore $ archiveFree a
liftIO act
readArchiveBSL :: BSL.ByteString -> Either ArchiveResult [Entry]
readArchiveBSL = unsafeDupablePerformIO . runArchiveM . (actFreeCallback hsEntries <=< bslToArchive)
{-# NOINLINE readArchiveBSL #-}
bslToArchive :: BSL.ByteString
-> ArchiveM (Ptr Archive, IO ())
bslToArchive bs = do
a <- liftIO archiveReadNew
ignore $ archiveReadSupportFormatAll a
bufPtr <- liftIO $ mallocBytes (32 * 1024)
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)
nothingPtr <- liftIO $ mallocBytes 0
let seqErr = traverse_ handle
seqErr [ archiveReadSetReadCallback a rc
, archiveReadSetCloseCallback a cc
, archiveReadSetCallbackData a nothingPtr
, archiveReadOpen1 a
]
pure (a, freeHaskellFunPtr cc *> (free =<< readIORef bufPtrRef))
where readBSL bsRef bufSzRef bufPtrRef _ _ dataPtr = do
bs' <- readIORef bsRef
case bs' of
[] -> pure 0
(x:_) -> do
modifyIORef bsRef tail
useAsCStringLen 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