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

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

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