{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK not-home #-}

-- Needed by GHC <= 9.2 for newtype deriving Prim below
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE UnboxedTuples       #-}

-- | Functionalty related to CRC-32C (Castagnoli) checksums:
--
-- * Support for calculating checksums while incrementally writing files.
-- * Support for verifying checksums of files.
-- * Support for a text file format listing file checksums.
--
module Database.LSMTree.Internal.CRC32C (

  CRC32C(..),

  -- * Pure incremental checksum calculation
  initialCRC32C,
  updateCRC32C,

  -- * I\/O with checksum calculation
  hGetSomeCRC32C,
  hGetExactlyCRC32C,
  hPutSomeCRC32C,
  hPutAllCRC32C,
  hPutAllChunksCRC32C,
  readFileCRC32C,

  ChunkSize (..),
  defaultChunkSize,
  hGetExactlyCRC32C_SBS,
  hGetAllCRC32C',

  -- * Checksum files
  -- $checksum-files
  ChecksumsFile,
  ChecksumsFileName(..),
  getChecksum,
  readChecksumsFile,
  writeChecksumsFile,
  writeChecksumsFile',

  -- * Checksum checking
  checkCRC,
  expectChecksum,

  -- * File format errors
  FileFormat (..),
  FileCorruptedError (..),
  expectValidFile,
  ) where

import           Control.Monad
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Primitive
import           Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Internal as BS.Internal
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Short as SBS
import           Data.Char (ord)
import           Data.Digest.CRC32C as CRC
import           Data.Either (partitionEithers)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Primitive
import           Data.Word
import           GHC.Exts
import qualified GHC.ForeignPtr as Foreign
import           System.FS.API
import           System.FS.API.Lazy
import           System.FS.BlockIO.API (Advice (..), ByteCount, HasBlockIO,
                     hAdviseAll, hDropCacheAll)

newtype CRC32C = CRC32C {CRC32C -> Word32
unCRC32C :: Word32}
  deriving stock (CRC32C -> CRC32C -> Bool
(CRC32C -> CRC32C -> Bool)
-> (CRC32C -> CRC32C -> Bool) -> Eq CRC32C
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CRC32C -> CRC32C -> Bool
== :: CRC32C -> CRC32C -> Bool
$c/= :: CRC32C -> CRC32C -> Bool
/= :: CRC32C -> CRC32C -> Bool
Eq, Eq CRC32C
Eq CRC32C =>
(CRC32C -> CRC32C -> Ordering)
-> (CRC32C -> CRC32C -> Bool)
-> (CRC32C -> CRC32C -> Bool)
-> (CRC32C -> CRC32C -> Bool)
-> (CRC32C -> CRC32C -> Bool)
-> (CRC32C -> CRC32C -> CRC32C)
-> (CRC32C -> CRC32C -> CRC32C)
-> Ord CRC32C
CRC32C -> CRC32C -> Bool
CRC32C -> CRC32C -> Ordering
CRC32C -> CRC32C -> CRC32C
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CRC32C -> CRC32C -> Ordering
compare :: CRC32C -> CRC32C -> Ordering
$c< :: CRC32C -> CRC32C -> Bool
< :: CRC32C -> CRC32C -> Bool
$c<= :: CRC32C -> CRC32C -> Bool
<= :: CRC32C -> CRC32C -> Bool
$c> :: CRC32C -> CRC32C -> Bool
> :: CRC32C -> CRC32C -> Bool
$c>= :: CRC32C -> CRC32C -> Bool
>= :: CRC32C -> CRC32C -> Bool
$cmax :: CRC32C -> CRC32C -> CRC32C
max :: CRC32C -> CRC32C -> CRC32C
$cmin :: CRC32C -> CRC32C -> CRC32C
min :: CRC32C -> CRC32C -> CRC32C
Ord, Int -> CRC32C -> ShowS
[CRC32C] -> ShowS
CRC32C -> String
(Int -> CRC32C -> ShowS)
-> (CRC32C -> String) -> ([CRC32C] -> ShowS) -> Show CRC32C
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CRC32C -> ShowS
showsPrec :: Int -> CRC32C -> ShowS
$cshow :: CRC32C -> String
show :: CRC32C -> String
$cshowList :: [CRC32C] -> ShowS
showList :: [CRC32C] -> ShowS
Show)
  deriving newtype (Addr# -> Int# -> CRC32C
ByteArray# -> Int# -> CRC32C
Proxy CRC32C -> Int#
CRC32C -> Int#
(Proxy CRC32C -> Int#)
-> (CRC32C -> Int#)
-> (Proxy CRC32C -> Int#)
-> (CRC32C -> Int#)
-> (ByteArray# -> Int# -> CRC32C)
-> (forall s.
    MutableByteArray# s -> Int# -> State# s -> (# State# s, CRC32C #))
-> (forall s.
    MutableByteArray# s -> Int# -> CRC32C -> State# s -> State# s)
-> (forall s.
    MutableByteArray# s
    -> Int# -> Int# -> CRC32C -> State# s -> State# s)
-> (Addr# -> Int# -> CRC32C)
-> (forall s. Addr# -> Int# -> State# s -> (# State# s, CRC32C #))
-> (forall s. Addr# -> Int# -> CRC32C -> State# s -> State# s)
-> (forall s.
    Addr# -> Int# -> Int# -> CRC32C -> State# s -> State# s)
-> Prim CRC32C
forall s. Addr# -> Int# -> Int# -> CRC32C -> State# s -> State# s
forall s. Addr# -> Int# -> State# s -> (# State# s, CRC32C #)
forall s. Addr# -> Int# -> CRC32C -> State# s -> State# s
forall s.
MutableByteArray# s
-> Int# -> Int# -> CRC32C -> State# s -> State# s
forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, CRC32C #)
forall s.
MutableByteArray# s -> Int# -> CRC32C -> State# s -> State# s
forall a.
(Proxy a -> Int#)
-> (a -> Int#)
-> (Proxy a -> Int#)
-> (a -> Int#)
-> (ByteArray# -> Int# -> a)
-> (forall s.
    MutableByteArray# s -> Int# -> State# s -> (# State# s, a #))
-> (forall s.
    MutableByteArray# s -> Int# -> a -> State# s -> State# s)
-> (forall s.
    MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s)
-> (Addr# -> Int# -> a)
-> (forall s. Addr# -> Int# -> State# s -> (# State# s, a #))
-> (forall s. Addr# -> Int# -> a -> State# s -> State# s)
-> (forall s. Addr# -> Int# -> Int# -> a -> State# s -> State# s)
-> Prim a
$csizeOfType# :: Proxy CRC32C -> Int#
sizeOfType# :: Proxy CRC32C -> Int#
$csizeOf# :: CRC32C -> Int#
sizeOf# :: CRC32C -> Int#
$calignmentOfType# :: Proxy CRC32C -> Int#
alignmentOfType# :: Proxy CRC32C -> Int#
$calignment# :: CRC32C -> Int#
alignment# :: CRC32C -> Int#
$cindexByteArray# :: ByteArray# -> Int# -> CRC32C
indexByteArray# :: ByteArray# -> Int# -> CRC32C
$creadByteArray# :: forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, CRC32C #)
readByteArray# :: forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, CRC32C #)
$cwriteByteArray# :: forall s.
MutableByteArray# s -> Int# -> CRC32C -> State# s -> State# s
writeByteArray# :: forall s.
MutableByteArray# s -> Int# -> CRC32C -> State# s -> State# s
$csetByteArray# :: forall s.
MutableByteArray# s
-> Int# -> Int# -> CRC32C -> State# s -> State# s
setByteArray# :: forall s.
MutableByteArray# s
-> Int# -> Int# -> CRC32C -> State# s -> State# s
$cindexOffAddr# :: Addr# -> Int# -> CRC32C
indexOffAddr# :: Addr# -> Int# -> CRC32C
$creadOffAddr# :: forall s. Addr# -> Int# -> State# s -> (# State# s, CRC32C #)
readOffAddr# :: forall s. Addr# -> Int# -> State# s -> (# State# s, CRC32C #)
$cwriteOffAddr# :: forall s. Addr# -> Int# -> CRC32C -> State# s -> State# s
writeOffAddr# :: forall s. Addr# -> Int# -> CRC32C -> State# s -> State# s
$csetOffAddr# :: forall s. Addr# -> Int# -> Int# -> CRC32C -> State# s -> State# s
setOffAddr# :: forall s. Addr# -> Int# -> Int# -> CRC32C -> State# s -> State# s
Prim)


initialCRC32C :: CRC32C
initialCRC32C :: CRC32C
initialCRC32C = Word32 -> CRC32C
CRC32C Word32
0 -- same as crc32c BS.empty


updateCRC32C :: BS.ByteString -> CRC32C -> CRC32C
updateCRC32C :: ByteString -> CRC32C -> CRC32C
updateCRC32C ByteString
bs (CRC32C Word32
crc) = Word32 -> CRC32C
CRC32C (Word32 -> ByteString -> Word32
CRC.crc32c_update Word32
crc ByteString
bs)

{-# SPECIALISE hGetSomeCRC32C :: HasFS IO h -> Handle h -> Word64 -> CRC32C -> IO (BS.ByteString, CRC32C) #-}
hGetSomeCRC32C :: Monad m
               => HasFS m h
               -> Handle h
               -> Word64
               -> CRC32C -> m (BS.ByteString, CRC32C)
hGetSomeCRC32C :: forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> Word64 -> CRC32C -> m (ByteString, CRC32C)
hGetSomeCRC32C HasFS m h
fs Handle h
h Word64
n CRC32C
crc = do
    ByteString
bs <- HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
hGetSome HasFS m h
fs Handle h
h Word64
n
    let !crc' :: CRC32C
crc' = ByteString -> CRC32C -> CRC32C
updateCRC32C ByteString
bs CRC32C
crc
    (ByteString, CRC32C) -> m (ByteString, CRC32C)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, CRC32C
crc')


-- | This function ensures that exactly the requested number of bytes is read.
-- If the file is too short, an 'FsError' of type 'FsReachedEOF' is thrown.
--
-- It attempts to read everything into a single strict chunk, which should
-- almost always succeed. If it doesn't, multiple chunks are produced.
--
-- TODO: To reliably return a strict bytestring without additional copying,
-- @fs-api@ needs to support directly reading into a buffer, which is currently
-- work in progress: <https://github.com/input-output-hk/fs-sim/pull/46>
{-# SPECIALISE hGetExactlyCRC32C :: HasFS IO h -> Handle h -> Word64 -> CRC32C -> IO (BSL.ByteString, CRC32C) #-}
hGetExactlyCRC32C :: MonadThrow m
               => HasFS m h
               -> Handle h
               -> Word64
               -> CRC32C -> m (BSL.ByteString, CRC32C)
hGetExactlyCRC32C :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> Handle h -> Word64 -> CRC32C -> m (ByteString, CRC32C)
hGetExactlyCRC32C HasFS m h
fs Handle h
h Word64
n CRC32C
crc = do
    ByteString
lbs <- HasFS m h -> Handle h -> Word64 -> m ByteString
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h -> Handle h -> Word64 -> m ByteString
hGetExactly HasFS m h
fs Handle h
h Word64
n
    let !crc' :: CRC32C
crc' = (CRC32C -> ByteString -> CRC32C) -> CRC32C -> ByteString -> CRC32C
forall a. (a -> ByteString -> a) -> a -> ByteString -> a
BSL.foldlChunks ((ByteString -> CRC32C -> CRC32C) -> CRC32C -> ByteString -> CRC32C
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> CRC32C -> CRC32C
updateCRC32C) CRC32C
crc ByteString
lbs
    (ByteString, CRC32C) -> m (ByteString, CRC32C)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
lbs, CRC32C
crc')


{-# SPECIALISE hPutSomeCRC32C :: HasFS IO h -> Handle h -> BS.ByteString -> CRC32C -> IO (Word64, CRC32C) #-}
hPutSomeCRC32C :: Monad m
               => HasFS m h
               -> Handle h
               -> BS.ByteString
               -> CRC32C -> m (Word64, CRC32C)
hPutSomeCRC32C :: forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> ByteString -> CRC32C -> m (Word64, CRC32C)
hPutSomeCRC32C HasFS m h
fs Handle h
h ByteString
bs CRC32C
crc = do
    !Word64
n <- HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hPutSome HasFS m h
fs Handle h
h ByteString
bs
    let !crc' :: CRC32C
crc' = ByteString -> CRC32C -> CRC32C
updateCRC32C (Int -> ByteString -> ByteString
BS.take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) ByteString
bs) CRC32C
crc
    (Word64, CRC32C) -> m (Word64, CRC32C)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
n, CRC32C
crc')


-- | This function makes sure that the whole 'BS.ByteString' is written.
{-# SPECIALISE hPutAllCRC32C :: HasFS IO h -> Handle h -> BS.ByteString -> CRC32C -> IO (Word64, CRC32C) #-}
hPutAllCRC32C :: forall m h
              .  Monad m
              => HasFS m h
              -> Handle h
              -> BS.ByteString
              -> CRC32C -> m (Word64, CRC32C)
hPutAllCRC32C :: forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> ByteString -> CRC32C -> m (Word64, CRC32C)
hPutAllCRC32C HasFS m h
fs Handle h
h = Word64 -> ByteString -> CRC32C -> m (Word64, CRC32C)
go Word64
0
  where
    go :: Word64 -> BS.ByteString -> CRC32C -> m (Word64, CRC32C)
    go :: Word64 -> ByteString -> CRC32C -> m (Word64, CRC32C)
go !Word64
written !ByteString
bs !CRC32C
crc = do
      (Word64
n, CRC32C
crc') <- HasFS m h -> Handle h -> ByteString -> CRC32C -> m (Word64, CRC32C)
forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> ByteString -> CRC32C -> m (Word64, CRC32C)
hPutSomeCRC32C HasFS m h
fs Handle h
h ByteString
bs CRC32C
crc
      let bs' :: ByteString
bs'      = Int -> ByteString -> ByteString
BS.drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) ByteString
bs
          written' :: Word64
written' = Word64
written Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
n
      if ByteString -> Bool
BS.null ByteString
bs'
        then (Word64, CRC32C) -> m (Word64, CRC32C)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
written', CRC32C
crc')
        else Word64 -> ByteString -> CRC32C -> m (Word64, CRC32C)
go Word64
written' ByteString
bs' CRC32C
crc'

-- | This function makes sure that the whole /lazy/ 'BSL.ByteString' is written.
{-# SPECIALISE hPutAllChunksCRC32C :: HasFS IO h -> Handle h -> BSL.ByteString -> CRC32C -> IO (Word64, CRC32C) #-}
hPutAllChunksCRC32C :: forall m h
                    .  Monad m
                    => HasFS m h
                    -> Handle h
                    -> BSL.ByteString
                    -> CRC32C -> m (Word64, CRC32C)
hPutAllChunksCRC32C :: forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> ByteString -> CRC32C -> m (Word64, CRC32C)
hPutAllChunksCRC32C HasFS m h
fs Handle h
h = \ByteString
lbs CRC32C
crc ->
    ((Word64, CRC32C) -> ByteString -> m (Word64, CRC32C))
-> (Word64, CRC32C) -> [ByteString] -> m (Word64, CRC32C)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Word64 -> CRC32C -> ByteString -> m (Word64, CRC32C))
-> (Word64, CRC32C) -> ByteString -> m (Word64, CRC32C)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word64 -> CRC32C -> ByteString -> m (Word64, CRC32C)
putChunk) (Word64
0, CRC32C
crc) (ByteString -> [ByteString]
BSL.toChunks ByteString
lbs)
  where
    putChunk :: Word64 -> CRC32C -> BS.ByteString -> m (Word64, CRC32C)
    putChunk :: Word64 -> CRC32C -> ByteString -> m (Word64, CRC32C)
putChunk !Word64
written !CRC32C
crc !ByteString
bs = do
      (Word64
n, CRC32C
crc') <- HasFS m h -> Handle h -> ByteString -> CRC32C -> m (Word64, CRC32C)
forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> ByteString -> CRC32C -> m (Word64, CRC32C)
hPutAllCRC32C HasFS m h
fs Handle h
h ByteString
bs CRC32C
crc
      (Word64, CRC32C) -> m (Word64, CRC32C)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
written Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
n, CRC32C
crc')

{-# SPECIALISE readFileCRC32C :: HasFS IO h -> FsPath -> IO CRC32C #-}
readFileCRC32C :: forall m h. MonadThrow m => HasFS m h -> FsPath -> m CRC32C
readFileCRC32C :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> FsPath -> m CRC32C
readFileCRC32C HasFS m h
fs FsPath
file =
    HasFS m h
-> FsPath -> OpenMode -> (Handle h -> m CRC32C) -> m CRC32C
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
fs FsPath
file OpenMode
ReadMode (\Handle h
h -> Handle h -> CRC32C -> m CRC32C
go Handle h
h CRC32C
initialCRC32C)
  where
    go :: Handle h -> CRC32C -> m CRC32C
    go :: Handle h -> CRC32C -> m CRC32C
go !Handle h
h !CRC32C
crc = do
      ByteString
bs <- HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
hGetSome HasFS m h
fs Handle h
h Word64
65504  -- 2^16 - 4 words overhead
      if ByteString -> Bool
BS.null ByteString
bs
        then CRC32C -> m CRC32C
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CRC32C
crc
        else Handle h -> CRC32C -> m CRC32C
go Handle h
h (ByteString -> CRC32C -> CRC32C
updateCRC32C ByteString
bs CRC32C
crc)

newtype ChunkSize = ChunkSize ByteCount

defaultChunkSize :: ChunkSize
defaultChunkSize :: ChunkSize
defaultChunkSize = ByteCount -> ChunkSize
ChunkSize ByteCount
65504 -- 2^16 - 4 words overhead

{-# SPECIALISE hGetExactlyCRC32C_SBS :: HasFS IO h -> Handle h -> ByteCount -> CRC32C -> IO (SBS.ShortByteString, CRC32C) #-}
-- | Reads exactly as many bytes as requested, returning a 'ShortByteString' and
-- updating a given 'CRC32C' value.
--
-- If EOF is found before the requested number of bytes is read, an FsError
-- exception is thrown.
--
-- The returned 'ShortByteString' is backed by pinned memory.
hGetExactlyCRC32C_SBS ::
     forall m h. (MonadThrow m, PrimMonad m)
  => HasFS m h
  -> Handle h
  -> ByteCount -- ^ Number of bytes to read
  -> CRC32C
  -> m (SBS.ShortByteString, CRC32C)
hGetExactlyCRC32C_SBS :: forall (m :: * -> *) h.
(MonadThrow m, PrimMonad m) =>
HasFS m h
-> Handle h -> ByteCount -> CRC32C -> m (ShortByteString, CRC32C)
hGetExactlyCRC32C_SBS HasFS m h
hfs Handle h
h !ByteCount
c !CRC32C
crc = do
    buf :: MutableByteArray (PrimState m)
buf@(MutableByteArray !MutableByteArray# (PrimState m)
mba#) <- Int -> m (MutableByteArray (PrimState m))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
c)
    m ByteCount -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ByteCount -> m ()) -> m ByteCount -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h
-> Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h
-> Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufExactly HasFS m h
hfs Handle h
h MutableByteArray (PrimState m)
buf BufferOffset
0 ByteCount
c
    (ByteArray !ByteArray#
ba#) <- MutableByteArray (PrimState m) -> m ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray (PrimState m)
buf
    let fp :: ForeignPtr Word8
fp = Addr# -> ForeignPtrContents -> ForeignPtr Word8
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
Foreign.ForeignPtr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba#) (MutableByteArray# RealWorld -> ForeignPtrContents
Foreign.PlainPtr (MutableByteArray# (PrimState m) -> MutableByteArray# RealWorld
forall a b. a -> b
unsafeCoerce# MutableByteArray# (PrimState m)
mba#))
        !bs :: ByteString
bs = ForeignPtr Word8 -> Int -> ByteString
BS.Internal.BS ForeignPtr Word8
fp (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
c)
        !crc' :: CRC32C
crc' = ByteString -> CRC32C -> CRC32C
updateCRC32C ByteString
bs CRC32C
crc
    (ShortByteString, CRC32C) -> m (ShortByteString, CRC32C)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteArray# -> ShortByteString
SBS.SBS ByteArray#
ba#, CRC32C
crc')

{-# SPECIALISE hGetAllCRC32C' :: HasFS IO h -> Handle h -> ChunkSize -> CRC32C -> IO CRC32C #-}
-- | Reads all bytes, updating a given 'CRC32C' value without returning the
-- bytes.
hGetAllCRC32C' ::
     forall m h. PrimMonad m
  => HasFS m h
  -> Handle h
  -> ChunkSize -- ^ Chunk size, must be larger than 0
  -> CRC32C
  -> m CRC32C
hGetAllCRC32C' :: forall (m :: * -> *) h.
PrimMonad m =>
HasFS m h -> Handle h -> ChunkSize -> CRC32C -> m CRC32C
hGetAllCRC32C' HasFS m h
hfs Handle h
h (ChunkSize !ByteCount
chunkSize) !CRC32C
crc0
  | ByteCount
chunkSize ByteCount -> ByteCount -> Bool
forall a. Ord a => a -> a -> Bool
<= ByteCount
0
  = String -> m CRC32C
forall a. HasCallStack => String -> a
error String
"hGetAllCRC32C': chunkSize must be >0"
  | Bool
otherwise
  = do
      buf :: MutableByteArray (PrimState m)
buf@(MutableByteArray !MutableByteArray# (PrimState m)
mba#) <- Int -> m (MutableByteArray (PrimState m))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
chunkSize)
      (ByteArray !ByteArray#
ba#) <- MutableByteArray (PrimState m) -> m ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray (PrimState m)
buf
      let fp :: ForeignPtr Word8
fp = Addr# -> ForeignPtrContents -> ForeignPtr Word8
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
Foreign.ForeignPtr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba#) (MutableByteArray# RealWorld -> ForeignPtrContents
Foreign.PlainPtr (MutableByteArray# (PrimState m) -> MutableByteArray# RealWorld
forall a b. a -> b
unsafeCoerce# MutableByteArray# (PrimState m)
mba#))
          !bs :: ByteString
bs = ForeignPtr Word8 -> Int -> ByteString
BS.Internal.BS ForeignPtr Word8
fp (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
chunkSize)
      ByteString -> MutableByteArray (PrimState m) -> CRC32C -> m CRC32C
go ByteString
bs MutableByteArray (PrimState m)
buf CRC32C
crc0
  where
    -- In particular, note that the "immutable" bs :: BS.ByteString aliases the
    -- mutable buf :: MutableByteArray. This is a bit hairy but we need to do
    -- something like this because the CRC code only works with ByteString.
    -- We thus have to be very careful about when bs is used.
    go :: BS.ByteString -> MutableByteArray (PrimState m) -> CRC32C -> m CRC32C
    go :: ByteString -> MutableByteArray (PrimState m) -> CRC32C -> m CRC32C
go !ByteString
bs MutableByteArray (PrimState m)
buf !CRC32C
crc = do
      !ByteCount
n <- HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hGetBufSome HasFS m h
hfs Handle h
h MutableByteArray (PrimState m)
buf BufferOffset
0 ByteCount
chunkSize
      if ByteCount
n ByteCount -> ByteCount -> Bool
forall a. Eq a => a -> a -> Bool
== ByteCount
0
        then CRC32C -> m CRC32C
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CRC32C
crc
        else do
          -- compute the update CRC value before reading the next bytes
          let !crc' :: CRC32C
crc' = ByteString -> CRC32C -> CRC32C
updateCRC32C (Int -> ByteString -> ByteString
BS.take (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
n) ByteString
bs) CRC32C
crc
          ByteString -> MutableByteArray (PrimState m) -> CRC32C -> m CRC32C
go ByteString
bs MutableByteArray (PrimState m)
buf CRC32C
crc'


{- $checksum-files
We use @.checksum@ files to help verify the integrity of on disk snapshots.
Each .checksum file lists the CRC-32C (Castagnoli) of other files. For further
details see @doc/format-directory.md@.

The file uses the BSD-style checksum format (e.g. as produced by tools like
@md5sum --tag@), with the algorithm name \"CRC32C\". This format is text,
one line per file, using hexedecimal for the 32bit output.

Checksum files are used for each LSM run, and for the snapshot metadata.

Typical examples are:

> CRC32C (keyops) = fd040004
> CRC32C (blobs) = 5a3b820c
> CRC32C (filter) = 6653e178
> CRC32C (index) = f4ec6724

Or

> CRC32C (snapshot) = 87972d7f
-}

type ChecksumsFile = Map ChecksumsFileName CRC32C

-- | File names must not include characters @'('@, @')'@ or @'\n'@.
--
newtype ChecksumsFileName = ChecksumsFileName {ChecksumsFileName -> ByteString
unChecksumsFileName :: BSC.ByteString}
  deriving stock (ChecksumsFileName -> ChecksumsFileName -> Bool
(ChecksumsFileName -> ChecksumsFileName -> Bool)
-> (ChecksumsFileName -> ChecksumsFileName -> Bool)
-> Eq ChecksumsFileName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChecksumsFileName -> ChecksumsFileName -> Bool
== :: ChecksumsFileName -> ChecksumsFileName -> Bool
$c/= :: ChecksumsFileName -> ChecksumsFileName -> Bool
/= :: ChecksumsFileName -> ChecksumsFileName -> Bool
Eq, Eq ChecksumsFileName
Eq ChecksumsFileName =>
(ChecksumsFileName -> ChecksumsFileName -> Ordering)
-> (ChecksumsFileName -> ChecksumsFileName -> Bool)
-> (ChecksumsFileName -> ChecksumsFileName -> Bool)
-> (ChecksumsFileName -> ChecksumsFileName -> Bool)
-> (ChecksumsFileName -> ChecksumsFileName -> Bool)
-> (ChecksumsFileName -> ChecksumsFileName -> ChecksumsFileName)
-> (ChecksumsFileName -> ChecksumsFileName -> ChecksumsFileName)
-> Ord ChecksumsFileName
ChecksumsFileName -> ChecksumsFileName -> Bool
ChecksumsFileName -> ChecksumsFileName -> Ordering
ChecksumsFileName -> ChecksumsFileName -> ChecksumsFileName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ChecksumsFileName -> ChecksumsFileName -> Ordering
compare :: ChecksumsFileName -> ChecksumsFileName -> Ordering
$c< :: ChecksumsFileName -> ChecksumsFileName -> Bool
< :: ChecksumsFileName -> ChecksumsFileName -> Bool
$c<= :: ChecksumsFileName -> ChecksumsFileName -> Bool
<= :: ChecksumsFileName -> ChecksumsFileName -> Bool
$c> :: ChecksumsFileName -> ChecksumsFileName -> Bool
> :: ChecksumsFileName -> ChecksumsFileName -> Bool
$c>= :: ChecksumsFileName -> ChecksumsFileName -> Bool
>= :: ChecksumsFileName -> ChecksumsFileName -> Bool
$cmax :: ChecksumsFileName -> ChecksumsFileName -> ChecksumsFileName
max :: ChecksumsFileName -> ChecksumsFileName -> ChecksumsFileName
$cmin :: ChecksumsFileName -> ChecksumsFileName -> ChecksumsFileName
min :: ChecksumsFileName -> ChecksumsFileName -> ChecksumsFileName
Ord, Int -> ChecksumsFileName -> ShowS
[ChecksumsFileName] -> ShowS
ChecksumsFileName -> String
(Int -> ChecksumsFileName -> ShowS)
-> (ChecksumsFileName -> String)
-> ([ChecksumsFileName] -> ShowS)
-> Show ChecksumsFileName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChecksumsFileName -> ShowS
showsPrec :: Int -> ChecksumsFileName -> ShowS
$cshow :: ChecksumsFileName -> String
show :: ChecksumsFileName -> String
$cshowList :: [ChecksumsFileName] -> ShowS
showList :: [ChecksumsFileName] -> ShowS
Show)

{-# SPECIALISE
  getChecksum ::
     FsPath
  -> ChecksumsFile
  -> ChecksumsFileName
  -> IO CRC32C
  #-}
getChecksum ::
     MonadThrow m
  => FsPath
  -> ChecksumsFile
  -> ChecksumsFileName
  -> m CRC32C
getChecksum :: forall (m :: * -> *).
MonadThrow m =>
FsPath -> ChecksumsFile -> ChecksumsFileName -> m CRC32C
getChecksum FsPath
fsPath ChecksumsFile
checksumsFile ChecksumsFileName
checksumsFileName =
  case ChecksumsFileName -> ChecksumsFile -> Maybe CRC32C
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ChecksumsFileName
checksumsFileName ChecksumsFile
checksumsFile of
    Just CRC32C
checksum ->
      CRC32C -> m CRC32C
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CRC32C
checksum
    Maybe CRC32C
Nothing ->
      FileCorruptedError -> m CRC32C
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FileCorruptedError -> m CRC32C)
-> (String -> FileCorruptedError) -> String -> m CRC32C
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsPath -> FileFormat -> String -> FileCorruptedError
ErrFileFormatInvalid FsPath
fsPath FileFormat
FormatChecksumsFile (String -> m CRC32C) -> String -> m CRC32C
forall a b. (a -> b) -> a -> b
$
        String
"could not find checksum for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show (ChecksumsFileName -> ByteString
unChecksumsFileName ChecksumsFileName
checksumsFileName)

{-# SPECIALISE
  readChecksumsFile ::
       HasFS IO h
    -> FsPath
    -> IO ChecksumsFile
    #-}
readChecksumsFile ::
     (MonadThrow m)
  => HasFS m h
  -> FsPath
  -> m ChecksumsFile
readChecksumsFile :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> FsPath -> m ChecksumsFile
readChecksumsFile HasFS m h
fs FsPath
path = do
    ByteString
str <- HasFS m h
-> FsPath -> OpenMode -> (Handle h -> m ByteString) -> m ByteString
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
fs FsPath
path OpenMode
ReadMode (\Handle h
h -> HasFS m h -> Handle h -> m ByteString
forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> m ByteString
hGetAll HasFS m h
fs Handle h
h)
    FsPath
-> FileFormat -> Either String ChecksumsFile -> m ChecksumsFile
forall (m :: * -> *) a.
MonadThrow m =>
FsPath -> FileFormat -> Either String a -> m a
expectValidFile FsPath
path FileFormat
FormatChecksumsFile (ByteString -> Either String ChecksumsFile
parseChecksumsFile (ByteString -> ByteString
BSL.toStrict ByteString
str))

{-# SPECIALISE writeChecksumsFile :: HasFS IO h -> FsPath -> ChecksumsFile -> IO () #-}
writeChecksumsFile :: MonadThrow m
                   => HasFS m h -> FsPath -> ChecksumsFile -> m ()
writeChecksumsFile :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> FsPath -> ChecksumsFile -> m ()
writeChecksumsFile HasFS m h
fs FsPath
path ChecksumsFile
checksums =
    HasFS m h -> FsPath -> OpenMode -> (Handle h -> m ()) -> m ()
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
fs FsPath
path (AllowExisting -> OpenMode
WriteMode AllowExisting
MustBeNew) ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle h
h -> do
      Word64
_ <- HasFS m h -> Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
hPutAll HasFS m h
fs Handle h
h (ChecksumsFile -> ByteString
formatChecksumsFile ChecksumsFile
checksums)
      () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-# SPECIALISE writeChecksumsFile' :: HasFS IO h -> Handle h -> ChecksumsFile -> IO () #-}
writeChecksumsFile' :: MonadThrow m
                    => HasFS m h -> Handle h -> ChecksumsFile -> m ()
writeChecksumsFile' :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> Handle h -> ChecksumsFile -> m ()
writeChecksumsFile' HasFS m h
fs Handle h
h ChecksumsFile
checksums = m Word64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
hPutAll HasFS m h
fs Handle h
h (ChecksumsFile -> ByteString
formatChecksumsFile ChecksumsFile
checksums)

parseChecksumsFile :: BSC.ByteString -> Either String ChecksumsFile
parseChecksumsFile :: ByteString -> Either String ChecksumsFile
parseChecksumsFile ByteString
content =
    case [Either ByteString (ChecksumsFileName, CRC32C)]
-> ([ByteString], [(ChecksumsFileName, CRC32C)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (ByteString -> [Either ByteString (ChecksumsFileName, CRC32C)]
parseLines ByteString
content) of
      ([], [(ChecksumsFileName, CRC32C)]
entries)    -> ChecksumsFile -> Either String ChecksumsFile
forall a b. b -> Either a b
Right (ChecksumsFile -> Either String ChecksumsFile)
-> ChecksumsFile -> Either String ChecksumsFile
forall a b. (a -> b) -> a -> b
$! [(ChecksumsFileName, CRC32C)] -> ChecksumsFile
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ChecksumsFileName, CRC32C)]
entries
      ((ByteString
badline:[ByteString]
_), [(ChecksumsFileName, CRC32C)]
_) -> String -> Either String ChecksumsFile
forall a b. a -> Either a b
Left (String -> Either String ChecksumsFile)
-> String -> Either String ChecksumsFile
forall a b. (a -> b) -> a -> b
$! String
"could not parse '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BSC.unpack ByteString
badline String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'"
  where
    parseLines :: ByteString -> [Either ByteString (ChecksumsFileName, CRC32C)]
parseLines = (ByteString -> Either ByteString (ChecksumsFileName, CRC32C))
-> [ByteString] -> [Either ByteString (ChecksumsFileName, CRC32C)]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
l -> Either ByteString (ChecksumsFileName, CRC32C)
-> ((ChecksumsFileName, CRC32C)
    -> Either ByteString (ChecksumsFileName, CRC32C))
-> Maybe (ChecksumsFileName, CRC32C)
-> Either ByteString (ChecksumsFileName, CRC32C)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> Either ByteString (ChecksumsFileName, CRC32C)
forall a b. a -> Either a b
Left ByteString
l) (ChecksumsFileName, CRC32C)
-> Either ByteString (ChecksumsFileName, CRC32C)
forall a b. b -> Either a b
Right (ByteString -> Maybe (ChecksumsFileName, CRC32C)
parseChecksumFileLine ByteString
l))
               ([ByteString] -> [Either ByteString (ChecksumsFileName, CRC32C)])
-> (ByteString -> [ByteString])
-> ByteString
-> [Either ByteString (ChecksumsFileName, CRC32C)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
BSC.null)
               ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BSC.lines

parseChecksumFileLine :: BSC.ByteString -> Maybe (ChecksumsFileName, CRC32C)
parseChecksumFileLine :: ByteString -> Maybe (ChecksumsFileName, CRC32C)
parseChecksumFileLine ByteString
str0 = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int -> ByteString -> ByteString
BSC.take Int
8 ByteString
str0 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"CRC32C (")
    let str1 :: ByteString
str1 = Int -> ByteString -> ByteString
BSC.drop Int
8 ByteString
str0
    let (ByteString
name, ByteString
str2) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BSC.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
')') ByteString
str1
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int -> ByteString -> ByteString
BSC.take Int
4 ByteString
str2 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
") = ")
    let str3 :: ByteString
str3 = Int -> ByteString -> ByteString
BSC.drop Int
4 ByteString
str2
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
BSC.length ByteString
str3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 Bool -> Bool -> Bool
&& (Char -> Bool) -> ByteString -> Bool
BSC.all Char -> Bool
isHexDigit ByteString
str3)
    let !crc :: Word32
crc = Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Word
hexdigitsToInt ByteString
str3)
    (ChecksumsFileName, CRC32C) -> Maybe (ChecksumsFileName, CRC32C)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ChecksumsFileName
ChecksumsFileName ByteString
name, Word32 -> CRC32C
CRC32C Word32
crc)

isHexDigit :: Char -> Bool
isHexDigit :: Char -> Bool
isHexDigit Char
c = (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')
            Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f') --lower case only

-- Precondition: BSC.all isHexDigit
hexdigitsToInt :: BSC.ByteString -> Word
hexdigitsToInt :: ByteString -> Word
hexdigitsToInt =
    (Word -> Char -> Word) -> Word -> ByteString -> Word
forall a. (a -> Char -> a) -> a -> ByteString -> a
BSC.foldl' Word -> Char -> Word
accumdigit Word
0
  where
    accumdigit :: Word -> Char -> Word
    accumdigit :: Word -> Char -> Word
accumdigit !Word
a !Char
c =
      (Word
a Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Char -> Word
hexdigitToWord Char
c

-- Precondition: isHexDigit
hexdigitToWord :: Char -> Word
hexdigitToWord :: Char -> Word
hexdigitToWord Char
c
  | let !dec :: Word
dec = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0')
  , Word
dec Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
9  = Word
dec

  | let !hex :: Word
hex = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10)
  , Bool
otherwise = Word
hex

formatChecksumsFile :: ChecksumsFile -> BSL.ByteString
formatChecksumsFile :: ChecksumsFile -> ByteString
formatChecksumsFile ChecksumsFile
checksums =
    Builder -> ByteString
BS.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
      [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [    ByteString -> Builder
BS.byteString ByteString
"CRC32C ("
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BS.byteString ByteString
name
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BS.byteString ByteString
") = "
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
BS.word32HexFixed Word32
crc
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BS.char8 Char
'\n'
        | (ChecksumsFileName ByteString
name, CRC32C Word32
crc) <- ChecksumsFile -> [(ChecksumsFileName, CRC32C)]
forall k a. Map k a -> [(k, a)]
Map.toList ChecksumsFile
checksums ]

{-------------------------------------------------------------------------------
  Checksum errors
-------------------------------------------------------------------------------}

-- | Check the CRC32C checksum for a file.
--
--   If the boolean argument is @True@, all file data for this path is evicted
--   from the page cache.
{-# SPECIALISE
  checkCRC ::
       HasFS IO h
    -> HasBlockIO IO h
    -> Bool
    -> CRC32C
    -> FsPath
    -> IO ()
  #-}
checkCRC ::
     forall m h.
     (MonadMask m, PrimMonad m)
  => HasFS m h
  -> HasBlockIO m h
  -> Bool
  -> CRC32C
  -> FsPath
  -> m ()
checkCRC :: forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h -> HasBlockIO m h -> Bool -> CRC32C -> FsPath -> m ()
checkCRC HasFS m h
fs HasBlockIO m h
hbio Bool
dropCache CRC32C
expected FsPath
fp = HasFS m h -> FsPath -> OpenMode -> (Handle h -> m ()) -> m ()
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
fs FsPath
fp OpenMode
ReadMode ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle h
h -> do
  -- double the file readahead window (only applies to this file descriptor)
  HasBlockIO m h -> Handle h -> Advice -> m ()
forall (m :: * -> *) h.
HasBlockIO m h -> Handle h -> Advice -> m ()
hAdviseAll HasBlockIO m h
hbio Handle h
h Advice
AdviceSequential
  !CRC32C
checksum <- HasFS m h -> Handle h -> ChunkSize -> CRC32C -> m CRC32C
forall (m :: * -> *) h.
PrimMonad m =>
HasFS m h -> Handle h -> ChunkSize -> CRC32C -> m CRC32C
hGetAllCRC32C' HasFS m h
fs Handle h
h ChunkSize
defaultChunkSize CRC32C
initialCRC32C
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
dropCache (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ HasBlockIO m h -> Handle h -> m ()
forall (m :: * -> *) h. HasBlockIO m h -> Handle h -> m ()
hDropCacheAll HasBlockIO m h
hbio Handle h
h
  FsPath -> CRC32C -> CRC32C -> m ()
forall (m :: * -> *).
MonadThrow m =>
FsPath -> CRC32C -> CRC32C -> m ()
expectChecksum FsPath
fp CRC32C
expected CRC32C
checksum

{-# SPECIALISE
  expectChecksum ::
     FsPath
  -> CRC32C
  -> CRC32C
  -> IO ()
  #-}
expectChecksum ::
     MonadThrow m
  => FsPath
  -> CRC32C
  -> CRC32C
  -> m ()
expectChecksum :: forall (m :: * -> *).
MonadThrow m =>
FsPath -> CRC32C -> CRC32C -> m ()
expectChecksum FsPath
fp CRC32C
expected CRC32C
checksum =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CRC32C
expected CRC32C -> CRC32C -> Bool
forall a. Eq a => a -> a -> Bool
/= CRC32C
checksum) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      FileCorruptedError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FileCorruptedError -> m ()) -> FileCorruptedError -> m ()
forall a b. (a -> b) -> a -> b
$ FsPath -> Word32 -> Word32 -> FileCorruptedError
ErrFileChecksumMismatch FsPath
fp (CRC32C -> Word32
unCRC32C CRC32C
expected) (CRC32C -> Word32
unCRC32C CRC32C
checksum)


{-------------------------------------------------------------------------------
  File Format Errors
-------------------------------------------------------------------------------}

data FileFormat
    = FormatChecksumsFile
    | FormatBloomFilterFile
    | FormatIndexFile
    | FormatWriteBufferFile
    | FormatSnapshotMetaData
    deriving stock (Int -> FileFormat -> ShowS
[FileFormat] -> ShowS
FileFormat -> String
(Int -> FileFormat -> ShowS)
-> (FileFormat -> String)
-> ([FileFormat] -> ShowS)
-> Show FileFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileFormat -> ShowS
showsPrec :: Int -> FileFormat -> ShowS
$cshow :: FileFormat -> String
show :: FileFormat -> String
$cshowList :: [FileFormat] -> ShowS
showList :: [FileFormat] -> ShowS
Show, FileFormat -> FileFormat -> Bool
(FileFormat -> FileFormat -> Bool)
-> (FileFormat -> FileFormat -> Bool) -> Eq FileFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileFormat -> FileFormat -> Bool
== :: FileFormat -> FileFormat -> Bool
$c/= :: FileFormat -> FileFormat -> Bool
/= :: FileFormat -> FileFormat -> Bool
Eq)

-- | The file is corrupted.
data FileCorruptedError
    = -- | The file fails to parse.
      ErrFileFormatInvalid
        -- | File.
        !FsPath
        -- | File format.
        !FileFormat
        -- | Error message.
        !String
    | -- | The file CRC32 checksum is invalid.
      ErrFileChecksumMismatch
        -- | File.
        !FsPath
        -- | Expected checksum.
        !Word32
        -- | Actual checksum.
        !Word32
    deriving stock (Int -> FileCorruptedError -> ShowS
[FileCorruptedError] -> ShowS
FileCorruptedError -> String
(Int -> FileCorruptedError -> ShowS)
-> (FileCorruptedError -> String)
-> ([FileCorruptedError] -> ShowS)
-> Show FileCorruptedError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileCorruptedError -> ShowS
showsPrec :: Int -> FileCorruptedError -> ShowS
$cshow :: FileCorruptedError -> String
show :: FileCorruptedError -> String
$cshowList :: [FileCorruptedError] -> ShowS
showList :: [FileCorruptedError] -> ShowS
Show, FileCorruptedError -> FileCorruptedError -> Bool
(FileCorruptedError -> FileCorruptedError -> Bool)
-> (FileCorruptedError -> FileCorruptedError -> Bool)
-> Eq FileCorruptedError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileCorruptedError -> FileCorruptedError -> Bool
== :: FileCorruptedError -> FileCorruptedError -> Bool
$c/= :: FileCorruptedError -> FileCorruptedError -> Bool
/= :: FileCorruptedError -> FileCorruptedError -> Bool
Eq)
    deriving anyclass (Show FileCorruptedError
Typeable FileCorruptedError
(Typeable FileCorruptedError, Show FileCorruptedError) =>
(FileCorruptedError -> SomeException)
-> (SomeException -> Maybe FileCorruptedError)
-> (FileCorruptedError -> String)
-> Exception FileCorruptedError
SomeException -> Maybe FileCorruptedError
FileCorruptedError -> String
FileCorruptedError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: FileCorruptedError -> SomeException
toException :: FileCorruptedError -> SomeException
$cfromException :: SomeException -> Maybe FileCorruptedError
fromException :: SomeException -> Maybe FileCorruptedError
$cdisplayException :: FileCorruptedError -> String
displayException :: FileCorruptedError -> String
Exception)

{-# SPECIALISE
  expectValidFile ::
      (MonadThrow m)
    => FsPath
    -> FileFormat
    -> Either String a
    -> m a
  #-}
expectValidFile ::
     (MonadThrow m)
  => FsPath
  -> FileFormat
  -> Either String a
  -> m a
expectValidFile :: forall (m :: * -> *) a.
MonadThrow m =>
FsPath -> FileFormat -> Either String a -> m a
expectValidFile FsPath
_file FileFormat
_format (Right a
x) =
    a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
expectValidFile FsPath
file FileFormat
format (Left String
msg) =
    FileCorruptedError -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FileCorruptedError -> m a) -> FileCorruptedError -> m a
forall a b. (a -> b) -> a -> b
$ FsPath -> FileFormat -> String -> FileCorruptedError
ErrFileFormatInvalid FsPath
file FileFormat
format String
msg