-- |
-- Module     : Codec.Compression.SnappyC.Raw
-- Copyright  : (c) 2024 Finley McIlwaine
-- License    : BSD-3-Clause (see LICENSE)
--
-- Maintainer : Finley McIlwaine <finley@well-typed.com>
--
-- Raw format Snappy compression/decompression.
--
-- > import Codec.Compression.SnappyC.Raw qualified as Snappy

module Codec.Compression.SnappyC.Raw
  ( -- * Compression
    compress
    -- * Decompression
  , decompress
  ) where

import Codec.Compression.SnappyC.Internal.C qualified as C

import Data.ByteString.Internal (ByteString(..))
import Foreign
import System.IO.Unsafe

-- | Compress the input using [Snappy](https://github.com/google/snappy/).
--
-- The result is in Snappy raw format, /not/ the framing format.
compress :: ByteString -> ByteString
compress :: ByteString -> ByteString
compress (BS ForeignPtr Word8
sfp Int
slen) =
    IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ do
      let dlen :: CSize
dlen = CSize -> CSize
C.snappy_max_compressed_length (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
slen)
      ForeignPtr Word8
dfp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
dlen)
      ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
sfp ((Ptr Word8 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
sptr ->
        ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
dfp ((Ptr Word8 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dptr ->
          CSize -> (Ptr CSize -> IO ByteString) -> IO ByteString
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with CSize
dlen ((Ptr CSize -> IO ByteString) -> IO ByteString)
-> (Ptr CSize -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CSize
dlen_ptr ->
            case
              CString -> CSize -> CString -> Ptr CSize -> CInt
C.snappy_compress
                (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
sptr)
                (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
slen)
                (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
dptr)
                Ptr CSize
dlen_ptr
            of
              CInt
0 ->
                ForeignPtr Word8 -> Int -> ByteString
BS ForeignPtr Word8
dfp (Int -> ByteString) -> (CSize -> Int) -> CSize -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> ByteString) -> IO CSize -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
dlen_ptr
              CInt
1 ->
                [Char] -> IO ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: there is no invalid input for compression"
              CInt
2 ->
                [Char] -> IO ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: the buffer size is always set correctly"
              CInt
status ->
                [Char] -> IO ByteString
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ByteString) -> [Char] -> IO ByteString
forall a b. (a -> b) -> a -> b
$
                  [Char]
"impossible: unexpected status from snappy_compress: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                  CInt -> [Char]
forall a. Show a => a -> [Char]
show CInt
status

-- | Decompress the input using [Snappy](https://github.com/google/snappy/).
--
-- Returns 'Nothing' if the input is not in Snappy raw format or
-- otherwise ill-formed.
decompress :: ByteString -> Maybe ByteString
decompress :: ByteString -> Maybe ByteString
decompress (BS ForeignPtr Word8
sfp Int
slen) =
    IO (Maybe ByteString) -> Maybe ByteString
forall a. IO a -> a
unsafePerformIO (IO (Maybe ByteString) -> Maybe ByteString)
-> IO (Maybe ByteString) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ do
      ForeignPtr Word8
-> (Ptr Word8 -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
sfp ((Ptr Word8 -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (Ptr Word8 -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
        \Ptr Word8
sptr ->
          (Ptr CSize -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (Ptr CSize -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
            \Ptr CSize
dlen_ptr ->
              case
                CString -> CSize -> Ptr CSize -> CInt
C.snappy_uncompressed_length
                  (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
sptr)
                  (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
slen)
                  Ptr CSize
dlen_ptr
              of
                CInt
0 -> do
                  Int
dlen <- CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> Int) -> IO CSize -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
dlen_ptr
                  ForeignPtr Word8
dfp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
dlen
                  ForeignPtr Word8
-> (Ptr Word8 -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
dfp ((Ptr Word8 -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (Ptr Word8 -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
                    \Ptr Word8
dptr ->
                      case
                          CString -> CSize -> CString -> Ptr CSize -> CInt
C.snappy_uncompress
                            (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
sptr)
                            (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
slen)
                            (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
dptr)
                            Ptr CSize
dlen_ptr
                      of
                        CInt
0 ->
                          ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (CSize -> ByteString) -> CSize -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr Word8 -> Int -> ByteString
BS ForeignPtr Word8
dfp (Int -> ByteString) -> (CSize -> Int) -> CSize -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> Maybe ByteString) -> IO CSize -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
dlen_ptr
                        CInt
1 ->
                          -- Invalid input. Successful result from
                          -- snappy_uncompressed_length does *not* mean the
                          -- input is completely valid
                          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
                        CInt
status ->
                          [Char] -> IO (Maybe ByteString)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (Maybe ByteString))
-> [Char] -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
                            [Char]
"impossible: decompression failed with status " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                            CInt -> [Char]
forall a. Show a => a -> [Char]
show CInt
status
                CInt
1 ->
                  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
                CInt
status ->
                  [Char] -> IO (Maybe ByteString)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (Maybe ByteString))
-> [Char] -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
                    [Char]
"impossible: snappy_uncompressed_length failed with " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                    [Char]
"status" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CInt -> [Char]
forall a. Show a => a -> [Char]
show CInt
status