Run lockstep tests with IOSim

blockio-sim/src/System/FS/BlockIO/Sim.hs

@@ -65,18 +65,26 @@ simTryLockFile hfs path lockmode =
       n <- readCount h
       case lockmode of
         SharedLock    | n >= 0 -> do writeCount h (n+1)
-                                     return (Just LockFileHandle { hUnlock })
+                                     mkLockFileHandle
         ExclusiveLock | n == 0 -> do writeCount h (-1)
-                                     return (Just LockFileHandle { hUnlock })
+                                     mkLockFileHandle
         _                      -> return Nothing
   where
-    hUnlock =
+    mkLockFileHandle = do
+      -- A lock file handle keeps open the file in read mode, such that a locked
+      -- file contributes to the number of open file handles. The mock FS allows
+      -- multiple readers and up to one writer to open the file concurrently.
+      h <- API.hOpen hfs path ReadMode
+      return (Just (LockFileHandle { hUnlock = hUnlock h }))
+
+    hUnlock h0 =
       API.withFile hfs path (ReadWriteMode AllowExisting) $ \h -> do
         n <- readCount h
         case lockmode of
           SharedLock    | n >  0  -> writeCount h (n-1)
           ExclusiveLock | n == -1 -> writeCount h 0
           _                       -> throwIO countCorrupt
+        hClose hfs h0
 
     readCount :: Handle h -> m Int
     readCount h = do

lsm-tree.cabal

@@ -395,6 +395,7 @@ test-suite lsm-tree-test
     , fs-api
     , fs-sim
     , io-classes
+    , io-classes:strict-mvar
     , io-classes:strict-stm
     , io-sim
     , lsm-tree

src/Database/LSMTree/Internal.hs

@@ -16,6 +16,7 @@ module Database.LSMTree.Internal (
   , Session (..)
   , SessionState (..)
   , SessionEnv (..)
+  , withOpenSession
     -- ** Implementation of public API
   , withSession
   , openSession

src/Database/LSMTree/Normal.hs

@@ -115,18 +115,20 @@ import           Control.Exception (throw)
 import           Control.Monad
 import           Data.Bifunctor (Bifunctor (..))
 import           Data.Kind (Type)
-import           Data.Typeable (Proxy (..), Typeable, cast)
+import           Data.Typeable (Proxy (..), eqT, type (:~:) (Refl))
 import qualified Data.Vector as V
 import           Database.LSMTree.Common (BlobRef (BlobRef), IOLike, Range (..),
                      SerialiseKey, SerialiseValue, Session, SnapshotName,
                      closeSession, deleteSnapshot, listSnapshots, openSession,
                      withSession)
 import qualified Database.LSMTree.Common as Common
 import qualified Database.LSMTree.Internal as Internal
+import qualified Database.LSMTree.Internal.BlobRef as Internal
 import qualified Database.LSMTree.Internal.Entry as Entry
 import           Database.LSMTree.Internal.Normal
 import qualified Database.LSMTree.Internal.Serialise as Internal
 import qualified Database.LSMTree.Internal.Vector as V
+import qualified System.FS.API as FS
 
 -- $resource-management
 -- Sessions, table handles and cursors use resources and as such need to be
@@ -569,16 +571,16 @@ deletes = updates . fmap (,Delete)
 retrieveBlobs ::
      ( IOLike m
      , SerialiseValue blob
-     , Typeable m
      )
   => Session m
   -> V.Vector (BlobRef m blob)
   -> m (V.Vector blob)
-retrieveBlobs (Internal.Session' sesh) refs =
+retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs =
     V.map Internal.deserialiseBlob <$>
       Internal.retrieveBlobs sesh (V.imap checkBlobRefType refs)
   where
-    checkBlobRefType _ (BlobRef ref) | Just ref' <- cast ref = ref'
+    checkBlobRefType _ (BlobRef (ref :: Internal.WeakBlobRef m (FS.Handle h')))
+      | Just Refl <- eqT @(FS.Handle h) @(FS.Handle h') = ref
     checkBlobRefType i _ = throw (Internal.ErrBlobRefInvalid i)
 
 {-------------------------------------------------------------------------------

test/Database/LSMTree/Class/Normal.hs

@@ -120,8 +120,6 @@ class (IsSession (Session h)) => IsTableHandle h where
     retrieveBlobs ::
            ( IOLike m
            , SerialiseValue blob
-             -- Model-specific constraints
-           , Typeable m
            )
         => proxy h
         -> Session h m

test/Test/Database/LSMTree/Class/Normal.hs

@@ -14,7 +14,6 @@ import qualified Data.List as List
 import qualified Data.List.NonEmpty as NE
 import           Data.Maybe (fromMaybe)
 import qualified Data.Proxy as Proxy
-import           Data.Typeable (Typeable)
 import qualified Data.Vector as V
 import qualified Data.Vector.Algorithms.Merge as VA
 import           Data.Word (Word64)
@@ -136,7 +135,6 @@ retrieveBlobsTrav ::
      , IOLike m
      , SerialiseValue blob
      , Traversable t
-     , Typeable m
      )
   => proxy h
   -> Session h m
@@ -155,7 +153,6 @@ lookupsWithBlobs :: forall h m k v blob.
      , SerialiseKey k
      , SerialiseValue v
      , SerialiseValue blob
-     , Typeable m
      )
   => h m k v blob
   -> Session h m
@@ -171,7 +168,6 @@ rangeLookupWithBlobs :: forall h m k v blob.
      , SerialiseKey k
      , SerialiseValue v
      , SerialiseValue blob
-     , Typeable m
      )
   => h m k v blob
   -> Session h m
@@ -187,7 +183,6 @@ readCursorWithBlobs :: forall h m k v blob proxy.
      , SerialiseKey k
      , SerialiseValue v
      , SerialiseValue blob
-     , Typeable m
      )
   => proxy h
   -> Session h m
@@ -204,7 +199,6 @@ readCursorAllWithBlobs :: forall h m k v blob proxy.
      , SerialiseKey k
      , SerialiseValue v
      , SerialiseValue blob
-     , Typeable m
      )
   => proxy h
   -> Session h m

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

@@ -33,7 +33,7 @@ import qualified Database.LSMTree.Internal.RawBytes as RB
 import           Database.LSMTree.Internal.RawPage
 import           Database.LSMTree.Internal.Run as Run
 import           Database.LSMTree.Internal.Serialise
-import           Test.Util.FS (noOpenHandles, withSimHasBlockIO)
+import           Test.Util.FS (propNoOpenHandles, withSimHasBlockIO)
 
 import qualified FormatPage as Proto
 
@@ -60,10 +60,10 @@ tests = testGroup "Database.LSMTree.Internal.Run"
               (mkVal ("test-value-" <> BS.concat (replicate 500 "0123456789")))
               Nothing
       , testProperty "prop_WriteAndOpen" $ \wb ->
-          ioProperty $ withSimHasBlockIO noOpenHandles $ \hfs hbio ->
+          ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio ->
             prop_WriteAndOpen hfs hbio wb
       , testProperty "prop_WriteNumEntries" $ \wb ->
-          ioProperty $ withSimHasBlockIO noOpenHandles $ \hfs hbio ->
+          ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio ->
             prop_WriteNumEntries hfs hbio wb
       ]
     ]

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

@@ -27,11 +27,11 @@ tests = testGroup "Test.Database.LSMTree.Internal.RunBuilder" [
         ]
     , testGroup "simHasFS" [
           testProperty "prop_newInExistingDir" $ ioProperty $
-            withSimHasFS noOpenHandles prop_newInExistingDir
+            withSimHasFS propNoOpenHandles prop_newInExistingDir
         , testProperty "prop_newInNonExistingDir" $ ioProperty $
-            withSimHasFS noOpenHandles prop_newInNonExistingDir
+            withSimHasFS propNoOpenHandles prop_newInNonExistingDir
         , testProperty "prop_newTwice" $ ioProperty $
-            withSimHasFS noOpenHandles prop_newTwice
+            withSimHasFS propNoOpenHandles prop_newTwice
         ]
     ]
 

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

@@ -18,27 +18,27 @@ import qualified System.FS.API as FS
 import qualified System.FS.BlockIO.API as FS
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.QuickCheck
-import           Test.Util.FS (noOpenHandles, withSimHasBlockIO,
+import           Test.Util.FS (propNoOpenHandles, withSimHasBlockIO,
                      withTempIOHasBlockIO)
 import           Test.Util.Orphans ()
 
 tests :: TestTree
 tests = testGroup "Database.LSMTree.Internal.RunReader"
     [ testGroup "MockFS"
         [ testProperty "prop_read" $ \wb ->
-            ioProperty $ withSimHasBlockIO noOpenHandles $ \hfs hbio -> do
+            ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
               prop_readAtOffset hfs hbio wb Nothing
         , testProperty "prop_readAtOffset" $ \wb offset ->
-            ioProperty $ withSimHasBlockIO noOpenHandles $ \hfs hbio -> do
+            ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
               prop_readAtOffset hfs hbio wb (Just offset)
         , testProperty "prop_readAtOffsetExisting" $ \wb i ->
-            ioProperty $ withSimHasBlockIO noOpenHandles $ \hfs hbio -> do
+            ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
               prop_readAtOffsetExisting hfs hbio wb i
         , testProperty "prop_readAtOffsetIdempotence" $ \wb i ->
-            ioProperty $ withSimHasBlockIO noOpenHandles $ \hfs hbio -> do
+            ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
               prop_readAtOffsetIdempotence hfs hbio wb i
         , testProperty "prop_readAtOffsetReadHead" $ \wb ->
-            ioProperty $ withSimHasBlockIO noOpenHandles $ \hfs hbio -> do
+            ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
               prop_readAtOffsetReadHead hfs hbio wb
         ]
     , testGroup "RealFS"