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 System.FS.API.Lazy (hGetExactlyAt)
import qualified System.FS.API.Lazy as Lazy
import qualified System.FS.API.Strict as Strict
import System.FS.Sim.Error
import System.FS.Sim.MockFS (HandleMock)
import qualified System.FS.Sim.MockFS as MockFS
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