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

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

import           Control.Monad (foldM)
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           NoThunks.Class (NoThunks)

import           Control.Monad.Class.MonadThrow


import           Ouroboros.Consensus.Storage.FS.API
import           Ouroboros.Consensus.Storage.FS.API.Types (AbsOffset (..))

{-------------------------------------------------------------------------------
  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
/= :: CRC -> CRC -> Bool
$c/= :: CRC -> CRC -> Bool
== :: CRC -> CRC -> Bool
$c== :: 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
showList :: [CRC] -> ShowS
$cshowList :: [CRC] -> ShowS
show :: CRC -> String
$cshow :: CRC -> String
showsPrec :: Int -> CRC -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep CRC x -> CRC
$cfrom :: forall x. CRC -> Rep CRC x
Generic, Context -> CRC -> IO (Maybe ThunkInfo)
Proxy CRC -> String
(Context -> CRC -> IO (Maybe ThunkInfo))
-> (Context -> CRC -> IO (Maybe ThunkInfo))
-> (Proxy CRC -> String)
-> NoThunks CRC
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy CRC -> String
$cshowTypeOf :: Proxy CRC -> String
wNoThunks :: Context -> CRC -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> CRC -> IO (Maybe ThunkInfo)
noThunks :: Context -> CRC -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> CRC -> IO (Maybe ThunkInfo)
NoThunks, Ptr b -> Int -> IO CRC
Ptr b -> Int -> CRC -> IO ()
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
poke :: Ptr CRC -> CRC -> IO ()
$cpoke :: Ptr CRC -> CRC -> IO ()
peek :: Ptr CRC -> IO CRC
$cpeek :: Ptr CRC -> IO CRC
pokeByteOff :: Ptr b -> Int -> CRC -> IO ()
$cpokeByteOff :: forall b. Ptr b -> Int -> CRC -> IO ()
peekByteOff :: Ptr b -> Int -> IO CRC
$cpeekByteOff :: forall b. Ptr b -> Int -> IO CRC
pokeElemOff :: Ptr CRC -> Int -> CRC -> IO ()
$cpokeElemOff :: Ptr CRC -> Int -> CRC -> IO ()
peekElemOff :: Ptr CRC -> Int -> IO CRC
$cpeekElemOff :: Ptr CRC -> Int -> IO CRC
alignment :: CRC -> Int
$calignment :: CRC -> Int
sizeOf :: CRC -> Int
$csizeOf :: CRC -> Int
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 :: a -> CRC -> CRC
updateCRC = (a -> Word32 -> Word32) -> a -> CRC -> CRC
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 :: a -> CRC
computeCRC = (a -> Word32) -> a -> CRC
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 :: 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 (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 :: 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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, CRC
crc)