{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}

-- | Support for CRC
module System.FS.CRC (
    -- * Wrap digest functionality
    CRC (..)
  , computeCRC
  , initCRC
  , updateCRC
    -- * File system functions with CRC functionality
  , hGetAllAtCRC
  , hGetExactlyAtCRC
  , hPutAllCRC
  ) where

import           Control.Monad (foldM)
import           Control.Monad.Class.MonadThrow
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import           Data.Coerce
import qualified Data.Digest.CRC32 as Digest
import           Data.Word
import           Foreign.Storable (Storable)
import           GHC.Generics (Generic)
import           GHC.Stack
import           System.FS.API.Lazy
import           System.FS.API.Strict

{-------------------------------------------------------------------------------
  Wrap functionality from digest
-------------------------------------------------------------------------------}

newtype CRC = CRC { CRC -> Word32
getCRC :: Word32 }
  deriving (CRC -> CRC -> Bool
(CRC -> CRC -> Bool) -> (CRC -> CRC -> Bool) -> Eq CRC
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CRC -> CRC -> Bool
== :: CRC -> CRC -> Bool
$c/= :: CRC -> CRC -> Bool
/= :: CRC -> CRC -> Bool
Eq, Int -> CRC -> ShowS
[CRC] -> ShowS
CRC -> String
(Int -> CRC -> ShowS)
-> (CRC -> String) -> ([CRC] -> ShowS) -> Show CRC
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CRC -> ShowS
showsPrec :: Int -> CRC -> ShowS
$cshow :: CRC -> String
show :: CRC -> String
$cshowList :: [CRC] -> ShowS
showList :: [CRC] -> ShowS
Show, (forall x. CRC -> Rep CRC x)
-> (forall x. Rep CRC x -> CRC) -> Generic CRC
forall x. Rep CRC x -> CRC
forall x. CRC -> Rep CRC x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CRC -> Rep CRC x
from :: forall x. CRC -> Rep CRC x
$cto :: forall x. Rep CRC x -> CRC
to :: forall x. Rep CRC x -> CRC
Generic, Ptr CRC -> IO CRC
Ptr CRC -> Int -> IO CRC
Ptr CRC -> Int -> CRC -> IO ()
Ptr CRC -> CRC -> IO ()
CRC -> Int
(CRC -> Int)
-> (CRC -> Int)
-> (Ptr CRC -> Int -> IO CRC)
-> (Ptr CRC -> Int -> CRC -> IO ())
-> (forall b. Ptr b -> Int -> IO CRC)
-> (forall b. Ptr b -> Int -> CRC -> IO ())
-> (Ptr CRC -> IO CRC)
-> (Ptr CRC -> CRC -> IO ())
-> Storable CRC
forall b. Ptr b -> Int -> IO CRC
forall b. Ptr b -> Int -> CRC -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
$csizeOf :: CRC -> Int
sizeOf :: CRC -> Int
$calignment :: CRC -> Int
alignment :: CRC -> Int
$cpeekElemOff :: Ptr CRC -> Int -> IO CRC
peekElemOff :: Ptr CRC -> Int -> IO CRC
$cpokeElemOff :: Ptr CRC -> Int -> CRC -> IO ()
pokeElemOff :: Ptr CRC -> Int -> CRC -> IO ()
$cpeekByteOff :: forall b. Ptr b -> Int -> IO CRC
peekByteOff :: forall b. Ptr b -> Int -> IO CRC
$cpokeByteOff :: forall b. Ptr b -> Int -> CRC -> IO ()
pokeByteOff :: forall b. Ptr b -> Int -> CRC -> IO ()
$cpeek :: Ptr CRC -> IO CRC
peek :: Ptr CRC -> IO CRC
$cpoke :: Ptr CRC -> CRC -> IO ()
poke :: Ptr CRC -> CRC -> IO ()
Storable)

initCRC :: CRC
initCRC :: CRC
initCRC = Word32 -> CRC
CRC (Word32 -> CRC) -> Word32 -> CRC
forall a b. (a -> b) -> a -> b
$ [Word8] -> Word32
forall a. CRC32 a => a -> Word32
Digest.crc32 ([] :: [Word8])

updateCRC :: forall a. Digest.CRC32 a => a -> CRC -> CRC
updateCRC :: forall a. CRC32 a => a -> CRC -> CRC
updateCRC = (a -> Word32 -> Word32) -> a -> CRC -> CRC
forall a b. Coercible a b => a -> b
coerce ((Word32 -> a -> Word32) -> a -> Word32 -> Word32
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Word32 -> a -> Word32
forall a. CRC32 a => Word32 -> a -> Word32
Digest.crc32Update :: Word32 -> a -> Word32))

computeCRC :: forall a. Digest.CRC32 a => a -> CRC
computeCRC :: forall a. CRC32 a => a -> CRC
computeCRC = (a -> Word32) -> a -> CRC
forall a b. Coercible a b => a -> b
coerce (a -> Word32
forall a. CRC32 a => a -> Word32
Digest.crc32 :: a -> Word32)

{-------------------------------------------------------------------------------
  File system functions that compute CRCs
-------------------------------------------------------------------------------}

-- | Variation on 'hPutAll' that also computes a CRC
hPutAllCRC :: forall m h. (HasCallStack, Monad m)
           => HasFS m h
           -> Handle h
           -> BL.ByteString
           -> m (Word64, CRC)
hPutAllCRC :: forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m (Word64, CRC)
hPutAllCRC HasFS m h
hasFS Handle h
h = ((Word64, CRC) -> ByteString -> m (Word64, CRC))
-> (Word64, CRC) -> [ByteString] -> m (Word64, CRC)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Word64, CRC) -> ByteString -> m (Word64, CRC)
putChunk (Word64
0, CRC
initCRC) ([ByteString] -> m (Word64, CRC))
-> (ByteString -> [ByteString]) -> ByteString -> m (Word64, CRC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.toChunks
  where
    putChunk :: (Word64, CRC) -> BS.ByteString -> m (Word64, CRC)
    putChunk :: (Word64, CRC) -> ByteString -> m (Word64, CRC)
putChunk (Word64
written, CRC
crc) ByteString
chunk = do
      Word64
chunkSize <- HasFS m h -> Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
hPutAllStrict HasFS m h
hasFS Handle h
h ByteString
chunk
      let !written' :: Word64
written' = Word64
written Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
chunkSize
          !crc' :: CRC
crc'     = ByteString -> CRC -> CRC
forall a. CRC32 a => a -> CRC -> CRC
updateCRC ByteString
chunk CRC
crc
      (Word64, CRC) -> m (Word64, CRC)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
written', CRC
crc')

-- | Variation on 'hGetExactlyAt' that also computes a CRC
hGetExactlyAtCRC :: forall m h. (HasCallStack, MonadThrow m)
                 => HasFS m h
                 -> Handle h
                 -> Word64    -- ^ The number of bytes to read.
                 -> AbsOffset -- ^ The offset at which to read.
                 -> m (BL.ByteString, CRC)
hGetExactlyAtCRC :: forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h -> Handle h -> Word64 -> AbsOffset -> m (ByteString, CRC)
hGetExactlyAtCRC HasFS m h
hasFS Handle h
h Word64
n AbsOffset
offset = do
    -- TODO Interleave reading with computing the CRC. Better cache locality
    -- and fits better with incremental parsing, when we add support for that.
    ByteString
bs <- HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString
hGetExactlyAt HasFS m h
hasFS Handle h
h Word64
n AbsOffset
offset
    let !crc :: CRC
crc = ByteString -> CRC
forall a. CRC32 a => a -> CRC
computeCRC ByteString
bs
    (ByteString, CRC) -> m (ByteString, CRC)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, CRC
crc)

-- | Variation on 'hGetAllAt' that also computes a CRC
hGetAllAtCRC :: forall m h. Monad m
             => HasFS m h
             -> Handle h
             -> AbsOffset -- ^ The offset at which to read.
             -> m (BL.ByteString, CRC)
hGetAllAtCRC :: forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> AbsOffset -> m (ByteString, CRC)
hGetAllAtCRC HasFS m h
hasFS Handle h
h AbsOffset
offset = do
    -- TODO Interleave reading with computing the CRC. Better cache locality
    -- and fits better with incremental parsing, when we add support for that.
    ByteString
bs <- HasFS m h -> Handle h -> AbsOffset -> m ByteString
forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> AbsOffset -> m ByteString
hGetAllAt HasFS m h
hasFS Handle h
h AbsOffset
offset
    let !crc :: CRC
crc = ByteString -> CRC
forall a. CRC32 a => a -> CRC
computeCRC ByteString
bs
    (ByteString, CRC) -> m (ByteString, CRC)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, CRC
crc)