{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE UndecidableInstances  #-}

-- | 'HasFS' instance wrapping 'SimFS' that generates errors, suitable for
-- testing error handling.
module System.FS.Sim.Error (
    -- * Simulate Errors monad
    simErrorHasFS
  , simErrorHasFS'
  , runSimErrorFS
  , withErrors
    -- * Streams
  , ErrorStream
  , ErrorStreamGetSome
  , ErrorStreamPutSome
    -- * Generating partial reads/writes
  , Partial (..)
  , partialiseByteCount
  , partialiseWord64
  , partialiseByteString
    -- * Blob
  , Blob (..)
  , blobFromBS
  , blobToBS
    -- * Generating corruption for 'hPutSome'
  , PutCorruption (..)
  , corruptByteString
    -- * Error streams for 'HasFS'
  , Errors (..)
  , allNull
  , emptyErrors
  , genErrors
  , simpleErrors
  ) where

import           Control.Concurrent.Class.MonadSTM.Strict
import           Control.Monad (unless, void)
import           Control.Monad.Class.MonadThrow hiding (handle)
import           Control.Monad.Primitive
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as LC8
import           Data.Coerce (coerce)
import           Data.Foldable (for_)
import           Data.List (intercalate)
import qualified Data.List as List
import           Data.Maybe (catMaybes)
import           Data.Primitive.ByteArray
import           Data.String (IsString (..))
import           Data.Word (Word64)
import           Foreign.C.Types
import           Prelude hiding (null)
import           SafeWildCards
import           System.Posix.Types

import qualified Test.QuickCheck as QC
import           Test.QuickCheck (ASCIIString (..), Arbitrary (..), Gen,
                     suchThat)

import           System.FS.API
import           System.FS.CallStack

import qualified System.FS.Sim.MockFS as MockFS
import           System.FS.Sim.MockFS (HandleMock, MockFS)
import qualified System.FS.Sim.STM as Sim
import qualified System.FS.Sim.Stream as Stream
import           System.FS.Sim.Stream (Stream)

{-------------------------------------------------------------------------------
  Streams of errors
-------------------------------------------------------------------------------}

-- | An 'ErrorStream' is a possibly infinite 'Stream' of (@Maybe@)
-- @'FsErrorType'@s.
--
-- 'Nothing' indicates that there is no error.
--
-- Each time the 'ErrorStream' is used (see 'runErrorStream'), the first
-- element ('Nothing' in case the list is empty) is taken from the list and an
-- 'ErrorStream' with the remainder of the list is returned. The first element
-- represents whether an error should be returned or not.
--
-- An 'FsError' consists of a number of fields: 'fsErrorType', a
-- 'fsErrorPath', etc. Only the first fields is interesting. Therefore, we
-- only generate the 'FsErrorType'. The 'FsErrorType' will be used to
-- construct the actual 'FsError'.
type ErrorStream = Stream FsErrorType

-- | 'ErrorStream' for reading bytes from a file: an error or a partial get.
type ErrorStreamGetSome = Stream (Either FsErrorType Partial)

-- | 'ErrorStream' for writing bytes to a file: an error and possibly some
-- corruption, or a partial write.
type ErrorStreamPutSome =
  Stream (Either (FsErrorType, Maybe PutCorruption) Partial)

{-------------------------------------------------------------------------------
  Generating partial reads/writes
-------------------------------------------------------------------------------}

-- | A @'Partial' p@, where @p > 0@, is a number representing how many fewer
-- bytes should be read or written than requested.
newtype Partial = Partial Word64
    deriving (Int -> Partial -> ShowS
[Partial] -> ShowS
Partial -> String
(Int -> Partial -> ShowS)
-> (Partial -> String) -> ([Partial] -> ShowS) -> Show Partial
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Partial -> ShowS
showsPrec :: Int -> Partial -> ShowS
$cshow :: Partial -> String
show :: Partial -> String
$cshowList :: [Partial] -> ShowS
showList :: [Partial] -> ShowS
Show)

instance Arbitrary Partial where
  arbitrary :: Gen Partial
arbitrary = Word64 -> Partial
Partial (Word64 -> Partial) -> Gen Word64 -> Gen Partial
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
QC.choose (Word64
1, Word64
100)
  shrink :: Partial -> [Partial]
shrink (Partial Word64
p) =
    [Word64 -> Partial
Partial Word64
p' | Word64
p' <- [Word64
1..Word64
p]]

-- | Given a requested number of bytes to read/write, compute a partial number
-- of bytes to read/write.
--
-- We subtract @p@ from the number of requested bytes. If that would result in 0
-- requested bytes or less, we request 1 byte. If the number of requested bytes
-- was already 0, we can't simulate a partial read so we return 0 again.
partialiseByteCount :: Partial -> ByteCount -> ByteCount
partialiseByteCount :: Partial -> ByteCount -> ByteCount
partialiseByteCount (Partial Word64
p) ByteCount
c
  | Word64
0 <- Word64
c'   = ByteCount
c
  | Word64
p Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
c'   = ByteCount
1
  | Bool
otherwise = ByteCount
c ByteCount -> ByteCount -> ByteCount
forall a. Num a => a -> a -> a
- Word64 -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
p
  where c' :: Word64
c' = ByteCount -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
c

-- | Like 'partialiseByteCount', but for 'Word64'.
partialiseWord64 :: Partial -> Word64 -> Word64
partialiseWord64 :: Partial -> Word64 -> Word64
partialiseWord64 = (Partial -> ByteCount -> ByteCount) -> Partial -> Word64 -> Word64
forall a b. Coercible a b => a -> b
coerce Partial -> ByteCount -> ByteCount
partialiseByteCount

-- | Given a bytestring that is requested to be written to disk, use
-- 'partialiseByteCount' to compute a partial bytestring.
partialiseByteString :: Partial -> BS.ByteString -> BS.ByteString
partialiseByteString :: Partial -> ByteString -> ByteString
partialiseByteString Partial
p ByteString
bs = Int -> ByteString -> ByteString
BS.take (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteCount -> Int) -> ByteCount -> Int
forall a b. (a -> b) -> a -> b
$ Partial -> ByteCount -> ByteCount
partialiseByteCount Partial
p ByteCount
len) ByteString
bs
  where len :: ByteCount
len = Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs)

{------------------------------------------------------------------------------
  Blob
------------------------------------------------------------------------------}

-- For the custom 'Show' and 'Arbitrary' instances
--
-- A builder of a non-empty bytestring.
newtype Blob = MkBlob { Blob -> ByteString
getBlob :: ByteString }
    deriving (Int -> Blob -> ShowS
[Blob] -> ShowS
Blob -> String
(Int -> Blob -> ShowS)
-> (Blob -> String) -> ([Blob] -> ShowS) -> Show Blob
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Blob -> ShowS
showsPrec :: Int -> Blob -> ShowS
$cshow :: Blob -> String
show :: Blob -> String
$cshowList :: [Blob] -> ShowS
showList :: [Blob] -> ShowS
Show)

instance Arbitrary Blob where
    arbitrary :: Gen Blob
arbitrary = do
      String
str <- (ASCIIString -> String
getASCIIString (ASCIIString -> String) -> Gen ASCIIString -> Gen String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ASCIIString
forall a. Arbitrary a => Gen a
arbitrary) Gen String -> (String -> Bool) -> Gen String
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null)
      Blob -> Gen Blob
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blob -> Gen Blob) -> Blob -> Gen Blob
forall a b. (a -> b) -> a -> b
$ String -> Blob
forall a. IsString a => String -> a
fromString String
str
    shrink :: Blob -> [Blob]
shrink (MkBlob ByteString
b) =
      [ String -> Blob
forall a. IsString a => String -> a
fromString String
s'
      | let s :: ASCIIString
s = String -> ASCIIString
ASCIIString (String -> ASCIIString) -> String -> ASCIIString
forall a b. (a -> b) -> a -> b
$ ByteString -> String
LC8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
b
      , String
s' <- ASCIIString -> String
getASCIIString (ASCIIString -> String) -> [ASCIIString] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ASCIIString -> [ASCIIString]
forall a. Arbitrary a => a -> [a]
shrink ASCIIString
s
      , Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null String
s') ]

blobToBS :: Blob -> ByteString
blobToBS :: Blob -> ByteString
blobToBS = Blob -> ByteString
getBlob

blobFromBS :: ByteString -> Blob
blobFromBS :: ByteString -> Blob
blobFromBS = ByteString -> Blob
MkBlob

instance IsString Blob where
    fromString :: String -> Blob
fromString = ByteString -> Blob
blobFromBS (ByteString -> Blob) -> (String -> ByteString) -> String -> Blob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C8.pack

{-------------------------------------------------------------------------------
  Generating corruption for hPutSome
-------------------------------------------------------------------------------}

-- | Model possible corruptions that could happen to a 'hPutSome' call.
data PutCorruption
    = SubstituteWithJunk Blob
      -- ^ The blob to write is substituted with corrupt junk
    | PartialWrite Partial
      -- ^ Only perform the write partially
    deriving (Int -> PutCorruption -> ShowS
[PutCorruption] -> ShowS
PutCorruption -> String
(Int -> PutCorruption -> ShowS)
-> (PutCorruption -> String)
-> ([PutCorruption] -> ShowS)
-> Show PutCorruption
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PutCorruption -> ShowS
showsPrec :: Int -> PutCorruption -> ShowS
$cshow :: PutCorruption -> String
show :: PutCorruption -> String
$cshowList :: [PutCorruption] -> ShowS
showList :: [PutCorruption] -> ShowS
Show)

instance Arbitrary PutCorruption where
  arbitrary :: Gen PutCorruption
arbitrary = [Gen PutCorruption] -> Gen PutCorruption
forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof
      [ Blob -> PutCorruption
SubstituteWithJunk (Blob -> PutCorruption) -> Gen Blob -> Gen PutCorruption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Blob
forall a. Arbitrary a => Gen a
arbitrary
      , Partial -> PutCorruption
PartialWrite (Partial -> PutCorruption) -> Gen Partial -> Gen PutCorruption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Partial
forall a. Arbitrary a => Gen a
arbitrary
      ]
  shrink :: PutCorruption -> [PutCorruption]
shrink (SubstituteWithJunk Blob
blob) =
      [Blob -> PutCorruption
SubstituteWithJunk Blob
blob' | Blob
blob' <- Blob -> [Blob]
forall a. Arbitrary a => a -> [a]
shrink Blob
blob]
  shrink (PartialWrite Partial
partial) =
      [Partial -> PutCorruption
PartialWrite Partial
partial' | Partial
partial' <- Partial -> [Partial]
forall a. Arbitrary a => a -> [a]
shrink Partial
partial]

-- | Apply the 'PutCorruption' to the 'BS.ByteString'.
--
-- If the bytestring is substituted by corrupt junk, then the output bytestring
-- __might__ be larger than the input bytestring.
corruptByteString :: BS.ByteString -> PutCorruption -> BS.ByteString
corruptByteString :: ByteString -> PutCorruption -> ByteString
corruptByteString ByteString
bs PutCorruption
pc = case PutCorruption
pc of
    SubstituteWithJunk Blob
blob -> Blob -> ByteString
getBlob Blob
blob
    PartialWrite Partial
partial    -> Partial -> ByteString -> ByteString
partialiseByteString Partial
partial ByteString
bs

-- | Apply the 'PutCorruption' to a 'MutableByteArray'.
--
-- This either means that part of the bytes written to file are subsituted with
-- junk, or that only part of the buffer will be written out to disk due to a
-- partial write.
--
-- With respect to junk substitution, the intent of this function is to model
-- corruption of the bytes written to a file, __not__ corruption of the
-- in-memory buffer itself. As such, we don't corrupt the argument
-- 'MutableByteArray' in place, but instead we return a new 'MutableByteArray'
-- that has the same contents plus some possible corruption. This ensures that
-- the corruption is not visible to other parts of the program that use the same
-- 'MutableByteArray'. Corruption will only be applied to the buffer at the the
-- given 'BufferOffset', up to the requested 'ByteCount'. If there are not
-- enough bytes in the bytearray, then corruption will only apply up until the
-- end of the bytearray.
--
-- With respect to partial writes, the function returns a new number of
-- requested bytes, which is strictly smaller or equal to the input
-- 'ByteCount'.
--
-- NOTE: junk substitution and partial writes are mutually exclusive, and so
-- this functions produces only one effect. Either the buffer contents are
-- changed, or the 'ByteCount' is reduced.
corruptBuffer ::
     PrimMonad m
  => MutableByteArray (PrimState m)
  -> BufferOffset
  -> ByteCount
  -> PutCorruption
  -> m (MutableByteArray (PrimState m), ByteCount)
corruptBuffer :: forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> PutCorruption
-> m (MutableByteArray (PrimState m), ByteCount)
corruptBuffer MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c PutCorruption
pc = do
    case PutCorruption
pc of
      SubstituteWithJunk Blob
blob -> do
        Int
len <- MutableByteArray (PrimState m) -> m Int
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m Int
getSizeofMutableByteArray MutableByteArray (PrimState m)
buf
        -- this creates an unpinned byte array containing a copy of @buf@. It should
        -- be fine that it is unpinned, because the simulation is fully in-memory.
        ByteArray
copy <- MutableByteArray (PrimState m) -> Int -> Int -> m ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> Int -> Int -> m ByteArray
freezeByteArray MutableByteArray (PrimState m)
buf Int
0 Int
len
        MutableByteArray (PrimState m)
buf' <- ByteArray -> m (MutableByteArray (PrimState m))
forall (m :: * -> *).
PrimMonad m =>
ByteArray -> m (MutableByteArray (PrimState m))
unsafeThawByteArray ByteArray
copy
        -- Only corrupt up to the end of the bytearray.
        let lenRemaining :: Int
lenRemaining = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- BufferOffset -> Int
unBufferOffset BufferOffset
bufOff
        Bool
b <- MutableByteArray (PrimState m)
-> BufferOffset -> ByteString -> m Bool
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset -> ByteString -> m Bool
MockFS.intoBuffer MutableByteArray (PrimState m)
buf' BufferOffset
bufOff (Int -> ByteString -> ByteString
BS.take Int
lenRemaining (Blob -> ByteString
getBlob Blob
blob))
        -- Applying the corruption shouldn't have failed because we've ensured
        -- that the bytestring isn't too large to fit into the buffer.
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall a. HasCallStack => String -> a
error String
"corruptBuffer: corruption failed. This probably \
                         \indicates a bug in the fs-sim library."
        (MutableByteArray (PrimState m), ByteCount)
-> m (MutableByteArray (PrimState m), ByteCount)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MutableByteArray (PrimState m)
buf', ByteCount
c)
      PartialWrite Partial
partial ->
        (MutableByteArray (PrimState m), ByteCount)
-> m (MutableByteArray (PrimState m), ByteCount)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MutableByteArray (PrimState m)
buf, Partial -> ByteCount -> ByteCount
partialiseByteCount Partial
partial ByteCount
c)

{-------------------------------------------------------------------------------
  Simulated errors
-------------------------------------------------------------------------------}

-- | Error streams for the methods of the 'HasFS' type class.
--
-- An 'ErrorStream' is provided for each method of the 'HasFS' type class.
-- This 'ErrorStream' will be used to generate potential errors that will be
-- thrown by the corresponding method.
--
-- For 'hPutSome', an 'ErrorStreamWithCorruption' is provided to simulate
-- corruption.
--
-- An 'Errors' is used in conjunction with 'SimErrorFS', which is a layer on
-- top of 'SimFS' that simulates methods throwing 'FsError's.
data Errors = Errors
  { Errors -> ErrorStream
dumpStateE                :: ErrorStream -- TODO remove
    -- Operations on files
  , Errors -> ErrorStream
hOpenE                    :: ErrorStream
  , Errors -> ErrorStream
hCloseE                   :: ErrorStream
  , Errors -> ErrorStream
hSeekE                    :: ErrorStream
  , Errors -> ErrorStreamGetSome
hGetSomeE                 :: ErrorStreamGetSome
  , Errors -> ErrorStreamGetSome
hGetSomeAtE               :: ErrorStreamGetSome
  , Errors -> ErrorStreamPutSome
hPutSomeE                 :: ErrorStreamPutSome
  , Errors -> ErrorStream
hTruncateE                :: ErrorStream
  , Errors -> ErrorStream
hGetSizeE                 :: ErrorStream
    -- Operations on directories
  , Errors -> ErrorStream
createDirectoryE          :: ErrorStream
  , Errors -> ErrorStream
createDirectoryIfMissingE :: ErrorStream
  , Errors -> ErrorStream
listDirectoryE            :: ErrorStream
  , Errors -> ErrorStream
doesDirectoryExistE       :: ErrorStream
  , Errors -> ErrorStream
doesFileExistE            :: ErrorStream
  , Errors -> ErrorStream
removeDirectoryRecursiveE :: ErrorStream
  , Errors -> ErrorStream
removeFileE               :: ErrorStream
  , Errors -> ErrorStream
renameFileE               :: ErrorStream
    -- File I\/O with user-supplied buffers
  , Errors -> ErrorStreamGetSome
hGetBufSomeE              :: ErrorStreamGetSome
  , Errors -> ErrorStreamGetSome
hGetBufSomeAtE            :: ErrorStreamGetSome
  , Errors -> ErrorStreamPutSome
hPutBufSomeE              :: ErrorStreamPutSome
  , Errors -> ErrorStreamPutSome
hPutBufSomeAtE            :: ErrorStreamPutSome
  }
$(pure []) -- https://blog.monadfix.com/th-groups

-- | Return 'True' if all streams are empty ('null').
allNull :: Errors -> Bool
allNull :: Errors -> Bool
allNull $(fields 'Errors) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [
      ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
dumpStateE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
hOpenE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
hCloseE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
hSeekE
    , ErrorStreamGetSome -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStreamGetSome
hGetSomeE
    , ErrorStreamGetSome -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStreamGetSome
hGetSomeAtE
    , ErrorStreamPutSome -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStreamPutSome
hPutSomeE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
hTruncateE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
hGetSizeE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
createDirectoryE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
createDirectoryIfMissingE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
listDirectoryE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
doesDirectoryExistE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
doesFileExistE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
removeDirectoryRecursiveE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
removeFileE
    , ErrorStream -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStream
renameFileE
      -- File I\/O with user-supplied buffers
    , ErrorStreamGetSome -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStreamGetSome
hGetBufSomeE, ErrorStreamGetSome -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStreamGetSome
hGetBufSomeAtE
    , ErrorStreamPutSome -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStreamPutSome
hPutBufSomeE, ErrorStreamPutSome -> Bool
forall a. Stream a -> Bool
Stream.null ErrorStreamPutSome
hPutBufSomeAtE
    ]

instance Show Errors where
  show :: Errors -> String
show $(fields 'Errors) =
      String
"Errors {"  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
streams String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"}"
    where
      -- | Show a stream unless it is empty
      s :: Show a => String -> Stream a -> Maybe String
      s :: forall a. Show a => String -> Stream a -> Maybe String
s String
fld Stream a
str | Stream a -> Bool
forall a. Stream a -> Bool
Stream.null Stream a
str = Maybe String
forall a. Maybe a
Nothing
                | Bool
otherwise       = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
fld String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Stream a -> String
forall a. Show a => a -> String
show Stream a
str

      streams :: [String]
      streams :: [String]
streams = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes
        [ String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"dumpStateE"                ErrorStream
dumpStateE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hOpenE"                    ErrorStream
hOpenE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hCloseE"                   ErrorStream
hCloseE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hSeekE"                    ErrorStream
hSeekE
        , String -> ErrorStreamGetSome -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hGetSomeE"                 ErrorStreamGetSome
hGetSomeE
        , String -> ErrorStreamGetSome -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hGetSomeAtE"               ErrorStreamGetSome
hGetSomeAtE
        , String -> ErrorStreamPutSome -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hPutSomeE"                 ErrorStreamPutSome
hPutSomeE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hTruncateE"                ErrorStream
hTruncateE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hGetSizeE"                 ErrorStream
hGetSizeE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"createDirectoryE"          ErrorStream
createDirectoryE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"createDirectoryIfMissingE" ErrorStream
createDirectoryIfMissingE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"listDirectoryE"            ErrorStream
listDirectoryE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"doesDirectoryExistE"       ErrorStream
doesDirectoryExistE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"doesFileExistE"            ErrorStream
doesFileExistE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"removeDirectoryRecursiveE" ErrorStream
removeDirectoryRecursiveE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"removeFileE"               ErrorStream
removeFileE
        , String -> ErrorStream -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"renameFileE"               ErrorStream
renameFileE
          -- File I\/O with user-supplied buffers
        , String -> ErrorStreamGetSome -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hGetBufSomeE"   ErrorStreamGetSome
hGetBufSomeE
        , String -> ErrorStreamGetSome -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hGetBufSomeAtE" ErrorStreamGetSome
hGetBufSomeAtE
        , String -> ErrorStreamPutSome -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hPutBufSomeE"   ErrorStreamPutSome
hPutBufSomeE
        , String -> ErrorStreamPutSome -> Maybe String
forall a. Show a => String -> Stream a -> Maybe String
s String
"hPutBufSomeAtE" ErrorStreamPutSome
hPutBufSomeAtE
        ]

emptyErrors :: Errors
emptyErrors :: Errors
emptyErrors = ErrorStream -> Errors
simpleErrors ErrorStream
forall a. Stream a
Stream.empty

-- | Use the given 'ErrorStream' for each field/method. No corruption of
-- 'hPutSome'.
simpleErrors :: ErrorStream -> Errors
simpleErrors :: ErrorStream -> Errors
simpleErrors ErrorStream
es = Errors
    { dumpStateE :: ErrorStream
dumpStateE                = ErrorStream
es
    , hOpenE :: ErrorStream
hOpenE                    = ErrorStream
es
    , hCloseE :: ErrorStream
hCloseE                   = ErrorStream
es
    , hSeekE :: ErrorStream
hSeekE                    = ErrorStream
es
    , hGetSomeE :: ErrorStreamGetSome
hGetSomeE                 = FsErrorType -> Either FsErrorType Partial
forall a b. a -> Either a b
Left               (FsErrorType -> Either FsErrorType Partial)
-> ErrorStream -> ErrorStreamGetSome
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream
es
    , hGetSomeAtE :: ErrorStreamGetSome
hGetSomeAtE               = FsErrorType -> Either FsErrorType Partial
forall a b. a -> Either a b
Left               (FsErrorType -> Either FsErrorType Partial)
-> ErrorStream -> ErrorStreamGetSome
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream
es
    , hPutSomeE :: ErrorStreamPutSome
hPutSomeE                 = (FsErrorType, Maybe PutCorruption)
-> Either (FsErrorType, Maybe PutCorruption) Partial
forall a b. a -> Either a b
Left ((FsErrorType, Maybe PutCorruption)
 -> Either (FsErrorType, Maybe PutCorruption) Partial)
-> (FsErrorType -> (FsErrorType, Maybe PutCorruption))
-> FsErrorType
-> Either (FsErrorType, Maybe PutCorruption) Partial
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Maybe PutCorruption
forall a. Maybe a
Nothing) (FsErrorType -> Either (FsErrorType, Maybe PutCorruption) Partial)
-> ErrorStream -> ErrorStreamPutSome
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream
es
    , hTruncateE :: ErrorStream
hTruncateE                = ErrorStream
es
    , hGetSizeE :: ErrorStream
hGetSizeE                 = ErrorStream
es
    , createDirectoryE :: ErrorStream
createDirectoryE          = ErrorStream
es
    , createDirectoryIfMissingE :: ErrorStream
createDirectoryIfMissingE = ErrorStream
es
    , listDirectoryE :: ErrorStream
listDirectoryE            = ErrorStream
es
    , doesDirectoryExistE :: ErrorStream
doesDirectoryExistE       = ErrorStream
es
    , doesFileExistE :: ErrorStream
doesFileExistE            = ErrorStream
es
    , removeDirectoryRecursiveE :: ErrorStream
removeDirectoryRecursiveE = ErrorStream
es
    , removeFileE :: ErrorStream
removeFileE               = ErrorStream
es
    , renameFileE :: ErrorStream
renameFileE               = ErrorStream
es
      -- File I\/O with user-supplied buffers
    , hGetBufSomeE :: ErrorStreamGetSome
hGetBufSomeE   = FsErrorType -> Either FsErrorType Partial
forall a b. a -> Either a b
Left (FsErrorType -> Either FsErrorType Partial)
-> ErrorStream -> ErrorStreamGetSome
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream
es
    , hGetBufSomeAtE :: ErrorStreamGetSome
hGetBufSomeAtE = FsErrorType -> Either FsErrorType Partial
forall a b. a -> Either a b
Left (FsErrorType -> Either FsErrorType Partial)
-> ErrorStream -> ErrorStreamGetSome
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream
es
    , hPutBufSomeE :: ErrorStreamPutSome
hPutBufSomeE   = (FsErrorType, Maybe PutCorruption)
-> Either (FsErrorType, Maybe PutCorruption) Partial
forall a b. a -> Either a b
Left ((FsErrorType, Maybe PutCorruption)
 -> Either (FsErrorType, Maybe PutCorruption) Partial)
-> (FsErrorType -> (FsErrorType, Maybe PutCorruption))
-> FsErrorType
-> Either (FsErrorType, Maybe PutCorruption) Partial
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Maybe PutCorruption
forall a. Maybe a
Nothing) (FsErrorType -> Either (FsErrorType, Maybe PutCorruption) Partial)
-> ErrorStream -> ErrorStreamPutSome
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream
es
    , hPutBufSomeAtE :: ErrorStreamPutSome
hPutBufSomeAtE = (FsErrorType, Maybe PutCorruption)
-> Either (FsErrorType, Maybe PutCorruption) Partial
forall a b. a -> Either a b
Left ((FsErrorType, Maybe PutCorruption)
 -> Either (FsErrorType, Maybe PutCorruption) Partial)
-> (FsErrorType -> (FsErrorType, Maybe PutCorruption))
-> FsErrorType
-> Either (FsErrorType, Maybe PutCorruption) Partial
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Maybe PutCorruption
forall a. Maybe a
Nothing) (FsErrorType -> Either (FsErrorType, Maybe PutCorruption) Partial)
-> ErrorStream -> ErrorStreamPutSome
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream
es
    }

-- | Generator for 'Errors' that allows some things to be disabled.
--
-- This is needed by the VolatileDB state machine tests, which try to predict
-- what should happen based on the 'Errors', which is too complex sometimes.
genErrors :: Bool  -- ^ 'True' -> generate partial writes
          -> Bool  -- ^ 'True' -> generate 'SubstituteWithJunk' corruptions
          -> Gen Errors
genErrors :: Bool -> Bool -> Gen Errors
genErrors Bool
genPartialWrites Bool
genSubstituteWithJunk = do
    let -- TODO which errors are possible for these operations below (that
        -- have dummy for now)?
        dummy :: Gen ErrorStream
dummy = Int -> [FsErrorType] -> Gen ErrorStream
forall {a}. Int -> [a] -> Gen (Stream a)
streamGen Int
2 [ FsErrorType
FsInsufficientPermissions ]
    ErrorStream
dumpStateE          <- Gen ErrorStream
dummy
    -- TODO let this one fail:
    let hCloseE :: Stream a
hCloseE = Stream a
forall a. Stream a
Stream.empty
    ErrorStream
hTruncateE          <- Gen ErrorStream
dummy
    ErrorStream
doesDirectoryExistE <- Gen ErrorStream
dummy
    ErrorStream
doesFileExistE      <- Gen ErrorStream
dummy
    ErrorStream
hOpenE <- Int -> [FsErrorType] -> Gen ErrorStream
forall {a}. Int -> [a] -> Gen (Stream a)
streamGen Int
1
      [ FsErrorType
FsResourceDoesNotExist, FsErrorType
FsResourceInappropriateType
      , FsErrorType
FsResourceAlreadyInUse, FsErrorType
FsResourceAlreadyExist
      , FsErrorType
FsInsufficientPermissions, FsErrorType
FsTooManyOpenFiles ]
    ErrorStream
hSeekE      <- Int -> [FsErrorType] -> Gen ErrorStream
forall {a}. Int -> [a] -> Gen (Stream a)
streamGen Int
3 [ FsErrorType
FsReachedEOF ]
    ErrorStreamGetSome
hGetSomeE   <- Gen ErrorStreamGetSome
commonGetErrors
    ErrorStreamGetSome
hGetSomeAtE <- Gen ErrorStreamGetSome
commonGetErrors
    ErrorStreamPutSome
hPutSomeE   <- Gen ErrorStreamPutSome
commonPutErrors
    ErrorStream
hGetSizeE   <- Int -> [FsErrorType] -> Gen ErrorStream
forall {a}. Int -> [a] -> Gen (Stream a)
streamGen Int
2 [ FsErrorType
FsResourceDoesNotExist ]
    ErrorStream
createDirectoryE <- Int -> [FsErrorType] -> Gen ErrorStream
forall {a}. Int -> [a] -> Gen (Stream a)
streamGen Int
3
      [ FsErrorType
FsInsufficientPermissions, FsErrorType
FsResourceInappropriateType
      , FsErrorType
FsResourceAlreadyExist ]
    ErrorStream
createDirectoryIfMissingE <- Int -> [FsErrorType] -> Gen ErrorStream
forall {a}. Int -> [a] -> Gen (Stream a)
streamGen Int
3
      [ FsErrorType
FsInsufficientPermissions, FsErrorType
FsResourceInappropriateType
      , FsErrorType
FsResourceAlreadyExist ]
    ErrorStream
listDirectoryE <- Int -> [FsErrorType] -> Gen ErrorStream
forall {a}. Int -> [a] -> Gen (Stream a)
streamGen Int
3
      [ FsErrorType
FsInsufficientPermissions, FsErrorType
FsResourceInappropriateType
      , FsErrorType
FsResourceDoesNotExist ]
    ErrorStream
removeDirectoryRecursiveE <- Int -> [FsErrorType] -> Gen ErrorStream
forall {a}. Int -> [a] -> Gen (Stream a)
streamGen Int
3
      [ FsErrorType
FsInsufficientPermissions, FsErrorType
FsResourceAlreadyInUse
      , FsErrorType
FsResourceDoesNotExist, FsErrorType
FsResourceInappropriateType ]
    ErrorStream
removeFileE    <- Int -> [FsErrorType] -> Gen ErrorStream
forall {a}. Int -> [a] -> Gen (Stream a)
streamGen Int
3
      [ FsErrorType
FsInsufficientPermissions, FsErrorType
FsResourceAlreadyInUse
      , FsErrorType
FsResourceDoesNotExist, FsErrorType
FsResourceInappropriateType ]
    ErrorStream
renameFileE    <- Int -> [FsErrorType] -> Gen ErrorStream
forall {a}. Int -> [a] -> Gen (Stream a)
streamGen Int
3
      [ FsErrorType
FsInsufficientPermissions, FsErrorType
FsResourceAlreadyInUse
      , FsErrorType
FsResourceDoesNotExist, FsErrorType
FsResourceInappropriateType ]
    -- File I\/O with user-supplied buffers
    ErrorStreamGetSome
hGetBufSomeE   <- Gen ErrorStreamGetSome
commonGetErrors
    ErrorStreamGetSome
hGetBufSomeAtE <- Gen ErrorStreamGetSome
commonGetErrors
    ErrorStreamPutSome
hPutBufSomeE   <- Gen ErrorStreamPutSome
commonPutErrors
    ErrorStreamPutSome
hPutBufSomeAtE <- Gen ErrorStreamPutSome
commonPutErrors
    Errors -> Gen Errors
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Errors {ErrorStreamPutSome
ErrorStreamGetSome
ErrorStream
forall a. Stream a
dumpStateE :: ErrorStream
hOpenE :: ErrorStream
hCloseE :: ErrorStream
hSeekE :: ErrorStream
hGetSomeE :: ErrorStreamGetSome
hGetSomeAtE :: ErrorStreamGetSome
hPutSomeE :: ErrorStreamPutSome
hTruncateE :: ErrorStream
hGetSizeE :: ErrorStream
createDirectoryE :: ErrorStream
createDirectoryIfMissingE :: ErrorStream
listDirectoryE :: ErrorStream
doesDirectoryExistE :: ErrorStream
doesFileExistE :: ErrorStream
removeDirectoryRecursiveE :: ErrorStream
removeFileE :: ErrorStream
renameFileE :: ErrorStream
hGetBufSomeE :: ErrorStreamGetSome
hGetBufSomeAtE :: ErrorStreamGetSome
hPutBufSomeE :: ErrorStreamPutSome
hPutBufSomeAtE :: ErrorStreamPutSome
dumpStateE :: ErrorStream
hCloseE :: forall a. Stream a
hTruncateE :: ErrorStream
doesDirectoryExistE :: ErrorStream
doesFileExistE :: ErrorStream
hOpenE :: ErrorStream
hSeekE :: ErrorStream
hGetSomeE :: ErrorStreamGetSome
hGetSomeAtE :: ErrorStreamGetSome
hPutSomeE :: ErrorStreamPutSome
hGetSizeE :: ErrorStream
createDirectoryE :: ErrorStream
createDirectoryIfMissingE :: ErrorStream
listDirectoryE :: ErrorStream
removeDirectoryRecursiveE :: ErrorStream
removeFileE :: ErrorStream
renameFileE :: ErrorStream
hGetBufSomeE :: ErrorStreamGetSome
hGetBufSomeAtE :: ErrorStreamGetSome
hPutBufSomeE :: ErrorStreamPutSome
hPutBufSomeAtE :: ErrorStreamPutSome
..}
  where
    streamGen :: Int -> [a] -> Gen (Stream a)
streamGen Int
l = Gen (Maybe a) -> Gen (Stream a)
forall a. Gen (Maybe a) -> Gen (Stream a)
Stream.genInfinite (Gen (Maybe a) -> Gen (Stream a))
-> ([a] -> Gen (Maybe a)) -> [a] -> Gen (Stream a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Gen a -> Gen (Maybe a)
forall a. Int -> Gen a -> Gen (Maybe a)
Stream.genMaybe' Int
l (Gen a -> Gen (Maybe a)) -> ([a] -> Gen a) -> [a] -> Gen (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Gen a
forall a. HasCallStack => [a] -> Gen a
QC.elements
    streamGen' :: Int -> [(Int, Gen a)] -> Gen (Stream a)
streamGen' Int
l = Gen (Maybe a) -> Gen (Stream a)
forall a. Gen (Maybe a) -> Gen (Stream a)
Stream.genInfinite (Gen (Maybe a) -> Gen (Stream a))
-> ([(Int, Gen a)] -> Gen (Maybe a))
-> [(Int, Gen a)]
-> Gen (Stream a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Gen a -> Gen (Maybe a)
forall a. Int -> Gen a -> Gen (Maybe a)
Stream.genMaybe' Int
l (Gen a -> Gen (Maybe a))
-> ([(Int, Gen a)] -> Gen a) -> [(Int, Gen a)] -> Gen (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Gen a)] -> Gen a
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency

    commonGetErrors :: Gen ErrorStreamGetSome
commonGetErrors = Int
-> [(Int, Gen (Either FsErrorType Partial))]
-> Gen ErrorStreamGetSome
forall {a}. Int -> [(Int, Gen a)] -> Gen (Stream a)
streamGen' Int
20
      [ (Int
1, Either FsErrorType Partial -> Gen (Either FsErrorType Partial)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FsErrorType Partial -> Gen (Either FsErrorType Partial))
-> Either FsErrorType Partial -> Gen (Either FsErrorType Partial)
forall a b. (a -> b) -> a -> b
$ FsErrorType -> Either FsErrorType Partial
forall a b. a -> Either a b
Left FsErrorType
FsReachedEOF)
      , (Int
3, Partial -> Either FsErrorType Partial
forall a b. b -> Either a b
Right (Partial -> Either FsErrorType Partial)
-> Gen Partial -> Gen (Either FsErrorType Partial)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Partial
forall a. Arbitrary a => Gen a
arbitrary) ]

    commonPutErrors :: Gen ErrorStreamPutSome
commonPutErrors = Int
-> [(Int, Gen (Either (FsErrorType, Maybe PutCorruption) Partial))]
-> Gen ErrorStreamPutSome
forall {a}. Int -> [(Int, Gen a)] -> Gen (Stream a)
streamGen' Int
5
      [ (Int
1, (FsErrorType, Maybe PutCorruption)
-> Either (FsErrorType, Maybe PutCorruption) Partial
forall a b. a -> Either a b
Left ((FsErrorType, Maybe PutCorruption)
 -> Either (FsErrorType, Maybe PutCorruption) Partial)
-> (Maybe PutCorruption -> (FsErrorType, Maybe PutCorruption))
-> Maybe PutCorruption
-> Either (FsErrorType, Maybe PutCorruption) Partial
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FsErrorType
FsDeviceFull, ) (Maybe PutCorruption
 -> Either (FsErrorType, Maybe PutCorruption) Partial)
-> Gen (Maybe PutCorruption)
-> Gen (Either (FsErrorType, Maybe PutCorruption) Partial)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Gen (Maybe PutCorruption))] -> Gen (Maybe PutCorruption)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
            [ (Int
2, Maybe PutCorruption -> Gen (Maybe PutCorruption)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PutCorruption
forall a. Maybe a
Nothing)
            , (Int
1, PutCorruption -> Maybe PutCorruption
forall a. a -> Maybe a
Just (PutCorruption -> Maybe PutCorruption)
-> (Partial -> PutCorruption) -> Partial -> Maybe PutCorruption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Partial -> PutCorruption
PartialWrite (Partial -> Maybe PutCorruption)
-> Gen Partial -> Gen (Maybe PutCorruption)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Partial
forall a. Arbitrary a => Gen a
arbitrary)
            , (if Bool
genSubstituteWithJunk then Int
1 else Int
0,
               PutCorruption -> Maybe PutCorruption
forall a. a -> Maybe a
Just (PutCorruption -> Maybe PutCorruption)
-> (Blob -> PutCorruption) -> Blob -> Maybe PutCorruption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blob -> PutCorruption
SubstituteWithJunk (Blob -> Maybe PutCorruption)
-> Gen Blob -> Gen (Maybe PutCorruption)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Blob
forall a. Arbitrary a => Gen a
arbitrary)
            ])
      , (if Bool
genPartialWrites then Int
3 else Int
0, Partial -> Either (FsErrorType, Maybe PutCorruption) Partial
forall a b. b -> Either a b
Right (Partial -> Either (FsErrorType, Maybe PutCorruption) Partial)
-> Gen Partial
-> Gen (Either (FsErrorType, Maybe PutCorruption) Partial)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Partial
forall a. Arbitrary a => Gen a
arbitrary) ]

instance Arbitrary Errors where
  arbitrary :: Gen Errors
arbitrary = Bool -> Bool -> Gen Errors
genErrors Bool
True Bool
True

  shrink :: Errors -> [Errors]
shrink err :: Errors
err@($(fields 'Errors)) = ([Errors] -> [Errors]) -> [[Errors]] -> [Errors]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Errors -> Bool) -> [Errors] -> [Errors]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Errors -> Bool) -> Errors -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Errors -> Bool
allNull))
      [ (\ErrorStream
s' -> Errors
err { dumpStateE = s' })                (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
dumpStateE
      , (\ErrorStream
s' -> Errors
err { hOpenE = s' })                    (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
hOpenE
      , (\ErrorStream
s' -> Errors
err { hCloseE = s' })                   (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
hCloseE
      , (\ErrorStream
s' -> Errors
err { hSeekE = s' })                    (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
hSeekE
      , (\ErrorStreamGetSome
s' -> Errors
err { hGetSomeE = s' })                 (ErrorStreamGetSome -> Errors) -> [ErrorStreamGetSome] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStreamGetSome -> [ErrorStreamGetSome]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStreamGetSome
hGetSomeE
      , (\ErrorStreamGetSome
s' -> Errors
err { hGetSomeAtE = s' })               (ErrorStreamGetSome -> Errors) -> [ErrorStreamGetSome] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStreamGetSome -> [ErrorStreamGetSome]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStreamGetSome
hGetSomeAtE
      , (\ErrorStreamPutSome
s' -> Errors
err { hPutSomeE = s' })                 (ErrorStreamPutSome -> Errors) -> [ErrorStreamPutSome] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStreamPutSome -> [ErrorStreamPutSome]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStreamPutSome
hPutSomeE
      , (\ErrorStream
s' -> Errors
err { hTruncateE = s' })                (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
hTruncateE
      , (\ErrorStream
s' -> Errors
err { hGetSizeE = s' })                 (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
hGetSizeE
      , (\ErrorStream
s' -> Errors
err { createDirectoryE = s' })          (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
createDirectoryE
      , (\ErrorStream
s' -> Errors
err { createDirectoryIfMissingE = s' }) (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
createDirectoryIfMissingE
      , (\ErrorStream
s' -> Errors
err { listDirectoryE = s' })            (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
listDirectoryE
      , (\ErrorStream
s' -> Errors
err { doesDirectoryExistE = s' })       (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
doesDirectoryExistE
      , (\ErrorStream
s' -> Errors
err { doesFileExistE = s' })            (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
doesFileExistE
      , (\ErrorStream
s' -> Errors
err { removeDirectoryRecursiveE = s' }) (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
removeDirectoryRecursiveE
      , (\ErrorStream
s' -> Errors
err { removeFileE = s' })               (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
removeFileE
      , (\ErrorStream
s' -> Errors
err { renameFileE = s' })               (ErrorStream -> Errors) -> [ErrorStream] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStream -> [ErrorStream]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStream
renameFileE
        -- File I\/O with user-supplied buffers
      , (\ErrorStreamGetSome
s' -> Errors
err { hGetBufSomeE = s' })   (ErrorStreamGetSome -> Errors) -> [ErrorStreamGetSome] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStreamGetSome -> [ErrorStreamGetSome]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStreamGetSome
hGetBufSomeE
      , (\ErrorStreamGetSome
s' -> Errors
err { hGetBufSomeAtE = s' }) (ErrorStreamGetSome -> Errors) -> [ErrorStreamGetSome] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStreamGetSome -> [ErrorStreamGetSome]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStreamGetSome
hGetBufSomeAtE
      , (\ErrorStreamPutSome
s' -> Errors
err { hPutBufSomeE = s' })   (ErrorStreamPutSome -> Errors) -> [ErrorStreamPutSome] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStreamPutSome -> [ErrorStreamPutSome]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStreamPutSome
hPutBufSomeE
      , (\ErrorStreamPutSome
s' -> Errors
err { hPutBufSomeAtE = s' }) (ErrorStreamPutSome -> Errors) -> [ErrorStreamPutSome] -> [Errors]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorStreamPutSome -> [ErrorStreamPutSome]
forall a. Stream a -> [Stream a]
Stream.shrinkStream ErrorStreamPutSome
hPutBufSomeAtE
      ]

{-------------------------------------------------------------------------------
  Simulate Errors monad
-------------------------------------------------------------------------------}

-- | Alternative to 'simErrorHasFS' that creates 'TVar's internally.
simErrorHasFS' :: (MonadSTM m, MonadThrow m, PrimMonad m)
                 => MockFS
                 -> Errors
                 -> m (HasFS m HandleMock)
simErrorHasFS' :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m) =>
MockFS -> Errors -> m (HasFS m HandleMock)
simErrorHasFS' MockFS
mockFS Errors
errs =
    StrictTMVar m MockFS -> StrictTVar m Errors -> HasFS m HandleMock
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m) =>
StrictTMVar m MockFS -> StrictTVar m Errors -> HasFS m HandleMock
simErrorHasFS (StrictTMVar m MockFS -> StrictTVar m Errors -> HasFS m HandleMock)
-> m (StrictTMVar m MockFS)
-> m (StrictTVar m Errors -> HasFS m HandleMock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockFS -> m (StrictTMVar m MockFS)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTMVar m a)
newTMVarIO MockFS
mockFS m (StrictTVar m Errors -> HasFS m HandleMock)
-> m (StrictTVar m Errors) -> m (HasFS m HandleMock)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Errors -> m (StrictTVar m Errors)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Errors
errs

-- | Introduce possibility of errors
simErrorHasFS :: forall m. (MonadSTM m, MonadThrow m, PrimMonad m)
                => StrictTMVar m MockFS
                -> StrictTVar m Errors
                -> HasFS m HandleMock
simErrorHasFS :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m) =>
StrictTMVar m MockFS -> StrictTVar m Errors -> HasFS m HandleMock
simErrorHasFS StrictTMVar m MockFS
fsVar StrictTVar m Errors
errorsVar =
    -- TODO: Lenses would be nice for the setters
    case StrictTMVar m MockFS -> HasFS m HandleMock
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m) =>
StrictTMVar m MockFS -> HasFS m HandleMock
Sim.simHasFS StrictTMVar m MockFS
fsVar of
      hfs :: HasFS m HandleMock
hfs@HasFS{m String
HasCallStack => Bool -> FsPath -> m ()
HasCallStack => FsPath -> m Bool
HasCallStack => FsPath -> m ()
HasCallStack => FsPath -> m (Set String)
HasCallStack => FsPath -> FsPath -> m ()
HasCallStack => FsPath -> OpenMode -> m (Handle HandleMock)
HasCallStack => Handle HandleMock -> m Bool
HasCallStack => Handle HandleMock -> m Word64
HasCallStack => Handle HandleMock -> m ()
HasCallStack => Handle HandleMock -> Word64 -> m ()
HasCallStack => Handle HandleMock -> Word64 -> m ByteString
HasCallStack =>
Handle HandleMock -> Word64 -> AbsOffset -> m ByteString
HasCallStack => Handle HandleMock -> SeekMode -> Int64 -> m ()
HasCallStack =>
Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
HasCallStack =>
Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
HasCallStack => Handle HandleMock -> ByteString -> m Word64
FsPath -> m String
FsPath -> FsErrorPath
hPutSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
dumpState :: m String
hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle HandleMock)
hClose :: HasCallStack => Handle HandleMock -> m ()
hIsOpen :: HasCallStack => Handle HandleMock -> m Bool
hSeek :: HasCallStack => Handle HandleMock -> SeekMode -> Int64 -> m ()
hGetSome :: HasCallStack => Handle HandleMock -> Word64 -> m ByteString
hGetSomeAt :: HasCallStack =>
Handle HandleMock -> Word64 -> AbsOffset -> m ByteString
hPutSome :: HasCallStack => Handle HandleMock -> ByteString -> m Word64
hTruncate :: HasCallStack => Handle HandleMock -> Word64 -> m ()
hGetSize :: HasCallStack => Handle HandleMock -> m Word64
createDirectory :: HasCallStack => FsPath -> m ()
createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> m ()
listDirectory :: HasCallStack => FsPath -> m (Set String)
doesDirectoryExist :: HasCallStack => FsPath -> m Bool
doesFileExist :: HasCallStack => FsPath -> m Bool
removeDirectoryRecursive :: HasCallStack => FsPath -> m ()
removeFile :: HasCallStack => FsPath -> m ()
renameFile :: HasCallStack => FsPath -> FsPath -> m ()
mkFsErrorPath :: FsPath -> FsErrorPath
unsafeToFilePath :: FsPath -> m String
hGetBufSome :: HasCallStack =>
Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufSomeAt :: HasCallStack =>
Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSome :: HasCallStack =>
Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hPutBufSomeAt :: HasCallStack =>
Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
createDirectory :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
createDirectoryIfMissing :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
dumpState :: forall (m :: * -> *) h. HasFS m h -> m String
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
hGetBufSome :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hGetBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Word64
hGetSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
hGetSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hIsOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Bool
hOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
hPutBufSome :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hPutBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hSeek :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hTruncate :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
mkFsErrorPath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
removeDirectoryRecursive :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeFile :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
renameFile :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
unsafeToFilePath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> m String
..} -> HasFS{
          dumpState :: m String
dumpState =
            StrictTVar m Errors
-> FsPath
-> m String
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m String
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar ([String] -> FsPath
mkFsPath [String
"<dumpState>"]) m String
dumpState String
"dumpState"
              Errors -> ErrorStream
dumpStateE (\ErrorStream
e Errors
es -> Errors
es { dumpStateE = e })
        , hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle HandleMock)
hOpen      = \FsPath
p OpenMode
m ->
            StrictTVar m Errors
-> FsPath
-> m (Handle HandleMock)
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m (Handle HandleMock)
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar FsPath
p (HasCallStack => FsPath -> OpenMode -> m (Handle HandleMock)
FsPath -> OpenMode -> m (Handle HandleMock)
hOpen FsPath
p OpenMode
m) String
"hOpen"
            Errors -> ErrorStream
hOpenE (\ErrorStream
e Errors
es -> Errors
es { hOpenE = e })
        , hClose :: HasCallStack => Handle HandleMock -> m ()
hClose     = \Handle HandleMock
h ->
            StrictTVar m Errors
-> Handle HandleMock
-> m ()
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> Handle HandleMock
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr' StrictTVar m Errors
errorsVar Handle HandleMock
h (HasCallStack => Handle HandleMock -> m ()
Handle HandleMock -> m ()
hClose Handle HandleMock
h) String
"hClose"
            Errors -> ErrorStream
hCloseE (\ErrorStream
e Errors
es -> Errors
es { hCloseE = e })
        , hIsOpen :: HasCallStack => Handle HandleMock -> m Bool
hIsOpen    = HasCallStack => Handle HandleMock -> m Bool
Handle HandleMock -> m Bool
hIsOpen
        , hSeek :: HasCallStack => Handle HandleMock -> SeekMode -> Int64 -> m ()
hSeek      = \Handle HandleMock
h SeekMode
m Int64
n ->
            StrictTVar m Errors
-> Handle HandleMock
-> m ()
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> Handle HandleMock
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr' StrictTVar m Errors
errorsVar Handle HandleMock
h (HasCallStack => Handle HandleMock -> SeekMode -> Int64 -> m ()
Handle HandleMock -> SeekMode -> Int64 -> m ()
hSeek Handle HandleMock
h SeekMode
m Int64
n) String
"hSeek"
            Errors -> ErrorStream
hSeekE (\ErrorStream
e Errors
es -> Errors
es { hSeekE = e })
        , hGetSome :: HasCallStack => Handle HandleMock -> Word64 -> m ByteString
hGetSome   = StrictTVar m Errors
-> (Handle HandleMock -> Word64 -> m ByteString)
-> Handle HandleMock
-> Word64
-> m ByteString
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> (Handle HandleMock -> Word64 -> m ByteString)
-> Handle HandleMock
-> Word64
-> m ByteString
hGetSome' StrictTVar m Errors
errorsVar HasCallStack => Handle HandleMock -> Word64 -> m ByteString
Handle HandleMock -> Word64 -> m ByteString
hGetSome
        , hGetSomeAt :: HasCallStack =>
Handle HandleMock -> Word64 -> AbsOffset -> m ByteString
hGetSomeAt = StrictTVar m Errors
-> (Handle HandleMock -> Word64 -> AbsOffset -> m ByteString)
-> Handle HandleMock
-> Word64
-> AbsOffset
-> m ByteString
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> (Handle HandleMock -> Word64 -> AbsOffset -> m ByteString)
-> Handle HandleMock
-> Word64
-> AbsOffset
-> m ByteString
hGetSomeAt' StrictTVar m Errors
errorsVar HasCallStack =>
Handle HandleMock -> Word64 -> AbsOffset -> m ByteString
Handle HandleMock -> Word64 -> AbsOffset -> m ByteString
hGetSomeAt
        , hPutSome :: HasCallStack => Handle HandleMock -> ByteString -> m Word64
hPutSome   = StrictTVar m Errors
-> (Handle HandleMock -> ByteString -> m Word64)
-> Handle HandleMock
-> ByteString
-> m Word64
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> (Handle HandleMock -> ByteString -> m Word64)
-> Handle HandleMock
-> ByteString
-> m Word64
hPutSome' StrictTVar m Errors
errorsVar HasCallStack => Handle HandleMock -> ByteString -> m Word64
Handle HandleMock -> ByteString -> m Word64
hPutSome
        , hTruncate :: HasCallStack => Handle HandleMock -> Word64 -> m ()
hTruncate  = \Handle HandleMock
h Word64
w ->
            StrictTVar m Errors
-> Handle HandleMock
-> m ()
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> Handle HandleMock
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr' StrictTVar m Errors
errorsVar Handle HandleMock
h (HasCallStack => Handle HandleMock -> Word64 -> m ()
Handle HandleMock -> Word64 -> m ()
hTruncate Handle HandleMock
h Word64
w) String
"hTruncate"
            Errors -> ErrorStream
hTruncateE (\ErrorStream
e Errors
es -> Errors
es { hTruncateE = e })
        , hGetSize :: HasCallStack => Handle HandleMock -> m Word64
hGetSize   =  \Handle HandleMock
h ->
            StrictTVar m Errors
-> Handle HandleMock
-> m Word64
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m Word64
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> Handle HandleMock
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr' StrictTVar m Errors
errorsVar Handle HandleMock
h (HasCallStack => Handle HandleMock -> m Word64
Handle HandleMock -> m Word64
hGetSize Handle HandleMock
h) String
"hGetSize"
            Errors -> ErrorStream
hGetSizeE (\ErrorStream
e Errors
es -> Errors
es { hGetSizeE = e })

        , createDirectory :: HasCallStack => FsPath -> m ()
createDirectory          = \FsPath
p ->
            StrictTVar m Errors
-> FsPath
-> m ()
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar FsPath
p (HasCallStack => FsPath -> m ()
FsPath -> m ()
createDirectory FsPath
p) String
"createDirectory"
            Errors -> ErrorStream
createDirectoryE (\ErrorStream
e Errors
es -> Errors
es { createDirectoryE = e })
        , createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> m ()
createDirectoryIfMissing = \Bool
b FsPath
p ->
            StrictTVar m Errors
-> FsPath
-> m ()
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar FsPath
p (HasCallStack => Bool -> FsPath -> m ()
Bool -> FsPath -> m ()
createDirectoryIfMissing Bool
b FsPath
p) String
"createDirectoryIfMissing"
            Errors -> ErrorStream
createDirectoryIfMissingE (\ErrorStream
e Errors
es -> Errors
es { createDirectoryIfMissingE = e })
        , listDirectory :: HasCallStack => FsPath -> m (Set String)
listDirectory            = \FsPath
p ->
            StrictTVar m Errors
-> FsPath
-> m (Set String)
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m (Set String)
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar FsPath
p (HasCallStack => FsPath -> m (Set String)
FsPath -> m (Set String)
listDirectory FsPath
p) String
"listDirectory"
            Errors -> ErrorStream
listDirectoryE (\ErrorStream
e Errors
es -> Errors
es { listDirectoryE = e })
        , doesDirectoryExist :: HasCallStack => FsPath -> m Bool
doesDirectoryExist       = \FsPath
p ->
            StrictTVar m Errors
-> FsPath
-> m Bool
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m Bool
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar FsPath
p (HasCallStack => FsPath -> m Bool
FsPath -> m Bool
doesDirectoryExist FsPath
p) String
"doesDirectoryExist"
            Errors -> ErrorStream
doesDirectoryExistE (\ErrorStream
e Errors
es -> Errors
es { doesDirectoryExistE = e })
        , doesFileExist :: HasCallStack => FsPath -> m Bool
doesFileExist            = \FsPath
p ->
            StrictTVar m Errors
-> FsPath
-> m Bool
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m Bool
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar FsPath
p (HasCallStack => FsPath -> m Bool
FsPath -> m Bool
doesFileExist FsPath
p) String
"doesFileExist"
            Errors -> ErrorStream
doesFileExistE (\ErrorStream
e Errors
es -> Errors
es { doesFileExistE = e })
        , removeDirectoryRecursive :: HasCallStack => FsPath -> m ()
removeDirectoryRecursive = \FsPath
p ->
            StrictTVar m Errors
-> FsPath
-> m ()
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar FsPath
p (HasCallStack => FsPath -> m ()
FsPath -> m ()
removeDirectoryRecursive FsPath
p) String
"removeFile"
            Errors -> ErrorStream
removeDirectoryRecursiveE (\ErrorStream
e Errors
es -> Errors
es { removeDirectoryRecursiveE = e })
        , removeFile :: HasCallStack => FsPath -> m ()
removeFile               = \FsPath
p ->
            StrictTVar m Errors
-> FsPath
-> m ()
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar FsPath
p (HasCallStack => FsPath -> m ()
FsPath -> m ()
removeFile FsPath
p) String
"removeFile"
            Errors -> ErrorStream
removeFileE (\ErrorStream
e Errors
es -> Errors
es { removeFileE = e })
        , renameFile :: HasCallStack => FsPath -> FsPath -> m ()
renameFile               = \FsPath
p1 FsPath
p2 ->
            StrictTVar m Errors
-> FsPath
-> m ()
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar FsPath
p1 (HasCallStack => FsPath -> FsPath -> m ()
FsPath -> FsPath -> m ()
renameFile FsPath
p1 FsPath
p2) String
"renameFile"
            Errors -> ErrorStream
renameFileE (\ErrorStream
e Errors
es -> Errors
es { renameFileE = e })
        , mkFsErrorPath :: FsPath -> FsErrorPath
mkFsErrorPath = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted
        , unsafeToFilePath :: FsPath -> m String
unsafeToFilePath = String -> FsPath -> m String
forall a. HasCallStack => String -> a
error String
"simErrorHasFS:unsafeToFilePath"
          -- File I\/O with user-supplied buffers
        , hGetBufSome :: HasCallStack =>
Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufSome   = StrictTVar m Errors
-> HasFS m HandleMock
-> Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors -> HasFS m HandleMock -> HGetBufSome m
hGetBufSomeWithErr   StrictTVar m Errors
errorsVar HasFS m HandleMock
hfs
        , hGetBufSomeAt :: HasCallStack =>
Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hGetBufSomeAt = StrictTVar m Errors
-> HasFS m HandleMock
-> Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors -> HasFS m HandleMock -> HGetBufSomeAt m
hGetBufSomeAtWithErr StrictTVar m Errors
errorsVar HasFS m HandleMock
hfs
        , hPutBufSome :: HasCallStack =>
Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hPutBufSome   = StrictTVar m Errors
-> HasFS m HandleMock
-> Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack) =>
StrictTVar m Errors -> HasFS m HandleMock -> HPutBufSome m
hPutBufSomeWithErr   StrictTVar m Errors
errorsVar HasFS m HandleMock
hfs
        , hPutBufSomeAt :: HasCallStack =>
Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSomeAt = StrictTVar m Errors
-> HasFS m HandleMock
-> Handle HandleMock
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack) =>
StrictTVar m Errors -> HasFS m HandleMock -> HPutBufSomeAt m
hPutBufSomeAtWithErr StrictTVar m Errors
errorsVar HasFS m HandleMock
hfs
        }

-- | Runs a computation provided an 'Errors' and an initial
-- 'MockFS', producing a result and the final state of the filesystem.
runSimErrorFS :: (MonadSTM m, MonadThrow m, PrimMonad m)
              => MockFS
              -> Errors
              -> (StrictTVar m Errors -> HasFS m HandleMock -> m a)
              -> m (a, MockFS)
runSimErrorFS :: forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, PrimMonad m) =>
MockFS
-> Errors
-> (StrictTVar m Errors -> HasFS m HandleMock -> m a)
-> m (a, MockFS)
runSimErrorFS MockFS
mockFS Errors
errors StrictTVar m Errors -> HasFS m HandleMock -> m a
action = do
    StrictTMVar m MockFS
fsVar     <- MockFS -> m (StrictTMVar m MockFS)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTMVar m a)
newTMVarIO MockFS
mockFS
    StrictTVar m Errors
errorsVar <- Errors -> m (StrictTVar m Errors)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Errors
errors
    a
a         <- StrictTVar m Errors -> HasFS m HandleMock -> m a
action StrictTVar m Errors
errorsVar (HasFS m HandleMock -> m a) -> HasFS m HandleMock -> m a
forall a b. (a -> b) -> a -> b
$ StrictTMVar m MockFS -> StrictTVar m Errors -> HasFS m HandleMock
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m) =>
StrictTMVar m MockFS -> StrictTVar m Errors -> HasFS m HandleMock
simErrorHasFS StrictTMVar m MockFS
fsVar StrictTVar m Errors
errorsVar
    MockFS
fs'       <- STM m MockFS -> m MockFS
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m MockFS -> m MockFS) -> STM m MockFS -> m MockFS
forall a b. (a -> b) -> a -> b
$ StrictTMVar m MockFS -> STM m MockFS
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
takeTMVar StrictTMVar m MockFS
fsVar
    (a, MockFS) -> m (a, MockFS)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, MockFS
fs')

-- | Execute the next action using the given 'Errors'. After the action is
-- finished, the previous 'Errors' are restored.
withErrors :: MonadSTM m => StrictTVar m Errors -> Errors -> m a -> m a
withErrors :: forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m Errors -> Errors -> m a -> m a
withErrors StrictTVar m Errors
errorsVar Errors
tempErrors m a
action = do
    Errors
originalErrors <- STM m Errors -> m Errors
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Errors -> m Errors) -> STM m Errors -> m Errors
forall a b. (a -> b) -> a -> b
$ do
      Errors
originalErrors <- StrictTVar m Errors -> STM m Errors
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m Errors
errorsVar
      StrictTVar m Errors -> Errors -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m Errors
errorsVar Errors
tempErrors
      Errors -> STM m Errors
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Errors
originalErrors
    a
res <- m a
action
    STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m Errors -> Errors -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m Errors
errorsVar Errors
originalErrors
    a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

{-------------------------------------------------------------------------------
  Utilities
-------------------------------------------------------------------------------}

-- | Advance to the next error in the stream of some 'ErrorStream' in the
-- 'Errors' stored in the 'StrictTVar'. Extracts the right error stream from
-- the state with the @getter@ and stores the advanced error stream in the
-- state with the @setter@.
next :: MonadSTM m
     => StrictTVar m Errors
     -> (Errors -> Stream a)            -- ^ @getter@
     -> (Stream a -> Errors -> Errors)  -- ^ @setter@
     -> m (Maybe a)
next :: forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m Errors
-> (Errors -> Stream a)
-> (Stream a -> Errors -> Errors)
-> m (Maybe a)
next StrictTVar m Errors
errorsVar Errors -> Stream a
getter Stream a -> Errors -> Errors
setter = do
    STM m (Maybe a) -> m (Maybe a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe a) -> m (Maybe a)) -> STM m (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
      Errors
errors <- StrictTVar m Errors -> STM m Errors
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m Errors
errorsVar
      let (Maybe a
mb, Stream a
s') = Stream a -> (Maybe a, Stream a)
forall a. Stream a -> (Maybe a, Stream a)
Stream.runStream (Errors -> Stream a
getter Errors
errors)
      StrictTVar m Errors -> Errors -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m Errors
errorsVar (Stream a -> Errors -> Errors
setter Stream a
s' Errors
errors)
      Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mb

-- | Execute an action or throw an error, depending on the corresponding
-- 'ErrorStream' (see 'nextError').
withErr :: (MonadSTM m, MonadThrow m, HasCallStack)
        => StrictTVar m Errors
        -> FsPath     -- ^ The path for the error, if thrown
        -> m a        -- ^ Action in case no error is thrown
        -> String     -- ^ Extra message for in the 'fsErrorString'
        -> (Errors -> ErrorStream)           -- ^ @getter@
        -> (ErrorStream -> Errors -> Errors) -- ^ @setter@
        -> m a
withErr :: forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar FsPath
path m a
action String
msg Errors -> ErrorStream
getter ErrorStream -> Errors -> Errors
setter = do
    Maybe FsErrorType
mbErr <- StrictTVar m Errors
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m (Maybe FsErrorType)
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m Errors
-> (Errors -> Stream a)
-> (Stream a -> Errors -> Errors)
-> m (Maybe a)
next StrictTVar m Errors
errorsVar Errors -> ErrorStream
getter ErrorStream -> Errors -> Errors
setter
    case Maybe FsErrorType
mbErr of
      Maybe FsErrorType
Nothing      -> m a
action
      Just FsErrorType
errType -> FsError -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO FsError
        { fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
errType
        , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
path
        , fsErrorString :: String
fsErrorString = String
"simulated error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg
        , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
        , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
        , fsLimitation :: Bool
fsLimitation  = Bool
False
        }

-- | Variant of 'withErr' that works with 'Handle's.
--
-- The path of the handle is retrieved from the 'MockFS' using 'handleFsPath'.
withErr' :: (MonadSTM m, MonadThrow m, HasCallStack)
         => StrictTVar m Errors
         -> Handle HandleMock   -- ^ The path for the error, if thrown
         -> m a        -- ^ Action in case no error is thrown
         -> String     -- ^ Extra message for in the 'fsErrorString'
         -> (Errors -> ErrorStream)           -- ^ @getter@
         -> (ErrorStream -> Errors -> Errors) -- ^ @setter@
         -> m a
withErr' :: forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> Handle HandleMock
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr' StrictTVar m Errors
errorsVar Handle HandleMock
handle m a
action String
msg Errors -> ErrorStream
getter ErrorStream -> Errors -> Errors
setter =
    StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> FsPath
-> m a
-> String
-> (Errors -> ErrorStream)
-> (ErrorStream -> Errors -> Errors)
-> m a
withErr StrictTVar m Errors
errorsVar (Handle HandleMock -> FsPath
forall h. Handle h -> FsPath
handlePath Handle HandleMock
handle) m a
action String
msg Errors -> ErrorStream
getter ErrorStream -> Errors -> Errors
setter

-- | Execute the wrapped 'hGetSome', throw an error, or simulate a partial
-- read, depending on the corresponding 'ErrorStreamGetSome' (see
-- 'nextError').
hGetSome'  :: (MonadSTM m, MonadThrow m, HasCallStack)
           => StrictTVar m Errors
           -> (Handle HandleMock -> Word64 -> m BS.ByteString)  -- ^ Wrapped 'hGetSome'
           -> Handle HandleMock -> Word64 -> m BS.ByteString
hGetSome' :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> (Handle HandleMock -> Word64 -> m ByteString)
-> Handle HandleMock
-> Word64
-> m ByteString
hGetSome' StrictTVar m Errors
errorsVar Handle HandleMock -> Word64 -> m ByteString
hGetSomeWrapped Handle HandleMock
handle Word64
n =
    StrictTVar m Errors
-> (Errors -> ErrorStreamGetSome)
-> (ErrorStreamGetSome -> Errors -> Errors)
-> m (Maybe (Either FsErrorType Partial))
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m Errors
-> (Errors -> Stream a)
-> (Stream a -> Errors -> Errors)
-> m (Maybe a)
next StrictTVar m Errors
errorsVar Errors -> ErrorStreamGetSome
hGetSomeE (\ErrorStreamGetSome
e Errors
es -> Errors
es { hGetSomeE = e }) m (Maybe (Either FsErrorType Partial))
-> (Maybe (Either FsErrorType Partial) -> m ByteString)
-> m ByteString
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Either FsErrorType Partial)
Nothing             -> Handle HandleMock -> Word64 -> m ByteString
hGetSomeWrapped Handle HandleMock
handle Word64
n
      Just (Left FsErrorType
errType) -> FsError -> m ByteString
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO FsError
        { fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
errType
        , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted (FsPath -> FsErrorPath) -> FsPath -> FsErrorPath
forall a b. (a -> b) -> a -> b
$ Handle HandleMock -> FsPath
forall h. Handle h -> FsPath
handlePath Handle HandleMock
handle
        , fsErrorString :: String
fsErrorString = String
"simulated error: hGetSome"
        , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
        , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
        , fsLimitation :: Bool
fsLimitation  = Bool
False
        }
      Just (Right Partial
partial) ->
        Handle HandleMock -> Word64 -> m ByteString
hGetSomeWrapped Handle HandleMock
handle (Partial -> Word64 -> Word64
partialiseWord64 Partial
partial Word64
n)

-- | In the thread safe version of 'hGetSome', we simulate exactly the same errors.
hGetSomeAt' :: (MonadSTM m, MonadThrow m, HasCallStack)
            => StrictTVar m Errors
            -> (Handle HandleMock -> Word64 -> AbsOffset -> m BS.ByteString)  -- ^ Wrapped 'hGetSomeAt'
            -> Handle HandleMock -> Word64 -> AbsOffset -> m BS.ByteString
hGetSomeAt' :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> (Handle HandleMock -> Word64 -> AbsOffset -> m ByteString)
-> Handle HandleMock
-> Word64
-> AbsOffset
-> m ByteString
hGetSomeAt' StrictTVar m Errors
errorsVar Handle HandleMock -> Word64 -> AbsOffset -> m ByteString
hGetSomeAtWrapped Handle HandleMock
handle Word64
n AbsOffset
offset =
    StrictTVar m Errors
-> (Errors -> ErrorStreamGetSome)
-> (ErrorStreamGetSome -> Errors -> Errors)
-> m (Maybe (Either FsErrorType Partial))
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m Errors
-> (Errors -> Stream a)
-> (Stream a -> Errors -> Errors)
-> m (Maybe a)
next StrictTVar m Errors
errorsVar Errors -> ErrorStreamGetSome
hGetSomeAtE (\ErrorStreamGetSome
e Errors
es -> Errors
es { hGetSomeAtE = e }) m (Maybe (Either FsErrorType Partial))
-> (Maybe (Either FsErrorType Partial) -> m ByteString)
-> m ByteString
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Either FsErrorType Partial)
Nothing             -> Handle HandleMock -> Word64 -> AbsOffset -> m ByteString
hGetSomeAtWrapped Handle HandleMock
handle Word64
n AbsOffset
offset
      Just (Left FsErrorType
errType) -> FsError -> m ByteString
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO FsError
        { fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
errType
        , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted (FsPath -> FsErrorPath) -> FsPath -> FsErrorPath
forall a b. (a -> b) -> a -> b
$ Handle HandleMock -> FsPath
forall h. Handle h -> FsPath
handlePath Handle HandleMock
handle
        , fsErrorString :: String
fsErrorString = String
"simulated error: hGetSomeAt"
        , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
        , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
        , fsLimitation :: Bool
fsLimitation  = Bool
False
        }
      Just (Right Partial
partial) ->
        Handle HandleMock -> Word64 -> AbsOffset -> m ByteString
hGetSomeAtWrapped Handle HandleMock
handle (Partial -> Word64 -> Word64
partialiseWord64 Partial
partial Word64
n) AbsOffset
offset

-- | Execute the wrapped 'hPutSome', throw an error and apply possible
-- corruption to the blob to write, or simulate a partial write, depending on
-- the corresponding 'ErrorStreamPutSome' (see 'nextError').
hPutSome' :: (MonadSTM m, MonadThrow m, HasCallStack)
          => StrictTVar m Errors
          -> (Handle HandleMock -> BS.ByteString -> m Word64)  -- ^ Wrapped 'hPutSome'
          -> Handle HandleMock -> BS.ByteString -> m Word64
hPutSome' :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors
-> (Handle HandleMock -> ByteString -> m Word64)
-> Handle HandleMock
-> ByteString
-> m Word64
hPutSome' StrictTVar m Errors
errorsVar Handle HandleMock -> ByteString -> m Word64
hPutSomeWrapped Handle HandleMock
handle ByteString
bs =
    StrictTVar m Errors
-> (Errors -> ErrorStreamPutSome)
-> (ErrorStreamPutSome -> Errors -> Errors)
-> m (Maybe (Either (FsErrorType, Maybe PutCorruption) Partial))
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m Errors
-> (Errors -> Stream a)
-> (Stream a -> Errors -> Errors)
-> m (Maybe a)
next StrictTVar m Errors
errorsVar Errors -> ErrorStreamPutSome
hPutSomeE (\ErrorStreamPutSome
e Errors
es -> Errors
es { hPutSomeE = e }) m (Maybe (Either (FsErrorType, Maybe PutCorruption) Partial))
-> (Maybe (Either (FsErrorType, Maybe PutCorruption) Partial)
    -> m Word64)
-> m Word64
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Either (FsErrorType, Maybe PutCorruption) Partial)
Nothing                       -> Handle HandleMock -> ByteString -> m Word64
hPutSomeWrapped Handle HandleMock
handle ByteString
bs
      Just (Left (FsErrorType
errType, Maybe PutCorruption
mbCorr)) -> do
        Maybe PutCorruption -> (PutCorruption -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe PutCorruption
mbCorr ((PutCorruption -> m ()) -> m ())
-> (PutCorruption -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \PutCorruption
corr ->
          m Word64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ Handle HandleMock -> ByteString -> m Word64
hPutSomeWrapped Handle HandleMock
handle (ByteString -> PutCorruption -> ByteString
corruptByteString ByteString
bs PutCorruption
corr)
        FsError -> m Word64
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO FsError
          { fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
errType
          , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted (FsPath -> FsErrorPath) -> FsPath -> FsErrorPath
forall a b. (a -> b) -> a -> b
$ Handle HandleMock -> FsPath
forall h. Handle h -> FsPath
handlePath Handle HandleMock
handle
          , fsErrorString :: String
fsErrorString = String
"simulated error: hPutSome" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> case Maybe PutCorruption
mbCorr of
              Maybe PutCorruption
Nothing   -> String
""
              Just PutCorruption
corr -> String
" with corruption: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PutCorruption -> String
forall a. Show a => a -> String
show PutCorruption
corr
          , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
          , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
          , fsLimitation :: Bool
fsLimitation  = Bool
False
          }
      Just (Right Partial
partial)          ->
        Handle HandleMock -> ByteString -> m Word64
hPutSomeWrapped Handle HandleMock
handle (Partial -> ByteString -> ByteString
partialiseByteString Partial
partial ByteString
bs)

{-------------------------------------------------------------------------------
  File I\/O with user-supplied buffers
-------------------------------------------------------------------------------}

-- | Short-hand for the type of 'hGetBufSome'
type HGetBufSome m =
     Handle HandleMock
  -> MutableByteArray (PrimState m)
  -> BufferOffset
  -> ByteCount
  -> m ByteCount

-- | Execute the wrapped 'hGetBufSome', throw an error, or simulate a partial
-- read, depending on the corresponding 'ErrorStreamGetSome' (see 'nextError').
hGetBufSomeWithErr  ::
     (MonadSTM m, MonadThrow m, HasCallStack)
  => StrictTVar m Errors
  -> HasFS m HandleMock
  -> HGetBufSome m
hGetBufSomeWithErr :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors -> HasFS m HandleMock -> HGetBufSome m
hGetBufSomeWithErr StrictTVar m Errors
errorsVar HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c =
    StrictTVar m Errors
-> (Errors -> ErrorStreamGetSome)
-> (ErrorStreamGetSome -> Errors -> Errors)
-> m (Maybe (Either FsErrorType Partial))
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m Errors
-> (Errors -> Stream a)
-> (Stream a -> Errors -> Errors)
-> m (Maybe a)
next StrictTVar m Errors
errorsVar Errors -> ErrorStreamGetSome
hGetBufSomeE (\ErrorStreamGetSome
e Errors
es -> Errors
es { hGetBufSomeE = e }) m (Maybe (Either FsErrorType Partial))
-> (Maybe (Either FsErrorType Partial) -> m ByteCount)
-> m ByteCount
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Either FsErrorType Partial)
Nothing             -> HasFS m HandleMock
-> HasCallStack =>
   Handle HandleMock
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hGetBufSome HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c
      Just (Left FsErrorType
errType) -> FsError -> m ByteCount
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO FsError
        { fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
errType
        , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted (FsPath -> FsErrorPath) -> FsPath -> FsErrorPath
forall a b. (a -> b) -> a -> b
$ Handle HandleMock -> FsPath
forall h. Handle h -> FsPath
handlePath Handle HandleMock
h
        , fsErrorString :: String
fsErrorString = String
"simulated error: hGetBufSome"
        , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
        , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
        , fsLimitation :: Bool
fsLimitation  = Bool
False
        }
      Just (Right Partial
partial) ->
        HasFS m HandleMock
-> HasCallStack =>
   Handle HandleMock
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hGetBufSome HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff (Partial -> ByteCount -> ByteCount
partialiseByteCount Partial
partial ByteCount
c)

-- | Short-hand for the type of 'hGetBufSomeAt'
type HGetBufSomeAt m =
     Handle HandleMock
  -> MutableByteArray (PrimState m)
  -> BufferOffset
  -> ByteCount
  -> AbsOffset
  -> m ByteCount

-- | Execute the wrapped 'hGetBufSomeAt', throw an error, or simulate a partial
-- read, depending on the corresponding 'ErrorStreamGetSome' (see 'nextError').
hGetBufSomeAtWithErr  ::
     (MonadSTM m, MonadThrow m, HasCallStack)
  => StrictTVar m Errors
  -> HasFS m HandleMock
  -> HGetBufSomeAt m
hGetBufSomeAtWithErr :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, HasCallStack) =>
StrictTVar m Errors -> HasFS m HandleMock -> HGetBufSomeAt m
hGetBufSomeAtWithErr StrictTVar m Errors
errorsVar HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c AbsOffset
off =
    StrictTVar m Errors
-> (Errors -> ErrorStreamGetSome)
-> (ErrorStreamGetSome -> Errors -> Errors)
-> m (Maybe (Either FsErrorType Partial))
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m Errors
-> (Errors -> Stream a)
-> (Stream a -> Errors -> Errors)
-> m (Maybe a)
next StrictTVar m Errors
errorsVar Errors -> ErrorStreamGetSome
hGetBufSomeAtE (\ErrorStreamGetSome
e Errors
es -> Errors
es { hGetBufSomeAtE = e }) m (Maybe (Either FsErrorType Partial))
-> (Maybe (Either FsErrorType Partial) -> m ByteCount)
-> m ByteCount
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Either FsErrorType Partial)
Nothing             -> HasFS m HandleMock
-> HasCallStack =>
   Handle HandleMock
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hGetBufSomeAt HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c AbsOffset
off
      Just (Left FsErrorType
errType) -> FsError -> m ByteCount
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO FsError
        { fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
errType
        , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted (FsPath -> FsErrorPath) -> FsPath -> FsErrorPath
forall a b. (a -> b) -> a -> b
$ Handle HandleMock -> FsPath
forall h. Handle h -> FsPath
handlePath Handle HandleMock
h
        , fsErrorString :: String
fsErrorString = String
"simulated error: hGetBufSomeAt"
        , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
        , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
        , fsLimitation :: Bool
fsLimitation  = Bool
False
        }
      Just (Right Partial
partial) ->
        HasFS m HandleMock
-> HasCallStack =>
   Handle HandleMock
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hGetBufSomeAt HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff (Partial -> ByteCount -> ByteCount
partialiseByteCount Partial
partial ByteCount
c) AbsOffset
off

-- | Short-hand for the type of 'hPutBufSome'
type HPutBufSome m =
     Handle HandleMock
  -> MutableByteArray (PrimState m)
  -> BufferOffset
  -> ByteCount
  -> m ByteCount

-- | Execute the wrapped 'hPutBufSome', throw an error and apply possible
-- corruption to the blob to write, or simulate a partial write, depending on
-- the corresponding 'ErrorStreamPutSome' (see 'nextError').
hPutBufSomeWithErr ::
     (MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack)
  => StrictTVar m Errors
  -> HasFS m HandleMock
  -> HPutBufSome m
hPutBufSomeWithErr :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack) =>
StrictTVar m Errors -> HasFS m HandleMock -> HPutBufSome m
hPutBufSomeWithErr StrictTVar m Errors
errorsVar HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c =
    StrictTVar m Errors
-> (Errors -> ErrorStreamPutSome)
-> (ErrorStreamPutSome -> Errors -> Errors)
-> m (Maybe (Either (FsErrorType, Maybe PutCorruption) Partial))
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m Errors
-> (Errors -> Stream a)
-> (Stream a -> Errors -> Errors)
-> m (Maybe a)
next StrictTVar m Errors
errorsVar Errors -> ErrorStreamPutSome
hPutBufSomeE (\ErrorStreamPutSome
e Errors
es -> Errors
es { hPutBufSomeE = e }) m (Maybe (Either (FsErrorType, Maybe PutCorruption) Partial))
-> (Maybe (Either (FsErrorType, Maybe PutCorruption) Partial)
    -> m ByteCount)
-> m ByteCount
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Either (FsErrorType, Maybe PutCorruption) Partial)
Nothing                       -> HasFS m HandleMock
-> HasCallStack =>
   Handle HandleMock
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hPutBufSome HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c
      Just (Left (FsErrorType
errType, Maybe PutCorruption
mbCorr)) -> do
        Maybe PutCorruption -> (PutCorruption -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe PutCorruption
mbCorr ((PutCorruption -> m ()) -> m ())
-> (PutCorruption -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \PutCorruption
corr -> do
          (MutableByteArray (PrimState m)
buf', ByteCount
c') <- MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> PutCorruption
-> m (MutableByteArray (PrimState m), ByteCount)
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> PutCorruption
-> m (MutableByteArray (PrimState m), ByteCount)
corruptBuffer MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c PutCorruption
corr
          m ByteCount -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ByteCount -> m ()) -> m ByteCount -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m HandleMock
-> HasCallStack =>
   Handle HandleMock
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hPutBufSome HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf' BufferOffset
bufOff ByteCount
c'
        FsError -> m ByteCount
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO FsError
          { fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
errType
          , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted (FsPath -> FsErrorPath) -> FsPath -> FsErrorPath
forall a b. (a -> b) -> a -> b
$ Handle HandleMock -> FsPath
forall h. Handle h -> FsPath
handlePath Handle HandleMock
h
          , fsErrorString :: String
fsErrorString = String
"simulated error: hPutSome" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> case Maybe PutCorruption
mbCorr of
              Maybe PutCorruption
Nothing   -> String
""
              Just PutCorruption
corr -> String
" with corruption: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PutCorruption -> String
forall a. Show a => a -> String
show PutCorruption
corr
          , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
          , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
          , fsLimitation :: Bool
fsLimitation  = Bool
False
          }
      Just (Right Partial
partial)          ->
        HasFS m HandleMock
-> HasCallStack =>
   Handle HandleMock
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> m ByteCount
hPutBufSome HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff (Partial -> ByteCount -> ByteCount
partialiseByteCount Partial
partial ByteCount
c)

-- | Short-hand for the type of 'hPutBufSomeAt'
type HPutBufSomeAt m =
     Handle HandleMock
  -> MutableByteArray (PrimState m)
  -> BufferOffset
  -> ByteCount
  -> AbsOffset
  -> m ByteCount

-- | Execute the wrapped 'hPutBufSomeAt', throw an error and apply possible
-- corruption to the blob to write, or simulate a partial write, depending on
-- the corresponding 'ErrorStreamPutSome' (see 'nextError').
hPutBufSomeAtWithErr ::
     (MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack)
  => StrictTVar m Errors
  -> HasFS m HandleMock
  -> HPutBufSomeAt m
hPutBufSomeAtWithErr :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack) =>
StrictTVar m Errors -> HasFS m HandleMock -> HPutBufSomeAt m
hPutBufSomeAtWithErr StrictTVar m Errors
errorsVar HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c AbsOffset
off =
    StrictTVar m Errors
-> (Errors -> ErrorStreamPutSome)
-> (ErrorStreamPutSome -> Errors -> Errors)
-> m (Maybe (Either (FsErrorType, Maybe PutCorruption) Partial))
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m Errors
-> (Errors -> Stream a)
-> (Stream a -> Errors -> Errors)
-> m (Maybe a)
next StrictTVar m Errors
errorsVar Errors -> ErrorStreamPutSome
hPutBufSomeAtE (\ErrorStreamPutSome
e Errors
es -> Errors
es { hPutBufSomeAtE = e }) m (Maybe (Either (FsErrorType, Maybe PutCorruption) Partial))
-> (Maybe (Either (FsErrorType, Maybe PutCorruption) Partial)
    -> m ByteCount)
-> m ByteCount
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Either (FsErrorType, Maybe PutCorruption) Partial)
Nothing                       -> HasFS m HandleMock
-> HasCallStack =>
   Handle HandleMock
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hPutBufSomeAt HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c AbsOffset
off
      Just (Left (FsErrorType
errType, Maybe PutCorruption
mbCorr)) -> do
        Maybe PutCorruption -> (PutCorruption -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe PutCorruption
mbCorr ((PutCorruption -> m ()) -> m ())
-> (PutCorruption -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \PutCorruption
corr -> do
          (MutableByteArray (PrimState m)
buf', ByteCount
c') <- MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> PutCorruption
-> m (MutableByteArray (PrimState m), ByteCount)
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> PutCorruption
-> m (MutableByteArray (PrimState m), ByteCount)
corruptBuffer MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c PutCorruption
corr
          m ByteCount -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ByteCount -> m ()) -> m ByteCount -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m HandleMock
-> HasCallStack =>
   Handle HandleMock
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hPutBufSomeAt HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf' BufferOffset
bufOff ByteCount
c' AbsOffset
off
        FsError -> m ByteCount
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO FsError
          { fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
errType
          , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted (FsPath -> FsErrorPath) -> FsPath -> FsErrorPath
forall a b. (a -> b) -> a -> b
$ Handle HandleMock -> FsPath
forall h. Handle h -> FsPath
handlePath Handle HandleMock
h
          , fsErrorString :: String
fsErrorString = String
"simulated error: hPutSome" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> case Maybe PutCorruption
mbCorr of
              Maybe PutCorruption
Nothing   -> String
""
              Just PutCorruption
corr -> String
" with corruption: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PutCorruption -> String
forall a. Show a => a -> String
show PutCorruption
corr
          , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
          , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
          , fsLimitation :: Bool
fsLimitation  = Bool
False
          }
      Just (Right Partial
partial)          ->
        HasFS m HandleMock
-> HasCallStack =>
   Handle HandleMock
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
   Handle h
   -> MutableByteArray (PrimState m)
   -> BufferOffset
   -> ByteCount
   -> AbsOffset
   -> m ByteCount
hPutBufSomeAt HasFS m HandleMock
hfs Handle HandleMock
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff (Partial -> ByteCount -> ByteCount
partialiseByteCount Partial
partial ByteCount
c) AbsOffset
off