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 :: FilePath -> ByteString -> ArchiveM ()
unpackToDirLazy FilePath
fp ByteString
bs = do
    ArchivePtr
a <- ByteString -> ArchiveM ArchivePtr
bslToArchive ByteString
bs
    ArchivePtr -> FilePath -> ArchiveM ()
unpackEntriesFp ArchivePtr
a FilePath
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 :: ByteString -> Either ArchiveResult [Entry FilePath ByteString]
readArchiveBSL = (ArchivePtr -> Int -> IO ByteString)
-> ByteString -> Either ArchiveResult [Entry FilePath ByteString]
forall a e.
Integral a =>
(ArchivePtr -> a -> IO e)
-> ByteString -> Either ArchiveResult [Entry FilePath e]
readArchiveBSLAbs ArchivePtr -> Int -> IO ByteString
readBS

readArchiveBSLAbs :: Integral a
                  => (ArchivePtr -> a -> IO e)
                  -> BSL.ByteString
                  -> Either ArchiveResult [Entry FilePath e]
readArchiveBSLAbs :: (ArchivePtr -> a -> IO e)
-> ByteString -> Either ArchiveResult [Entry FilePath e]
readArchiveBSLAbs ArchivePtr -> a -> IO e
read' = IO (Either ArchiveResult [Entry FilePath e])
-> Either ArchiveResult [Entry FilePath e]
forall a. IO a -> a
unsafeDupablePerformIO (IO (Either ArchiveResult [Entry FilePath e])
 -> Either ArchiveResult [Entry FilePath e])
-> (ByteString -> IO (Either ArchiveResult [Entry FilePath e]))
-> ByteString
-> Either ArchiveResult [Entry FilePath e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM [Entry FilePath e]
-> IO (Either ArchiveResult [Entry FilePath e])
forall a. ArchiveM a -> IO (Either ArchiveResult a)
runArchiveM (ArchiveM [Entry FilePath e]
 -> IO (Either ArchiveResult [Entry FilePath e]))
-> (ByteString -> ArchiveM [Entry FilePath e])
-> ByteString
-> IO (Either ArchiveResult [Entry FilePath e])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ArchivePtr -> a -> IO e)
-> ArchivePtr -> ArchiveM [Entry FilePath e]
forall a e.
Integral a =>
(ArchivePtr -> a -> IO e)
-> ArchivePtr -> ArchiveM [Entry FilePath e]
hsEntriesAbs ArchivePtr -> a -> IO e
read' (ArchivePtr -> ArchiveM [Entry FilePath e])
-> (ByteString -> ArchiveM ArchivePtr)
-> ByteString
-> ArchiveM [Entry FilePath e]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> ArchiveM ArchivePtr
bslToArchive)
{-# NOINLINE readArchiveBSLAbs #-}

-- | Lazily stream a 'BSL.ByteString'
bslToArchive :: BSL.ByteString
             -> ArchiveM ArchivePtr
bslToArchive :: ByteString -> ArchiveM ArchivePtr
bslToArchive ByteString
bs = do
    Ptr Archive
preA <- IO (Ptr Archive) -> ExceptT ArchiveResult IO (Ptr Archive)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Ptr Archive)
archiveReadNew
    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)
    ArchivePtr
a <- IO ArchivePtr -> ArchiveM ArchivePtr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ArchivePtr -> ArchiveM ArchivePtr)
-> IO ArchivePtr -> ArchiveM ArchivePtr
forall a b. (a -> b) -> a -> b
$ ForeignPtr Any -> ArchivePtr
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr (ForeignPtr Any -> ArchivePtr)
-> IO (ForeignPtr Any) -> IO ArchivePtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Any -> IO () -> IO (ForeignPtr Any)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
newForeignPtr (Ptr Archive -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr Archive
preA) (Ptr Archive -> IO CInt
archiveFree Ptr Archive
preA IO CInt -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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))
    IO ArchiveResult -> ArchiveM ()
ignore (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ ArchivePtr -> IO ArchiveResult
archiveReadSupportFormatAll ArchivePtr
a
    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 [ ArchivePtr
-> FunPtr (ArchiveReadCallback Any Any) -> IO ArchiveResult
forall a b.
ArchivePtr -> FunPtr (ArchiveReadCallback a b) -> IO ArchiveResult
archiveReadSetReadCallback ArchivePtr
a FunPtr (ArchiveReadCallback Any Any)
rc
           , ArchivePtr
-> FunPtr (ArchiveCloseCallbackRaw Any) -> IO ArchiveResult
forall a.
ArchivePtr
-> FunPtr (ArchiveCloseCallbackRaw a) -> IO ArchiveResult
archiveReadSetCloseCallback ArchivePtr
a FunPtr (ArchiveCloseCallbackRaw Any)
cc
           , ArchivePtr -> Ptr Any -> IO ArchiveResult
forall a. ArchivePtr -> Ptr a -> IO ArchiveResult
archiveReadSetCallbackData ArchivePtr
a Ptr Any
nothingPtr
           , ArchivePtr -> IO ArchiveResult
archiveReadOpen1 ArchivePtr
a
           ]
    ArchivePtr -> ArchiveM ArchivePtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArchivePtr
a

    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