Skip to content

Commit 4cecb21

Browse files
jorisdraljorisdral
committed
Use the public API instead of the internal API for unit-like property tests
1 parent 7de86b9 commit 4cecb21

File tree

2 files changed

+129
-85
lines changed

2 files changed

+129
-85
lines changed

‎test/Test/Database/LSMTree.hs‎

Lines changed: 128 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,10 +4,12 @@
44

55
module Test.Database.LSMTree (tests) where
66

7+
import Control.Exception
78
import Control.Tracer
89
import Data.Function (on)
910
import Data.IORef
1011
import Data.Monoid
12+
import Data.Typeable (Typeable)
1113
import qualified Data.Vector as V
1214
import qualified Data.Vector.Algorithms as VA
1315
import Data.Void
@@ -16,6 +18,7 @@ import Database.LSMTree
1618
import Database.LSMTree.Extras (showRangesOf)
1719
import Database.LSMTree.Extras.Generators ()
1820
import qualified System.FS.API as FS
21+
import qualified System.FS.BlockIO.API as FS
1922
import Test.QuickCheck
2023
import Test.Tasty
2124
import Test.Tasty.QuickCheck
@@ -27,6 +30,14 @@ tests = testGroup "Test.Database.LSMTree" [
2730
-- openSession
2831
testProperty "prop_openSession_newSession" prop_openSession_newSession
2932
, testProperty "prop_openSession_restoreSession" prop_openSession_restoreSession
33+
-- happy path
34+
, testProperty "prop_newSession_restoreSession_happyPath" prop_newSession_restoreSession_happyPath
35+
-- missing session directory
36+
, testProperty "prop_sessionDirDoesNotExist" prop_sessionDirDoesNotExist
37+
-- session directory already locked
38+
, testProperty "prop_sessionDirLocked" prop_sessionDirLocked
39+
-- malformed session directory
40+
, testProperty "prop_sessionDirCorrupted" prop_sessionDirCorrupted
3041
-- salt
3142
, testProperty "prop_goodAndBadSessionSalt" prop_goodAndBadSessionSalt
3243
]
@@ -56,6 +67,30 @@ instance Arbitrary NewOrRestore where
5667
arbitrary = arbitraryBoundedEnum
5768
shrink = shrinkBoundedEnum
5869

70+
-- | If 'New', use 'newSession', otherwise if 'Restore', use 'restoreSession'.
71+
--
72+
-- This allows us to run properties on both 'newSession' and 'restoreSession',
73+
-- without having to write almost identical code twice.
74+
--
75+
-- In a sense, this is somewhat similar to 'openSession', but whereas
76+
-- 'openSession' would defer to 'newSession' or 'restoreSession' based on the
77+
-- directory contents, here the user gets to pick whether to use 'newSession' or
78+
-- 'restoreSession'.
79+
withNewSessionOrRestoreSession ::
80+
(IOLike m, Typeable h)
81+
=> NewOrRestore
82+
-> Tracer m LSMTreeTrace
83+
-> FS.HasFS m h
84+
-> FS.HasBlockIO m h
85+
-> Salt
86+
-> FS.FsPath
87+
-> (Session m -> m a)
88+
-> m a
89+
withNewSessionOrRestoreSession newOrRestore tr hfs hbio salt path =
90+
case newOrRestore of
91+
New -> withNewSession tr hfs hbio salt path
92+
Restore -> withRestoreSession tr hfs hbio path
93+
5994
{-------------------------------------------------------------------------------
6095
Session: openSession
6196
-------------------------------------------------------------------------------}
@@ -105,6 +140,99 @@ mkSessionOpenModeTracer var = Tracer $ emit $ \case
105140
TraceRestoreSession{} -> modifyIORef var ("Restore" :)
106141
_ -> pure ()
107142

143+
{-------------------------------------------------------------------------------
144+
Session: happy path
145+
-------------------------------------------------------------------------------}
146+
147+
prop_newSession_restoreSession_happyPath ::
148+
Positive (Small Int)
149+
-> V.Vector (Key, Value)
150+
-> Property
151+
prop_newSession_restoreSession_happyPath (Positive (Small bufferSize)) ins =
152+
ioProperty $
153+
withTempIOHasBlockIO "prop_newSession_restoreSession_happyPath" $ \hfs hbio -> do
154+
withNewSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \session1 ->
155+
withTableWith conf session1 $ \(table :: Table IO Key Value Blob) -> do
156+
inserts table $ V.map (\(k, v) -> (k, v, Nothing)) ins
157+
saveSnapshot "snap" "KeyValueBlob" table
158+
withRestoreSession nullTracer hfs hbio (FS.mkFsPath []) $ \session2 ->
159+
withTableFromSnapshot session2 "snap" "KeyValueBlob"
160+
$ \(_ :: Table IO Key Value Blob) -> pure ()
161+
where
162+
testSalt = 6
163+
conf = defaultTableConfig {
164+
confWriteBufferAlloc = AllocNumEntries bufferSize
165+
}
166+
167+
{-------------------------------------------------------------------------------
168+
Session: missing session directory
169+
-------------------------------------------------------------------------------}
170+
171+
prop_sessionDirDoesNotExist :: NewOrRestore -> Property
172+
prop_sessionDirDoesNotExist newOrRestore =
173+
ioProperty $
174+
withTempIOHasBlockIO "prop_sessionDirDoesNotExist" $ \hfs hbio -> do
175+
result <- try @SessionDirDoesNotExistError $
176+
withNewSessionOrRestoreSession
177+
newOrRestore
178+
nullTracer hfs hbio testSalt (FS.mkFsPath ["missing-dir"])
179+
$ \_session -> pure ()
180+
pure
181+
$ counterexample
182+
("Expecting an ErrSessionDirDoesNotExist error, but got: " ++ show result)
183+
$ case result of
184+
Left ErrSessionDirDoesNotExist{} -> True
185+
_ -> False
186+
where
187+
testSalt = 6
188+
189+
{-------------------------------------------------------------------------------
190+
Session: session directory already locked
191+
-------------------------------------------------------------------------------}
192+
193+
prop_sessionDirLocked :: NewOrRestore -> Property
194+
prop_sessionDirLocked newOrRestore =
195+
ioProperty $
196+
withTempIOHasBlockIO "prop_sessionDirLocked" $ \hfs hbio -> do
197+
result <-
198+
withNewSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \_session1 -> do
199+
try @SessionDirLockedError $
200+
withNewSessionOrRestoreSession
201+
newOrRestore
202+
nullTracer hfs hbio testSalt (FS.mkFsPath [])
203+
$ \_session2 -> pure ()
204+
pure
205+
$ counterexample
206+
("Expecting an ErrSessionDirLocked error, but got: " ++ show result)
207+
$ case result of
208+
Left ErrSessionDirLocked{} -> True
209+
_ -> False
210+
where
211+
testSalt = 6
212+
213+
{-------------------------------------------------------------------------------
214+
Session: malformed session directory
215+
-------------------------------------------------------------------------------}
216+
217+
prop_sessionDirCorrupted :: NewOrRestore -> Property
218+
prop_sessionDirCorrupted newOrRestore =
219+
ioProperty $
220+
withTempIOHasBlockIO "sessionDirCorrupted" $ \hfs hbio -> do
221+
FS.createDirectory hfs (FS.mkFsPath ["unexpected-directory"])
222+
result <- try @SessionDirCorruptedError $
223+
withNewSessionOrRestoreSession
224+
newOrRestore
225+
nullTracer hfs hbio testSalt (FS.mkFsPath [])
226+
$ \_session -> pure ()
227+
pure
228+
$ counterexample
229+
("Expecting an ErrSessionDirCorrupted error, but got: " ++ show result)
230+
$ case result of
231+
Left ErrSessionDirCorrupted{} -> True
232+
_ -> False
233+
where
234+
testSalt = 6
235+
108236
{-------------------------------------------------------------------------------
109237
Session: salt
110238
-------------------------------------------------------------------------------}

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

Lines changed: 1 addition & 85 deletions
Original file line numberDiff line numberDiff line change
@@ -4,18 +4,11 @@
44

55
module Test.Database.LSMTree.Internal (tests) where
66

7-
import Control.Concurrent.Class.MonadMVar (MonadMVar)
8-
import Control.Concurrent.Class.MonadSTM (MonadSTM)
9-
import Control.Exception
10-
import Control.Monad.Class.MonadThrow (MonadMask)
11-
import Control.Monad.Primitive (PrimMonad)
127
import Control.Tracer
13-
import Data.Bifunctor (Bifunctor (..))
148
import Data.Coerce (coerce)
159
import qualified Data.Map.Strict as Map
1610
import Data.Maybe (isJust, mapMaybe)
1711
import qualified Data.Vector as V
18-
import Data.Word
1912
import Database.LSMTree.Extras.Generators ()
2013
import Database.LSMTree.Internal.BlobRef
2114
import qualified Database.LSMTree.Internal.BloomFilter as Bloom
@@ -26,20 +19,12 @@ import Database.LSMTree.Internal.Unsafe
2619
import qualified System.FS.API as FS
2720
import Test.QuickCheck
2821
import Test.Tasty
29-
import Test.Tasty.HUnit
3022
import Test.Tasty.QuickCheck
3123
import Test.Util.FS
3224

3325
tests :: TestTree
3426
tests = testGroup "Test.Database.LSMTree.Internal" [
35-
testGroup "Session" [
36-
testProperty "prop_newSession" prop_newSession
37-
, testProperty "prop_restoreSession" prop_restoreSession
38-
, testProperty "sessionDirLocked" sessionDirLocked
39-
, testCase "sessionDirCorrupted" sessionDirCorrupted
40-
, testCase "sessionDirDoesNotExist" sessionDirDoesNotExist
41-
]
42-
, testGroup "Cursor" [
27+
testGroup "Cursor" [
4328
testProperty "prop_roundtripCursor" $ withMaxSuccess 500 $
4429
prop_roundtripCursor
4530
]
@@ -56,75 +41,6 @@ testTableConfig = defaultTableConfig {
5641
confWriteBufferAlloc = AllocNumEntries 3
5742
}
5843

59-
prop_newSession ::
60-
Positive (Small Int)
61-
-> V.Vector (Word64, Entry Word64 Word64)
62-
-> Property
63-
prop_newSession (Positive (Small bufferSize)) es =
64-
ioProperty $
65-
withTempIOHasBlockIO "prop_newSession" $ \hfs hbio ->
66-
withOpenSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \session ->
67-
withTable session conf (updates const es')
68-
where
69-
conf = testTableConfig {
70-
confWriteBufferAlloc = AllocNumEntries bufferSize
71-
}
72-
es' = fmap (bimap serialiseKey (bimap serialiseValue serialiseBlob)) es
73-
74-
prop_restoreSession ::
75-
Positive (Small Int)
76-
-> V.Vector (Word64, Entry Word64 Word64)
77-
-> Property
78-
prop_restoreSession (Positive (Small bufferSize)) es =
79-
ioProperty $
80-
withTempIOHasBlockIO "prop_restoreSession" $ \hfs hbio -> do
81-
withOpenSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \session1 ->
82-
withTable session1 conf (updates const es')
83-
withOpenSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \session2 ->
84-
withTable session2 conf (updates const es')
85-
where
86-
conf = testTableConfig {
87-
confWriteBufferAlloc = AllocNumEntries bufferSize
88-
}
89-
es' = fmap (bimap serialiseKey (bimap serialiseValue serialiseBlob)) es
90-
91-
sessionDirLocked :: Property
92-
sessionDirLocked = ioProperty $
93-
withTempIOHasBlockIO "sessionDirLocked" $ \hfs hbio -> do
94-
bracket (openSession nullTracer hfs hbio testSalt (FS.mkFsPath [])) closeSession $ \_sesh1 ->
95-
bracket (try @SessionDirLockedError $ openSession nullTracer hfs hbio testSalt (FS.mkFsPath [])) tryCloseSession $ \case
96-
Left (ErrSessionDirLocked _dir) -> pure ()
97-
x -> assertFailure $ "Opening a session twice in the same directory \
98-
\should fail with an ErrSessionDirLocked error, but \
99-
\it returned this instead: " <> showLeft "Session" x
100-
101-
sessionDirCorrupted :: Assertion
102-
sessionDirCorrupted =
103-
withTempIOHasBlockIO "sessionDirCorrupted" $ \hfs hbio -> do
104-
FS.createDirectory hfs (FS.mkFsPath ["unexpected-directory"])
105-
bracket (try @SessionDirCorruptedError (openSession nullTracer hfs hbio testSalt (FS.mkFsPath []))) tryCloseSession $ \case
106-
Left (ErrSessionDirCorrupted _ _dir) -> pure ()
107-
x -> assertFailure $ "Restoring a session in a directory with a wrong \
108-
\layout should fail with a ErrSessionDirCorrupted, but \
109-
\it returned this instead: " <> showLeft "Session" x
110-
111-
sessionDirDoesNotExist :: Assertion
112-
sessionDirDoesNotExist = withTempIOHasBlockIO "sessionDirDoesNotExist" $ \hfs hbio -> do
113-
bracket (try @SessionDirDoesNotExistError (openSession nullTracer hfs hbio testSalt (FS.mkFsPath ["missing-dir"]))) tryCloseSession $ \case
114-
Left (ErrSessionDirDoesNotExist _dir) -> pure ()
115-
x -> assertFailure $ "Opening a session in a non-existent directory should \
116-
\fail with a ErrSessionDirDoesNotExist error, but it \
117-
\returned this instead: " <> showLeft "Session" x
118-
119-
-- | Internal helper: close a session opened with 'try'.
120-
tryCloseSession :: (MonadMask m, MonadSTM m, MonadMVar m, PrimMonad m) => Either e (Session m h) -> m ()
121-
tryCloseSession = either (const $ pure ()) closeSession
122-
123-
showLeft :: Show a => String -> Either a b -> String
124-
showLeft x = \case
125-
Left e -> show e
126-
Right _ -> x
127-
12844
-- | Check that reading from a cursor returns exactly the entries that have
12945
-- been inserted into the table. Roughly:
13046
--

0 commit comments

Comments
 (0)