-- |
-- 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
import Data.ByteString.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 ByteString
bs = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ do
    ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
sptr, Int
slen) -> 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)
      Ptr CChar
dptr <- Int -> IO (Ptr CChar)
forall a. Int -> IO (Ptr a)
mallocBytes (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
dlen)
      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
          Ptr CChar -> CSize -> Ptr CChar -> Ptr CSize -> CInt
C.snappy_compress
            (Ptr CChar -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
sptr)
            (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
slen)
            (Ptr CChar -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
dptr)
            Ptr CSize
dlen_ptr
        of
          CInt
0 -> do
            Int
len <- 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
            CStringLen -> IO ByteString
unsafePackMallocCStringLen (Ptr CChar
dptr, Int
len)
          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 ByteString
bs = 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
    ByteString
-> (CStringLen -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (CStringLen -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
sptr, Int
slen) ->
      (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
          Ptr CChar -> CSize -> Ptr CSize -> CInt
C.snappy_uncompressed_length
            (Ptr CChar -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
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
            Ptr CChar
dptr <- Int -> IO (Ptr CChar)
forall a. Int -> IO (Ptr a)
mallocBytes Int
dlen
            case
                Ptr CChar -> CSize -> Ptr CChar -> Ptr CSize -> CInt
C.snappy_uncompress
                  (Ptr CChar -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
sptr)
                  (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
slen)
                  (Ptr CChar -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
dptr)
                  Ptr CSize
dlen_ptr
             of
              CInt
0 -> do
                Int
len <- 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
                ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CStringLen -> IO ByteString
unsafePackMallocCStringLen (Ptr CChar
dptr, Int
len)
              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