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
import Control.Monad
import Data.Bits
import Data.ByteString
import qualified Data.ByteString as B
import Data.Int
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.Posix.Types

data CArchive

data CEntry

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

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

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

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

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

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

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

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

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

foreign import ccall safe "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 safe "archive.h archive_read_free"
  c_archive_read_free :: Ptr CArchive -> IO CInt

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

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

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

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

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

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

foreign import ccall safe "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
$cshowsPrec :: Int -> RetCode -> ShowS
showsPrec :: Int -> RetCode -> ShowS
$cshow :: RetCode -> String
show :: RetCode -> String
$cshowList :: [RetCode] -> ShowS
showList :: [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
$cshowsPrec :: Int -> ArchiveError -> ShowS
showsPrec :: Int -> ArchiveError -> ShowS
$cshow :: ArchiveError -> String
show :: ArchiveError -> String
$cshowList :: [ArchiveError] -> ShowS
showList :: [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
$cshowsPrec :: Int -> ErrorString -> ShowS
showsPrec :: Int -> ErrorString -> ShowS
$cshow :: ErrorString -> String
show :: ErrorString -> String
$cshowList :: [ErrorString] -> ShowS
showList :: [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 a. a -> IO a
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 :: forall noReturn. 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
      { 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
$cshowsPrec :: Int -> FileType -> ShowS
showsPrec :: Int -> FileType -> ShowS
$cshow :: FileType -> String
show :: FileType -> String
$cshowList :: [FileType] -> ShowS
showList :: [FileType] -> ShowS
Show, FileType -> FileType -> Bool
(FileType -> FileType -> Bool)
-> (FileType -> FileType -> Bool) -> Eq FileType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileType -> FileType -> Bool
== :: FileType -> FileType -> Bool
$c/= :: FileType -> FileType -> Bool
/= :: 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 a. a -> IO a
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 :: forall a. Num a => 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 a b. IO a -> (a -> IO b) -> IO b
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 -- EOF.
    then Maybe Entry -> IO (Maybe Entry)
forall a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a b. IO a -> (a -> IO b) -> IO b
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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
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 a. a -> IO a
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