blockio: refactor and document the Sim module

Author: jorisdral

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

@@ -1,10 +1,18 @@
+-- | Simulated instances of 'HasBlockIO' and 'HasFS'.
 module System.FS.BlockIO.Sim (
-    fromHasFS
-    -- * Initialisation helpers
+    -- * Implementation details #impl#
+    -- $impl
+
+    -- * Runners
+    runSimHasBlockIO
+  , runSimErrorHasBlockIO
+    -- * Initialisation
   , simHasBlockIO
   , simHasBlockIO'
   , simErrorHasBlockIO
   , simErrorHasBlockIO'
+    -- ** Unsafe
+  , unsafeFromHasFS
   ) where
 
 import           Control.Concurrent.Class.MonadMVar
@@ -24,11 +32,55 @@ import           System.FS.Sim.Error
 import           System.FS.Sim.MockFS hiding (hClose, hOpen)
 import           System.FS.Sim.STM
 
-fromHasFS ::
+{- $impl
+
+  We include below some documentation about the effects of calling the interface
+  functions on the simulated instance of the 'HasBlockIO' interface.
+
+  [IO context]: For uniform behaviour across implementations, the simulation
+    creates and stores a mocked IO context that has the open/closed behaviour
+    that is specified by the interface.
+
+  ['close']: Close the mocked context
+
+  ['submitIO']: Submit a batch of I\/O operations using serial I\/O using a
+      'HasFS'
+
+  ['hSetNoCache']: No-op
+
+  ['hAdvise']: No-op
+
+  ['hAllocate']: No-op
+
+  ['tryLockFile']: Simulate a lock by putting the lock state into the file
+      contents
+
+  ['hSynchronise']: No-op
+
+  ['synchroniseDirectory']: No-op
+
+  ['createHardLink']: Copy all file contents from the source path to the target
+      path. Therefore, this is currently only correctly simulating hard links
+      for /immutable/ files.
+-}
+
+-- | Simulate a 'HasBlockIO' using the given 'HasFS'.
+--
+-- === Unsafe
+--
+-- You will probably want to use one of the safe functions like
+-- 'runSimHasBlockIO' or 'simErrorHasBlockIO' instead.
+--
+-- Only a simulated 'HasFS', like the 'simHasFS' and 'simErrorHasFS'
+-- simulations, should be passed to 'unsafeFromHasFS'. Technically, one could
+-- pass a 'HasFS' for the /real/ file system, but then the resulting
+-- 'HasBlockIO' would contain a mix of simulated functions and real functions,
+-- which is probably not what you want.
+unsafeFromHasFS ::
      forall m. (MonadCatch m, MonadMVar m, PrimMonad m)
   => HasFS m HandleMock
   -> m (HasBlockIO m HandleMock)
-fromHasFS hfs =
+unsafeFromHasFS hfs =
     serialHasBlockIO
       hSetNoCache
       hAdvise
@@ -142,43 +194,131 @@ simCreateHardLink hfs sourcePath targetPath =
       void $ API.hPutAll hfs targetHandle bs
 
 {-------------------------------------------------------------------------------
-  Initialisation helpers
+  Runners
 -------------------------------------------------------------------------------}
 
+-- | @'runSimHasBlockIO' mockFS action@ runs an @action@ using a pair of
+-- simulated 'HasFS' and 'HasBlockIO'.
+--
+-- The pair of interfaces share the same mocked file system. The initial state
+-- of the mocked file system is set to @mockFs@. The final state of the mocked
+-- file system is returned with the result of @action@.
+--
+-- If you want to have access to the current state of the mocked file system,
+-- use 'simHasBlockIO' instead.
+runSimHasBlockIO ::
+     (MonadSTM m, PrimMonad m, MonadCatch m, MonadMVar m)
+  => MockFS
+  -> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m a)
+  -> m (a, MockFS)
+runSimHasBlockIO mockFS k = do
+    runSimFS mockFS $ \hfs -> do
+      hbio <- unsafeFromHasFS hfs
+      k hfs hbio
+
+-- | @'runSimErrorHasBlockIO' mockFS errors action@ runs an @action@ using a
+-- pair of simulated 'HasFS' and 'HasBlockIO' that allow fault injection.
+--
+-- The pair of interfaces share the same mocked file system. The initial state
+-- of the mocked file system is set to @mockFs@. The final state of the mocked
+-- file system is returned with the result of @action@.
+--
+-- The pair of interfaces share the same stream of errors. The initial state of
+-- the stream of errors is set to @errors@. The final state of the stream of
+-- errors is returned with the result of @action@.
+--
+-- If you want to have access to the current state of the mocked file system
+-- or stream of errors, use 'simErrorHasBlockIO' instead.
+runSimErrorHasBlockIO ::
+     (MonadSTM m, PrimMonad m, MonadCatch m, MonadMVar m)
+  => MockFS
+  -> Errors
+  -> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m a)
+  -> m (a, MockFS, Errors)
+runSimErrorHasBlockIO mockFS errs k = do
+    fsVar <- newTMVarIO mockFS
+    errorsVar <- newTVarIO errs
+    (hfs, hbio) <- simErrorHasBlockIO fsVar errorsVar
+    a <- k hfs hbio
+    fs' <- atomically $ takeTMVar fsVar
+    errs' <- readTVarIO errorsVar
+    pure (a, fs', errs')
+
+{-------------------------------------------------------------------------------
+  Initialisation
+-------------------------------------------------------------------------------}
+
+-- | @'simHasBlockIO' mockFsVar@ creates a pair of simulated 'HasFS' and
+-- 'HasBlockIO'.
+--
+-- The pair of interfaces share the same mocked file system, which is stored in
+-- @mockFsVar@. The current state of the mocked file system can be accessed by
+-- the user by reading @mockFsVar@, but note that the user should not leave
+-- @mockFsVar@ empty.
 simHasBlockIO ::
      (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)
   => StrictTMVar m MockFS
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
 simHasBlockIO var = do
     let hfs = simHasFS var
-    hbio <- fromHasFS hfs
+    hbio <- unsafeFromHasFS hfs
     pure (hfs, hbio)
 
+-- | @'simHasBlockIO' mockFs@ creates a pair of simulated 'HasFS' and
+-- 'HasBlockIO' that allow fault injection.
+--
+-- The pair of interfaces share the same mocked file system. The initial state
+-- of the mocked file system is set to @mockFs@.
+--
+-- If you want to have access to the current state of the mocked file system,
+-- use 'simHasBlockIO' instead.
 simHasBlockIO' ::
      (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)
   => MockFS
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
 simHasBlockIO' mockFS = do
     hfs <- simHasFS' mockFS
-    hbio <- fromHasFS hfs
+    hbio <- unsafeFromHasFS hfs
     pure (hfs, hbio)
 
+-- | @'simErrorHasBlockIO' mockFsVar errorsVar@ creates a pair of simulated
+-- 'HasFS' and 'HasBlockIO' that allow fault injection.
+--
+-- The pair of interfaces share the same mocked file system, which is stored in
+-- @mockFsVar@. The current state of the mocked file system can be accessed by
+-- the user by reading @mockFsVar@, but note that the user should not leave
+-- @mockFsVar@ empty.
+--
+-- The pair of interfaces share the same stream of errors, which is stored in
+-- @errorsVar@. The current state of the stream of errors can be accessed by the
+-- user by reading @errorsVar@.
 simErrorHasBlockIO ::
      forall m. (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)
   => StrictTMVar m MockFS
   -> StrictTVar m Errors
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
 simErrorHasBlockIO fsVar errorsVar = do
     let hfs = simErrorHasFS fsVar errorsVar
-    hbio <- fromHasFS hfs
+    hbio <- unsafeFromHasFS hfs
     pure (hfs, hbio)
 
+-- | @'simErrorHasBlockIO' mockFs errors@ creates a pair of simulated 'HasFS'
+-- and 'HasBlockIO' that allow fault injection.
+--
+-- The pair of interfaces share the same mocked file system. The initial state
+-- of the mocked file system is set to @mockFs@.
+--
+-- The pair of interfaces share the same stream of errors. The initial state of
+-- the stream of errors is set to @errors@.
+--
+-- If you want to have access to the current state of the mocked file system
+-- or stream of errors, use 'simErrorHasBlockIO' instead.
 simErrorHasBlockIO' ::
      (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)
   => MockFS
   -> Errors
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
 simErrorHasBlockIO' mockFS errs = do
     hfs <- simErrorHasFS' mockFS errs
-    hbio <- fromHasFS hfs
+    hbio <- unsafeFromHasFS hfs
     pure (hfs, hbio)

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

@@ -51,10 +51,7 @@ tests = testGroup "Test.Database.LSMTree.Internal.Merge"
       => (FS.HasFS IO FsSim.HandleMock -> FS.HasBlockIO IO FsSim.HandleMock -> IO p)
       -> Property
     ioPropertyWithMockFS prop = ioProperty $ do
-        (res, mockFS) <-
-          FsSim.runSimErrorFS FsSim.empty FsSim.emptyErrors $ \_ fs -> do
-            hbio <- FsSim.fromHasFS fs
-            prop fs hbio
+        (res, mockFS, _) <- FsSim.runSimErrorHasBlockIO FsSim.empty FsSim.emptyErrors prop
         pure $ res
             .&&. counterexample "open handles"
                    (FsSim.numOpenHandles mockFS === 0)

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

@@ -38,7 +38,6 @@ import qualified System.FS.API as FS
 import qualified System.FS.BlockIO.API as FS
 import qualified System.FS.BlockIO.Sim as FsSim
 import qualified System.FS.Sim.MockFS as MockFS
-import qualified System.FS.Sim.STM as FsSim
 import qualified Test.QuickCheck as QC
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.QuickCheck
@@ -54,8 +53,7 @@ tests = testGroup "Database.LSMTree.Internal.Readers"
     [ testProperty "prop_lockstep" $
         Lockstep.runActionsBracket (Proxy @ReadersState)
           mempty mempty $ \act () -> do
-          (prop, mockFS) <- FsSim.runSimFS MockFS.empty $ \hfs -> do
-            hbio <- FsSim.fromHasFS hfs
+          (prop, mockFS) <- FsSim.runSimHasBlockIO MockFS.empty $ \hfs hbio -> do
             (prop, RealState _ mCtx) <- runRealMonad hfs hbio
                                                      (RealState 0 Nothing) act
             traverse_ closeReadersCtx mCtx  -- close current readers

test/Test/Util/FS.hs

@@ -75,7 +75,7 @@ import           System.FS.API as FS
 import qualified System.FS.API.Lazy as FSL
 import           System.FS.BlockIO.API
 import           System.FS.BlockIO.IO hiding (unsafeFromHasFS)
-import           System.FS.BlockIO.Sim (fromHasFS)
+import           System.FS.BlockIO.Sim (unsafeFromHasFS)
 import           System.FS.IO
 import           System.FS.Sim.Error
 import           System.FS.Sim.MockFS (HandleMock, MockFS, numOpenHandles,
@@ -136,7 +136,7 @@ withSimHasBlockIO ::
   -> m Property
 withSimHasBlockIO post fs k = do
     withSimHasFS post fs $ \hfs fsVar -> do
-      hbio <- fromHasFS hfs
+      hbio <- unsafeFromHasFS hfs
       k hfs hbio fsVar
 
 {-------------------------------------------------------------------------------
@@ -180,7 +180,7 @@ withSimErrorHasBlockIO ::
   -> m Property
 withSimErrorHasBlockIO post fs errs k =
     withSimErrorHasFS post fs errs $ \hfs fsVar errsVar -> do
-      hbio <- fromHasFS hfs
+      hbio <- unsafeFromHasFS hfs
       k hfs hbio fsVar errsVar
 
 {-------------------------------------------------------------------------------

test/Test/Util/FS/Error.hs

@@ -114,7 +114,7 @@ simErrorHasBlockIOLogged ::
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
 simErrorHasBlockIOLogged fsVar errorsVar logVar = do
     let hfs = simErrorHasFSLogged fsVar errorsVar logVar
-    hbio <- fromHasFS hfs
+    hbio <- unsafeFromHasFS hfs
     pure (hfs, hbio)
 
 -- | Produce a simulated file system with injected errors and a logger for those