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.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.Marshal.Alloc  (free, mallocBytes, reallocBytes)
import           Foreign.Ptr
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 :: FilePath -> ByteString -> ArchiveM ()
unpackToDirLazy FilePath
fp ByteString
bs = do
    (Ptr Archive
a, IO ()
act) <- ByteString -> ArchiveM (Ptr Archive, IO ())
bslToArchive ByteString
bs
    Ptr Archive -> FilePath -> ArchiveM ()
unpackEntriesFp Ptr Archive
a FilePath
fp
    IO ArchiveResult -> ArchiveM ()
ignore (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ Ptr Archive -> IO ArchiveResult
archiveFree Ptr Archive
a
    IO () -> ArchiveM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
act

-- | 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]
readArchiveBSL :: ByteString -> Either ArchiveResult [Entry]
readArchiveBSL = IO (Either ArchiveResult [Entry]) -> Either ArchiveResult [Entry]
forall a. IO a -> a
unsafeDupablePerformIO (IO (Either ArchiveResult [Entry]) -> Either ArchiveResult [Entry])
-> (ByteString -> IO (Either ArchiveResult [Entry]))
-> ByteString
-> Either ArchiveResult [Entry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM [Entry] -> IO (Either ArchiveResult [Entry])
forall a. ArchiveM a -> IO (Either ArchiveResult a)
runArchiveM (ArchiveM [Entry] -> IO (Either ArchiveResult [Entry]))
-> (ByteString -> ArchiveM [Entry])
-> ByteString
-> IO (Either ArchiveResult [Entry])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Ptr Archive -> ArchiveM [Entry])
-> (Ptr Archive, IO ()) -> ArchiveM [Entry]
forall (m :: * -> *) a.
MonadIO m =>
(Ptr Archive -> m a) -> (Ptr Archive, IO ()) -> m a
actFreeCallback Ptr Archive -> ArchiveM [Entry]
hsEntries ((Ptr Archive, IO ()) -> ArchiveM [Entry])
-> (ByteString -> ArchiveM (Ptr Archive, IO ()))
-> ByteString
-> ArchiveM [Entry]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> ArchiveM (Ptr Archive, IO ())
bslToArchive)
{-# NOINLINE readArchiveBSL #-}

-- | Lazily stream a 'BSL.ByteString'
bslToArchive :: BSL.ByteString
             -> ArchiveM (Ptr Archive, IO ()) -- ^ Returns an 'IO' action to be used to clean up after we're done with the archive
bslToArchive :: ByteString -> ArchiveM (Ptr Archive, IO ())
bslToArchive ByteString
bs = do
    Ptr Archive
a <- IO (Ptr Archive) -> ExceptT ArchiveResult IO (Ptr Archive)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Ptr Archive)
archiveReadNew
    IO ArchiveResult -> ArchiveM ()
ignore (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ Ptr Archive -> IO ArchiveResult
archiveReadSupportFormatAll Ptr Archive
a
    Ptr Any
bufPtr <- IO (Ptr Any) -> ExceptT ArchiveResult IO (Ptr Any)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Any) -> ExceptT ArchiveResult IO (Ptr Any))
-> IO (Ptr Any) -> ExceptT ArchiveResult IO (Ptr Any)
forall a b. (a -> b) -> a -> b
$ Int -> IO (Ptr Any)
forall a. Int -> IO (Ptr a)
mallocBytes (Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024) -- default to 32k byte chunks
    IORef (Ptr Any)
bufPtrRef <- IO (IORef (Ptr Any)) -> ExceptT ArchiveResult IO (IORef (Ptr Any))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Ptr Any))
 -> ExceptT ArchiveResult IO (IORef (Ptr Any)))
-> IO (IORef (Ptr Any))
-> ExceptT ArchiveResult IO (IORef (Ptr Any))
forall a b. (a -> b) -> a -> b
$ Ptr Any -> IO (IORef (Ptr Any))
forall a. a -> IO (IORef a)
newIORef Ptr Any
bufPtr
    IORef [ByteString]
bsChunksRef <- IO (IORef [ByteString])
-> ExceptT ArchiveResult IO (IORef [ByteString])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [ByteString])
 -> ExceptT ArchiveResult IO (IORef [ByteString]))
-> IO (IORef [ByteString])
-> ExceptT ArchiveResult IO (IORef [ByteString])
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef [ByteString]
bsChunks
    IORef Int
bufSzRef <- IO (IORef Int) -> ExceptT ArchiveResult IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> ExceptT ArchiveResult IO (IORef Int))
-> IO (IORef Int) -> ExceptT ArchiveResult IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024)
    FunPtr (ArchiveReadCallback Any Any)
rc <- IO (FunPtr (ArchiveReadCallback Any Any))
-> ExceptT ArchiveResult IO (FunPtr (ArchiveReadCallback Any Any))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr (ArchiveReadCallback Any Any))
 -> ExceptT ArchiveResult IO (FunPtr (ArchiveReadCallback Any Any)))
-> IO (FunPtr (ArchiveReadCallback Any Any))
-> ExceptT ArchiveResult IO (FunPtr (ArchiveReadCallback Any Any))
forall a b. (a -> b) -> a -> b
$ ArchiveReadCallback Any Any
-> IO (FunPtr (ArchiveReadCallback Any Any))
forall a b.
ArchiveReadCallback a b -> IO (FunPtr (ArchiveReadCallback a b))
mkReadCallback (IORef [ByteString]
-> IORef Int -> IORef (Ptr Any) -> ArchiveReadCallback Any Any
forall b a p p.
Num b =>
IORef [ByteString]
-> IORef Int -> IORef (Ptr a) -> p -> p -> Ptr (Ptr a) -> IO b
readBSL IORef [ByteString]
bsChunksRef IORef Int
bufSzRef IORef (Ptr Any)
bufPtrRef)
    FunPtr (ArchiveCloseCallbackRaw Any)
cc <- IO (FunPtr (ArchiveCloseCallbackRaw Any))
-> ExceptT ArchiveResult IO (FunPtr (ArchiveCloseCallbackRaw Any))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr (ArchiveCloseCallbackRaw Any))
 -> ExceptT ArchiveResult IO (FunPtr (ArchiveCloseCallbackRaw Any)))
-> IO (FunPtr (ArchiveCloseCallbackRaw Any))
-> ExceptT ArchiveResult IO (FunPtr (ArchiveCloseCallbackRaw Any))
forall a b. (a -> b) -> a -> b
$ ArchiveCloseCallback Any
-> IO (FunPtr (ArchiveCloseCallbackRaw Any))
forall a.
ArchiveCloseCallback a -> IO (FunPtr (ArchiveCloseCallbackRaw a))
mkCloseCallback (\Ptr Archive
_ Ptr Any
ptr -> FunPtr (ArchiveReadCallback Any Any) -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr (ArchiveReadCallback Any Any)
rc IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Ptr Any -> IO ()
forall a. Ptr a -> IO ()
free Ptr Any
ptr IO () -> ArchiveResult -> IO ArchiveResult
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ArchiveResult
ArchiveOk)
    Ptr Any
nothingPtr <- IO (Ptr Any) -> ExceptT ArchiveResult IO (Ptr Any)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Any) -> ExceptT ArchiveResult IO (Ptr Any))
-> IO (Ptr Any) -> ExceptT ArchiveResult IO (Ptr Any)
forall a b. (a -> b) -> a -> b
$ Int -> IO (Ptr Any)
forall a. Int -> IO (Ptr a)
mallocBytes Int
0
    let seqErr :: [IO ArchiveResult] -> ArchiveM ()
seqErr = (IO ArchiveResult -> ArchiveM ())
-> [IO ArchiveResult] -> ArchiveM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ IO ArchiveResult -> ArchiveM ()
handle
    [IO ArchiveResult] -> ArchiveM ()
seqErr [ Ptr Archive
-> FunPtr (ArchiveReadCallback Any Any) -> IO ArchiveResult
forall a b.
Ptr Archive -> FunPtr (ArchiveReadCallback a b) -> IO ArchiveResult
archiveReadSetReadCallback Ptr Archive
a FunPtr (ArchiveReadCallback Any Any)
rc
           , Ptr Archive
-> FunPtr (ArchiveCloseCallbackRaw Any) -> IO ArchiveResult
forall a.
Ptr Archive
-> FunPtr (ArchiveCloseCallbackRaw a) -> IO ArchiveResult
archiveReadSetCloseCallback Ptr Archive
a FunPtr (ArchiveCloseCallbackRaw Any)
cc
           , ArchiveCloseCallback Any
forall a. Ptr Archive -> Ptr a -> IO ArchiveResult
archiveReadSetCallbackData Ptr Archive
a Ptr Any
nothingPtr
           , Ptr Archive -> IO ArchiveResult
archiveReadOpen1 Ptr Archive
a
           ]
    (Ptr Archive, IO ()) -> ArchiveM (Ptr Archive, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Archive
a, FunPtr (ArchiveCloseCallbackRaw Any) -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr (ArchiveCloseCallbackRaw Any)
cc IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Ptr Any -> IO ()
forall a. Ptr a -> IO ()
free (Ptr Any -> IO ()) -> IO (Ptr Any) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Ptr Any) -> IO (Ptr Any)
forall a. IORef a -> IO a
readIORef IORef (Ptr Any)
bufPtrRef))

    where readBSL :: IORef [ByteString]
-> IORef Int -> IORef (Ptr a) -> p -> p -> Ptr (Ptr a) -> IO b
readBSL IORef [ByteString]
bsRef IORef Int
bufSzRef IORef (Ptr a)
bufPtrRef p
_ p
_ Ptr (Ptr a)
dataPtr = do
                [ByteString]
bs' <- IORef [ByteString] -> IO [ByteString]
forall a. IORef a -> IO a
readIORef IORef [ByteString]
bsRef
                case [ByteString]
bs' of
                    [] -> b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
0
                    (ByteString
x:[ByteString]
_) -> do
                        IORef [ByteString] -> ([ByteString] -> [ByteString]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [ByteString]
bsRef [ByteString] -> [ByteString]
forall a. [a] -> [a]
tail
                        ByteString -> (CStringLen -> IO b) -> IO b
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
x ((CStringLen -> IO b) -> IO b) -> (CStringLen -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
charPtr, Int
sz) -> do
                            Int
bufSz <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
bufSzRef
                            Ptr a
bufPtr <- IORef (Ptr a) -> IO (Ptr a)
forall a. IORef a -> IO a
readIORef IORef (Ptr a)
bufPtrRef
                            Ptr a
bufPtr' <- if Int
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
bufSz
                                then do
                                    IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
bufSzRef Int
sz
                                    Ptr a
newBufPtr <- Ptr a -> Int -> IO (Ptr a)
forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes Ptr a
bufPtr Int
sz
                                    IORef (Ptr a) -> Ptr a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Ptr a)
bufPtrRef Ptr a
newBufPtr
                                    Ptr a -> IO (Ptr a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr a
newBufPtr
                                else IORef (Ptr a) -> IO (Ptr a)
forall a. IORef a -> IO a
readIORef IORef (Ptr a)
bufPtrRef
                            Ptr a -> Ptr CChar -> CSize -> IO ()
forall a b. Ptr a -> Ptr b -> CSize -> IO ()
hmemcpy Ptr a
bufPtr' Ptr CChar
charPtr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz)
                            Ptr (Ptr a) -> Ptr a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr a)
dataPtr Ptr a
bufPtr' IO () -> b -> IO b
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz
          bsChunks :: [ByteString]
bsChunks = ByteString -> [ByteString]
BSL.toChunks ByteString
bs