module Codec.Archive.Pack.Lazy ( entriesToBSL
                               , entriesToBSL7zip
                               , entriesToBSLzip
                               , entriesToBSLCpio
                               , entriesToBSLXar
                               , packFiles
                               , packFilesZip
                               , packFiles7zip
                               , packFilesCpio
                               , packFilesXar
                               ) where

import           Codec.Archive.Foreign
import           Codec.Archive.Monad
import           Codec.Archive.Pack
import           Codec.Archive.Pack.Common
import           Codec.Archive.Types
import           Control.Composition       ((.@))
import           Control.Monad.IO.Class    (liftIO)
import           Data.ByteString           (packCStringLen)
import qualified Data.ByteString.Lazy      as BSL
import qualified Data.DList                as DL
import           Data.Foldable             (toList)
import           Data.Functor              (($>))
import           Data.IORef                (modifyIORef', newIORef, readIORef)
import           Foreign.Marshal.Alloc     (free, mallocBytes)
import           Foreign.Ptr
import           System.IO.Unsafe          (unsafeDupablePerformIO)

packer :: (Traversable t) => (t Entry -> BSL.ByteString) -> t FilePath -> IO BSL.ByteString
packer :: (t Entry -> ByteString) -> t FilePath -> IO ByteString
packer = (FilePath -> IO Entry) -> t FilePath -> IO (t Entry)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> IO Entry
mkEntry (t FilePath -> IO (t Entry))
-> ((t Entry -> ByteString) -> IO (t Entry) -> IO ByteString)
-> (t Entry -> ByteString)
-> t FilePath
-> IO ByteString
forall b c a d. (b -> c) -> (a -> c -> d) -> a -> b -> d
.@ (t Entry -> ByteString) -> IO (t Entry) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

-- | Pack files into a tar archive
--
-- @since 2.0.0.0
packFiles :: Traversable t
          => t FilePath -- ^ Filepaths relative to the current directory
          -> IO BSL.ByteString
packFiles :: t FilePath -> IO ByteString
packFiles = (t Entry -> ByteString) -> t FilePath -> IO ByteString
forall (t :: * -> *).
Traversable t =>
(t Entry -> ByteString) -> t FilePath -> IO ByteString
packer t Entry -> ByteString
forall (t :: * -> *). Foldable t => t Entry -> ByteString
entriesToBSL

-- | @since 2.0.0.0
packFilesZip :: Traversable t => t FilePath -> IO BSL.ByteString
packFilesZip :: t FilePath -> IO ByteString
packFilesZip = (t Entry -> ByteString) -> t FilePath -> IO ByteString
forall (t :: * -> *).
Traversable t =>
(t Entry -> ByteString) -> t FilePath -> IO ByteString
packer t Entry -> ByteString
forall (t :: * -> *). Foldable t => t Entry -> ByteString
entriesToBSLzip

-- | @since 2.0.0.0
packFiles7zip :: Traversable t => t FilePath -> IO BSL.ByteString
packFiles7zip :: t FilePath -> IO ByteString
packFiles7zip = (t Entry -> ByteString) -> t FilePath -> IO ByteString
forall (t :: * -> *).
Traversable t =>
(t Entry -> ByteString) -> t FilePath -> IO ByteString
packer t Entry -> ByteString
forall (t :: * -> *). Foldable t => t Entry -> ByteString
entriesToBSL7zip

-- | @since 2.2.3.0
packFilesCpio :: Traversable t => t FilePath -> IO BSL.ByteString
packFilesCpio :: t FilePath -> IO ByteString
packFilesCpio = (t Entry -> ByteString) -> t FilePath -> IO ByteString
forall (t :: * -> *).
Traversable t =>
(t Entry -> ByteString) -> t FilePath -> IO ByteString
packer t Entry -> ByteString
forall (t :: * -> *). Foldable t => t Entry -> ByteString
entriesToBSLCpio

-- | @since 2.2.4.0
packFilesXar :: Traversable t => t FilePath -> IO BSL.ByteString
packFilesXar :: t FilePath -> IO ByteString
packFilesXar = (t Entry -> ByteString) -> t FilePath -> IO ByteString
forall (t :: * -> *).
Traversable t =>
(t Entry -> ByteString) -> t FilePath -> IO ByteString
packer t Entry -> ByteString
forall (t :: * -> *). Foldable t => t Entry -> ByteString
entriesToBSLXar

-- | @since 1.0.5.0
entriesToBSLzip :: Foldable t => t Entry -> BSL.ByteString
entriesToBSLzip :: t Entry -> ByteString
entriesToBSLzip = IO ByteString -> ByteString
forall a. IO a -> a
unsafeDupablePerformIO (IO ByteString -> ByteString)
-> (t Entry -> IO ByteString) -> t Entry -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM ByteString -> IO ByteString
forall a. ArchiveM a -> IO a
noFail (ArchiveM ByteString -> IO ByteString)
-> (t Entry -> ArchiveM ByteString) -> t Entry -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
forall (t :: * -> *).
Foldable t =>
(Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
entriesToBSLGeneral Ptr Archive -> IO ArchiveResult
archiveWriteSetFormatZip
{-# NOINLINE entriesToBSLzip #-}

-- | @since 1.0.5.0
entriesToBSL7zip :: Foldable t => t Entry -> BSL.ByteString
entriesToBSL7zip :: t Entry -> ByteString
entriesToBSL7zip = IO ByteString -> ByteString
forall a. IO a -> a
unsafeDupablePerformIO (IO ByteString -> ByteString)
-> (t Entry -> IO ByteString) -> t Entry -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM ByteString -> IO ByteString
forall a. ArchiveM a -> IO a
noFail (ArchiveM ByteString -> IO ByteString)
-> (t Entry -> ArchiveM ByteString) -> t Entry -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
forall (t :: * -> *).
Foldable t =>
(Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
entriesToBSLGeneral Ptr Archive -> IO ArchiveResult
archiveWriteSetFormat7zip
{-# NOINLINE entriesToBSL7zip #-}

-- | @since 2.2.3.0
entriesToBSLCpio :: Foldable t => t Entry -> BSL.ByteString
entriesToBSLCpio :: t Entry -> ByteString
entriesToBSLCpio = IO ByteString -> ByteString
forall a. IO a -> a
unsafeDupablePerformIO (IO ByteString -> ByteString)
-> (t Entry -> IO ByteString) -> t Entry -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM ByteString -> IO ByteString
forall a. ArchiveM a -> IO a
noFail (ArchiveM ByteString -> IO ByteString)
-> (t Entry -> ArchiveM ByteString) -> t Entry -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
forall (t :: * -> *).
Foldable t =>
(Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
entriesToBSLGeneral Ptr Archive -> IO ArchiveResult
archiveWriteSetFormatCpio
{-# NOINLINE entriesToBSLCpio #-}

-- | @since 2.2.4.0
entriesToBSLXar :: Foldable t => t Entry -> BSL.ByteString
entriesToBSLXar :: t Entry -> ByteString
entriesToBSLXar = IO ByteString -> ByteString
forall a. IO a -> a
unsafeDupablePerformIO (IO ByteString -> ByteString)
-> (t Entry -> IO ByteString) -> t Entry -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM ByteString -> IO ByteString
forall a. ArchiveM a -> IO a
noFail (ArchiveM ByteString -> IO ByteString)
-> (t Entry -> ArchiveM ByteString) -> t Entry -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
forall (t :: * -> *).
Foldable t =>
(Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
entriesToBSLGeneral Ptr Archive -> IO ArchiveResult
archiveWriteSetFormatXar
{-# NOINLINE entriesToBSLXar #-}

-- | In general, this will be more efficient than 'entriesToBS'
--
-- @since 1.0.5.0
entriesToBSL :: Foldable t => t Entry -> BSL.ByteString
entriesToBSL :: t Entry -> ByteString
entriesToBSL = IO ByteString -> ByteString
forall a. IO a -> a
unsafeDupablePerformIO (IO ByteString -> ByteString)
-> (t Entry -> IO ByteString) -> t Entry -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM ByteString -> IO ByteString
forall a. ArchiveM a -> IO a
noFail (ArchiveM ByteString -> IO ByteString)
-> (t Entry -> ArchiveM ByteString) -> t Entry -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
forall (t :: * -> *).
Foldable t =>
(Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
entriesToBSLGeneral Ptr Archive -> IO ArchiveResult
archiveWriteSetFormatPaxRestricted
{-# NOINLINE entriesToBSL #-}

entriesToBSLGeneral :: Foldable t => (Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM BSL.ByteString
entriesToBSLGeneral :: (Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM ByteString
entriesToBSLGeneral Ptr Archive -> IO ArchiveResult
modifier t Entry
hsEntries' = 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)
archiveWriteNew
    IORef (DList ByteString)
bsRef <- IO (IORef (DList ByteString))
-> ExceptT ArchiveResult IO (IORef (DList ByteString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (DList ByteString))
 -> ExceptT ArchiveResult IO (IORef (DList ByteString)))
-> IO (IORef (DList ByteString))
-> ExceptT ArchiveResult IO (IORef (DList ByteString))
forall a b. (a -> b) -> a -> b
$ DList ByteString -> IO (IORef (DList ByteString))
forall a. a -> IO (IORef a)
newIORef DList ByteString
forall a. Monoid a => a
mempty
    FunPtr (ArchiveOpenCallbackRaw Any)
oc <- IO (FunPtr (ArchiveOpenCallbackRaw Any))
-> ExceptT ArchiveResult IO (FunPtr (ArchiveOpenCallbackRaw Any))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr (ArchiveOpenCallbackRaw Any))
 -> ExceptT ArchiveResult IO (FunPtr (ArchiveOpenCallbackRaw Any)))
-> IO (FunPtr (ArchiveOpenCallbackRaw Any))
-> ExceptT ArchiveResult IO (FunPtr (ArchiveOpenCallbackRaw Any))
forall a b. (a -> b) -> a -> b
$ ArchiveOpenCallback Any -> IO (FunPtr (ArchiveOpenCallbackRaw Any))
forall a.
ArchiveOpenCallback a -> IO (FunPtr (ArchiveOpenCallbackRaw a))
mkOpenCallback ArchiveOpenCallback Any
forall (f :: * -> *) p p.
Applicative f =>
p -> p -> f ArchiveResult
doNothing
    FunPtr (ArchiveWriteCallback Any CChar)
wc <- IO (FunPtr (ArchiveWriteCallback Any CChar))
-> ExceptT
     ArchiveResult IO (FunPtr (ArchiveWriteCallback Any CChar))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr (ArchiveWriteCallback Any CChar))
 -> ExceptT
      ArchiveResult IO (FunPtr (ArchiveWriteCallback Any CChar)))
-> IO (FunPtr (ArchiveWriteCallback Any CChar))
-> ExceptT
     ArchiveResult IO (FunPtr (ArchiveWriteCallback Any CChar))
forall a b. (a -> b) -> a -> b
$ ArchiveWriteCallback Any CChar
-> IO (FunPtr (ArchiveWriteCallback Any CChar))
forall a b.
ArchiveWriteCallback a b -> IO (FunPtr (ArchiveWriteCallback a b))
mkWriteCallback (IORef (DList ByteString) -> ArchiveWriteCallback Any CChar
forall b a p p.
(Integral b, Integral a) =>
IORef (DList ByteString) -> p -> p -> Ptr CChar -> a -> IO b
writeBSL IORef (DList ByteString)
bsRef)
    FunPtr (ArchiveOpenCallbackRaw Any)
cc <- IO (FunPtr (ArchiveOpenCallbackRaw Any))
-> ExceptT ArchiveResult IO (FunPtr (ArchiveOpenCallbackRaw Any))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FunPtr (ArchiveOpenCallbackRaw Any))
 -> ExceptT ArchiveResult IO (FunPtr (ArchiveOpenCallbackRaw Any)))
-> IO (FunPtr (ArchiveOpenCallbackRaw Any))
-> ExceptT ArchiveResult IO (FunPtr (ArchiveOpenCallbackRaw Any))
forall a b. (a -> b) -> a -> b
$ ArchiveOpenCallback Any -> IO (FunPtr (ArchiveOpenCallbackRaw Any))
forall a.
ArchiveOpenCallback a -> IO (FunPtr (ArchiveOpenCallbackRaw a))
mkCloseCallback (\Ptr Archive
_ Ptr Any
ptr -> FunPtr (ArchiveOpenCallbackRaw Any) -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr (ArchiveOpenCallbackRaw Any)
oc IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> FunPtr (ArchiveWriteCallback Any CChar) -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr (ArchiveWriteCallback Any CChar)
wc 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
    IO ArchiveResult -> ArchiveM ()
ignore (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ Ptr Archive -> IO ArchiveResult
modifier Ptr Archive
a
    IO ArchiveResult -> ArchiveM ()
handle (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ Ptr Archive
-> Ptr Any
-> FunPtr (ArchiveOpenCallbackRaw Any)
-> FunPtr (ArchiveWriteCallback Any CChar)
-> FunPtr (ArchiveOpenCallbackRaw Any)
-> IO ArchiveResult
forall a b.
Ptr Archive
-> Ptr a
-> FunPtr (ArchiveOpenCallbackRaw a)
-> FunPtr (ArchiveWriteCallback a b)
-> FunPtr (ArchiveOpenCallbackRaw a)
-> IO ArchiveResult
archiveWriteOpen Ptr Archive
a Ptr Any
nothingPtr FunPtr (ArchiveOpenCallbackRaw Any)
oc FunPtr (ArchiveWriteCallback Any CChar)
wc FunPtr (ArchiveOpenCallbackRaw Any)
cc
    Ptr Archive -> t Entry -> ArchiveM ()
forall (t :: * -> *).
Foldable t =>
Ptr Archive -> t Entry -> ArchiveM ()
packEntries Ptr Archive
a t Entry
hsEntries'
    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
    [ByteString] -> ByteString
BSL.fromChunks ([ByteString] -> ByteString)
-> (DList ByteString -> [ByteString])
-> DList ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList ByteString -> [ByteString]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (DList ByteString -> ByteString)
-> ExceptT ArchiveResult IO (DList ByteString)
-> ArchiveM ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (DList ByteString)
-> ExceptT ArchiveResult IO (DList ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (DList ByteString) -> IO (DList ByteString)
forall a. IORef a -> IO a
readIORef IORef (DList ByteString)
bsRef) ArchiveM ByteString -> ArchiveM () -> ArchiveM ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO () -> ArchiveM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FunPtr (ArchiveOpenCallbackRaw Any) -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr (ArchiveOpenCallbackRaw Any)
cc)

    where writeBSL :: IORef (DList ByteString) -> p -> p -> Ptr CChar -> a -> IO b
writeBSL IORef (DList ByteString)
bsRef p
_ p
_ Ptr CChar
bufPtr a
sz = do
            let bytesRead :: b
bytesRead = b -> b -> b
forall a. Ord a => a -> a -> a
min (a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
sz) (b
32 b -> b -> b
forall a. Num a => a -> a -> a
* b
1024)
            ByteString
bsl <- CStringLen -> IO ByteString
packCStringLen (Ptr CChar
bufPtr, b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
bytesRead)
            IORef (DList ByteString)
-> (DList ByteString -> DList ByteString) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (DList ByteString)
bsRef (DList ByteString -> ByteString -> DList ByteString
forall a. DList a -> a -> DList a
`DL.snoc` ByteString
bsl)
            b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
bytesRead
          doNothing :: p -> p -> f ArchiveResult
doNothing p
_ p
_ = ArchiveResult -> f ArchiveResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArchiveResult
ArchiveOk
          -- FIXME: this part isn't sufficiently lazy