{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

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

import Control.Exception (mask_)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Either
import Data.Function
import Data.Int (Int64)
import Data.Void (Void)
import Foreign (Ptr, free, malloc)
import Foreign.C.Types (CChar, CSize)
import Streamly.Data.Fold (Fold)
import qualified Streamly.Data.Parser as P
import Streamly.Data.Stream.Prelude (Stream)
import qualified Streamly.Data.Stream.Prelude as S
import Streamly.Data.Unfold (lmap)
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,
  )
import Streamly.Internal.Data.IOFinalizer (newIOFinalizer, runIOFinalizer)
import Streamly.Internal.Data.Stream.StreamD.Type (Step (..))
import Streamly.Internal.Data.Unfold.Type (Unfold (..))

-- | 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 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 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 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 Entry
e) = Entry -> IO (Maybe Int)
archive_entry_size Entry
e

-- | A convenience function for grouping @Either Header ByteString@s, usually obtained with
-- 'readArchive', by the headers. The input @Fold@ processes a single entry (a 'Header' followed by
-- zero or more @ByteString@s).
{-# INLINE groupByHeader #-}
groupByHeader ::
  (Monad m) =>
  Fold m (Either Header ByteString) b ->
  Stream m (Either Header ByteString) ->
  Stream m b
groupByHeader :: forall (m :: * -> *) b.
Monad m =>
Fold m (Either Header ByteString) b
-> Stream m (Either Header ByteString) -> Stream m b
groupByHeader Fold m (Either Header ByteString) b
itemFold Stream m (Either Header ByteString)
str =
  Stream m (Either Header ByteString)
str
    forall a b. a -> (a -> b) -> b
& forall (m :: * -> *) a b.
Monad m =>
Parser a m b -> Stream m a -> Stream m (Either ParseError b)
S.parseMany (forall (m :: * -> *) a b.
Monad m =>
(a -> a -> Bool) -> Fold m a b -> Parser a m b
P.groupBy (\Either Header ByteString
_ Either Header ByteString
e -> forall a b. Either a b -> Bool
isRight Either Header ByteString
e) Fold m (Either Header ByteString) b
itemFold)
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      ( \case
          Left ParseError
_ ->
            -- groupBy is documented to never fail.
            forall a. HasCallStack => [Char] -> a
error [Char]
"unexpected parseMany/groupBy error"
          Right b
b -> b
b
      )

-- | 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 :: forall (m :: * -> *).
MonadIO m =>
[Char] -> Unfold m Void (Either Header ByteString)
readArchive [Char]
fp =
  (forall a c (m :: * -> *) b.
(a -> c) -> Unfold m c b -> Unfold m a b
lmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const) () forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a b s.
(s -> m (Step s b)) -> (a -> m s) -> Unfold m a b
Unfold
      ( \(Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, Int64
pos, IOFinalizer
ref, Bool
readHeader) ->
          if Bool
readHeader
            then do
              Maybe Entry
me <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Archive -> IO (Maybe Entry)
archive_read_next_header Archive
arch
              case Maybe Entry
me of
                Maybe Entry
Nothing -> do
                  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => IOFinalizer -> m ()
runIOFinalizer IOFinalizer
ref
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall s a. Step s a
Stop
                Just Entry
e -> do
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s a. a -> s -> Step s a
Yield (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Entry -> Header
Header Entry
e) (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, Int64
0, IOFinalizer
ref, Bool
False)
            else do
              (ByteString
bs, Bool
done) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                if ByteString -> Int
B.length ByteString
bs forall a. Ord a => a -> a -> Bool
> Int
0
                  then
                    forall s a. a -> s -> Step s a
Yield
                      (forall a b. b -> Either a b
Right ByteString
bs)
                      (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, Int64
pos forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs), IOFinalizer
ref, Bool
done)
                  else forall s a. s -> Step s a
Skip (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, Int64
pos, IOFinalizer
ref, Bool
done)
      )
      ( \() -> do
          (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, IOFinalizer
ref) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
            Archive
arch <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Archive
archive_read_new
            Ptr (Ptr CChar)
buf :: Ptr (Ptr CChar) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. Storable a => IO (Ptr a)
malloc
            Ptr CSize
sz :: Ptr CSize <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. Storable a => IO (Ptr a)
malloc
            Ptr Int64
offs :: Ptr Int64 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. Storable a => IO (Ptr a)
malloc
            IOFinalizer
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m IOFinalizer
newIOFinalizer forall a b. (a -> b) -> a -> b
$ Archive -> IO ()
archive_read_free Archive
arch forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Ptr a -> IO ()
free Ptr (Ptr CChar)
buf forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Ptr a -> IO ()
free Ptr CSize
sz forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Ptr a -> IO ()
free Ptr Int64
offs
            forall (m :: * -> *) a. Monad m => a -> m a
return (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, IOFinalizer
ref)
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Archive -> IO ()
archive_read_support_filter_all Archive
arch
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Archive -> IO ()
archive_read_support_format_all Archive
arch
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Archive -> [Char] -> IO ()
archive_read_open_filename Archive
arch [Char]
fp
          forall (m :: * -> *) a. Monad m => a -> m a
return (Archive
arch, Ptr (Ptr CChar)
buf, Ptr CSize
sz, Ptr Int64
offs, Int64
0, IOFinalizer
ref, Bool
True)
      )