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
packFiles :: Traversable t
=> t FilePath
-> 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
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
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
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
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
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 #-}
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 #-}
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 #-}
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 #-}
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