module Codec.Archive.Internal.Unpack ( hsEntriesAbs
                                     , unpackEntriesFp
                                     , unpackArchive
                                     , readArchiveFile
                                     , readArchiveBS
                                     , archiveFile
                                     , bsToArchive
                                     , unpackToDir
                                     , readBS
                                     , readBSL
                                     , readEntry
                                     , readContents
                                     , getHsEntry
                                     , hsEntries
                                     , hsEntriesST
                                     , hsEntriesSTLazy
                                     , hsEntriesSTAbs
                                     ) where

import           Codec.Archive.Foreign
import           Codec.Archive.Internal.Monad
import           Codec.Archive.Types
import           Control.Monad                ((<=<))
import           Control.Monad.IO.Class       (liftIO)
import qualified Control.Monad.ST.Lazy        as LazyST
import qualified Control.Monad.ST.Lazy.Unsafe as LazyST
import           Data.Bifunctor               (first)
import qualified Data.ByteString              as BS
import qualified Data.ByteString.Lazy         as BSL
import           Data.Functor                 (void, ($>))
import           Foreign.C.String
import           Foreign.Concurrent           (newForeignPtr)
import           Foreign.ForeignPtr           (castForeignPtr, newForeignPtr_)
import           Foreign.Marshal.Alloc        (allocaBytes, free, mallocBytes)
import           Foreign.Marshal.Utils        (copyBytes)
import           Foreign.Ptr                  (castPtr, nullPtr)
import           System.FilePath              ((</>))
import           System.IO.Unsafe             (unsafeDupablePerformIO)

-- | Read an archive contained in a 'BS.ByteString'. The format of the archive is
-- automatically detected.
--
-- @since 1.0.0.0
readArchiveBS :: BS.ByteString -> Either ArchiveResult [Entry FilePath BS.ByteString]
readArchiveBS :: ByteString -> Either ArchiveResult [Entry FilePath ByteString]
readArchiveBS = IO (Either ArchiveResult [Entry FilePath ByteString])
-> Either ArchiveResult [Entry FilePath ByteString]
forall a. IO a -> a
unsafeDupablePerformIO (IO (Either ArchiveResult [Entry FilePath ByteString])
 -> Either ArchiveResult [Entry FilePath ByteString])
-> (ByteString
    -> IO (Either ArchiveResult [Entry FilePath ByteString]))
-> ByteString
-> Either ArchiveResult [Entry FilePath ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM [Entry FilePath ByteString]
-> IO (Either ArchiveResult [Entry FilePath ByteString])
forall a. ArchiveM a -> IO (Either ArchiveResult a)
runArchiveM (ArchiveM [Entry FilePath ByteString]
 -> IO (Either ArchiveResult [Entry FilePath ByteString]))
-> (ByteString -> ArchiveM [Entry FilePath ByteString])
-> ByteString
-> IO (Either ArchiveResult [Entry FilePath ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ArchivePtr -> ArchiveM [Entry FilePath ByteString])
-> (ArchivePtr, IO ()) -> ArchiveM [Entry FilePath ByteString]
forall {f :: * -> *} {t} {a} {b}.
MonadIO f =>
(t -> f a) -> (t, IO b) -> f a
go ArchivePtr -> ArchiveM [Entry FilePath ByteString]
hsEntries ((ArchivePtr, IO ()) -> ArchiveM [Entry FilePath ByteString])
-> (ByteString -> ExceptT ArchiveResult IO (ArchivePtr, IO ()))
-> ByteString
-> ArchiveM [Entry FilePath ByteString]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> ExceptT ArchiveResult IO (ArchivePtr, IO ())
bsToArchive)
    where go :: (t -> f a) -> (t, IO b) -> f a
go t -> f a
f (t
y, IO b
act) = t -> f a
f t
y f a -> f b -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO b -> f b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO b
act
{-# NOINLINE readArchiveBS #-}

bsToArchive :: BS.ByteString -> ArchiveM (ArchivePtr, IO ())
bsToArchive :: ByteString -> ExceptT ArchiveResult IO (ArchivePtr, IO ())
bsToArchive 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
    ArchivePtr
a <- IO ArchivePtr -> ExceptT ArchiveResult IO ArchivePtr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ArchivePtr -> ExceptT ArchiveResult IO ArchivePtr)
-> IO ArchivePtr -> ExceptT ArchiveResult IO 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) (IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Archive -> IO CInt
archiveFree Ptr Archive
preA)
    IO ArchiveResult -> ArchiveM ()
ignore (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ ArchivePtr -> IO ArchiveResult
archiveReadSupportFormatAll ArchivePtr
a
    CString
bufPtr <- ByteString
-> (CStringLen -> ExceptT ArchiveResult IO CString)
-> ExceptT ArchiveResult IO CString
forall a b.
ByteString -> (CStringLen -> ExceptT a IO b) -> ExceptT a IO b
useAsCStringLenArchiveM ByteString
bs ((CStringLen -> ExceptT ArchiveResult IO CString)
 -> ExceptT ArchiveResult IO CString)
-> (CStringLen -> ExceptT ArchiveResult IO CString)
-> ExceptT ArchiveResult IO CString
forall a b. (a -> b) -> a -> b
$
        \(CString
buf, Int
sz) -> do
            CString
buf' <- IO CString -> ExceptT ArchiveResult IO CString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CString -> ExceptT ArchiveResult IO CString)
-> IO CString -> ExceptT ArchiveResult IO CString
forall a b. (a -> b) -> a -> b
$ Int -> IO CString
forall a. Int -> IO (Ptr a)
mallocBytes Int
sz
            ()
_ <- IO () -> ArchiveM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ArchiveM ()) -> IO () -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ CString -> CString -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes CString
buf' CString
buf Int
sz
            IO ArchiveResult -> ArchiveM ()
handle (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ ArchivePtr -> CString -> CSize -> IO ArchiveResult
forall a. ArchivePtr -> Ptr a -> CSize -> IO ArchiveResult
archiveReadOpenMemory ArchivePtr
a CString
buf (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz)
            CString -> ExceptT ArchiveResult IO CString
forall (f :: * -> *) a. Applicative f => a -> f a
pure CString
buf'
    (ArchivePtr, IO ()) -> ExceptT ArchiveResult IO (ArchivePtr, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArchivePtr
a, CString -> IO ()
forall a. Ptr a -> IO ()
free CString
bufPtr)

-- | Read an archive from a file. The format of the archive is automatically
-- detected.
--
-- @since 1.0.0.0
readArchiveFile :: FilePath -> ArchiveM [Entry FilePath BS.ByteString]
readArchiveFile :: FilePath -> ArchiveM [Entry FilePath ByteString]
readArchiveFile FilePath
fp = ArchivePtr -> ArchiveM [Entry FilePath ByteString]
act (ArchivePtr -> ArchiveM [Entry FilePath ByteString])
-> ExceptT ArchiveResult IO ArchivePtr
-> ArchiveM [Entry FilePath ByteString]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ArchivePtr -> ExceptT ArchiveResult IO ArchivePtr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (do
    Ptr Archive
pre <- IO (Ptr Archive)
archiveReadNew
    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
pre) (IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Archive -> IO CInt
archiveFree Ptr Archive
pre))

    where act :: ArchivePtr -> ArchiveM [Entry FilePath ByteString]
act ArchivePtr
a =
            FilePath -> ArchivePtr -> ArchiveM ()
archiveFile FilePath
fp ArchivePtr
a ArchiveM ()
-> [Entry FilePath ByteString]
-> ArchiveM [Entry FilePath ByteString]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (forall s. ST s [Entry FilePath ByteString])
-> [Entry FilePath ByteString]
forall a. (forall s. ST s a) -> a
LazyST.runST (ArchivePtr -> ST s [Entry FilePath ByteString]
forall s. ArchivePtr -> ST s [Entry FilePath ByteString]
hsEntriesST ArchivePtr
a)

{-# INLINE archiveAbs #-}
archiveAbs :: (ArchivePtr -> IO ArchiveResult) -- ^ Function to set format support
           -> FilePath
           -> ArchivePtr
           -> ArchiveM ()
archiveAbs :: (ArchivePtr -> IO ArchiveResult)
-> FilePath -> ArchivePtr -> ArchiveM ()
archiveAbs ArchivePtr -> IO ArchiveResult
support FilePath
fp ArchivePtr
a = FilePath -> (CString -> ArchiveM ()) -> ArchiveM ()
forall a b.
FilePath -> (CString -> ExceptT a IO b) -> ExceptT a IO b
withCStringArchiveM FilePath
fp ((CString -> ArchiveM ()) -> ArchiveM ())
-> (CString -> ArchiveM ()) -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ \CString
cpath ->
    IO ArchiveResult -> ArchiveM ()
ignore (ArchivePtr -> IO ArchiveResult
support ArchivePtr
a) ArchiveM () -> ArchiveM () -> ArchiveM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
    IO ArchiveResult -> ArchiveM ()
handle (ArchivePtr -> CString -> CSize -> IO ArchiveResult
archiveReadOpenFilename ArchivePtr
a CString
cpath CSize
10240)

-- TODO: general function for format
archiveFile :: FilePath -> ArchivePtr -> ArchiveM ()
archiveFile :: FilePath -> ArchivePtr -> ArchiveM ()
archiveFile = (ArchivePtr -> IO ArchiveResult)
-> FilePath -> ArchivePtr -> ArchiveM ()
archiveAbs ArchivePtr -> IO ArchiveResult
archiveReadSupportFormatAll

-- | This is more efficient than
--
-- @
-- unpackToDir "llvm" =<< BS.readFile "llvm.tar"
-- @
unpackArchive :: FilePath -- ^ Filepath pointing to archive
              -> FilePath -- ^ Dirctory to unpack in
              -> ArchiveM ()
unpackArchive :: FilePath -> FilePath -> ArchiveM ()
unpackArchive FilePath
tarFp FilePath
dirFp = 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
    ArchivePtr
a <- IO ArchivePtr -> ExceptT ArchiveResult IO ArchivePtr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ArchivePtr -> ExceptT ArchiveResult IO ArchivePtr)
-> IO ArchivePtr -> ExceptT ArchiveResult IO 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) (IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Archive -> IO CInt
archiveFree Ptr Archive
preA)
    ArchivePtr -> ArchiveM ()
act ArchivePtr
a

    where act :: ArchivePtr -> ArchiveM ()
act ArchivePtr
a =
            FilePath -> ArchivePtr -> ArchiveM ()
archiveFile FilePath
tarFp ArchivePtr
a ArchiveM () -> ArchiveM () -> ArchiveM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
            ArchivePtr -> FilePath -> ArchiveM ()
unpackEntriesFp ArchivePtr
a FilePath
dirFp

readEntry :: Integral a
          => (ArchivePtr -> a -> IO e)
          -> ArchivePtr
          -> ArchiveEntryPtr
          -> IO (Entry FilePath e)
readEntry :: forall a e.
Integral a =>
(ArchivePtr -> a -> IO e)
-> ArchivePtr -> ArchiveEntryPtr -> IO (Entry FilePath e)
readEntry ArchivePtr -> a -> IO e
read' ArchivePtr
a ArchiveEntryPtr
entry =
    FilePath
-> EntryContent FilePath e
-> Permissions
-> Ownership
-> Maybe ModTime
-> Entry FilePath e
forall fp e.
fp
-> EntryContent fp e
-> Permissions
-> Ownership
-> Maybe ModTime
-> Entry fp e
Entry
        (FilePath
 -> EntryContent FilePath e
 -> Permissions
 -> Ownership
 -> Maybe ModTime
 -> Entry FilePath e)
-> IO FilePath
-> IO
     (EntryContent FilePath e
      -> Permissions -> Ownership -> Maybe ModTime -> Entry FilePath e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CString -> IO FilePath
peekCString (CString -> IO FilePath) -> IO CString -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArchiveEntryPtr -> IO CString
archiveEntryPathname ArchiveEntryPtr
entry)
        IO
  (EntryContent FilePath e
   -> Permissions -> Ownership -> Maybe ModTime -> Entry FilePath e)
-> IO (EntryContent FilePath e)
-> IO
     (Permissions -> Ownership -> Maybe ModTime -> Entry FilePath e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ArchivePtr -> a -> IO e)
-> ArchivePtr -> ArchiveEntryPtr -> IO (EntryContent FilePath e)
forall a e.
Integral a =>
(ArchivePtr -> a -> IO e)
-> ArchivePtr -> ArchiveEntryPtr -> IO (EntryContent FilePath e)
readContents ArchivePtr -> a -> IO e
read' ArchivePtr
a ArchiveEntryPtr
entry
        IO (Permissions -> Ownership -> Maybe ModTime -> Entry FilePath e)
-> IO Permissions
-> IO (Ownership -> Maybe ModTime -> Entry FilePath e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArchiveEntryPtr -> IO Permissions
archiveEntryPerm ArchiveEntryPtr
entry
        IO (Ownership -> Maybe ModTime -> Entry FilePath e)
-> IO Ownership -> IO (Maybe ModTime -> Entry FilePath e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArchiveEntryPtr -> IO Ownership
readOwnership ArchiveEntryPtr
entry
        IO (Maybe ModTime -> Entry FilePath e)
-> IO (Maybe ModTime) -> IO (Entry FilePath e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArchiveEntryPtr -> IO (Maybe ModTime)
readTimes ArchiveEntryPtr
entry

-- | Yield the next entry in an archive
getHsEntry :: Integral a
           => (ArchivePtr -> a -> IO e)
           -> ArchivePtr
           -> IO (Maybe (Entry FilePath e))
getHsEntry :: forall a e.
Integral a =>
(ArchivePtr -> a -> IO e)
-> ArchivePtr -> IO (Maybe (Entry FilePath e))
getHsEntry ArchivePtr -> a -> IO e
read' ArchivePtr
a = do
    Maybe ArchiveEntryPtr
entry <- ArchivePtr -> IO (Maybe ArchiveEntryPtr)
getEntry ArchivePtr
a
    case Maybe ArchiveEntryPtr
entry of
        Maybe ArchiveEntryPtr
Nothing -> Maybe (Entry FilePath e) -> IO (Maybe (Entry FilePath e))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Entry FilePath e)
forall a. Maybe a
Nothing
        Just ArchiveEntryPtr
x  -> Entry FilePath e -> Maybe (Entry FilePath e)
forall a. a -> Maybe a
Just (Entry FilePath e -> Maybe (Entry FilePath e))
-> IO (Entry FilePath e) -> IO (Maybe (Entry FilePath e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArchivePtr -> a -> IO e)
-> ArchivePtr -> ArchiveEntryPtr -> IO (Entry FilePath e)
forall a e.
Integral a =>
(ArchivePtr -> a -> IO e)
-> ArchivePtr -> ArchiveEntryPtr -> IO (Entry FilePath e)
readEntry ArchivePtr -> a -> IO e
read' ArchivePtr
a ArchiveEntryPtr
x

-- | Return a list of 'Entry's.
hsEntries :: ArchivePtr -> ArchiveM [Entry FilePath BS.ByteString]
hsEntries :: ArchivePtr -> ArchiveM [Entry FilePath ByteString]
hsEntries = (ArchivePtr -> Int -> IO ByteString)
-> ArchivePtr -> ArchiveM [Entry FilePath ByteString]
forall a e.
Integral a =>
(ArchivePtr -> a -> IO e)
-> ArchivePtr -> ArchiveM [Entry FilePath e]
hsEntriesAbs ArchivePtr -> Int -> IO ByteString
readBS

hsEntriesAbs :: Integral a
             => (ArchivePtr -> a -> IO e)
             -> ArchivePtr
             -> ArchiveM [Entry FilePath e]
hsEntriesAbs :: forall a e.
Integral a =>
(ArchivePtr -> a -> IO e)
-> ArchivePtr -> ArchiveM [Entry FilePath e]
hsEntriesAbs ArchivePtr -> a -> IO e
read' ArchivePtr
p = [Entry FilePath e] -> ExceptT ArchiveResult IO [Entry FilePath e]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall s. ST s [Entry FilePath e]) -> [Entry FilePath e]
forall a. (forall s. ST s a) -> a
LazyST.runST ((forall s. ST s [Entry FilePath e]) -> [Entry FilePath e])
-> (forall s. ST s [Entry FilePath e]) -> [Entry FilePath e]
forall a b. (a -> b) -> a -> b
$ (ArchivePtr -> a -> IO e) -> ArchivePtr -> ST s [Entry FilePath e]
forall a e s.
Integral a =>
(ArchivePtr -> a -> IO e) -> ArchivePtr -> ST s [Entry FilePath e]
hsEntriesSTAbs ArchivePtr -> a -> IO e
read' ArchivePtr
p)

-- | Return a list of 'Entry's.
hsEntriesST :: ArchivePtr -> LazyST.ST s [Entry FilePath BS.ByteString]
hsEntriesST :: forall s. ArchivePtr -> ST s [Entry FilePath ByteString]
hsEntriesST = (ArchivePtr -> Int -> IO ByteString)
-> ArchivePtr -> ST s [Entry FilePath ByteString]
forall a e s.
Integral a =>
(ArchivePtr -> a -> IO e) -> ArchivePtr -> ST s [Entry FilePath e]
hsEntriesSTAbs ArchivePtr -> Int -> IO ByteString
readBS

hsEntriesSTLazy :: ArchivePtr -> LazyST.ST s [Entry FilePath BSL.ByteString]
hsEntriesSTLazy :: forall s. ArchivePtr -> ST s [Entry FilePath ByteString]
hsEntriesSTLazy = (ArchivePtr -> Int -> IO ByteString)
-> ArchivePtr -> ST s [Entry FilePath ByteString]
forall a e s.
Integral a =>
(ArchivePtr -> a -> IO e) -> ArchivePtr -> ST s [Entry FilePath e]
hsEntriesSTAbs ArchivePtr -> Int -> IO ByteString
readBSL

hsEntriesSTAbs :: Integral a
               => (ArchivePtr -> a -> IO e)
               -> ArchivePtr
               -> LazyST.ST s [Entry FilePath e]
hsEntriesSTAbs :: forall a e s.
Integral a =>
(ArchivePtr -> a -> IO e) -> ArchivePtr -> ST s [Entry FilePath e]
hsEntriesSTAbs ArchivePtr -> a -> IO e
read' ArchivePtr
a = do
    Maybe (Entry FilePath e)
next <- IO (Maybe (Entry FilePath e)) -> ST s (Maybe (Entry FilePath e))
forall a s. IO a -> ST s a
LazyST.unsafeIOToST ((ArchivePtr -> a -> IO e)
-> ArchivePtr -> IO (Maybe (Entry FilePath e))
forall a e.
Integral a =>
(ArchivePtr -> a -> IO e)
-> ArchivePtr -> IO (Maybe (Entry FilePath e))
getHsEntry ArchivePtr -> a -> IO e
read' ArchivePtr
a)
    case Maybe (Entry FilePath e)
next of
        Maybe (Entry FilePath e)
Nothing -> [Entry FilePath e] -> ST s [Entry FilePath e]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        Just Entry FilePath e
x  -> (Entry FilePath e
xEntry FilePath e -> [Entry FilePath e] -> [Entry FilePath e]
forall a. a -> [a] -> [a]
:) ([Entry FilePath e] -> [Entry FilePath e])
-> ST s [Entry FilePath e] -> ST s [Entry FilePath e]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArchivePtr -> a -> IO e) -> ArchivePtr -> ST s [Entry FilePath e]
forall a e s.
Integral a =>
(ArchivePtr -> a -> IO e) -> ArchivePtr -> ST s [Entry FilePath e]
hsEntriesSTAbs ArchivePtr -> a -> IO e
read' ArchivePtr
a

-- | Unpack an archive in a given directory
unpackEntriesFp :: ArchivePtr -> FilePath -> ArchiveM ()
unpackEntriesFp :: ArchivePtr -> FilePath -> ArchiveM ()
unpackEntriesFp ArchivePtr
a FilePath
fp = do
    Maybe ArchiveEntryPtr
res <- IO (Maybe ArchiveEntryPtr)
-> ExceptT ArchiveResult IO (Maybe ArchiveEntryPtr)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ArchiveEntryPtr)
 -> ExceptT ArchiveResult IO (Maybe ArchiveEntryPtr))
-> IO (Maybe ArchiveEntryPtr)
-> ExceptT ArchiveResult IO (Maybe ArchiveEntryPtr)
forall a b. (a -> b) -> a -> b
$ ArchivePtr -> IO (Maybe ArchiveEntryPtr)
getEntry ArchivePtr
a
    case Maybe ArchiveEntryPtr
res of
        Maybe ArchiveEntryPtr
Nothing -> () -> ArchiveM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just ArchiveEntryPtr
x  -> do
            CString
preFile <- IO CString -> ExceptT ArchiveResult IO CString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CString -> ExceptT ArchiveResult IO CString)
-> IO CString -> ExceptT ArchiveResult IO CString
forall a b. (a -> b) -> a -> b
$ ArchiveEntryPtr -> IO CString
archiveEntryPathname ArchiveEntryPtr
x
            FilePath
file <- IO FilePath -> ExceptT ArchiveResult IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT ArchiveResult IO FilePath)
-> IO FilePath -> ExceptT ArchiveResult IO FilePath
forall a b. (a -> b) -> a -> b
$ CString -> IO FilePath
peekCString CString
preFile
            let file' :: FilePath
file' = FilePath
fp FilePath -> FilePath -> FilePath
</> FilePath
file
            IO () -> ArchiveM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ArchiveM ()) -> IO () -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> (CString -> IO ()) -> IO ()
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
file' ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
fileC ->
                ArchiveEntryPtr -> CString -> IO ()
archiveEntrySetPathname ArchiveEntryPtr
x CString
fileC
            Maybe FileType
ft <- IO (Maybe FileType) -> ExceptT ArchiveResult IO (Maybe FileType)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FileType) -> ExceptT ArchiveResult IO (Maybe FileType))
-> IO (Maybe FileType) -> ExceptT ArchiveResult IO (Maybe FileType)
forall a b. (a -> b) -> a -> b
$ ArchiveEntryPtr -> IO (Maybe FileType)
archiveEntryFiletype ArchiveEntryPtr
x
            case Maybe FileType
ft of
                Just{} ->
                    IO ArchiveResult -> ArchiveM ()
ignore (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ ArchivePtr -> ArchiveEntryPtr -> Flags -> IO ArchiveResult
archiveReadExtract ArchivePtr
a ArchiveEntryPtr
x Flags
archiveExtractTime
                Maybe FileType
Nothing -> do
                    FilePath
hardlink <- IO FilePath -> ExceptT ArchiveResult IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT ArchiveResult IO FilePath)
-> IO FilePath -> ExceptT ArchiveResult IO FilePath
forall a b. (a -> b) -> a -> b
$ CString -> IO FilePath
peekCString (CString -> IO FilePath) -> IO CString -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArchiveEntryPtr -> IO CString
archiveEntryHardlink ArchiveEntryPtr
x
                    let hardlink' :: FilePath
hardlink' = FilePath
fp FilePath -> FilePath -> FilePath
</> FilePath
hardlink
                    IO () -> ArchiveM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ArchiveM ()) -> IO () -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> (CString -> IO ()) -> IO ()
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
hardlink' ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
hl ->
                        ArchiveEntryPtr -> CString -> IO ()
archiveEntrySetHardlink ArchiveEntryPtr
x CString
hl
                    IO ArchiveResult -> ArchiveM ()
ignore (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ ArchivePtr -> ArchiveEntryPtr -> Flags -> IO ArchiveResult
archiveReadExtract ArchivePtr
a ArchiveEntryPtr
x Flags
archiveExtractTime
            IO ArchiveResult -> ArchiveM ()
ignore (IO ArchiveResult -> ArchiveM ())
-> IO ArchiveResult -> ArchiveM ()
forall a b. (a -> b) -> a -> b
$ ArchivePtr -> IO ArchiveResult
archiveReadDataSkip ArchivePtr
a
            ArchivePtr -> FilePath -> ArchiveM ()
unpackEntriesFp ArchivePtr
a FilePath
fp

{-# INLINE readBS #-}
readBS :: ArchivePtr -> Int -> IO BS.ByteString
readBS :: ArchivePtr -> Int -> IO ByteString
readBS ArchivePtr
a Int
sz =
    Int -> (CString -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sz ((CString -> IO ByteString) -> IO ByteString)
-> (CString -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \CString
buff ->
        ArchivePtr -> CString -> CSize -> IO LaInt64
forall a. ArchivePtr -> Ptr a -> CSize -> IO LaInt64
archiveReadData ArchivePtr
a CString
buff (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz) IO LaInt64 -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
        CStringLen -> IO ByteString
BS.packCStringLen (CString
buff, Int
sz)

-- TODO: sanity check by comparing to archiveEntrySize?
readBSL :: ArchivePtr -> Int -> IO BSL.ByteString
readBSL :: ArchivePtr -> Int -> IO ByteString
readBSL ArchivePtr
a Int
_ = [ByteString] -> ByteString
BSL.fromChunks ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [ByteString]
loop
    where step :: IO (Maybe ByteString)
step =
            Int -> (CString -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
bufSz ((CString -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (CString -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \CString
bufPtr -> do
                LaInt64
bRead <- ArchivePtr -> CString -> CSize -> IO LaInt64
forall a. ArchivePtr -> Ptr a -> CSize -> IO LaInt64
archiveReadData ArchivePtr
a CString
bufPtr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bufSz)
                if LaInt64
bRead LaInt64 -> LaInt64 -> Bool
forall a. Eq a => a -> a -> Bool
== LaInt64
0
                    then Maybe ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
                    else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CStringLen -> IO ByteString
BS.packCStringLen (CString
bufPtr, LaInt64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral LaInt64
bRead)

          loop :: IO [ByteString]
loop = do
            Maybe ByteString
res <- IO (Maybe ByteString)
step
            case Maybe ByteString
res of
                Just ByteString
b  -> (ByteString
bByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [ByteString]
loop
                Maybe ByteString
Nothing -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

          bufSz :: Int
bufSz = Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 -- read in 32k blocks

readContents :: Integral a
             => (ArchivePtr -> a -> IO e)
             -> ArchivePtr
             -> ArchiveEntryPtr
             -> IO (EntryContent FilePath e)
readContents :: forall a e.
Integral a =>
(ArchivePtr -> a -> IO e)
-> ArchivePtr -> ArchiveEntryPtr -> IO (EntryContent FilePath e)
readContents ArchivePtr -> a -> IO e
read' ArchivePtr
a ArchiveEntryPtr
entry = Maybe FileType -> IO (EntryContent FilePath e)
go (Maybe FileType -> IO (EntryContent FilePath e))
-> IO (Maybe FileType) -> IO (EntryContent FilePath e)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArchiveEntryPtr -> IO (Maybe FileType)
archiveEntryFiletype ArchiveEntryPtr
entry
    where go :: Maybe FileType -> IO (EntryContent FilePath e)
go Maybe FileType
Nothing            = FilePath -> EntryContent FilePath e
forall fp e. fp -> EntryContent fp e
Hardlink (FilePath -> EntryContent FilePath e)
-> IO FilePath -> IO (EntryContent FilePath e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CString -> IO FilePath
peekCString (CString -> IO FilePath) -> IO CString -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArchiveEntryPtr -> IO CString
archiveEntryHardlink ArchiveEntryPtr
entry)
          go (Just FileType
FtRegular)   = e -> EntryContent FilePath e
forall fp e. e -> EntryContent fp e
NormalFile (e -> EntryContent FilePath e)
-> IO e -> IO (EntryContent FilePath e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArchivePtr -> a -> IO e
read' ArchivePtr
a (a -> IO e) -> IO a -> IO e
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
sz)
          go (Just FileType
FtLink)      = FilePath -> Symlink -> EntryContent FilePath e
forall fp e. fp -> Symlink -> EntryContent fp e
Symlink (FilePath -> Symlink -> EntryContent FilePath e)
-> IO FilePath -> IO (Symlink -> EntryContent FilePath e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CString -> IO FilePath
peekCString (CString -> IO FilePath) -> IO CString -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ArchiveEntryPtr -> IO CString
archiveEntrySymlink ArchiveEntryPtr
entry) IO (Symlink -> EntryContent FilePath e)
-> IO Symlink -> IO (EntryContent FilePath e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArchiveEntryPtr -> IO Symlink
archiveEntrySymlinkType ArchiveEntryPtr
entry
          go (Just FileType
FtDirectory) = EntryContent FilePath e -> IO (EntryContent FilePath e)
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryContent FilePath e
forall fp e. EntryContent fp e
Directory
          go (Just FileType
_)           = FilePath -> IO (EntryContent FilePath e)
forall a. HasCallStack => FilePath -> a
error FilePath
"Unsupported filetype"
          sz :: IO a
sz = LaInt64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (LaInt64 -> a) -> IO LaInt64 -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArchiveEntryPtr -> IO LaInt64
archiveEntrySize ArchiveEntryPtr
entry

archiveGetterHelper :: (ArchiveEntryPtr -> IO a) -> (ArchiveEntryPtr -> IO Bool) -> ArchiveEntryPtr -> IO (Maybe a)
archiveGetterHelper :: forall a.
(ArchiveEntryPtr -> IO a)
-> (ArchiveEntryPtr -> IO Bool) -> ArchiveEntryPtr -> IO (Maybe a)
archiveGetterHelper ArchiveEntryPtr -> IO a
get ArchiveEntryPtr -> IO Bool
check ArchiveEntryPtr
entry = do
    Bool
check' <- ArchiveEntryPtr -> IO Bool
check ArchiveEntryPtr
entry
    if Bool
check'
        then a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArchiveEntryPtr -> IO a
get ArchiveEntryPtr
entry
        else Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

archiveGetterNull :: (ArchiveEntryPtr -> IO CString) -> ArchiveEntryPtr -> IO (Maybe String)
archiveGetterNull :: (ArchiveEntryPtr -> IO CString)
-> ArchiveEntryPtr -> IO (Maybe FilePath)
archiveGetterNull ArchiveEntryPtr -> IO CString
get ArchiveEntryPtr
entry = do
    CString
res <- ArchiveEntryPtr -> IO CString
get ArchiveEntryPtr
entry
    if CString
res CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
        then Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
        else (FilePath -> Maybe FilePath) -> IO FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (CString -> IO FilePath
peekCString CString
res)

readOwnership :: ArchiveEntryPtr -> IO Ownership
readOwnership :: ArchiveEntryPtr -> IO Ownership
readOwnership ArchiveEntryPtr
entry =
    Maybe FilePath -> Maybe FilePath -> Id -> Id -> Ownership
Ownership
        (Maybe FilePath -> Maybe FilePath -> Id -> Id -> Ownership)
-> IO (Maybe FilePath)
-> IO (Maybe FilePath -> Id -> Id -> Ownership)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArchiveEntryPtr -> IO CString)
-> ArchiveEntryPtr -> IO (Maybe FilePath)
archiveGetterNull ArchiveEntryPtr -> IO CString
archiveEntryUname ArchiveEntryPtr
entry
        IO (Maybe FilePath -> Id -> Id -> Ownership)
-> IO (Maybe FilePath) -> IO (Id -> Id -> Ownership)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ArchiveEntryPtr -> IO CString)
-> ArchiveEntryPtr -> IO (Maybe FilePath)
archiveGetterNull ArchiveEntryPtr -> IO CString
archiveEntryGname ArchiveEntryPtr
entry
        IO (Id -> Id -> Ownership) -> IO Id -> IO (Id -> Ownership)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LaInt64 -> Id
forall a b. (Integral a, Num b) => a -> b
fromIntegral (LaInt64 -> Id) -> IO LaInt64 -> IO Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArchiveEntryPtr -> IO LaInt64
archiveEntryUid ArchiveEntryPtr
entry)
        IO (Id -> Ownership) -> IO Id -> IO Ownership
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LaInt64 -> Id
forall a b. (Integral a, Num b) => a -> b
fromIntegral (LaInt64 -> Id) -> IO LaInt64 -> IO Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArchiveEntryPtr -> IO LaInt64
archiveEntryGid ArchiveEntryPtr
entry)

readTimes :: ArchiveEntryPtr -> IO (Maybe ModTime)
readTimes :: ArchiveEntryPtr -> IO (Maybe ModTime)
readTimes = (ArchiveEntryPtr -> IO ModTime)
-> (ArchiveEntryPtr -> IO Bool)
-> ArchiveEntryPtr
-> IO (Maybe ModTime)
forall a.
(ArchiveEntryPtr -> IO a)
-> (ArchiveEntryPtr -> IO Bool) -> ArchiveEntryPtr -> IO (Maybe a)
archiveGetterHelper ArchiveEntryPtr -> IO ModTime
go ArchiveEntryPtr -> IO Bool
archiveEntryMtimeIsSet
    where go :: ArchiveEntryPtr -> IO ModTime
go ArchiveEntryPtr
entry =
            (,) (CTime -> LaInt64 -> ModTime)
-> IO CTime -> IO (LaInt64 -> ModTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArchiveEntryPtr -> IO CTime
archiveEntryMtime ArchiveEntryPtr
entry IO (LaInt64 -> ModTime) -> IO LaInt64 -> IO ModTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArchiveEntryPtr -> IO LaInt64
archiveEntryMtimeNsec ArchiveEntryPtr
entry

-- | Get the next 'ArchiveEntry' in an 'Archive'
getEntry :: ArchivePtr -> IO (Maybe ArchiveEntryPtr)
getEntry :: ArchivePtr -> IO (Maybe ArchiveEntryPtr)
getEntry ArchivePtr
a = do
    let done :: ArchiveResult -> Bool
done ArchiveResult
ArchiveOk    = Bool
False
        done ArchiveResult
ArchiveRetry = Bool
False
        done ArchiveResult
_            = Bool
True
    (Bool
stop, Ptr ArchiveEntry
res) <- (ArchiveResult -> Bool)
-> (ArchiveResult, Ptr ArchiveEntry) -> (Bool, Ptr ArchiveEntry)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ArchiveResult -> Bool
done ((ArchiveResult, Ptr ArchiveEntry) -> (Bool, Ptr ArchiveEntry))
-> IO (ArchiveResult, Ptr ArchiveEntry)
-> IO (Bool, Ptr ArchiveEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArchivePtr -> IO (ArchiveResult, Ptr ArchiveEntry)
archiveReadNextHeader ArchivePtr
a
    if Bool
stop
        then Maybe ArchiveEntryPtr -> IO (Maybe ArchiveEntryPtr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ArchiveEntryPtr
forall a. Maybe a
Nothing
        else ArchiveEntryPtr -> Maybe ArchiveEntryPtr
forall a. a -> Maybe a
Just (ArchiveEntryPtr -> Maybe ArchiveEntryPtr)
-> (ForeignPtr Any -> ArchiveEntryPtr)
-> ForeignPtr Any
-> Maybe ArchiveEntryPtr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr Any -> ArchiveEntryPtr
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr (ForeignPtr Any -> Maybe ArchiveEntryPtr)
-> IO (ForeignPtr Any) -> IO (Maybe ArchiveEntryPtr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Any -> IO (ForeignPtr Any)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ (Ptr ArchiveEntry -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr ArchiveEntry
res)

unpackToDir :: FilePath -- ^ Directory to unpack in
            -> BS.ByteString -- ^ 'BS.ByteString' containing archive
            -> ArchiveM ()
unpackToDir :: FilePath -> ByteString -> ArchiveM ()
unpackToDir FilePath
fp ByteString
bs = do
    (ArchivePtr
a, IO ()
act) <- ByteString -> ExceptT ArchiveResult IO (ArchivePtr, IO ())
bsToArchive ByteString
bs
    ArchivePtr -> FilePath -> ArchiveM ()
unpackEntriesFp ArchivePtr
a FilePath
fp
    IO () -> ArchiveM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
act