WIP

fs-sim/fs-sim.cabal

@@ -68,10 +68,13 @@ test-suite fs-sim-test
     Test.System.FS.Sim.Error
     Test.System.FS.Sim.FsTree
     Test.System.FS.StateMachine
+    Test.Util
     Test.Util.RefEnv
+    Test.Util.WithEntryCounter
 
   default-language: Haskell2010
   build-depends:
+    , barbies
     , base
     , base16-bytestring
     , bifunctors

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

@@ -3,45 +3,73 @@
 module Test.System.FS.Sim.Error (tests) where
 
 import           Control.Concurrent.Class.MonadSTM.Strict
-import           Data.ByteString
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Lazy as LBS
+import           Data.Word
 import           System.FS.API
+import qualified System.FS.API.Lazy as Lazy
 import qualified System.FS.API.Strict as Strict
 import           System.FS.Sim.Error
 import qualified System.FS.Sim.MockFS as MockFS
+import           System.FS.Sim.MockFS (HandleMock)
 import qualified System.FS.Sim.Stream as Stream
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
+import           Test.Util
+import           Test.Util.WithEntryCounter
 
 tests :: TestTree
 tests = testGroup "Test.System.FS.Sim.Error" [
-      testProperty "propPutAllStrictPutsAll" $
-        forAllShrink sometimesPartialWrites Stream.shrinkStream
-          propPutAllStrictPutsAll
+      testProperty "propPutterPutsAll Strict.hPutAllStrict" $
+        propPutterPutsAll Strict.hPutAllStrict id hPutSomeC
+    , testProperty "propPutterPutsAll Lazy.hPutAll" $
+        propPutterPutsAll Lazy.hPutAll LBS.fromStrict hPutSomeC
+    , testProperty "propPutterPutsAll Lazy.hPut" $
+        propPutterPutsAll Lazy.hPut BB.byteString hPutSomeC
     ]
 
-instance Arbitrary ByteString where
+instance Arbitrary BS.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 =
+newtype SometimesPartialWrites = SometimesPartialWrites {
+    getSometimesPartialWrites :: ErrorStreamPutSome
+  }
+  deriving Show
+
+instance Arbitrary SometimesPartialWrites where
+  arbitrary = SometimesPartialWrites <$> Stream.genInfinite (fmap Right <$> (arbitrary :: Gen (Maybe Partial)))
+  shrink = fmap SometimesPartialWrites .  Stream.shrinkStream . getSometimesPartialWrites
+
+type PutFunction input = HasFS IO HandleMock -> Handle HandleMock -> input -> IO Word64
+type ToInput input = BS.ByteString -> input
+
+propPutterPutsAll ::
+     PutFunction input
+  -> ToInput input
+  -> (EntryCounters (StrictTVar IO) -> StrictTVar IO Word64)
+  -> SometimesPartialWrites
+  -> BS.ByteString
+  -> Property
+propPutterPutsAll put toInput count (SometimesPartialWrites 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
+      errVar <- newTVarIO onlyPutErrors
+      counters <- zeroEntryCounters
+      let hfs = withEntryCounters counters $ mkSimErrorHasFS fsVar errVar
+      withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do
+        n' <- put hfs h (toInput 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)
+        putN <- readTVarIO (count counters)
+        pure $ tabulate "number of writes (>1 indicates partial writes)"
+                        [showPowersOf 2 $ fromIntegral putN]
+            . cover 0.75 (putN > 1) "At least one partial write"
+            $ n === n' .&&. bs === bs'
+  where
+    onlyPutErrors = emptyErrors {
+        hPutSomeE = errStream
+      , hPutBufSomeE = errStream
+      , hPutBufSomeAtE = errStream
+      }

fs-sim/test/Test/Util.hs

@@ -0,0 +1,21 @@
+module Test.Util (
+    showPowersOf10
+  , showPowersOf
+  ) where
+
+import           Data.List (find)
+import           Data.Maybe (fromJust)
+import           Text.Printf
+
+showPowersOf10 :: Int -> String
+showPowersOf10 = showPowersOf 10
+
+showPowersOf :: Int -> Int -> String
+showPowersOf factor n
+  | factor <= 1 = error "showPowersOf: factor must be larger than 1"
+  | n < 0       = "n < 0"
+  | n == 0      = "n == 0"
+  | otherwise   = printf "%d <= n < %d" lb ub
+  where
+    ub = fromJust (find (n <) (iterate (* factor) factor))
+    lb = ub `div` factor

fs-sim/test/Test/Util/WithEntryCounter.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Test.Util.WithEntryCounter (
+    EntryCounters (..)
+  , zeroEntryCounters
+  , incrTVar
+  , withEntryCounters
+  ) where
+
+import           Control.Concurrent.Class.MonadSTM.Strict
+import           Data.Word
+import           System.FS.API
+
+data EntryCounters f = EntryCounters {
+    dumpStateC                :: f Word64
+    -- file operations
+  , hOpenC                    :: f Word64
+  , hCloseC                   :: f Word64
+  , hIsOpenC                  :: f Word64
+  , hSeekC                    :: f Word64
+  , hGetSomeC                 :: f Word64
+  , hGetSomeAtC               :: f Word64
+  , hPutSomeC                 :: f Word64
+  , hTruncateC                :: f Word64
+  , hGetSizeC                 :: f Word64
+    -- directory operations
+  , createDirectoryC          :: f Word64
+  , createDirectoryIfMissingC :: f Word64
+  , listDirectoryC            :: f Word64
+  , doesDirectoryExistC       :: f Word64
+  , doesFileExistC            :: f Word64
+  , removeDirectoryRecursiveC :: f Word64
+  , removeFileC               :: f Word64
+  , renameFileC               :: f Word64
+    -- file I\/O with user-supplied buffers
+  , hGetBufSomeC              :: f Word64
+  , hGetBufSomeAtC            :: f Word64
+  , hPutBufSomeC              :: f Word64
+  , hPutBufSomeAtC            :: f Word64
+  }
+
+zeroEntryCounters :: MonadSTM m => m (EntryCounters (StrictTVar m))
+zeroEntryCounters = EntryCounters <$>
+    newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*>
+    newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*>
+    newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*>
+    newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*>
+    newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*>
+    newTVarIO 0 <*> newTVarIO 0
+
+incrTVar :: MonadSTM m => StrictTVar m Word64 -> m ()
+incrTVar var = atomically $ modifyTVar var (+1)
+
+withEntryCounters ::
+     MonadSTM m
+  => EntryCounters (StrictTVar m)
+  -> HasFS m h
+  -> HasFS m h
+withEntryCounters EntryCounters{..} HasFS{..} = HasFS {
+      dumpState = incrTVar dumpStateC >> dumpState
+      -- file operatoins
+    , hOpen = \a b -> incrTVar hOpenC >> hOpen a b
+    , hClose = \a -> incrTVar hCloseC >> hClose a
+    , hIsOpen = \a -> incrTVar hIsOpenC >> hIsOpen a
+    , hSeek = \a b c -> incrTVar hSeekC >> hSeek a b c
+    , hGetSome = \a b -> incrTVar hGetSomeC >> hGetSome a b
+    , hGetSomeAt = \a b c -> incrTVar hGetSomeAtC >> hGetSomeAt a b c
+    , hPutSome = \a b -> incrTVar hPutSomeC >> hPutSome a b
+    , hTruncate = \a b -> incrTVar hTruncateC >> hTruncate a b
+    , hGetSize = \a -> incrTVar hGetSizeC >> hGetSize a
+      -- directory operations
+    , createDirectory = \a -> incrTVar createDirectoryC >> createDirectory a
+    , createDirectoryIfMissing = \a b -> incrTVar createDirectoryIfMissingC >> createDirectoryIfMissing a b
+    , listDirectory = \a -> incrTVar listDirectoryC >> listDirectory a
+    , doesDirectoryExist = \a -> incrTVar doesDirectoryExistC >> doesDirectoryExist a
+    , doesFileExist = \a -> incrTVar doesFileExistC >> doesFileExist a
+    , removeDirectoryRecursive = \a -> incrTVar removeDirectoryRecursiveC >> removeDirectoryRecursive a
+    , removeFile = \a -> incrTVar removeFileC >> removeFile a
+    , renameFile = \a b -> incrTVar renameFileC >> renameFile a b
+    , mkFsErrorPath = mkFsErrorPath
+    , unsafeToFilePath = unsafeToFilePath
+      -- file I\/O with user-supplied buffers
+    , hGetBufSome = \a b c d -> incrTVar hGetBufSomeC >> hGetBufSome a b c d
+    , hGetBufSomeAt = \a b c d e -> incrTVar hGetBufSomeAtC >> hGetBufSomeAt a b c d e
+    , hPutBufSome = \a b c d -> incrTVar hPutBufSomeC >> hPutBufSome a b c d
+    , hPutBufSomeAt = \a b c d e -> incrTVar hPutBufSomeAtC >> hPutBufSomeAt a b c d e
+    }