--------------------------------------------------------------------------------

module Streamly.External.Archive.Internal.Foreign
    ( Archive
    , Entry
    , FileType (..)
    , archive_read_new
    , archive_read_support_filter_all
    , archive_read_support_format_all
    , archive_read_support_format_gnutar
    , blockSize
    , archive_read_open_filename
    , archive_read_next_header
    , archive_entry_filetype
    , archive_entry_pathname
    , archive_entry_pathname_utf8
    , archive_entry_size
    , alloc_archive_read_data_buffer
    , archive_read_data
    , archive_read_data_block
    , archive_read_free ) where

--------------------------------------------------------------------------------

import Control.Exception (Exception, mask_, throw)
import Control.Monad (when)
import Data.Bits ((.&.))
import Data.ByteString (ByteString, packCString, packCStringLen)
import Data.Int (Int64)
import Foreign (FunPtr, Ptr, nullPtr, peek)
import Foreign.C.String (CString, peekCString, withCString)
import Foreign.C.Types (CChar, CInt (CInt), CSize (CSize))
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)
import Foreign.Marshal.Alloc (mallocBytes)
import System.Posix.Types (CSsize (CSsize), CMode (CMode))

import qualified Data.ByteString as B

--------------------------------------------------------------------------------

data CArchive
data CEntry

foreign import ccall unsafe "archive.h archive_errno"
    c_archive_errno :: Ptr CArchive -> IO CInt

foreign import ccall unsafe "archive.h archive_error_string"
    c_archive_error_string :: Ptr CArchive -> IO CString

foreign import ccall unsafe "archive.h archive_read_new"
    c_archive_read_new :: IO (Ptr CArchive)

foreign import ccall unsafe "archive.h archive_read_support_filter_all"
    c_archive_read_support_filter_all :: Ptr CArchive -> IO CInt

foreign import ccall unsafe "archive.h archive_read_support_format_all"
    c_archive_read_support_format_all :: Ptr CArchive -> IO CInt

foreign import ccall unsafe "archive.h archive_read_support_format_gnutar"
    c_archive_read_support_format_gnutar :: Ptr CArchive -> IO CInt

foreign import ccall unsafe "archive.h archive_read_open_filename"
    c_archive_read_open_filename :: Ptr CArchive -> CString -> CSize -> IO CInt

foreign import ccall unsafe "archive.h archive_read_next_header2"
    c_archive_read_next_header2 :: Ptr CArchive -> Ptr CEntry -> IO CInt

foreign import ccall unsafe "archive.h archive_read_data"
    c_archive_read_data :: Ptr CArchive -> Ptr CChar -> CSize -> IO CSsize -- Todo: Think about la_ssize_t on non-POSIX.

foreign import ccall unsafe "archive.h archive_read_data_block"
    c_archive_read_data_block :: Ptr CArchive -> Ptr (Ptr CChar) -> Ptr CSize -> Ptr Int64 -> IO CInt

foreign import ccall unsafe "archive.h archive_read_free"
    c_archive_read_free :: Ptr CArchive -> IO CInt

foreign import ccall unsafe "archive_entry.h archive_entry_filetype"
    c_archive_entry_filetype :: Ptr CEntry -> IO CMode -- Todo: Think about type on non-POSIX.

foreign import ccall unsafe "archive_entry.h archive_entry_new"
    c_archive_entry_new :: IO (Ptr CEntry)

-- Similar to c_free_finalizer from ByteString.
foreign import ccall unsafe "static archive_entry.h &archive_entry_free"
    c_archive_entry_free_finalizer :: FunPtr (Ptr CEntry -> IO ())

foreign import ccall unsafe "archive_entry.h archive_entry_pathname"
    c_archive_entry_pathname :: Ptr CEntry -> IO CString

foreign import ccall unsafe "archive_entry.h archive_entry_pathname_utf8"
    c_archive_entry_pathname_utf8 :: Ptr CEntry -> IO CString

foreign import ccall unsafe "archive_entry.h archive_entry_size"
    c_archive_entry_size :: Ptr CEntry -> IO Int64

foreign import ccall unsafe "archive_entry.h archive_entry_size_is_set"
    c_archive_entry_size_is_set :: Ptr CEntry -> IO CInt

--------------------------------------------------------------------------------

-- Documented libarchive return codes.
data RetCode
    = RetCodeEOF
    | RetCodeOK
    | RetCodeRETRY
    | RetCodeWARN
    | RetCodeFAILED
    | RetCodeFATAL
    deriving (Int -> RetCode -> ShowS
[RetCode] -> ShowS
RetCode -> String
(Int -> RetCode -> ShowS)
-> (RetCode -> String) -> ([RetCode] -> ShowS) -> Show RetCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RetCode] -> ShowS
$cshowList :: [RetCode] -> ShowS
show :: RetCode -> String
$cshow :: RetCode -> String
showsPrec :: Int -> RetCode -> ShowS
$cshowsPrec :: Int -> RetCode -> ShowS
Show)

retCodes :: [(CInt, RetCode)]
retCodes :: [(CInt, RetCode)]
retCodes =
    [ (CInt
1, RetCode
RetCodeEOF)
    , (CInt
0, RetCode
RetCodeOK)
    , (-CInt
10, RetCode
RetCodeRETRY)
    , (-CInt
20, RetCode
RetCodeWARN)
    , (-CInt
25, RetCode
RetCodeFAILED)
    , (-CInt
30, RetCode
RetCodeFATAL) ]

data ArchiveError =
     ArchiveError { ArchiveError -> String
err_function :: !String
                  , ArchiveError -> Either CInt RetCode
err_retcode  :: !(Either CInt RetCode)
                  , ArchiveError -> Int
err_number   :: !Int
                  , ArchiveError -> String
err_string   :: !String }
                  deriving (Int -> ArchiveError -> ShowS
[ArchiveError] -> ShowS
ArchiveError -> String
(Int -> ArchiveError -> ShowS)
-> (ArchiveError -> String)
-> ([ArchiveError] -> ShowS)
-> Show ArchiveError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArchiveError] -> ShowS
$cshowList :: [ArchiveError] -> ShowS
show :: ArchiveError -> String
$cshow :: ArchiveError -> String
showsPrec :: Int -> ArchiveError -> ShowS
$cshowsPrec :: Int -> ArchiveError -> ShowS
Show)
instance Exception ArchiveError

newtype ErrorString = ErrorString String deriving (Int -> ErrorString -> ShowS
[ErrorString] -> ShowS
ErrorString -> String
(Int -> ErrorString -> ShowS)
-> (ErrorString -> String)
-> ([ErrorString] -> ShowS)
-> Show ErrorString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorString] -> ShowS
$cshowList :: [ErrorString] -> ShowS
show :: ErrorString -> String
$cshow :: ErrorString -> String
showsPrec :: Int -> ErrorString -> ShowS
$cshowsPrec :: Int -> ErrorString -> ShowS
Show)
instance Exception ErrorString

archive_error_string :: Ptr CArchive -> IO String
archive_error_string :: Ptr CArchive -> IO String
archive_error_string Ptr CArchive
aptr = do
    CString
cstr <- Ptr CArchive -> IO CString
c_archive_error_string Ptr CArchive
aptr
    if CString
cstr CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
        then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"archive_error_string returned NULL"
        else CString -> IO String
peekCString CString
cstr

throwArchiveError :: String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError :: String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError String
fn CInt
rc Ptr CArchive
aptr = do
    Int
num <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CArchive -> IO CInt
c_archive_errno Ptr CArchive
aptr
    String
str <-  Ptr CArchive -> IO String
archive_error_string Ptr CArchive
aptr
    ArchiveError -> IO noReturn
forall a e. Exception e => e -> a
throw (ArchiveError -> IO noReturn) -> ArchiveError -> IO noReturn
forall a b. (a -> b) -> a -> b
$ ArchiveError :: String -> Either CInt RetCode -> Int -> String -> ArchiveError
ArchiveError
        { err_function :: String
err_function = String
fn
        , err_retcode :: Either CInt RetCode
err_retcode = Either CInt RetCode
-> (RetCode -> Either CInt RetCode)
-> Maybe RetCode
-> Either CInt RetCode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CInt -> Either CInt RetCode
forall a b. a -> Either a b
Left CInt
rc) RetCode -> Either CInt RetCode
forall a b. b -> Either a b
Right (CInt -> [(CInt, RetCode)] -> Maybe RetCode
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CInt
rc [(CInt, RetCode)]
retCodes)
        , err_number :: Int
err_number = Int
num
        , err_string :: String
err_string = String
str }

--------------------------------------------------------------------------------

newtype Archive = Archive (Ptr CArchive)

newtype Entry = Entry (ForeignPtr CEntry)

data FileType = FileTypeRegular
              | FileTypeSymlink
              | FileTypeSocket
              | FileTypeCharDevice
              | FileTypeBlockDevice
              | FileTypeDirectory
              | FileTypeNamedPipe
              deriving (Int -> FileType -> ShowS
[FileType] -> ShowS
FileType -> String
(Int -> FileType -> ShowS)
-> (FileType -> String) -> ([FileType] -> ShowS) -> Show FileType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileType] -> ShowS
$cshowList :: [FileType] -> ShowS
show :: FileType -> String
$cshow :: FileType -> String
showsPrec :: Int -> FileType -> ShowS
$cshowsPrec :: Int -> FileType -> ShowS
Show, FileType -> FileType -> Bool
(FileType -> FileType -> Bool)
-> (FileType -> FileType -> Bool) -> Eq FileType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileType -> FileType -> Bool
$c/= :: FileType -> FileType -> Bool
== :: FileType -> FileType -> Bool
$c== :: FileType -> FileType -> Bool
Eq)

archive_read_new :: IO Archive
archive_read_new :: IO Archive
archive_read_new = do
    Ptr CArchive
aptr <- IO (Ptr CArchive)
c_archive_read_new
    if Ptr CArchive
aptr Ptr CArchive -> Ptr CArchive -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CArchive
forall a. Ptr a
nullPtr
        then ErrorString -> IO Archive
forall a e. Exception e => e -> a
throw (ErrorString -> IO Archive) -> ErrorString -> IO Archive
forall a b. (a -> b) -> a -> b
$ String -> ErrorString
ErrorString String
"archive_read_new returned NULL"
        else Archive -> IO Archive
forall (m :: * -> *) a. Monad m => a -> m a
return (Archive -> IO Archive) -> Archive -> IO Archive
forall a b. (a -> b) -> a -> b
$ Ptr CArchive -> Archive
Archive Ptr CArchive
aptr

archive_read_support_filter_all :: Archive -> IO ()
archive_read_support_filter_all :: Archive -> IO ()
archive_read_support_filter_all (Archive Ptr CArchive
aptr) = do
    CInt
rc <- Ptr CArchive -> IO CInt
c_archive_read_support_filter_all Ptr CArchive
aptr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CInt -> Ptr CArchive -> IO ()
forall noReturn. String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError String
"archive_read_support_filter_all" CInt
rc Ptr CArchive
aptr

archive_read_support_format_all :: Archive -> IO ()
archive_read_support_format_all :: Archive -> IO ()
archive_read_support_format_all (Archive Ptr CArchive
aptr) = do
    CInt
rc <- Ptr CArchive -> IO CInt
c_archive_read_support_format_all Ptr CArchive
aptr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CInt -> Ptr CArchive -> IO ()
forall noReturn. String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError String
"archive_read_support_format_all" CInt
rc Ptr CArchive
aptr

archive_read_support_format_gnutar :: Archive -> IO ()
archive_read_support_format_gnutar :: Archive -> IO ()
archive_read_support_format_gnutar (Archive Ptr CArchive
aptr) = do
    CInt
rc <- Ptr CArchive -> IO CInt
c_archive_read_support_format_gnutar Ptr CArchive
aptr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CInt -> Ptr CArchive -> IO ()
forall noReturn. String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError String
"archive_read_support_format_gnutar" CInt
rc Ptr CArchive
aptr

-- Fixed block size for now.
{-# INLINE blockSize #-}
blockSize :: (Num a) => a
blockSize :: a
blockSize = a
4096

archive_read_open_filename :: Archive -> FilePath -> IO ()
archive_read_open_filename :: Archive -> String -> IO ()
archive_read_open_filename (Archive Ptr CArchive
aptr) String
fp =
    String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
fp ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cstr -> do
        CInt
rc <- Ptr CArchive -> CString -> CSize -> IO CInt
c_archive_read_open_filename Ptr CArchive
aptr CString
cstr CSize
forall a. Num a => a
blockSize
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CInt -> Ptr CArchive -> IO ()
forall noReturn. String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError String
"archive_read_open_filename" CInt
rc Ptr CArchive
aptr

-- | Returns 'Nothing' if we have reached the end of the archive.
{-# INLINE archive_read_next_header #-}
archive_read_next_header :: Archive -> IO (Maybe Entry)
archive_read_next_header :: Archive -> IO (Maybe Entry)
archive_read_next_header (Archive Ptr CArchive
aptr) = do
    ForeignPtr CEntry
fpe <- IO (ForeignPtr CEntry) -> IO (ForeignPtr CEntry)
forall a. IO a -> IO a
mask_ (IO (ForeignPtr CEntry) -> IO (ForeignPtr CEntry))
-> IO (ForeignPtr CEntry) -> IO (ForeignPtr CEntry)
forall a b. (a -> b) -> a -> b
$ IO (Ptr CEntry)
c_archive_entry_new IO (Ptr CEntry)
-> (Ptr CEntry -> IO (ForeignPtr CEntry)) -> IO (ForeignPtr CEntry)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FinalizerPtr CEntry -> Ptr CEntry -> IO (ForeignPtr CEntry)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr CEntry
c_archive_entry_free_finalizer
    CInt
rc <- ForeignPtr CEntry -> (Ptr CEntry -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CEntry
fpe ((Ptr CEntry -> IO CInt) -> IO CInt)
-> (Ptr CEntry -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ Ptr CArchive -> Ptr CEntry -> IO CInt
c_archive_read_next_header2 Ptr CArchive
aptr
    if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1 then  -- EOF.
        Maybe Entry -> IO (Maybe Entry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Entry
forall a. Maybe a
Nothing
    else if CInt
rc CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0 then
        String -> CInt -> Ptr CArchive -> IO (Maybe Entry)
forall noReturn. String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError String
"archive_read_next_header" CInt
rc Ptr CArchive
aptr
    else
        Maybe Entry -> IO (Maybe Entry)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Entry -> IO (Maybe Entry))
-> (ForeignPtr CEntry -> Maybe Entry)
-> ForeignPtr CEntry
-> IO (Maybe Entry)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> Maybe Entry
forall a. a -> Maybe a
Just (Entry -> Maybe Entry)
-> (ForeignPtr CEntry -> Entry) -> ForeignPtr CEntry -> Maybe Entry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr CEntry -> Entry
Entry (ForeignPtr CEntry -> IO (Maybe Entry))
-> ForeignPtr CEntry -> IO (Maybe Entry)
forall a b. (a -> b) -> a -> b
$ ForeignPtr CEntry
fpe

{-# INLINE fileTypeAeIFMT #-}
fileTypeAeIFMT :: CMode
fileTypeAeIFMT :: CMode
fileTypeAeIFMT = CMode
0o0170000

{-# INLINE fileTypes #-}
fileTypes :: [(CMode, FileType)]
fileTypes :: [(CMode, FileType)]
fileTypes =
    [ (CMode
0o0100000, FileType
FileTypeRegular)
    , (CMode
0o0120000, FileType
FileTypeSymlink)
    , (CMode
0o0140000, FileType
FileTypeSocket)
    , (CMode
0o0020000, FileType
FileTypeCharDevice)
    , (CMode
0o0060000, FileType
FileTypeBlockDevice)
    , (CMode
0o0040000, FileType
FileTypeDirectory)
    , (CMode
0o0010000, FileType
FileTypeNamedPipe) ]

{-# INLINE archive_entry_filetype #-}
archive_entry_filetype :: Entry -> IO (Maybe FileType)
archive_entry_filetype :: Entry -> IO (Maybe FileType)
archive_entry_filetype (Entry ForeignPtr CEntry
feptr) = ForeignPtr CEntry
-> (Ptr CEntry -> IO (Maybe FileType)) -> IO (Maybe FileType)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CEntry
feptr ((Ptr CEntry -> IO (Maybe FileType)) -> IO (Maybe FileType))
-> (Ptr CEntry -> IO (Maybe FileType)) -> IO (Maybe FileType)
forall a b. (a -> b) -> a -> b
$ \Ptr CEntry
eptr -> do
    CMode
i <- Ptr CEntry -> IO CMode
c_archive_entry_filetype Ptr CEntry
eptr
    Maybe FileType -> IO (Maybe FileType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FileType -> IO (Maybe FileType))
-> Maybe FileType -> IO (Maybe FileType)
forall a b. (a -> b) -> a -> b
$ CMode -> [(CMode, FileType)] -> Maybe FileType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (CMode
i CMode -> CMode -> CMode
forall a. Bits a => a -> a -> a
.&. CMode
fileTypeAeIFMT) [(CMode, FileType)]
fileTypes

{-# INLINE archive_entry_pathname #-}
archive_entry_pathname :: Entry -> IO (Maybe ByteString)
archive_entry_pathname :: Entry -> IO (Maybe ByteString)
archive_entry_pathname (Entry ForeignPtr CEntry
feptr) = ForeignPtr CEntry
-> (Ptr CEntry -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CEntry
feptr ((Ptr CEntry -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (Ptr CEntry -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CEntry
eptr -> do
    CString
cstr <- Ptr CEntry -> IO CString
c_archive_entry_pathname Ptr CEntry
eptr
    if CString
cstr CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
        then Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return 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
<$> CString -> IO ByteString
packCString CString
cstr

{-# INLINE archive_entry_pathname_utf8 #-}
archive_entry_pathname_utf8 :: Entry -> IO (Maybe ByteString)
archive_entry_pathname_utf8 :: Entry -> IO (Maybe ByteString)
archive_entry_pathname_utf8 (Entry ForeignPtr CEntry
feptr) = ForeignPtr CEntry
-> (Ptr CEntry -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CEntry
feptr ((Ptr CEntry -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (Ptr CEntry -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CEntry
eptr -> do
    CString
cstr <- Ptr CEntry -> IO CString
c_archive_entry_pathname_utf8 Ptr CEntry
eptr
    if CString
cstr CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
        then Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return 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
<$> CString -> IO ByteString
packCString CString
cstr

{-# INLINE archive_entry_size #-}
archive_entry_size :: Entry -> IO (Maybe Int)
archive_entry_size :: Entry -> IO (Maybe Int)
archive_entry_size (Entry ForeignPtr CEntry
feptr) = ForeignPtr CEntry
-> (Ptr CEntry -> IO (Maybe Int)) -> IO (Maybe Int)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CEntry
feptr ((Ptr CEntry -> IO (Maybe Int)) -> IO (Maybe Int))
-> (Ptr CEntry -> IO (Maybe Int)) -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ \Ptr CEntry
eptr -> do
    Bool
size_is_set <- (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CEntry -> IO CInt
c_archive_entry_size_is_set Ptr CEntry
eptr
    if Bool
size_is_set then
        Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int64 -> Int) -> Int64 -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Maybe Int) -> IO Int64 -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CEntry -> IO Int64
c_archive_entry_size Ptr CEntry
eptr
    else
        Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing

-- | Please free after use.
alloc_archive_read_data_buffer :: IO (Ptr CChar)
alloc_archive_read_data_buffer :: IO CString
alloc_archive_read_data_buffer = Int -> IO CString
forall a. Int -> IO (Ptr a)
mallocBytes Int
forall a. Num a => a
blockSize

-- | Returns 'Nothing' if there is no more data for the current entry.
-- Pass in a buffer allocated with 'alloc_archive_read_data_buffer'.
{-# INLINE archive_read_data #-}
archive_read_data :: Archive -> Ptr CChar -> IO (Maybe ByteString)
archive_read_data :: Archive -> CString -> IO (Maybe ByteString)
archive_read_data (Archive Ptr CArchive
aptr) CString
buf = do
    CSsize
rb <- Ptr CArchive -> CString -> CSize -> IO CSsize
c_archive_read_data Ptr CArchive
aptr CString
buf CSize
forall a. Num a => a
blockSize
    if CSsize
rb CSsize -> CSsize -> Bool
forall a. Eq a => a -> a -> Bool
== CSsize
0 then
        Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
    else if CSsize
rb CSsize -> CSsize -> Bool
forall a. Ord a => a -> a -> Bool
< CSsize
0 then
        String -> CInt -> Ptr CArchive -> IO (Maybe ByteString)
forall noReturn. String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError String
"archive_read_data" (CSsize -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSsize
rb) Ptr CArchive
aptr
    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
packCStringLen (CString
buf, CSsize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSsize
rb)

{-# INLINE archive_read_data_block #-}
archive_read_data_block :: Archive -> Ptr (Ptr CChar) -> Ptr CSize -> Ptr Int64 -> Int64 -> IO (ByteString, Bool)
archive_read_data_block :: Archive
-> Ptr CString
-> Ptr CSize
-> Ptr Int64
-> Int64
-> IO (ByteString, Bool)
archive_read_data_block (Archive Ptr CArchive
aptr) Ptr CString
buf Ptr CSize
sz Ptr Int64
offs Int64
pos = do
    CInt
rc <- Ptr CArchive -> Ptr CString -> Ptr CSize -> Ptr Int64 -> IO CInt
c_archive_read_data_block Ptr CArchive
aptr Ptr CString
buf Ptr CSize
sz Ptr Int64
offs
    if CInt
rc CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0 then
        String -> CInt -> Ptr CArchive -> IO (ByteString, Bool)
forall noReturn. String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError String
"archive_read_data_block" (CInt -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
rc) Ptr CArchive
aptr
    else if CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 Bool -> Bool -> Bool
|| CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1 then do -- OK or EOF.
        ByteString
bs <- Ptr CString -> IO CString
forall a. Storable a => Ptr a -> IO a
peek Ptr CString
buf IO CString -> (CString -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CString
buf' -> Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
sz IO CSize -> (CSize -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CSize
sz' -> CStringLen -> IO ByteString
packCStringLen (CString
buf', CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sz')
        Int64
offs' <- Ptr Int64 -> IO Int64
forall a. Storable a => Ptr a -> IO a
peek Ptr Int64
offs
        -- pos: Where we are currently located and where the data goes normally (for non-sparse files).
        -- offs': Where libarchive is asking us to position the data.
        if Int64
offs' Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
pos then
            (ByteString, Bool) -> IO (ByteString, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1)
        else if Int64
offs' Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
pos then do
            -- For a sparse file, we need to prepend zeroes to the normal data.
            let diff :: Int64
diff = Int64
offs' Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
pos
            let bs' :: ByteString
bs' = Int -> Word8 -> ByteString
B.replicate (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
diff) Word8
0 ByteString -> ByteString -> ByteString
`B.append` ByteString
bs
            (ByteString, Bool) -> IO (ByteString, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs', CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1)
        else
            ErrorString -> IO (ByteString, Bool)
forall a e. Exception e => e -> a
throw (ErrorString -> IO (ByteString, Bool))
-> ErrorString -> IO (ByteString, Bool)
forall a b. (a -> b) -> a -> b
$ String -> ErrorString
ErrorString String
"archive_read_data_block: unexpected offset"
    else
        ErrorString -> IO (ByteString, Bool)
forall a e. Exception e => e -> a
throw (ErrorString -> IO (ByteString, Bool))
-> ErrorString -> IO (ByteString, Bool)
forall a b. (a -> b) -> a -> b
$ String -> ErrorString
ErrorString String
"archive_read_data_block: unexpected return code"

archive_read_free :: Archive -> IO ()
archive_read_free :: Archive -> IO ()
archive_read_free (Archive Ptr CArchive
aptr) = do
    CInt
rc <- Ptr CArchive -> IO CInt
c_archive_read_free Ptr CArchive
aptr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CInt -> Ptr CArchive -> IO ()
forall noReturn. String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError String
"archive_read_free" CInt
rc Ptr CArchive
aptr

--------------------------------------------------------------------------------