Tests for simulation with error injection

fs-sim/fs-sim.cabal

@@ -59,9 +59,13 @@ test-suite fs-sim-test
   hs-source-dirs:   test src
   main-is:          Main.hs
   other-modules:
+    System.FS.Sim.Error
     System.FS.Sim.FsTree
     System.FS.Sim.MockFS
     System.FS.Sim.Prim
+    System.FS.Sim.STM
+    System.FS.Sim.Stream
+    Test.System.FS.Sim.Error
     Test.System.FS.Sim.FsTree
     Test.System.FS.StateMachine
     Test.Util.RefEnv
@@ -75,12 +79,15 @@ test-suite fs-sim-test
     , containers
     , fs-api
     , generics-sop
+    , io-classes
     , mtl
     , pretty-show
     , primitive
     , QuickCheck
     , quickcheck-state-machine  >=0.7.2 && <0.8
     , random
+    , safe-wild-cards
+    , strict-stm
     , tasty
     , tasty-hunit
     , tasty-quickcheck

fs-sim/test/Main.hs

@@ -1,20 +1,13 @@
 module Main (main) where
 
-import           System.IO.Temp (withSystemTempDirectory)
-
-import           Test.Tasty
-
+import qualified Test.System.FS.Sim.Error
 import qualified Test.System.FS.Sim.FsTree
 import qualified Test.System.FS.StateMachine
+import           Test.Tasty
 
 main :: IO ()
-main = withSystemTempDirectory "fs-sim-test" $ \tmpDir ->
-  defaultMain $
-    testGroup "Test" [
-        testGroup "System" [
-            testGroup "FS" [
-                Test.System.FS.StateMachine.tests tmpDir
-              , Test.System.FS.Sim.FsTree.tests
-              ]
-          ]
-      ]
+main = defaultMain $ testGroup "fs-sim-test" [
+      Test.System.FS.Sim.Error.tests
+    , Test.System.FS.Sim.FsTree.tests
+    , Test.System.FS.StateMachine.tests
+    ]

fs-sim/test/Test/System/FS/Sim/Error.hs

@@ -0,0 +1,47 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.System.FS.Sim.Error (tests) where
+
+import           Control.Concurrent.Class.MonadSTM.Strict
+import           Data.ByteString
+import qualified Data.ByteString as BS
+import           System.FS.API
+import qualified System.FS.API.Strict as Strict
+import           System.FS.Sim.Error
+import qualified System.FS.Sim.MockFS as MockFS
+import qualified System.FS.Sim.Stream as Stream
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+
+tests :: TestTree
+tests = testGroup "Test.System.FS.Sim.Error" [
+      testProperty "propPutAllStrictPutsAll" $
+        forAllShrink sometimesPartialWrites Stream.shrinkStream
+          propPutAllStrictPutsAll
+    ]
+
+instance Arbitrary ByteString where
+  arbitrary = BS.pack <$> arbitrary
+  shrink = fmap BS.pack . shrink . BS.unpack
+
+-- | Verify that 'hPutAllStrict' writes all requested bytes in the presence of
+-- partial writes.
+propPutAllStrictPutsAll :: ErrorStreamPutSome -> ByteString -> Property
+propPutAllStrictPutsAll errStream bs =
+    ioProperty $ do
+      fsVar <- newTMVarIO MockFS.empty
+      errVar <- newTVarIO (emptyErrors { hPutSomeE = errStream })
+      let hfs = mkSimErrorHasFS fsVar errVar
+      prop <- withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do
+        n' <- Strict.hPutAllStrict hfs h bs
+        let n = fromIntegral $ BS.length bs
+        bs' <- hGetSomeAt hfs h n 0
+        pure (n === n' .&&. bs === bs')
+      fcover <- withFile hfs (mkFsPath ["file2"]) (ReadWriteMode MustBeNew) $ \h -> do
+        n' <- Strict.hPutSome hfs h bs
+        let n = fromIntegral $ BS.length bs
+        pure $ cover 0.5 (n /= n') "At least one partial write"
+      pure $ fcover prop
+
+sometimesPartialWrites :: Gen ErrorStreamPutSome
+sometimesPartialWrites = Stream.genInfinite (Just . Right <$> arbitrary)

fs-sim/test/Test/System/FS/StateMachine.hs

@@ -84,7 +84,7 @@ import           Data.Word (Word64)
 import qualified Generics.SOP as SOP
 import           GHC.Generics
 import           GHC.Stack hiding (prettyCallStack)
-import           System.IO.Temp (withTempDirectory)
+import           System.IO.Temp (withSystemTempDirectory)
 import           System.Posix.Types (ByteCount)
 import           System.Random (getStdRandom, randomR)
 import           Text.Read (readMaybe)
@@ -1567,14 +1567,14 @@ showLabelledExamples' mReplay numTests focus = do
 showLabelledExamples :: IO ()
 showLabelledExamples = showLabelledExamples' Nothing 1000 (const True)
 
-prop_sequential :: FilePath -> Property
-prop_sequential tmpDir = withMaxSuccess 1000 $
-    QSM.forAllCommands (sm mountUnused) Nothing $ runCmds tmpDir
+prop_sequential :: Property
+prop_sequential = withMaxSuccess 1000 $
+    QSM.forAllCommands (sm mountUnused) Nothing runCmds
 
-runCmds :: FilePath -> QSM.Commands (At Cmd) (At Resp) -> Property
-runCmds tmpDir cmds = QC.monadicIO $ do
+runCmds :: QSM.Commands (At Cmd) (At Resp) -> Property
+runCmds cmds = QC.monadicIO $ do
       (tstTmpDir, hist, res) <- QC.run $
-        withTempDirectory tmpDir "HasFS" $ \tstTmpDir -> do
+        withSystemTempDirectory "StateMachine" $ \tstTmpDir -> do
           let mount = MountPoint tstTmpDir
               sm'   = sm mount
 
@@ -1591,11 +1591,11 @@ runCmds tmpDir cmds = QC.monadicIO $ do
         $ counterexample ("Mount point: " ++ tstTmpDir)
         $ res === QSM.Ok
 
-tests :: FilePath -> TestTree
-tests tmpDir = testGroup "HasFS" [
-      testProperty "q-s-m" $ prop_sequential tmpDir
+tests :: TestTree
+tests = testGroup "Test.System.FS.StateMachine" [
+      testProperty "q-s-m" $ prop_sequential
     , localOption (QuickCheckTests 1)
-    $ testProperty "regression_removeFileOnDir" $ runCmds tmpDir regression_removeFileOnDir
+    $ testProperty "regression_removeFileOnDir" $ runCmds regression_removeFileOnDir
     ]
 
 -- | Unused mount mount