module Codec.Archive.Internal.Unpack.Lazy ( readArchiveBSL
                                          , readArchiveBSLAbs
                                          , unpackToDirLazy
                                          , bslToArchive
                                          , bslToArchiveAbs
                                          ) 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 :: 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) -- ^ Action to read contents from an archive entry
                  -> 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 = (ArchivePtr -> IO ArchiveResult)
-> ByteString -> ArchiveM ArchivePtr
bslToArchiveAbs ArchivePtr -> IO ArchiveResult
archiveReadSupportFormatAll

{-# INLINE bslToArchiveAbs #-}
bslToArchiveAbs :: (ArchivePtr -> IO ArchiveResult) -- ^ Action to set supported formats
                -> BSL.ByteString
                -> ArchiveM ArchivePtr
bslToArchiveAbs :: (ArchivePtr -> IO ArchiveResult)
-> ByteString -> ArchiveM ArchivePtr
bslToArchiveAbs ArchivePtr -> IO ArchiveResult
support 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 CChar
bufPtr <- IO (Ptr CChar) -> ExceptT ArchiveResult IO (Ptr CChar)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr CChar) -> ExceptT ArchiveResult IO (Ptr CChar))
-> IO (Ptr CChar) -> ExceptT ArchiveResult IO (Ptr CChar)
forall a b. (a -> b) -> a -> b
$ Int -> IO (Ptr CChar)
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 CChar)
bufPtrRef <- IO (IORef (Ptr CChar))
-> ExceptT ArchiveResult IO (IORef (Ptr CChar))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Ptr CChar))
 -> ExceptT ArchiveResult IO (IORef (Ptr CChar)))
-> IO (IORef (Ptr CChar))
-> ExceptT ArchiveResult IO (IORef (Ptr CChar))
forall a b. (a -> b) -> a -> b
$ Ptr CChar -> IO (IORef (Ptr CChar))
forall a. a -> IO (IORef a)
newIORef Ptr CChar
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 CChar)
rc <- IO (FunPtr (ArchiveReadCallback Any CChar))
-> ExceptT
     ArchiveResult IO (FunPtr (ArchiveReadCallback Any CChar))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr (ArchiveReadCallback Any CChar))
 -> ExceptT
      ArchiveResult IO (FunPtr (ArchiveReadCallback Any CChar)))
-> IO (FunPtr (ArchiveReadCallback Any CChar))
-> ExceptT
     ArchiveResult IO (FunPtr (ArchiveReadCallback Any CChar))
forall a b. (a -> b) -> a -> b
$ ArchiveReadCallback Any CChar
-> IO (FunPtr (ArchiveReadCallback Any CChar))
forall a b.
ArchiveReadCallback a b -> IO (FunPtr (ArchiveReadCallback a b))
mkReadCallback (IORef [ByteString]
-> IORef Int -> IORef (Ptr CChar) -> ArchiveReadCallback Any CChar
forall b p p.
Num b =>
IORef [ByteString]
-> IORef Int
-> IORef (Ptr CChar)
-> p
-> p
-> Ptr (Ptr CChar)
-> IO b
readBSL' IORef [ByteString]
bsChunksRef IORef Int
bufSzRef IORef (Ptr CChar)
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 CChar) -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr (ArchiveReadCallback Any CChar)
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 CChar -> IO ()
forall a. Ptr a -> IO ()
free (Ptr CChar -> IO ()) -> IO (Ptr CChar) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Ptr CChar) -> IO (Ptr CChar)
forall a. IORef a -> IO a
readIORef IORef (Ptr CChar)
bufPtrRef))
    IO ArchiveResult -> ArchiveM ()
ignore (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ ArchivePtr -> IO ArchiveResult
support 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 CChar) -> IO ArchiveResult
forall a b.
ArchivePtr -> FunPtr (ArchiveReadCallback a b) -> IO ArchiveResult
archiveReadSetReadCallback ArchivePtr
a FunPtr (ArchiveReadCallback Any CChar)
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 CChar)
-> p
-> p
-> Ptr (Ptr CChar)
-> IO b
readBSL' IORef [ByteString]
bsRef IORef Int
bufSzRef IORef (Ptr CChar)
bufPtrRef p
_ p
_ Ptr (Ptr CChar)
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 CChar
bufPtr <- IORef (Ptr CChar) -> IO (Ptr CChar)
forall a. IORef a -> IO a
readIORef IORef (Ptr CChar)
bufPtrRef
                            Ptr CChar
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 CChar
newBufPtr <- Ptr CChar -> Int -> IO (Ptr CChar)
forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes Ptr CChar
bufPtr Int
sz
                                    IORef (Ptr CChar) -> Ptr CChar -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Ptr CChar)
bufPtrRef Ptr CChar
newBufPtr
                                    Ptr CChar -> IO (Ptr CChar)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr CChar
newBufPtr
                                else IORef (Ptr CChar) -> IO (Ptr CChar)
forall a. IORef a -> IO a
readIORef IORef (Ptr CChar)
bufPtrRef
                            Ptr CChar -> Ptr CChar -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr CChar
bufPtr' Ptr CChar
charPtr Int
sz
                            Ptr (Ptr CChar) -> Ptr CChar -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr CChar)
dataPtr Ptr CChar
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