fs-sim-0.3.1.0: test/Test/System/FS/Sim/Error.hs
{-# OPTIONS_GHC -Wno-orphans #-}
module Test.System.FS.Sim.Error (tests) where
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad (unless, void)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as LBS
import Data.Primitive (newPinnedByteArray)
import Data.Word
import System.FS.API
import qualified System.FS.API.Lazy as Lazy
import System.FS.API.Lazy (hGetExactlyAt)
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
-- For simplicity:
-- * We always use the full bytestring that is an argument to a property.
-- * File offsets are always 0.
-- * Byte counts are always the length of the argument bytestring.
-- * Offsets into user-supplied buffers are always 0.
-- * User-supplied buffers are always precisely as large as they need to be.
tests :: TestTree
tests = testGroup "Test.System.FS.Sim.Error" [
-- putters
testProperty "propPutterPutsAll hPutSome (expects failure)" $ expectFailure $
let toInput = pure
in propPutterPutsAll hPutSomeC hPutSome toInput
, testProperty "propPutterPutsAll Strict.hPutAllStrict" $
let toInput = pure
in propPutterPutsAll hPutSomeC Strict.hPutAllStrict toInput
, testProperty "propPutterPutsAll Lazy.hPutAll" $
let toInput = pure . LBS.fromStrict
in propPutterPutsAll hPutSomeC Lazy.hPutAll toInput
, testProperty "propPutterPutsAll Lazy.hPut" $
let toInput = pure . BB.byteString
in propPutterPutsAll hPutSomeC Lazy.hPut toInput
, testProperty "propPutterPutsAll hPutBufSome (expects failure)" $ expectFailure $ \p bs ->
let put hfs h mba = fromIntegral <$>
hPutBufSome hfs h mba 0 (fromIntegral $ BS.length bs)
toInput _ = do
mba <- newPinnedByteArray (BS.length bs)
success <- MockFS.intoBuffer mba 0 bs
unless success $ error "toInput: should not fail"
pure mba
in propPutterPutsAll hPutBufSomeC put toInput p bs
, testProperty "propPutterPutsAll hPutBufSomeAt (expects failure)" $ expectFailure $ \p bs ->
let put hfs h mba = fromIntegral <$>
hPutBufSomeAt hfs h mba 0 (fromIntegral $ BS.length bs) 0
toInput _ = do
mba <- newPinnedByteArray (BS.length bs)
success <- MockFS.intoBuffer mba 0 bs
unless success $ error "toInput: should not fail"
pure mba
in propPutterPutsAll hPutBufSomeAtC put toInput p bs
, testProperty "propPutterPutsAll hPutBufAll" $ \p bs ->
let put hfs h mba = fromIntegral <$>
hPutBufExactly hfs h mba 0 (fromIntegral $ BS.length bs)
toInput _ = do
mba <- newPinnedByteArray (BS.length bs)
success <- MockFS.intoBuffer mba 0 bs
unless success $ error "toInput: should not fail"
pure mba
in propPutterPutsAll hPutBufSomeC put toInput p bs
, testProperty "propPutterPutsAll hPutBufAllAt" $ \p bs ->
let put hfs h mba = fromIntegral <$>
hPutBufExactlyAt hfs h mba 0 (fromIntegral $ BS.length bs) 0
toInput _ = do
mba <- newPinnedByteArray (BS.length bs)
success <- MockFS.intoBuffer mba 0 bs
unless success $ error "toInput: should not fail"
pure mba
in propPutterPutsAll hPutBufSomeAtC put toInput p bs
-- getters
, testProperty "propGetterGetsAll hGetSome (expect failure)" $ expectFailure $ \p bs ->
let get hfs h = hGetSome hfs h (fromIntegral $ BS.length bs)
fromOutput = pure
in propGetterGetsAll hGetSomeC get fromOutput p bs
, testProperty "propGetterGetsAll hGetSomeAt (expect failure)" $ expectFailure $ \p bs ->
let get hfs h = hGetSomeAt hfs h (fromIntegral $ BS.length bs) 0
fromOutput = pure
in propGetterGetsAll hGetSomeC get fromOutput p bs
, testProperty "propGetterGetsAll Lazy.hGetExactly" $ \p bs ->
let get hfs h = Lazy.hGetExactly hfs h (fromIntegral $ BS.length bs)
fromOutput = pure . LBS.toStrict
in propGetterGetsAll hGetSomeC get fromOutput p bs
, testProperty "propGetterGetsAll Lazy.hGetExactlyAt" $ \p bs ->
let get hfs h = Lazy.hGetExactlyAt hfs h (fromIntegral $ BS.length bs) 0
fromOutput = pure . LBS.toStrict
in propGetterGetsAll hGetSomeAtC get fromOutput p bs
, testProperty "propGetterGetsAll Lazy.hGetAll" $ \p bs ->
let get = Lazy.hGetAll
fromOutput = pure . LBS.toStrict
in propGetterGetsAll hGetSomeC get fromOutput p bs
, testProperty "propGetterGetsAll Lazy.hGetAllAt" $ \p bs ->
let get hfs h = Lazy.hGetAllAt hfs h 0
fromOutput = pure . LBS.toStrict
in propGetterGetsAll hGetSomeAtC get fromOutput p bs
, testProperty "propGetterGetsAll hGetBufSome (expects failure)" $ expectFailure $ \p bs ->
let get hfs h = do
mba <- newPinnedByteArray (BS.length bs)
void $ hGetBufSome hfs h mba 0 (fromIntegral $ BS.length bs)
pure mba
fromOutput mba = do
MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>=
maybe (error "fromOutput: should not fail") pure
in propGetterGetsAll hGetBufSomeC get fromOutput p bs
, testProperty "propGetterGetsAll hGetBufSomeAt (expects failure)" $ expectFailure $ \p bs ->
let get hfs h = do
mba <- newPinnedByteArray (BS.length bs)
void $ hGetBufSomeAt hfs h mba 0 (fromIntegral $ BS.length bs) 0
pure mba
fromOutput mba = do
MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>=
maybe (error "fromOutput: should not fail") pure
in propGetterGetsAll hGetBufSomeAtC get fromOutput p bs
, testProperty "propGetterGetsAll hGetBufExactly" $ \p bs ->
let get hfs h = do
mba <- newPinnedByteArray (BS.length bs)
void $ hGetBufExactly hfs h mba 0 (fromIntegral $ BS.length bs)
pure mba
fromOutput mba = do
MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>=
maybe (error "fromOutput: should not fail") pure
in propGetterGetsAll hGetBufSomeC get fromOutput p bs
, testProperty "propGetterGetsAll hGetBufExactlyAt" $ \p bs ->
let get hfs h = do
mba <- newPinnedByteArray (BS.length bs)
void $ hGetBufExactlyAt hfs h mba 0 (fromIntegral $ BS.length bs) 0
pure mba
fromOutput mba = do
MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>=
maybe (error "fromOutput: should not fail") pure
in propGetterGetsAll hGetBufSomeAtC get fromOutput p bs
-- Generators and shrinkers
, testProperty "prop_regression_shrinkErrors"
prop_regression_shrinkErrors
, testProperty "prop_regression_shrinkNonEmptyErrors"
prop_regression_shrinkNonEmptyErrors
, testProperty "prop_regression_shrinkEmptyErrors"
prop_regression_shrinkEmptyErrors
]
instance Arbitrary BS.ByteString where
arbitrary = BS.pack <$> arbitrary
shrink = fmap BS.pack . shrink . BS.unpack
{-------------------------------------------------------------------------------
Read functions get all requested bytes
-------------------------------------------------------------------------------}
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 GetCounter = EntryCounters (StrictTVar IO) -> StrictTVar IO Word64
type PutFunction input = HasFS IO HandleMock -> Handle HandleMock -> input -> IO Word64
type ToInput input = BS.ByteString -> IO input
propPutterPutsAll ::
GetCounter
-> PutFunction input
-> ToInput input
-> SometimesPartialWrites
-> BS.ByteString
-> Property
propPutterPutsAll getCounter put toInput (SometimesPartialWrites errStream) bs =
ioProperty $ do
fsVar <- newTMVarIO MockFS.empty
errVar <- newTVarIO onlyPutErrors
counters <- zeroEntryCounters
let hfs = withEntryCounters counters $ simErrorHasFS fsVar errVar
withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do
inp <- toInput bs
n' <- put hfs h inp
let n = fromIntegral $ BS.length bs
bs' <- LBS.toStrict <$> hGetExactlyAt hfs h n 0
putN <- readTVarIO (getCounter counters)
pure $ checkCoverage
$ tabulate "number of writes (>1 indicates partial writes)"
[showPowersOf 2 $ fromIntegral putN]
. cover 0.60 (putN > 1) "At least one partial write"
$ n === n' .&&. bs === bs'
where
onlyPutErrors = emptyErrors {
hPutSomeE = errStream
, hPutBufSomeE = errStream
, hPutBufSomeAtE = errStream
}
{-------------------------------------------------------------------------------
Write functions put all requested bytes
-------------------------------------------------------------------------------}
newtype SometimesPartialReads = SometimesPartialReads {
getSometimesPartialReads :: ErrorStreamGetSome
}
deriving Show
instance Arbitrary SometimesPartialReads where
arbitrary = SometimesPartialReads <$> Stream.genInfinite (fmap Right <$> (arbitrary :: Gen (Maybe Partial)))
shrink = fmap SometimesPartialReads . Stream.shrinkStream . getSometimesPartialReads
type GetFunction output = HasFS IO HandleMock -> Handle HandleMock -> IO output
type FromOutput output = output -> IO BS.ByteString
propGetterGetsAll ::
GetCounter
-> GetFunction output
-> FromOutput output
-> SometimesPartialReads
-> BS.ByteString
-> Property
propGetterGetsAll getCounter get fromOutput (SometimesPartialReads errStream) bs =
ioProperty $ do
fsVar <- newTMVarIO MockFS.empty
errVar <- newTVarIO onlyGetErrors
counters <- zeroEntryCounters
let hfs = withEntryCounters counters $ simErrorHasFS fsVar errVar
withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do
n' <- Strict.hPutAllStrict hfs h bs
let n = fromIntegral $ BS.length bs
hSeek hfs h AbsoluteSeek 0
outp <- get hfs h
bs' <- fromOutput outp
getN <- readTVarIO (getCounter counters)
pure $ checkCoverage
$ tabulate "number of reads (>1 indicates partial reads)"
[showPowersOf 2 $ fromIntegral getN]
. cover 60 (getN > 1) "At least one partial read"
$ n === n' .&&. bs === bs'
where
onlyGetErrors = emptyErrors {
hGetSomeE = errStream
, hGetSomeAtE = errStream
, hGetBufSomeE = errStream
, hGetBufSomeAtE = errStream
}
{-------------------------------------------------------------------------------
Generators and shrinkers
-------------------------------------------------------------------------------}
-- | See fs-sim#84
prop_regression_shrinkErrors :: Errors -> Property
prop_regression_shrinkErrors _errs = expectFailure $
property False
-- | See fs-sim#84
prop_regression_shrinkNonEmptyErrors :: Errors -> Property
prop_regression_shrinkNonEmptyErrors errs = expectFailure $
not (allNull errs) ==> property False
newtype EmptyErrors = EmptyErrors Errors
deriving Show
instance Arbitrary EmptyErrors where
arbitrary = EmptyErrors <$> oneof [ pure emptyErrors ]
shrink (EmptyErrors errs) = EmptyErrors <$> shrink errs
-- | See fs-sim#84
prop_regression_shrinkEmptyErrors :: EmptyErrors -> Property
prop_regression_shrinkEmptyErrors (EmptyErrors errs) = expectFailure $
allNull errs ==> property False