streamly-archive-0.0.1: src/Streamly/External/Archive/Internal/Foreign.hs
--------------------------------------------------------------------------------
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 (Show)
retCodes :: [(CInt, RetCode)]
retCodes =
[ (1, RetCodeEOF)
, (0, RetCodeOK)
, (-10, RetCodeRETRY)
, (-20, RetCodeWARN)
, (-25, RetCodeFAILED)
, (-30, RetCodeFATAL) ]
data ArchiveError =
ArchiveError { err_function :: !String
, err_retcode :: !(Either CInt RetCode)
, err_number :: !Int
, err_string :: !String }
deriving (Show)
instance Exception ArchiveError
newtype ErrorString = ErrorString String deriving (Show)
instance Exception ErrorString
archive_error_string :: Ptr CArchive -> IO String
archive_error_string aptr = do
cstr <- c_archive_error_string aptr
if cstr == nullPtr
then return "archive_error_string returned NULL"
else peekCString cstr
throwArchiveError :: String -> CInt -> Ptr CArchive -> IO noReturn
throwArchiveError fn rc aptr = do
num <- fromIntegral <$> c_archive_errno aptr
str <- archive_error_string aptr
throw $ ArchiveError
{ err_function = fn
, err_retcode = maybe (Left rc) Right (lookup rc retCodes)
, err_number = num
, err_string = str }
--------------------------------------------------------------------------------
newtype Archive = Archive (Ptr CArchive)
newtype Entry = Entry (ForeignPtr CEntry)
data FileType = FileTypeRegular
| FileTypeSymlink
| FileTypeSocket
| FileTypeCharDevice
| FileTypeBlockDevice
| FileTypeDirectory
| FileTypeNamedPipe
deriving (Show, Eq)
archive_read_new :: IO Archive
archive_read_new = do
aptr <- c_archive_read_new
if aptr == nullPtr
then throw $ ErrorString "archive_read_new returned NULL"
else return $ Archive aptr
archive_read_support_filter_all :: Archive -> IO ()
archive_read_support_filter_all (Archive aptr) = do
rc <- c_archive_read_support_filter_all aptr
when (rc /= 0) $ throwArchiveError "archive_read_support_filter_all" rc aptr
archive_read_support_format_all :: Archive -> IO ()
archive_read_support_format_all (Archive aptr) = do
rc <- c_archive_read_support_format_all aptr
when (rc /= 0) $ throwArchiveError "archive_read_support_format_all" rc aptr
archive_read_support_format_gnutar :: Archive -> IO ()
archive_read_support_format_gnutar (Archive aptr) = do
rc <- c_archive_read_support_format_gnutar aptr
when (rc /= 0) $ throwArchiveError "archive_read_support_format_gnutar" rc aptr
-- Fixed block size for now.
{-# INLINE blockSize #-}
blockSize :: (Num a) => a
blockSize = 4096
archive_read_open_filename :: Archive -> FilePath -> IO ()
archive_read_open_filename (Archive aptr) fp =
withCString fp $ \cstr -> do
rc <- c_archive_read_open_filename aptr cstr blockSize
when (rc /= 0) $ throwArchiveError "archive_read_open_filename" rc 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 aptr) = do
fpe <- mask_ $ c_archive_entry_new >>= newForeignPtr c_archive_entry_free_finalizer
rc <- withForeignPtr fpe $ c_archive_read_next_header2 aptr
if rc == 1 then -- EOF.
return Nothing
else if rc < 0 then
throwArchiveError "archive_read_next_header" rc aptr
else
return . Just . Entry $ fpe
{-# INLINE fileTypeAeIFMT #-}
fileTypeAeIFMT :: CMode
fileTypeAeIFMT = 0o0170000
{-# INLINE fileTypes #-}
fileTypes :: [(CMode, FileType)]
fileTypes =
[ (0o0100000, FileTypeRegular)
, (0o0120000, FileTypeSymlink)
, (0o0140000, FileTypeSocket)
, (0o0020000, FileTypeCharDevice)
, (0o0060000, FileTypeBlockDevice)
, (0o0040000, FileTypeDirectory)
, (0o0010000, FileTypeNamedPipe) ]
{-# INLINE archive_entry_filetype #-}
archive_entry_filetype :: Entry -> IO (Maybe FileType)
archive_entry_filetype (Entry feptr) = withForeignPtr feptr $ \eptr -> do
i <- c_archive_entry_filetype eptr
return $ lookup (i .&. fileTypeAeIFMT) fileTypes
{-# INLINE archive_entry_pathname #-}
archive_entry_pathname :: Entry -> IO (Maybe ByteString)
archive_entry_pathname (Entry feptr) = withForeignPtr feptr $ \eptr -> do
cstr <- c_archive_entry_pathname eptr
if cstr == nullPtr
then return Nothing
else Just <$> packCString cstr
{-# INLINE archive_entry_pathname_utf8 #-}
archive_entry_pathname_utf8 :: Entry -> IO (Maybe ByteString)
archive_entry_pathname_utf8 (Entry feptr) = withForeignPtr feptr $ \eptr -> do
cstr <- c_archive_entry_pathname_utf8 eptr
if cstr == nullPtr
then return Nothing
else Just <$> packCString cstr
{-# INLINE archive_entry_size #-}
archive_entry_size :: Entry -> IO (Maybe Int)
archive_entry_size (Entry feptr) = withForeignPtr feptr $ \eptr -> do
size_is_set <- (/= 0) <$> c_archive_entry_size_is_set eptr
if size_is_set then
Just . fromIntegral <$> c_archive_entry_size eptr
else
return Nothing
-- | Please free after use.
alloc_archive_read_data_buffer :: IO (Ptr CChar)
alloc_archive_read_data_buffer = mallocBytes 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 aptr) buf = do
rb <- c_archive_read_data aptr buf blockSize
if rb == 0 then
return Nothing
else if rb < 0 then
throwArchiveError "archive_read_data" (fromIntegral rb) aptr
else
Just <$> packCStringLen (buf, fromIntegral 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 aptr) buf sz offs pos = do
rc <- c_archive_read_data_block aptr buf sz offs
if rc < 0 then
throwArchiveError "archive_read_data_block" (fromIntegral rc) aptr
else if rc == 0 || rc == 1 then do -- OK or EOF.
bs <- peek buf >>= \buf' -> peek sz >>= \sz' -> packCStringLen (buf', fromIntegral sz')
offs' <- peek 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 offs' == pos then
return (bs, rc == 1)
else if offs' > pos then do
-- For a sparse file, we need to prepend zeroes to the normal data.
let diff = offs' - pos
let bs' = B.replicate (fromIntegral diff) 0 `B.append` bs
return (bs', rc == 1)
else
throw $ ErrorString "archive_read_data_block: unexpected offset"
else
throw $ ErrorString "archive_read_data_block: unexpected return code"
archive_read_free :: Archive -> IO ()
archive_read_free (Archive aptr) = do
rc <- c_archive_read_free aptr
when (rc /= 0) $ throwArchiveError "archive_read_free" rc aptr
--------------------------------------------------------------------------------