Merge pull request #557 from IntersectMBO/jdral/sync-snap-dir

Bugfix: synchronise the snapshot directory and its contents

Author: dcoutts

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

@@ -1174,15 +1174,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