Skip to content

Commit 5ea9cdb

Browse files
wenkokkewenkokke
authored
Merge pull request #532 from IntersectMBO/jdral/fault-test-writebufferreader
Make `WriteBufferReader` functions exception safe
2 parents 594123a + 7e962d2 commit 5ea9cdb

File tree

8 files changed

+179
-33
lines changed

8 files changed

+179
-33
lines changed

‎lsm-tree.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -382,6 +382,7 @@ test-suite lsm-tree-test
382382
Test.Database.LSMTree.Internal.Vector
383383
Test.Database.LSMTree.Internal.Vector.Growing
384384
Test.Database.LSMTree.Internal.WriteBufferBlobs.FS
385+
Test.Database.LSMTree.Internal.WriteBufferReader.FS
385386
Test.Database.LSMTree.Model.Table
386387
Test.Database.LSMTree.Monoidal
387388
Test.Database.LSMTree.StateMachine

‎src-extras/Database/LSMTree/Extras/RunData.hs

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -141,9 +141,7 @@ withSerialisedWriteBuffer hfs hbio wbPaths wb wbb =
141141
for_ [ Paths.writeBufferKOpsPath wbPaths
142142
, Paths.writeBufferBlobPath wbPaths
143143
, Paths.writeBufferChecksumsPath wbPaths
144-
] $ \fsPath -> do
145-
fsPathExists <- FS.doesFileExist hfs fsPath
146-
when fsPathExists $ FS.removeFile hfs fsPath
144+
] $ FS.removeFile hfs
147145

148146
{-------------------------------------------------------------------------------
149147
RunData

‎src/Database/LSMTree/Internal/RunReader.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -306,6 +306,10 @@ readDiskPage ::
306306
readDiskPage fs h = do
307307
mba <- newPinnedByteArray pageSize
308308
-- TODO: make sure no other exception type can be thrown
309+
--
310+
-- TODO: if FS.FsReachEOF is thrown as an injected disk fault, then we
311+
-- incorrectly deduce that the file has no more contents. We should probably
312+
-- use an explicit file pointer instead in the style of 'FilePointer'.
309313
handleJust (guard . FS.isFsErrorType FS.FsReachedEOF) (\_ -> pure Nothing) $ do
310314
bytesRead <- FS.hGetBufExactly fs h mba 0 (fromIntegral pageSize)
311315
assert (fromIntegral bytesRead == pageSize) $ pure ()

‎src/Database/LSMTree/Internal/WriteBufferReader.hs

Lines changed: 40 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,8 @@ module Database.LSMTree.Internal.WriteBufferReader (
77
import Control.Concurrent.Class.MonadMVar.Strict
88
import Control.Monad.Class.MonadST (MonadST (..))
99
import Control.Monad.Class.MonadSTM (MonadSTM (..))
10-
import Control.Monad.Class.MonadThrow (MonadMask, MonadThrow (..))
10+
import Control.Monad.Class.MonadThrow (MonadMask, MonadThrow (..),
11+
bracketOnError)
1112
import Control.Monad.Primitive (PrimMonad (..))
1213
import Control.RefCount (Ref, dupRef, releaseRef)
1314
import Data.Primitive.MutVar (MutVar, newMutVar, readMutVar,
@@ -43,8 +44,8 @@ import System.FS.BlockIO.API (HasBlockIO)
4344
#-}
4445
-- | Read a serialised `WriteBuffer` back into memory.
4546
--
46-
-- NOTE: The `BlobFile` argument /must be/ the blob file associated with the
47-
-- write buffer; @`readWriteBuffer`@ does not check this.
47+
-- The argument blob file ('BlobFile') must be the file associated with the
48+
-- argument key\/ops file ('ForKOps'). 'readWriteBuffer' does not check this.
4849
readWriteBuffer ::
4950
(MonadMVar m, MonadMask m, MonadSTM m, MonadST m)
5051
=> ResolveSerialisedValue
@@ -54,7 +55,7 @@ readWriteBuffer ::
5455
-> Ref (BlobFile m h)
5556
-> m WriteBuffer
5657
readWriteBuffer resolve hfs hbio kOpsPath blobFile =
57-
bracket (new hfs hbio kOpsPath blobFile) close $ readEntries
58+
bracket (new hfs hbio kOpsPath blobFile) close $ readEntries
5859
where
5960
readEntries reader = readEntriesAcc WB.empty
6061
where
@@ -88,30 +89,42 @@ data WriteBufferReader m h = WriteBufferReader {
8889
-> IO (WriteBufferReader IO h)
8990
#-}
9091
-- | See 'Database.LSMTree.Internal.RunReader.new'.
92+
--
93+
-- REF: the resulting 'WriteBufferReader' must be closed once it is no longer
94+
-- used.
95+
--
96+
-- ASYNC: this should be called with asynchronous exceptions masked because it
97+
-- allocates/creates resources.
9198
new :: forall m h.
9299
(MonadMVar m, MonadST m, MonadMask m)
93100
=> HasFS m h
94101
-> HasBlockIO m h
95102
-> ForKOps FS.FsPath
96103
-> Ref (BlobFile m h)
97104
-> m (WriteBufferReader m h)
98-
new readerHasFS readerHasBlockIO kOpsPath blobFile = do
99-
readerKOpsHandle <- FS.hOpen readerHasFS (unForKOps kOpsPath) FS.ReadMode
100-
-- Double the file readahead window (only applies to this file descriptor)
101-
FS.hAdviseAll readerHasBlockIO readerKOpsHandle FS.AdviceSequential
102-
readerBlobFile <- dupRef blobFile
103-
-- Load first page from disk, if it exists.
104-
readerCurrentEntryNo <- newPrimVar (0 :: Word16)
105-
firstPage <- readDiskPage readerHasFS readerKOpsHandle
106-
readerCurrentPage <- newMutVar firstPage
107-
pure $ WriteBufferReader{..}
105+
new readerHasFS readerHasBlockIO kOpsPath blobFile =
106+
bracketOnError openKOps (FS.hClose readerHasFS) $ \readerKOpsHandle -> do
107+
-- Double the file readahead window (only applies to this file descriptor)
108+
FS.hAdviseAll readerHasBlockIO readerKOpsHandle FS.AdviceSequential
109+
bracketOnError (dupRef blobFile) releaseRef $ \readerBlobFile -> do
110+
-- Load first page from disk, if it exists.
111+
readerCurrentEntryNo <- newPrimVar (0 :: Word16)
112+
firstPage <- readDiskPage readerHasFS readerKOpsHandle
113+
readerCurrentPage <- newMutVar firstPage
114+
pure $ WriteBufferReader{..}
115+
where
116+
openKOps = FS.hOpen readerHasFS (unForKOps kOpsPath) FS.ReadMode
108117

109118
{-# SPECIALISE
110119
next ::
111120
WriteBufferReader IO h
112121
-> IO (Result IO h)
113122
#-}
114123
-- | See 'Database.LSMTree.Internal.RunReader.next'.
124+
--
125+
-- TODO: 'next' is currently only used in 'readWriteBuffer', where it is a safe
126+
-- use of an unsafe function. If this function is ever exported and used
127+
-- directly, the TODOs in the body of this function should be addressed first.
115128
next :: forall m h.
116129
(MonadSTM m, MonadST m, MonadMask m)
117130
=> WriteBufferReader m h
@@ -124,13 +137,21 @@ next WriteBufferReader {..} = do
124137
entryNo <- readPrimVar readerCurrentEntryNo
125138
go entryNo page
126139
where
140+
-- TODO: if 'readerCurrentEntryNo' is incremented but an exception is thrown
141+
-- before the 'Result' is used by the caller of 'next', then we'll lose that
142+
-- 'Result'. The following call to 'next' will not return the 'Result' we
143+
-- missed.
127144
go :: Word16 -> RawPage -> m (Result m h)
128145
go !entryNo !page =
129146
-- take entry from current page (resolve blob if necessary)
130147
case rawPageIndex page entryNo of
131148
IndexNotPresent -> do
132149
-- if it is past the last one, load a new page from disk, try again
133150
newPage <- readDiskPage readerHasFS readerKOpsHandle
151+
-- TODO: if the next disk page is read but an (async) exception is
152+
-- thrown just before updating the MutVar below, then we lose the
153+
-- disk page because 'readDiskPage' has already updated its file
154+
-- pointer.
134155
stToIO $ writeMutVar readerCurrentPage newPage
135156
case newPage of
136157
Nothing -> do
@@ -154,10 +175,14 @@ next WriteBufferReader {..} = do
154175
return (ReadEntry key rawEntry)
155176

156177
{-# SPECIALISE close :: WriteBufferReader IO h -> IO () #-}
178+
-- | Close the 'WriteBufferReader'.
179+
--
180+
-- ASYNC: this should be called with asynchronous exceptions masked because it
181+
-- releases/removes resources.
157182
close ::
158183
(MonadMask m, PrimMonad m)
159184
=> WriteBufferReader m h
160185
-> m ()
161186
close WriteBufferReader{..} = do
162187
FS.hClose readerHasFS readerKOpsHandle
163-
releaseRef readerBlobFile
188+
`finally` releaseRef readerBlobFile

‎test/Main.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,7 @@ import qualified Test.Database.LSMTree.Internal.Snapshot.FS
3434
import qualified Test.Database.LSMTree.Internal.Vector
3535
import qualified Test.Database.LSMTree.Internal.Vector.Growing
3636
import qualified Test.Database.LSMTree.Internal.WriteBufferBlobs.FS
37+
import qualified Test.Database.LSMTree.Internal.WriteBufferReader.FS
3738
import qualified Test.Database.LSMTree.Model.Table
3839
import qualified Test.Database.LSMTree.Monoidal
3940
import qualified Test.Database.LSMTree.StateMachine
@@ -76,6 +77,7 @@ main = do
7677
, Test.Database.LSMTree.Internal.Vector.tests
7778
, Test.Database.LSMTree.Internal.Vector.Growing.tests
7879
, Test.Database.LSMTree.Internal.WriteBufferBlobs.FS.tests
80+
, Test.Database.LSMTree.Internal.WriteBufferReader.FS.tests
7981
, Test.Database.LSMTree.Model.Table.tests
8082
, Test.Database.LSMTree.Monoidal.tests
8183
, Test.Database.LSMTree.UnitTests.tests

‎test/Test/Database/LSMTree/Internal/WriteBufferReader/FS.hs

Lines changed: 80 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,80 @@
1+
module Test.Database.LSMTree.Internal.WriteBufferReader.FS (tests) where
2+
3+
4+
import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM (..))
5+
import Control.Concurrent.Class.MonadSTM.Strict.TMVar
6+
import Control.Monad.Class.MonadThrow
7+
import Control.RefCount
8+
import Database.LSMTree.Extras.Generators ()
9+
import Database.LSMTree.Extras.RunData (RunData,
10+
withRunDataAsWriteBuffer, withSerialisedWriteBuffer)
11+
import Database.LSMTree.Internal.Paths (ForKOps (ForKOps),
12+
WriteBufferFsPaths (WriteBufferFsPaths),
13+
writeBufferKOpsPath)
14+
import Database.LSMTree.Internal.RunNumber (RunNumber (RunNumber))
15+
import Database.LSMTree.Internal.Serialise (SerialisedBlob,
16+
SerialisedKey, SerialisedValue (..))
17+
import qualified Database.LSMTree.Internal.WriteBufferBlobs as WBB
18+
import Database.LSMTree.Internal.WriteBufferReader
19+
import System.FS.API
20+
import System.FS.Sim.Error hiding (genErrors)
21+
import qualified System.FS.Sim.MockFS as MockFS
22+
import qualified System.FS.Sim.Stream as Stream
23+
import Test.Tasty
24+
import Test.Tasty.QuickCheck as QC
25+
import Test.Util.FS
26+
27+
tests :: TestTree
28+
tests = testGroup "Test.Database.LSMTree.Internal.WriteBufferReader.FS" [
29+
testProperty "prop_fault_WriteBufferReader" prop_fault_WriteBufferReader
30+
]
31+
32+
-- | Test that 'writeWriteBuffer' roundtrips with 'readWriteBuffer', and test
33+
-- that the presence of disk faults for the latter does not leak file handles
34+
-- and files.
35+
prop_fault_WriteBufferReader ::
36+
NoCleanupErrors
37+
-> RunData SerialisedKey SerialisedValue SerialisedBlob
38+
-> Property
39+
prop_fault_WriteBufferReader (NoCleanupErrors readErrors) rdata =
40+
ioProperty $
41+
withSimErrorHasBlockIO propPost MockFS.empty emptyErrors $ \hfs hbio fsVar errsVar ->
42+
withRunDataAsWriteBuffer hfs resolve inPath rdata $ \wb wbb ->
43+
withSerialisedWriteBuffer hfs hbio outPath wb wbb $ do
44+
fsBefore <- atomically $ readTMVar fsVar
45+
eith <-
46+
try @_ @FsError $
47+
withErrors errsVar readErrors' $
48+
withRef wbb $ \wbb' -> do
49+
wb' <- readWriteBuffer resolve hfs hbio outKOpsPath (WBB.blobFile wbb')
50+
pure (wb === wb')
51+
52+
fsAfter <- atomically $ readTMVar fsVar
53+
pure $
54+
case eith of
55+
Left{} -> do
56+
label "FsError" $ property True
57+
Right prop ->
58+
label "Success" $ prop .&&. propEqNumDirEntries root fsBefore fsAfter
59+
where
60+
root = mkFsPath []
61+
-- The run number for the original write buffer. Primarily used to name the
62+
-- 'WriteBufferBlobs' corresponding to the write buffer.
63+
inPath = WriteBufferFsPaths root (RunNumber 0)
64+
-- The run number for the serialised write buffer. Used to name all files
65+
-- that are the result of serialising the write buffer.
66+
outPath = WriteBufferFsPaths root (RunNumber 1)
67+
outKOpsPath = ForKOps (writeBufferKOpsPath outPath)
68+
resolve (SerialisedValue x) (SerialisedValue y) = SerialisedValue (x <> y)
69+
propPost fs = propNoOpenHandles fs .&&. propNoDirEntries root fs
70+
71+
-- TODO: fix, see the TODO on readDiskPage
72+
readErrors' = readErrors {
73+
hGetBufSomeE = Stream.filter (not . isFsReachedEOF) (hGetBufSomeE readErrors)
74+
}
75+
76+
isFsReachedEOF Nothing = False
77+
isFsReachedEOF (Just (Left e)) = case e of
78+
FsReachedEOF -> True
79+
_ -> False
80+
isFsReachedEOF (Just (Right _)) = False

‎test/Test/Database/LSMTree/StateMachine.hs

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -134,8 +134,8 @@ import qualified Test.QuickCheck.StateModel.Lockstep.Defaults as Lockstep.Defaul
134134
import qualified Test.QuickCheck.StateModel.Lockstep.Run as Lockstep.Run
135135
import Test.Tasty (TestTree, testGroup)
136136
import Test.Tasty.QuickCheck (testProperty)
137-
import Test.Util.FS (approximateEqStream, propNoOpenHandles,
138-
propNumOpenHandles)
137+
import Test.Util.FS (approximateEqStream, noRemoveDirectoryRecursiveE,
138+
propNoOpenHandles, propNumOpenHandles)
139139
import Test.Util.PrettyProxy
140140
import Test.Util.QLS
141141
import Test.Util.TypeFamilyWrappers (WrapBlob (..), WrapBlobRef (..),
@@ -1434,8 +1434,7 @@ arbitraryActionWithVars _ label ctx (ModelState st _stats) =
14341434
++ [ (1, fmap Some $ OpenSnapshot @k @v @b PrettyProxy <$>
14351435
genErrors <*> pure label <*> genUsedSnapshotName)
14361436
| not (null usedSnapshotNames)
1437-
-- TODO: generate errors
1438-
, let genErrors = pure Nothing
1437+
, let genErrors = fmap noRemoveDirectoryRecursiveE <$> QC.arbitrary
14391438
]
14401439

14411440
++ [ (1, fmap Some $ DeleteSnapshot <$> genUsedSnapshotName)

‎test/Test/Util/FS.hs

Lines changed: 48 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -16,8 +16,10 @@ module Test.Util.FS (
1616
, propTrivial
1717
, propNumOpenHandles
1818
, propNoOpenHandles
19+
, numDirEntries
1920
, propNumDirEntries
2021
, propNoDirEntries
22+
, propEqNumDirEntries
2123
, assertNoOpenHandles
2224
, assertNumOpenHandles
2325
-- * Equality
@@ -30,6 +32,10 @@ module Test.Util.FS (
3032
-- * Corruption
3133
, flipFileBit
3234
, hFlipBit
35+
-- * Errors
36+
, noHCloseE
37+
, noRemoveFileE
38+
, noRemoveDirectoryRecursiveE
3339
-- * Arbitrary
3440
, FsPathComponent (..)
3541
, fsPathComponentFsPath
@@ -190,6 +196,12 @@ propNumOpenHandles expected fs =
190196
propNoOpenHandles :: MockFS -> Property
191197
propNoOpenHandles fs = propNumOpenHandles 0 fs
192198

199+
numDirEntries :: FsPath -> MockFS -> Int
200+
numDirEntries path fs = Set.size contents
201+
where
202+
(contents, _) =
203+
runSimOrThrow $ runSimFS fs $ \hfs -> FS.listDirectory hfs path
204+
193205
{-# INLINABLE propNumDirEntries #-}
194206
propNumDirEntries :: FsPath -> Int -> MockFS -> Property
195207
propNumDirEntries path expected fs =
@@ -199,19 +211,30 @@ propNumDirEntries path expected fs =
199211
(show path) actual) $
200212
printMockFSOnFailure fs $
201213
expected === actual
202-
where
203-
actual =
204-
let (contents, _) = runSimOrThrow $
205-
runSimFS fs $ \hfs ->
206-
FS.listDirectory hfs path
207-
in Set.size contents
214+
where actual = numDirEntries path fs
208215

209216
{-# INLINABLE propNoDirEntries #-}
210217
propNoDirEntries :: FsPath -> MockFS -> Property
211218
propNoDirEntries path fs = propNumDirEntries path 0 fs
212219

220+
{-# INLINABLE propEqNumDirEntries #-}
221+
propEqNumDirEntries :: FsPath -> MockFS -> MockFS -> Property
222+
propEqNumDirEntries path lhsFs rhsFs =
223+
counterexample
224+
(printf "The LHS has %d entries in the directory at %s, but the RHS has %d"
225+
lhs (show path) rhs) $
226+
printMockFSOnFailureWith "Mocked file system (LHS)" lhsFs $
227+
printMockFSOnFailureWith "Mocked file system (RHS)" rhsFs $
228+
lhs === rhs
229+
where
230+
lhs = numDirEntries path lhsFs
231+
rhs = numDirEntries path rhsFs
232+
213233
printMockFSOnFailure :: Testable prop => MockFS -> prop -> Property
214-
printMockFSOnFailure fs = counterexample ("Mocked file system: " <> pretty fs)
234+
printMockFSOnFailure = printMockFSOnFailureWith "Mocked file system"
235+
236+
printMockFSOnFailureWith :: Testable prop => String -> MockFS -> prop -> Property
237+
printMockFSOnFailureWith s fs = counterexample (s <> ": " <> pretty fs)
215238

216239
assertNoOpenHandles :: HasCallStack => MockFS -> a -> a
217240
assertNoOpenHandles fs = assertNumOpenHandles fs 0
@@ -354,6 +377,19 @@ hFlipBit hfs h bitOffset = do
354377
void $ hPutBufExactlyAt hfs h buf bufOff count off
355378

356379

380+
{-------------------------------------------------------------------------------
381+
Errors
382+
-------------------------------------------------------------------------------}
383+
384+
noHCloseE :: Errors -> Errors
385+
noHCloseE errs = errs { hCloseE = Stream.empty }
386+
387+
noRemoveFileE :: Errors -> Errors
388+
noRemoveFileE errs = errs { removeFileE = Stream.empty }
389+
390+
noRemoveDirectoryRecursiveE :: Errors -> Errors
391+
noRemoveDirectoryRecursiveE errs = errs { removeDirectoryRecursiveE = Stream.empty }
392+
357393
{-------------------------------------------------------------------------------
358394
Arbitrary
359395
-------------------------------------------------------------------------------}
@@ -396,10 +432,11 @@ newtype NoCleanupErrors = NoCleanupErrors Errors
396432
deriving stock Show
397433

398434
mkNoCleanupErrors :: Errors -> NoCleanupErrors
399-
mkNoCleanupErrors errs = NoCleanupErrors $ errs {
400-
hCloseE = Stream.empty
401-
, removeFileE = Stream.empty
402-
}
435+
mkNoCleanupErrors errs = NoCleanupErrors $
436+
noHCloseE
437+
$ noRemoveFileE
438+
$ noRemoveDirectoryRecursiveE
439+
$ errs
403440

404441
instance Arbitrary NoCleanupErrors where
405442
arbitrary = do

0 commit comments

Comments
 (0)