Merge pull request #543 from IntersectMBO/wenkokke/move-check-crc

fix: move checkCRC to CRC32C

Author: wenkokke

src/Database/LSMTree/Internal/CRC32C.hs

@@ -42,6 +42,11 @@ module Database.LSMTree.Internal.CRC32C (
   readChecksumsFile,
   writeChecksumsFile,
   writeChecksumsFile',
+
+  -- * Checksum checking
+  ChecksumError (..),
+  checkCRC,
+  expectChecksum,
   ) where
 
 import           Control.Monad
@@ -65,7 +70,8 @@ import           GHC.Exts
 import qualified GHC.ForeignPtr as Foreign
 import           System.FS.API
 import           System.FS.API.Lazy
-import           System.FS.BlockIO.API (ByteCount)
+import           System.FS.BlockIO.API (Advice (..), ByteCount, HasBlockIO,
+                     hAdviseAll, hDropCacheAll)
 
 
 newtype CRC32C = CRC32C Word32
@@ -347,3 +353,53 @@ formatChecksumsFile checksums =
           <> BS.word32HexFixed crc
           <> BS.char8 '\n'
         | (ChecksumsFileName name, CRC32C crc) <- Map.toList checksums ]
+
+data ChecksumError = ChecksumError FsPath CRC32C CRC32C
+  deriving stock Show
+  deriving anyclass Exception
+
+-- | 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 fs hbio dropCache expected fp = withFile fs fp ReadMode $ \h -> do
+  -- double the file readahead window (only applies to this file descriptor)
+  hAdviseAll hbio h AdviceSequential
+  !checksum <- hGetAllCRC32C' fs h defaultChunkSize initialCRC32C
+  when dropCache $ hDropCacheAll hbio h
+  expectChecksum fp expected checksum
+
+{-# SPECIALISE
+  expectChecksum ::
+     FsPath
+  -> CRC32C
+  -> CRC32C
+  -> IO ()
+  #-}
+expectChecksum ::
+     MonadThrow m
+  => FsPath
+  -> CRC32C
+  -> CRC32C
+  -> m ()
+expectChecksum fp expected checksum =
+    when (expected /= checksum) $
+      throwIO $ ChecksumError fp expected checksum

src/Database/LSMTree/Internal/Run.hs

@@ -23,12 +23,10 @@ module Database.LSMTree.Internal.Run (
   , RunDataCaching (..)
     -- * Snapshot
   , FileFormatError (..)
-  , ChecksumError (..)
   , openFromDisk
   ) where
 
 import           Control.DeepSeq (NFData (..), rwhnf)
-import           Control.Monad (when)
 import           Control.Monad.Class.MonadST (MonadST)
 import           Control.Monad.Class.MonadSTM (MonadSTM (..))
 import           Control.Monad.Class.MonadThrow
@@ -236,10 +234,6 @@ fromWriteBuffer fs hbio caching alloc fsPaths buffer blobs = do
   Snapshot
 -------------------------------------------------------------------------------}
 
-data ChecksumError = ChecksumError FS.FsPath CRC.CRC32C CRC.CRC32C
-  deriving stock Show
-  deriving anyclass Exception
-
 data FileFormatError = FileFormatError FS.FsPath String
   deriving stock Show
   deriving anyclass Exception
@@ -298,14 +292,8 @@ openFromDisk fs hbio runRunDataCaching runRunFsPaths = do
     -- Note: all file data for this path is evicted from the page cache /if/ the
     -- caching argument is 'NoCacheRunData'.
     checkCRC :: RunDataCaching -> CRC.CRC32C -> FS.FsPath -> m ()
-    checkCRC cache expected fp = FS.withFile fs fp FS.ReadMode $ \h -> do
-        -- double the file readahead window (only applies to this file descriptor)
-        FS.hAdviseAll hbio h FS.AdviceSequential
-        !checksum <- CRC.hGetAllCRC32C' fs h CRC.defaultChunkSize CRC.initialCRC32C
-        when (cache == NoCacheRunData) $
-          -- drop the file from the OS page cache
-          FS.hDropCacheAll hbio h
-        expectChecksum fp expected checksum
+    checkCRC cache expected fp =
+      CRC.checkCRC fs hbio (cache == NoCacheRunData) expected fp
 
     -- Note: all file data for this path is evicted from the page cache
     readCRC :: CRC.CRC32C -> FS.FsPath -> m SBS.ShortByteString
@@ -316,12 +304,8 @@ openFromDisk fs hbio runRunDataCaching runRunFsPaths = do
         (sbs, !checksum) <- CRC.hGetExactlyCRC32C_SBS fs h (fromIntegral n) CRC.initialCRC32C
         -- drop the file from the OS page cache
         FS.hAdviseAll hbio h FS.AdviceDontNeed
-        expectChecksum fp expected checksum
+        CRC.expectChecksum fp expected checksum
         return sbs
 
-    expectChecksum fp expected checksum =
-        when (expected /= checksum) $
-          throwIO $ ChecksumError fp expected checksum
-
     expectValidFile _  (Right x)  = pure x
     expectValidFile fp (Left err) = throwIO $ FileFormatError fp err

src/Database/LSMTree/Internal/Snapshot/Codec.hs

@@ -34,8 +34,7 @@ import           Database.LSMTree.Internal.Entry
 import           Database.LSMTree.Internal.Merge (MergeType (..))
 import           Database.LSMTree.Internal.MergeSchedule
 import           Database.LSMTree.Internal.MergingRun (NumRuns (..))
-import           Database.LSMTree.Internal.Run (ChecksumError (..),
-                     FileFormatError (..))
+import           Database.LSMTree.Internal.Run (FileFormatError (..))
 import           Database.LSMTree.Internal.RunNumber
 import           Database.LSMTree.Internal.Snapshot
 import qualified System.FS.API as FS