Bugfix: synchronise the snapshot directory and its contents

Not all the snapshot directory contents were being synchronised, and arguably
not in the correct order. The synchronisation now only happens at the very end
of taking a snapshot. Because of this, if other parts of the `createSnapshot`
function fail, then we won't have flushed file and directory contents to disk
unnecessarily.

Author: jorisdral

blockio-api/src/System/FS/BlockIO/API.hs

@@ -30,6 +30,7 @@ module System.FS.BlockIO.API (
   , LockFileHandle (..)
     -- ** Storage synchronisation
   , synchroniseFile
+  , synchroniseDirectoryRecursive
     -- * Defaults for the real file system
   , tryLockFileIO
   , createHardLinkIO
@@ -39,6 +40,7 @@ module System.FS.BlockIO.API (
   ) where
 
 import           Control.DeepSeq
+import           Control.Monad (forM_)
 import           Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError),
                      MonadThrow (..), bracketOnError, try)
 import           Control.Monad.Primitive (PrimMonad (PrimState))
@@ -60,6 +62,7 @@ import qualified System.IO as GHC
 import           System.IO.Error (doesNotExistErrorType, ioeSetErrorString,
                      mkIOError)
 import           System.Posix.Types (ByteCount, FileOffset)
+import           Text.Printf
 
 -- | Abstract interface for submitting large batches of I\/O operations.
 data HasBlockIO m h = HasBlockIO {
@@ -258,6 +261,7 @@ hDropCacheAll hbio h = hAdviseAll hbio h AdviceDontNeed
   Storage synchronisation
 -------------------------------------------------------------------------------}
 
+{-# SPECIALISE synchroniseFile :: HasFS IO h -> HasBlockIO IO h -> FsPath -> IO () #-}
 -- TODO: currently, we perform an explicit check to see if the file exists and
 -- throw an error when it does not exist. We would prefer to be able to rely on
 -- withFile to throw an error for us that we could rethrow with an upated
@@ -284,6 +288,37 @@ synchroniseFile hfs hbio path = do
         (mkIOError doesNotExistErrorType "synchroniseFile" Nothing Nothing)
         ("synchroniseFile: file does not exist")
 
+{-# SPECIALISE synchroniseDirectoryRecursive ::
+     HasFS IO h
+  -> HasBlockIO IO h
+  -> FsPath
+  -> IO ()
+  #-}
+-- | Synchronise a directory and recursively its contents with the storage
+-- device.
+synchroniseDirectoryRecursive ::
+     MonadThrow m
+  => HasFS m h
+  -> HasBlockIO m h
+  -> FsPath
+  -> m ()
+synchroniseDirectoryRecursive hfs hbio path = do
+    entries <- FS.listDirectory hfs path
+    forM_ entries $ \entry -> do
+      let path' = path FS.</> FS.mkFsPath [entry]
+      isFile <- FS.doesFileExist hfs path'
+      if isFile then
+        synchroniseFile hfs hbio path'
+      else do
+        isDirectory <- FS.doesDirectoryExist hfs path'
+        if isDirectory then do
+          synchroniseDirectoryRecursive hfs hbio path'
+          synchroniseDirectory hbio path'
+        else
+          error $ printf
+            "listDirectoryRecursive: %s is not a file or directory"
+            (show path')
+
 {-------------------------------------------------------------------------------
   File locks
 -------------------------------------------------------------------------------}

src/Database/LSMTree/Internal.hs

@@ -1173,15 +1173,18 @@ createSnapshot snap label tableType t = do
         snapLevels <- toSnapLevels (tableLevels content)
 
         -- Hard link runs into the named snapshot directory
-        snapLevels' <- snapshotRuns reg hbio snapUc snapDir snapLevels
+        snapLevels' <- snapshotRuns reg snapUc snapDir snapLevels
+
+        -- Release the table content
+        releaseTableContent reg content
 
         let snapMetaData = SnapshotMetaData label tableType (tableConfig t) snapWriteBufferNumber snapLevels'
             SnapshotMetaDataFile contentPath = Paths.snapshotMetaDataFile snapDir
             SnapshotMetaDataChecksumFile checksumPath = Paths.snapshotMetaDataChecksumFile snapDir
         writeFileSnapshotMetaData hfs contentPath checksumPath snapMetaData
 
-        -- Release the table content
-        releaseTableContent reg content
+        -- Make the directory and its contents durable.
+        FS.synchroniseDirectoryRecursive hfs hbio (Paths.getNamedSnapshotDir snapDir)
 
 {-# SPECIALISE openSnapshot ::
      Session IO h

src/Database/LSMTree/Internal/Snapshot.hs

@@ -22,15 +22,14 @@ module Database.LSMTree.Internal.Snapshot (
     -- * Opening from levels snapshot format
   , fromSnapLevels
     -- * Hard links
-  , HardLinkDurable (..)
   , hardLinkRunFiles
   ) where
 
 import           Control.ActionRegistry
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Concurrent.Class.MonadSTM (MonadSTM)
 import           Control.DeepSeq (NFData (..))
-import           Control.Monad (void, when)
+import           Control.Monad (void)
 import           Control.Monad.Class.MonadST (MonadST)
 import           Control.Monad.Class.MonadThrow (MonadMask)
 import           Control.Monad.Primitive (PrimMonad)
@@ -271,13 +270,13 @@ snapshotWriteBuffer reg hfs hbio activeUc snapUc activeDir snapDir wb wbb = do
   -- Hard link the write buffer and write buffer blobs to the snapshot directory.
   snapWriteBufferNumber <- uniqueToRunNumber <$> incrUniqCounter snapUc
   let snapWriteBufferPaths = WriteBufferFsPaths (getNamedSnapshotDir snapDir) snapWriteBufferNumber
-  hardLink reg hfs hbio HardLinkDurable
+  hardLink reg hfs hbio
     (writeBufferKOpsPath activeWriteBufferPaths)
     (writeBufferKOpsPath snapWriteBufferPaths)
-  hardLink reg hfs hbio HardLinkDurable
+  hardLink reg hfs hbio
     (writeBufferBlobPath activeWriteBufferPaths)
     (writeBufferBlobPath snapWriteBufferPaths)
-  hardLink reg hfs hbio HardLinkDurable
+  hardLink reg hfs hbio
     (writeBufferChecksumsPath activeWriteBufferPaths)
     (writeBufferChecksumsPath snapWriteBufferPaths)
   pure snapWriteBufferPaths
@@ -334,36 +333,30 @@ openWriteBuffer reg resolve hfs hbio uc activeDir snapWriteBufferPaths = do
 
 {-# SPECIALISE snapshotRuns ::
      ActionRegistry IO
-  -> HasBlockIO IO h
   -> UniqCounter IO
   -> NamedSnapshotDir
   -> SnapLevels (Ref (Run IO h))
   -> IO (SnapLevels RunNumber) #-}
 -- | @'snapshotRuns' _ _ snapUc targetDir levels@ creates hard links for all run
 -- files associated with the runs in @levels@, and puts the new directory
 -- entries in the @targetDir@ directory. The entries are renamed using @snapUc@.
--- The hard links and the @targetDir@ are made durable on disk.
 snapshotRuns ::
      (MonadMask m, PrimMonad m)
   => ActionRegistry m
-  -> HasBlockIO m h
   -> UniqCounter m
   -> NamedSnapshotDir
   -> SnapLevels (Ref (Run m h))
   -> m (SnapLevels RunNumber)
-snapshotRuns reg hbio0 snapUc (NamedSnapshotDir targetDir) levels = do
-    levels' <-
-      for levels $ \run@(DeRef Run.Run {
-          Run.runHasFS = hfs,
-          Run.runHasBlockIO = hbio
-        }) -> do
-          rn <- uniqueToRunNumber <$> incrUniqCounter snapUc
-          let sourcePaths = Run.runFsPaths run
-          let targetPaths = sourcePaths { runDir = targetDir , runNumber = rn}
-          hardLinkRunFiles reg hfs hbio HardLinkDurable sourcePaths targetPaths
-          pure (runNumber targetPaths)
-    FS.synchroniseDirectory hbio0 targetDir
-    pure levels'
+snapshotRuns reg snapUc (NamedSnapshotDir targetDir) levels = do
+    for levels $ \run@(DeRef Run.Run {
+        Run.runHasFS = hfs,
+        Run.runHasBlockIO = hbio
+      }) -> do
+        rn <- uniqueToRunNumber <$> incrUniqCounter snapUc
+        let sourcePaths = Run.runFsPaths run
+        let targetPaths = sourcePaths { runDir = targetDir , runNumber = rn}
+        hardLinkRunFiles reg hfs hbio sourcePaths targetPaths
+        pure (runNumber targetPaths)
 
 {-# SPECIALISE openRuns ::
      ActionRegistry IO
@@ -404,7 +397,7 @@ openRuns
           let sourcePaths = RunFsPaths sourceDir runNum
           runNum' <- uniqueToRunNumber <$> incrUniqCounter uc
           let targetPaths = RunFsPaths targetDir runNum'
-          hardLinkRunFiles reg hfs hbio NoHardLinkDurable sourcePaths targetPaths
+          hardLinkRunFiles reg hfs hbio sourcePaths targetPaths
 
           withRollback reg
             (Run.openFromDisk hfs hbio caching targetPaths)
@@ -490,64 +483,53 @@ fromSnapLevels reg hfs hbio conf@TableConfig{..} uc resolve dir (SnapLevels leve
   Hard links
 -------------------------------------------------------------------------------}
 
-data HardLinkDurable = HardLinkDurable | NoHardLinkDurable
-  deriving stock Eq
-
 {-# SPECIALISE hardLinkRunFiles ::
      ActionRegistry IO
   -> HasFS IO h
   -> HasBlockIO IO h
-  -> HardLinkDurable
   -> RunFsPaths
   -> RunFsPaths
   -> IO () #-}
--- | @'hardLinkRunFiles' _ _ _ dur sourcePaths targetPaths@ creates a hard link
--- for each @sourcePaths@ path using the corresponding @targetPaths@ path as the
--- name for the new directory entry. If @dur == HardLinkDurabl@, the links will
--- also be made durable on disk.
+-- | @'hardLinkRunFiles' _ _ _ sourcePaths targetPaths@ creates a hard link for
+-- each @sourcePaths@ path using the corresponding @targetPaths@ path as the
+-- name for the new directory entry.
 hardLinkRunFiles ::
      (MonadMask m, PrimMonad m)
   => ActionRegistry m
   -> HasFS m h
   -> HasBlockIO m h
-  -> HardLinkDurable
   -> RunFsPaths
   -> RunFsPaths
   -> m ()
-hardLinkRunFiles reg hfs hbio dur sourceRunFsPaths targetRunFsPaths = do
+hardLinkRunFiles reg hfs hbio sourceRunFsPaths targetRunFsPaths = do
     let sourcePaths = pathsForRunFiles sourceRunFsPaths
         targetPaths = pathsForRunFiles targetRunFsPaths
-    sequenceA_ (hardLink reg hfs hbio dur <$> sourcePaths <*> targetPaths)
-    hardLink reg hfs hbio dur (runChecksumsPath sourceRunFsPaths) (runChecksumsPath targetRunFsPaths)
+    sequenceA_ (hardLink reg hfs hbio <$> sourcePaths <*> targetPaths)
+    hardLink reg hfs hbio (runChecksumsPath sourceRunFsPaths) (runChecksumsPath targetRunFsPaths)
 
 {-# SPECIALISE
   hardLink ::
        ActionRegistry IO
     -> HasFS IO h
     -> HasBlockIO IO h
-    -> HardLinkDurable
     -> FS.FsPath
     -> FS.FsPath
     -> IO ()
   #-}
--- | @'hardLink' reg hfs hbio dur sourcePath targetPath@ creates a hard link
--- from @sourcePath@ to @targetPath@.
+-- | @'hardLink' reg hfs hbio sourcePath targetPath@ creates a hard link from
+-- @sourcePath@ to @targetPath@.
 hardLink ::
      (MonadMask m, PrimMonad m)
   => ActionRegistry m
   -> HasFS m h
   -> HasBlockIO m h
-  -> HardLinkDurable
   -> FS.FsPath
   -> FS.FsPath
   -> m ()
-hardLink reg hfs hbio dur sourcePath targetPath = do
+hardLink reg hfs hbio sourcePath targetPath = do
     withRollback_ reg
       (FS.createHardLink hbio sourcePath targetPath)
       (FS.removeFile hfs targetPath)
-    when (dur == HardLinkDurable) $
-      FS.synchroniseFile hfs hbio targetPath
-
 
 {-------------------------------------------------------------------------------
   Copy file

test/Test/Database/LSMTree/Internal/Run.hs

@@ -200,7 +200,7 @@ prop_WriteAndOpen fs hbio wb =
     withActionRegistry $ \reg -> do
       let paths = Run.runFsPaths written
           paths' = paths { runNumber = RunNumber 17}
-      hardLinkRunFiles reg fs hbio NoHardLinkDurable paths paths'
+      hardLinkRunFiles reg fs hbio paths paths'
       loaded <- openFromDisk fs hbio CacheRunData (simplePath 17)
 
       Run.size written @=? Run.size loaded