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.Composition ((.**))
import Control.Monad (void, (<=<))
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.C.Types
import Foreign.Marshal.Alloc (free, mallocBytes, reallocBytes)
import Foreign.Ptr
import Foreign.Storable (poke)
import System.IO.Unsafe (unsafeDupablePerformIO)
foreign import ccall memcpy :: Ptr a
-> Ptr b
-> CSize
-> IO (Ptr a)
hmemcpy :: Ptr a -> Ptr b -> CSize -> IO ()
hmemcpy = void .** memcpy
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)
bsChunksRef <- liftIO $ newIORef bsChunks
bufSzRef <- liftIO $ newIORef (32 * 1024)
rc <- liftIO $ mkReadCallback (readBSL bsChunksRef bufSzRef bufPtr)
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 bufPtr)
where readBSL bsRef bufSzRef bufPtr _ _ dataPtr = do
bs' <- readIORef bsRef
case bs' of
[] -> pure 0
(x:_) -> do
modifyIORef bsRef tail
useAsCStringLen x $ \(charPtr, sz) -> do
bufSz <- readIORef bufSzRef
bufPtr' <- if sz > bufSz
then writeIORef bufSzRef sz *> reallocBytes bufPtr sz
else pure bufPtr
hmemcpy bufPtr' charPtr (fromIntegral sz)
poke dataPtr bufPtr' $> fromIntegral sz
bsChunks = BSL.toChunks bs