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

{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}

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

module Streamly.External.Archive
    (
    -- ** Read
    readArchive,

    -- ** Header
    Header (..),
    FileType (..),
    headerFileType,
    headerPathName,
    headerPathNameUtf8,
    headerSize) where

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

import Control.Exception (mask_)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString (ByteString)
import Data.Int (Int64)
import Data.Void (Void)
import Foreign (Ptr, free, malloc)
import Foreign.C.Types (CChar, CSize)
import Streamly.Internal.Data.Stream.StreamD.Type (Step (..))
import Streamly.Internal.Data.Unfold (supply)
import Streamly.Internal.Data.Unfold.Types (Unfold (..))

import qualified Data.ByteString as B
import qualified Streamly.Internal.Data.Stream.StreamD as D

import Streamly.External.Archive.Internal.Foreign (Entry, FileType (..),
    archive_entry_filetype, archive_entry_pathname, archive_entry_pathname_utf8, archive_entry_size,
    archive_read_data_block, archive_read_free, archive_read_new, archive_read_next_header,
    archive_read_open_filename, archive_read_support_filter_all, archive_read_support_format_all)

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

-- | Header information for an entry in the archive.
newtype Header = Header Entry

{-# INLINE headerFileType #-}
headerFileType :: Header -> IO (Maybe FileType)
headerFileType :: Header -> IO (Maybe FileType)
headerFileType (Header e :: Entry
e) = Entry -> IO (Maybe FileType)
archive_entry_filetype Entry
e

{-# INLINE headerPathName #-}
headerPathName :: Header -> IO (Maybe ByteString)
headerPathName :: Header -> IO (Maybe ByteString)
headerPathName (Header e :: Entry
e) = Entry -> IO (Maybe ByteString)
archive_entry_pathname Entry
e

{-# INLINE headerPathNameUtf8 #-}
headerPathNameUtf8 :: Header -> IO (Maybe ByteString)
headerPathNameUtf8 :: Header -> IO (Maybe ByteString)
headerPathNameUtf8 (Header e :: Entry
e) = Entry -> IO (Maybe ByteString)
archive_entry_pathname_utf8 Entry
e

{-# INLINE headerSize #-}
headerSize :: Header -> IO (Maybe Int)
headerSize :: Header -> IO (Maybe Int)
headerSize (Header e :: Entry
e) = Entry -> IO (Maybe Int)
archive_entry_size Entry
e

-- | Creates an unfold with which we can stream data out of the given archive.
{-# INLINE readArchive #-}
readArchive :: (MonadIO m) => FilePath -> Unfold m Void (Either Header ByteString)
readArchive :: FilePath -> Unfold m Void (Either Header ByteString)
readArchive fp :: FilePath
fp = (Unfold m () (Either Header ByteString)
 -> () -> Unfold m Void (Either Header ByteString))
-> ()
-> Unfold m () (Either Header ByteString)
-> Unfold m Void (Either Header ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Unfold m () (Either Header ByteString)
-> () -> Unfold m Void (Either Header ByteString)
forall (m :: * -> *) a b. Unfold m a b -> a -> Unfold m Void b
supply () (Unfold m () (Either Header ByteString)
 -> Unfold m Void (Either Header ByteString))
-> Unfold m () (Either Header ByteString)
-> Unfold m Void (Either Header ByteString)
forall a b. (a -> b) -> a -> b
$
    ((Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
  IORef (Maybe (IO ())), Bool)
 -> m (Step
         (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
          IORef (Maybe (IO ())), Bool)
         (Either Header ByteString)))
-> (()
    -> m (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
          IORef (Maybe (IO ())), Bool))
-> Unfold m () (Either Header ByteString)
forall (m :: * -> *) a b s.
(s -> m (Step s b)) -> (a -> m s) -> Unfold m a b
Unfold
        (\(arch :: Archive
arch, buf :: Ptr (Ptr CChar)
buf, sz :: Ptr CSize
sz, offs :: Ptr Int64
offs, pos :: Int64
pos, ref :: IORef (Maybe (IO ()))
ref, readHeader :: Bool
readHeader) ->
            if Bool
readHeader then do
                Maybe Entry
me <- IO (Maybe Entry) -> m (Maybe Entry)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Entry) -> m (Maybe Entry))
-> IO (Maybe Entry) -> m (Maybe Entry)
forall a b. (a -> b) -> a -> b
$ Archive -> IO (Maybe Entry)
archive_read_next_header Archive
arch
                case Maybe Entry
me of
                    Nothing -> do
                        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (IO ())) -> IO ()
forall (m :: * -> *). MonadIO m => IORef (Maybe (IO ())) -> m ()
D.runIORefFinalizer IORef (Maybe (IO ()))
ref
                        Step
  (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
   IORef (Maybe (IO ())), Bool)
  (Either Header ByteString)
-> m (Step
        (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
         IORef (Maybe (IO ())), Bool)
        (Either Header ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return Step
  (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
   IORef (Maybe (IO ())), Bool)
  (Either Header ByteString)
forall s a. Step s a
Stop
                    Just e :: Entry
e -> do
                        Step
  (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
   IORef (Maybe (IO ())), Bool)
  (Either Header ByteString)
-> m (Step
        (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
         IORef (Maybe (IO ())), Bool)
        (Either Header ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Step
   (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
    IORef (Maybe (IO ())), Bool)
   (Either Header ByteString)
 -> m (Step
         (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
          IORef (Maybe (IO ())), Bool)
         (Either Header ByteString)))
-> Step
     (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
      IORef (Maybe (IO ())), Bool)
     (Either Header ByteString)
-> m (Step
        (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
         IORef (Maybe (IO ())), Bool)
        (Either Header ByteString))
forall a b. (a -> b) -> a -> b
$ Either Header ByteString
-> (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
    IORef (Maybe (IO ())), Bool)
-> Step
     (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
      IORef (Maybe (IO ())), Bool)
     (Either Header ByteString)
forall s a. a -> s -> Step s a
Yield (Header -> Either Header ByteString
forall a b. a -> Either a b
Left (Header -> Either Header ByteString)
-> Header -> Either Header ByteString
forall a b. (a -> b) -> a -> b
$ Entry -> Header
Header Entry
e) (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, 0, IORef (Maybe (IO ()))
ref, Bool
False)
            else do
                (bs :: ByteString
bs, done :: Bool
done) <- IO (ByteString, Bool) -> m (ByteString, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ByteString, Bool) -> m (ByteString, Bool))
-> IO (ByteString, Bool) -> m (ByteString, Bool)
forall a b. (a -> b) -> a -> b
$ Archive
-> Ptr (Ptr CChar)
-> Ptr CSize
-> Ptr Int64
-> Int64
-> IO (ByteString, Bool)
archive_read_data_block Archive
arch Ptr (Ptr CChar)
buf Ptr CSize
sz Ptr Int64
offs Int64
pos
                Step
  (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
   IORef (Maybe (IO ())), Bool)
  (Either Header ByteString)
-> m (Step
        (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
         IORef (Maybe (IO ())), Bool)
        (Either Header ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Step
   (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
    IORef (Maybe (IO ())), Bool)
   (Either Header ByteString)
 -> m (Step
         (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
          IORef (Maybe (IO ())), Bool)
         (Either Header ByteString)))
-> Step
     (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
      IORef (Maybe (IO ())), Bool)
     (Either Header ByteString)
-> m (Step
        (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
         IORef (Maybe (IO ())), Bool)
        (Either Header ByteString))
forall a b. (a -> b) -> a -> b
$
                    if ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then
                        Either Header ByteString
-> (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
    IORef (Maybe (IO ())), Bool)
-> Step
     (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
      IORef (Maybe (IO ())), Bool)
     (Either Header ByteString)
forall s a. a -> s -> Step s a
Yield (ByteString -> Either Header ByteString
forall a b. b -> Either a b
Right ByteString
bs) (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, Int64
pos Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs), IORef (Maybe (IO ()))
ref, Bool
done)
                    else
                        (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
 IORef (Maybe (IO ())), Bool)
-> Step
     (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
      IORef (Maybe (IO ())), Bool)
     (Either Header ByteString)
forall s a. s -> Step s a
Skip (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, Int64
pos, IORef (Maybe (IO ()))
ref, Bool
done))
        (\() -> do
            (arch :: Archive
arch, buf :: Ptr (Ptr CChar)
buf, sz :: Ptr CSize
sz, offs :: Ptr Int64
offs, ref :: IORef (Maybe (IO ()))
ref) <- IO
  (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
   IORef (Maybe (IO ())))
-> m (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
      IORef (Maybe (IO ())))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
    IORef (Maybe (IO ())))
 -> m (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
       IORef (Maybe (IO ()))))
-> (IO
      (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
       IORef (Maybe (IO ())))
    -> IO
         (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
          IORef (Maybe (IO ()))))
-> IO
     (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
      IORef (Maybe (IO ())))
-> m (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
      IORef (Maybe (IO ())))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO
  (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
   IORef (Maybe (IO ())))
-> IO
     (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
      IORef (Maybe (IO ())))
forall a. IO a -> IO a
mask_ (IO
   (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
    IORef (Maybe (IO ())))
 -> m (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
       IORef (Maybe (IO ()))))
-> IO
     (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
      IORef (Maybe (IO ())))
-> m (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
      IORef (Maybe (IO ())))
forall a b. (a -> b) -> a -> b
$ do
                Archive
arch <- IO Archive -> IO Archive
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Archive
archive_read_new
                Ptr (Ptr CChar)
buf :: Ptr (Ptr CChar) <- IO (Ptr (Ptr CChar)) -> IO (Ptr (Ptr CChar))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Ptr (Ptr CChar))
forall a. Storable a => IO (Ptr a)
malloc
                Ptr CSize
sz :: Ptr CSize <- IO (Ptr CSize) -> IO (Ptr CSize)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Ptr CSize)
forall a. Storable a => IO (Ptr a)
malloc
                Ptr Int64
offs :: Ptr Int64 <- IO (Ptr Int64) -> IO (Ptr Int64)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Ptr Int64)
forall a. Storable a => IO (Ptr a)
malloc
                IORef (Maybe (IO ()))
ref <- IO () -> IO (IORef (Maybe (IO ())))
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
m a -> m (IORef (Maybe (IO ())))
D.newFinalizedIORef (IO () -> IO (IORef (Maybe (IO ()))))
-> IO () -> IO (IORef (Maybe (IO ())))
forall a b. (a -> b) -> a -> b
$ Archive -> IO ()
archive_read_free Archive
arch IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr (Ptr CChar) -> IO ()
forall a. Ptr a -> IO ()
free Ptr (Ptr CChar)
buf IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr CSize -> IO ()
forall a. Ptr a -> IO ()
free Ptr CSize
sz IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Int64 -> IO ()
forall a. Ptr a -> IO ()
free Ptr Int64
offs
                (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
 IORef (Maybe (IO ())))
-> IO
     (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64,
      IORef (Maybe (IO ())))
forall (m :: * -> *) a. Monad m => a -> m a
return (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, IORef (Maybe (IO ()))
ref)
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Archive -> IO ()
archive_read_support_filter_all Archive
arch
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Archive -> IO ()
archive_read_support_format_all Archive
arch
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Archive -> FilePath -> IO ()
archive_read_open_filename Archive
arch FilePath
fp
            (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
 IORef (Maybe (IO ())), Bool)
-> m (Archive, Ptr (Ptr CChar), Ptr CSize, Ptr Int64, Int64,
      IORef (Maybe (IO ())), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, 0, IORef (Maybe (IO ()))
ref, Bool
True))

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