{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}

-- | Mock file system implementation
--
-- Intended for qualified import
--
-- > import           System.FS.Sim.MockFS (MockFS)
-- > import qualified System.FS.Sim.MockFS as Mock
module System.FS.Sim.MockFS (
    empty
  , example
  , handleIsOpen
  , numOpenHandles
  , pretty
    -- * Debugging
  , dumpState
    -- * Operations on files
  , hClose
  , hGetSize
  , hGetSome
  , hGetSomeAt
  , hIsOpen
  , hOpen
  , hPutSome
  , hSeek
  , hTruncate
    -- * Operations on directories
  , createDirectory
  , createDirectoryIfMissing
  , doesDirectoryExist
  , doesFileExist
  , listDirectory
  , removeDirectoryRecursive
  , removeFile
  , renameFile
    -- * Exported for the benefit of tests only
  , Files
  , mockFiles
    -- ** opaque
  , ClosedHandleState
  , FilePtr
  , HandleState
  , OpenHandleState
    -- * opaque
  , HandleMock
  , MockFS
    -- * HasBufFS
  , fromBuffer
  , intoBuffer
  , hGetBufSome
  , hGetBufSomeAt
  , hPutBufSome
  , hPutBufSomeAt
  ) where

import           Control.Monad (forM, forM_, unless, void, when)
import           Control.Monad.Except (MonadError, throwError)
import           Control.Monad.Primitive (PrimMonad (..))
import           Control.Monad.State.Strict (MonadState, get, gets, put)
import           Data.Bifunctor
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import           Data.Int (Int64)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import           Data.Maybe (mapMaybe)
import qualified Data.Primitive as P
import           Data.Primitive.ByteArray
import           Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Text as Text
import           Data.Word (Word64, Word8)
import           GHC.Generics (Generic)
import           System.Posix.Types (ByteCount)

import           System.FS.API (BufferOffset (..))
import           System.FS.API.Types
import           System.FS.CallStack

import qualified System.FS.Sim.FsTree as FS
import           System.FS.Sim.FsTree (FsTree (..), FsTreeError (..))

{-------------------------------------------------------------------------------
  Mock FS types
-------------------------------------------------------------------------------}

data MockFS = MockFS {
      MockFS -> Files
mockFiles      :: !Files
    , MockFS -> Map HandleMock HandleState
mockHandles    :: !(Map HandleMock HandleState)
    , MockFS -> HandleMock
mockNextHandle :: !HandleMock
    }
  deriving ((forall x. MockFS -> Rep MockFS x)
-> (forall x. Rep MockFS x -> MockFS) -> Generic MockFS
forall x. Rep MockFS x -> MockFS
forall x. MockFS -> Rep MockFS x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MockFS -> Rep MockFS x
from :: forall x. MockFS -> Rep MockFS x
$cto :: forall x. Rep MockFS x -> MockFS
to :: forall x. Rep MockFS x -> MockFS
Generic, Int -> MockFS -> ShowS
[MockFS] -> ShowS
MockFS -> String
(Int -> MockFS -> ShowS)
-> (MockFS -> String) -> ([MockFS] -> ShowS) -> Show MockFS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MockFS -> ShowS
showsPrec :: Int -> MockFS -> ShowS
$cshow :: MockFS -> String
show :: MockFS -> String
$cshowList :: [MockFS] -> ShowS
showList :: [MockFS] -> ShowS
Show)

-- | We store the files as an 'FsTree' of the file contents
type Files = FsTree ByteString

-- | A mock handle to a file on disk.
--
-- This is only meaningful when interpreted against a 'MockFS'.
newtype HandleMock = HandleMock Int
  deriving stock   (Int -> HandleMock -> ShowS
[HandleMock] -> ShowS
HandleMock -> String
(Int -> HandleMock -> ShowS)
-> (HandleMock -> String)
-> ([HandleMock] -> ShowS)
-> Show HandleMock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HandleMock -> ShowS
showsPrec :: Int -> HandleMock -> ShowS
$cshow :: HandleMock -> String
show :: HandleMock -> String
$cshowList :: [HandleMock] -> ShowS
showList :: [HandleMock] -> ShowS
Show, HandleMock -> HandleMock -> Bool
(HandleMock -> HandleMock -> Bool)
-> (HandleMock -> HandleMock -> Bool) -> Eq HandleMock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HandleMock -> HandleMock -> Bool
== :: HandleMock -> HandleMock -> Bool
$c/= :: HandleMock -> HandleMock -> Bool
/= :: HandleMock -> HandleMock -> Bool
Eq, Eq HandleMock
Eq HandleMock =>
(HandleMock -> HandleMock -> Ordering)
-> (HandleMock -> HandleMock -> Bool)
-> (HandleMock -> HandleMock -> Bool)
-> (HandleMock -> HandleMock -> Bool)
-> (HandleMock -> HandleMock -> Bool)
-> (HandleMock -> HandleMock -> HandleMock)
-> (HandleMock -> HandleMock -> HandleMock)
-> Ord HandleMock
HandleMock -> HandleMock -> Bool
HandleMock -> HandleMock -> Ordering
HandleMock -> HandleMock -> HandleMock
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HandleMock -> HandleMock -> Ordering
compare :: HandleMock -> HandleMock -> Ordering
$c< :: HandleMock -> HandleMock -> Bool
< :: HandleMock -> HandleMock -> Bool
$c<= :: HandleMock -> HandleMock -> Bool
<= :: HandleMock -> HandleMock -> Bool
$c> :: HandleMock -> HandleMock -> Bool
> :: HandleMock -> HandleMock -> Bool
$c>= :: HandleMock -> HandleMock -> Bool
>= :: HandleMock -> HandleMock -> Bool
$cmax :: HandleMock -> HandleMock -> HandleMock
max :: HandleMock -> HandleMock -> HandleMock
$cmin :: HandleMock -> HandleMock -> HandleMock
min :: HandleMock -> HandleMock -> HandleMock
Ord, (forall x. HandleMock -> Rep HandleMock x)
-> (forall x. Rep HandleMock x -> HandleMock) -> Generic HandleMock
forall x. Rep HandleMock x -> HandleMock
forall x. HandleMock -> Rep HandleMock x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HandleMock -> Rep HandleMock x
from :: forall x. HandleMock -> Rep HandleMock x
$cto :: forall x. Rep HandleMock x -> HandleMock
to :: forall x. Rep HandleMock x -> HandleMock
Generic)
  deriving newtype (Int -> HandleMock
HandleMock -> Int
HandleMock -> [HandleMock]
HandleMock -> HandleMock
HandleMock -> HandleMock -> [HandleMock]
HandleMock -> HandleMock -> HandleMock -> [HandleMock]
(HandleMock -> HandleMock)
-> (HandleMock -> HandleMock)
-> (Int -> HandleMock)
-> (HandleMock -> Int)
-> (HandleMock -> [HandleMock])
-> (HandleMock -> HandleMock -> [HandleMock])
-> (HandleMock -> HandleMock -> [HandleMock])
-> (HandleMock -> HandleMock -> HandleMock -> [HandleMock])
-> Enum HandleMock
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: HandleMock -> HandleMock
succ :: HandleMock -> HandleMock
$cpred :: HandleMock -> HandleMock
pred :: HandleMock -> HandleMock
$ctoEnum :: Int -> HandleMock
toEnum :: Int -> HandleMock
$cfromEnum :: HandleMock -> Int
fromEnum :: HandleMock -> Int
$cenumFrom :: HandleMock -> [HandleMock]
enumFrom :: HandleMock -> [HandleMock]
$cenumFromThen :: HandleMock -> HandleMock -> [HandleMock]
enumFromThen :: HandleMock -> HandleMock -> [HandleMock]
$cenumFromTo :: HandleMock -> HandleMock -> [HandleMock]
enumFromTo :: HandleMock -> HandleMock -> [HandleMock]
$cenumFromThenTo :: HandleMock -> HandleMock -> HandleMock -> [HandleMock]
enumFromThenTo :: HandleMock -> HandleMock -> HandleMock -> [HandleMock]
Enum)

-- | Instantiate 'Handle' with the mock handle
type Handle' = Handle HandleMock

-- | Mock handle internal state
data HandleState =
    HandleOpen !OpenHandleState
  | HandleClosed !ClosedHandleState
  deriving (Int -> HandleState -> ShowS
[HandleState] -> ShowS
HandleState -> String
(Int -> HandleState -> ShowS)
-> (HandleState -> String)
-> ([HandleState] -> ShowS)
-> Show HandleState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HandleState -> ShowS
showsPrec :: Int -> HandleState -> ShowS
$cshow :: HandleState -> String
show :: HandleState -> String
$cshowList :: [HandleState] -> ShowS
showList :: [HandleState] -> ShowS
Show, (forall x. HandleState -> Rep HandleState x)
-> (forall x. Rep HandleState x -> HandleState)
-> Generic HandleState
forall x. Rep HandleState x -> HandleState
forall x. HandleState -> Rep HandleState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HandleState -> Rep HandleState x
from :: forall x. HandleState -> Rep HandleState x
$cto :: forall x. Rep HandleState x -> HandleState
to :: forall x. Rep HandleState x -> HandleState
Generic)

data OpenHandleState = OpenHandle {
      OpenHandleState -> FsPath
openFilePath :: !FsPath
    , OpenHandleState -> FilePtr
openPtr      :: !FilePtr
    }
  deriving (Int -> OpenHandleState -> ShowS
[OpenHandleState] -> ShowS
OpenHandleState -> String
(Int -> OpenHandleState -> ShowS)
-> (OpenHandleState -> String)
-> ([OpenHandleState] -> ShowS)
-> Show OpenHandleState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenHandleState -> ShowS
showsPrec :: Int -> OpenHandleState -> ShowS
$cshow :: OpenHandleState -> String
show :: OpenHandleState -> String
$cshowList :: [OpenHandleState] -> ShowS
showList :: [OpenHandleState] -> ShowS
Show, (forall x. OpenHandleState -> Rep OpenHandleState x)
-> (forall x. Rep OpenHandleState x -> OpenHandleState)
-> Generic OpenHandleState
forall x. Rep OpenHandleState x -> OpenHandleState
forall x. OpenHandleState -> Rep OpenHandleState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OpenHandleState -> Rep OpenHandleState x
from :: forall x. OpenHandleState -> Rep OpenHandleState x
$cto :: forall x. Rep OpenHandleState x -> OpenHandleState
to :: forall x. Rep OpenHandleState x -> OpenHandleState
Generic)

-- | Check whether the file handle is in write/append mode.
isWriteHandle :: OpenHandleState -> Bool
isWriteHandle :: OpenHandleState -> Bool
isWriteHandle OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} = case FilePtr
openPtr of
    RW Bool
_ Bool
True  Word64
_ -> Bool
True
    FilePtr
Append       -> Bool
True
    FilePtr
_            -> Bool
False

-- | File pointer
--
-- This is purely an internal abstraction.
data FilePtr =
    -- | Read/write pointer
    --
    -- We record if we can read and/or write, and the current offset
    RW !Bool !Bool !Word64

    -- | Append-only pointer
    --
    -- Offset is always the end of the file in append mode
  | Append
  deriving (Int -> FilePtr -> ShowS
[FilePtr] -> ShowS
FilePtr -> String
(Int -> FilePtr -> ShowS)
-> (FilePtr -> String) -> ([FilePtr] -> ShowS) -> Show FilePtr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FilePtr -> ShowS
showsPrec :: Int -> FilePtr -> ShowS
$cshow :: FilePtr -> String
show :: FilePtr -> String
$cshowList :: [FilePtr] -> ShowS
showList :: [FilePtr] -> ShowS
Show, (forall x. FilePtr -> Rep FilePtr x)
-> (forall x. Rep FilePtr x -> FilePtr) -> Generic FilePtr
forall x. Rep FilePtr x -> FilePtr
forall x. FilePtr -> Rep FilePtr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FilePtr -> Rep FilePtr x
from :: forall x. FilePtr -> Rep FilePtr x
$cto :: forall x. Rep FilePtr x -> FilePtr
to :: forall x. Rep FilePtr x -> FilePtr
Generic)

data ClosedHandleState = ClosedHandle {
      ClosedHandleState -> FsPath
closedFilePath :: FsPath
    }
  deriving (Int -> ClosedHandleState -> ShowS
[ClosedHandleState] -> ShowS
ClosedHandleState -> String
(Int -> ClosedHandleState -> ShowS)
-> (ClosedHandleState -> String)
-> ([ClosedHandleState] -> ShowS)
-> Show ClosedHandleState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClosedHandleState -> ShowS
showsPrec :: Int -> ClosedHandleState -> ShowS
$cshow :: ClosedHandleState -> String
show :: ClosedHandleState -> String
$cshowList :: [ClosedHandleState] -> ShowS
showList :: [ClosedHandleState] -> ShowS
Show, (forall x. ClosedHandleState -> Rep ClosedHandleState x)
-> (forall x. Rep ClosedHandleState x -> ClosedHandleState)
-> Generic ClosedHandleState
forall x. Rep ClosedHandleState x -> ClosedHandleState
forall x. ClosedHandleState -> Rep ClosedHandleState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ClosedHandleState -> Rep ClosedHandleState x
from :: forall x. ClosedHandleState -> Rep ClosedHandleState x
$cto :: forall x. Rep ClosedHandleState x -> ClosedHandleState
to :: forall x. Rep ClosedHandleState x -> ClosedHandleState
Generic)

-- | Monads in which we can simulate the file system
type CanSimFS m = (HasCallStack, MonadState MockFS m, MonadError FsError m)

empty :: MockFS
empty :: MockFS
empty = Files -> Map HandleMock HandleState -> HandleMock -> MockFS
MockFS Files
forall a. FsTree a
FS.empty Map HandleMock HandleState
forall k a. Map k a
M.empty (Int -> HandleMock
HandleMock Int
0)

example :: MockFS
example :: MockFS
example = MockFS
empty { mockFiles = FS.example }

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Return 'True' iff the handle is open.
--
-- Throws an exception if the handle is unknown.
handleIsOpen :: MockFS -> HandleMock -> Bool
handleIsOpen :: MockFS -> HandleMock -> Bool
handleIsOpen MockFS{Map HandleMock HandleState
Files
HandleMock
mockFiles :: MockFS -> Files
mockHandles :: MockFS -> Map HandleMock HandleState
mockNextHandle :: MockFS -> HandleMock
mockFiles :: Files
mockHandles :: Map HandleMock HandleState
mockNextHandle :: HandleMock
..} HandleMock
h =
    case HandleMock -> Map HandleMock HandleState -> Maybe HandleState
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HandleMock
h Map HandleMock HandleState
mockHandles of
      Maybe HandleState
Nothing ->
        String -> Bool
forall a. HasCallStack => String -> a
error String
"handleIOMode: unknown handle"
      Just (HandleOpen OpenHandle{}) -> Bool
True
      Just (HandleClosed ClosedHandleState
_)          -> Bool
False

openHandles :: MockFS -> [OpenHandleState]
openHandles :: MockFS -> [OpenHandleState]
openHandles MockFS{Map HandleMock HandleState
Files
HandleMock
mockFiles :: MockFS -> Files
mockHandles :: MockFS -> Map HandleMock HandleState
mockNextHandle :: MockFS -> HandleMock
mockFiles :: Files
mockHandles :: Map HandleMock HandleState
mockNextHandle :: HandleMock
..} = (HandleState -> Maybe OpenHandleState)
-> [HandleState] -> [OpenHandleState]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HandleState -> Maybe OpenHandleState
isOpen ([HandleState] -> [OpenHandleState])
-> [HandleState] -> [OpenHandleState]
forall a b. (a -> b) -> a -> b
$ Map HandleMock HandleState -> [HandleState]
forall k a. Map k a -> [a]
M.elems Map HandleMock HandleState
mockHandles
  where
    isOpen :: HandleState -> Maybe OpenHandleState
    isOpen :: HandleState -> Maybe OpenHandleState
isOpen (HandleOpen   OpenHandleState
hs) = OpenHandleState -> Maybe OpenHandleState
forall a. a -> Maybe a
Just OpenHandleState
hs
    isOpen (HandleClosed ClosedHandleState
_ ) = Maybe OpenHandleState
forall a. Maybe a
Nothing

-- | A set containing each file path that some open handle refers to.
openFilePaths :: MockFS -> Set FsPath
openFilePaths :: MockFS -> Set FsPath
openFilePaths MockFS{Map HandleMock HandleState
Files
HandleMock
mockFiles :: MockFS -> Files
mockHandles :: MockFS -> Map HandleMock HandleState
mockNextHandle :: MockFS -> HandleMock
mockFiles :: Files
mockHandles :: Map HandleMock HandleState
mockNextHandle :: HandleMock
..} = (HandleState -> Set FsPath) -> [HandleState] -> Set FsPath
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap HandleState -> Set FsPath
handleOpenFilePath ([HandleState] -> Set FsPath) -> [HandleState] -> Set FsPath
forall a b. (a -> b) -> a -> b
$ Map HandleMock HandleState -> [HandleState]
forall k a. Map k a -> [a]
M.elems Map HandleMock HandleState
mockHandles
  where
    handleOpenFilePath :: HandleState -> Set FsPath
    handleOpenFilePath :: HandleState -> Set FsPath
handleOpenFilePath (HandleOpen OpenHandleState
hs)  = FsPath -> Set FsPath
forall a. a -> Set a
S.singleton (FsPath -> Set FsPath) -> FsPath -> Set FsPath
forall a b. (a -> b) -> a -> b
$ OpenHandleState -> FsPath
openFilePath OpenHandleState
hs
    handleOpenFilePath (HandleClosed ClosedHandleState
_) = Set FsPath
forall a. Set a
S.empty

-- | Number of open handles
numOpenHandles :: MockFS -> Int
numOpenHandles :: MockFS -> Int
numOpenHandles = [OpenHandleState] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([OpenHandleState] -> Int)
-> (MockFS -> [OpenHandleState]) -> MockFS -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockFS -> [OpenHandleState]
openHandles

-- | Updated file pointer
--
-- We lift this out as a separate concept primarily for the benefit of tests.
--
-- See 'hSeek' for limitations.
seekFilePtr :: MonadError FsError m
            => MockFS -> Handle' -> SeekMode -> Int64 -> m FilePtr
seekFilePtr :: forall (m :: * -> *).
MonadError FsError m =>
MockFS -> Handle' -> SeekMode -> Int64 -> m FilePtr
seekFilePtr MockFS{Map HandleMock HandleState
Files
HandleMock
mockFiles :: MockFS -> Files
mockHandles :: MockFS -> Map HandleMock HandleState
mockNextHandle :: MockFS -> HandleMock
mockFiles :: Files
mockHandles :: Map HandleMock HandleState
mockNextHandle :: HandleMock
..} (Handle HandleMock
h FsPath
_) SeekMode
seekMode Int64
o = do
    case Map HandleMock HandleState
mockHandles Map HandleMock HandleState -> HandleMock -> HandleState
forall k a. Ord k => Map k a -> k -> a
M.! HandleMock
h of
      HandleClosed ClosedHandle{FsPath
closedFilePath :: ClosedHandleState -> FsPath
closedFilePath :: FsPath
..} ->
        FsError -> m FilePtr
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
            fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsIllegalOperation
          , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
closedFilePath
          , fsErrorString :: String
fsErrorString = String
"handle closed"
          , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
          , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
          , fsLimitation :: Bool
fsLimitation  = Bool
False
          }
      HandleOpen OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} -> do
        ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath Files
mockFiles
        let fsize :: Word64
fsize = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
file) :: Word64
        case (FilePtr
openPtr, SeekMode
seekMode, Int64 -> Sign Word64
sign64 Int64
o) of
          (RW Bool
r Bool
w Word64
_cur, SeekMode
AbsoluteSeek, Positive Word64
o') -> do
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
o' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
fsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errPastEnd FsPath
openFilePath)
            FilePtr -> m FilePtr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePtr -> m FilePtr) -> FilePtr -> m FilePtr
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Word64 -> FilePtr
RW Bool
r Bool
w Word64
o'
          (FilePtr
_, SeekMode
AbsoluteSeek, Negative Word64
_) ->
            FsError -> m FilePtr
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsError -> m FilePtr) -> FsError -> m FilePtr
forall a b. (a -> b) -> a -> b
$ FsPath -> FsError
errNegative FsPath
openFilePath
          (RW Bool
r Bool
w Word64
cur, SeekMode
RelativeSeek, Positive Word64
o') -> do
            let cur' :: Word64
cur' = Word64
cur Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
o'
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
cur' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
fsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errPastEnd FsPath
openFilePath)
            FilePtr -> m FilePtr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePtr -> m FilePtr) -> FilePtr -> m FilePtr
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Word64 -> FilePtr
RW Bool
r Bool
w Word64
cur'
          (RW Bool
r Bool
w Word64
cur, SeekMode
RelativeSeek, Negative Word64
o') -> do
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
o' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
cur) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errNegative FsPath
openFilePath)
            let cur' :: Word64
cur' = Word64
cur Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
o'
            FilePtr -> m FilePtr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePtr -> m FilePtr) -> FilePtr -> m FilePtr
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Word64 -> FilePtr
RW Bool
r Bool
w Word64
cur'
          (RW Bool
r Bool
w Word64
_cur, SeekMode
SeekFromEnd, Positive Word64
0) ->
            FilePtr -> m FilePtr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePtr -> m FilePtr) -> FilePtr -> m FilePtr
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Word64 -> FilePtr
RW Bool
r Bool
w Word64
fsize
          (RW Bool
_ Bool
_ Word64
_, SeekMode
SeekFromEnd, Positive Word64
_) ->
            FsError -> m FilePtr
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errPastEnd FsPath
openFilePath)
          (RW Bool
r Bool
w Word64
_, SeekMode
SeekFromEnd, Negative Word64
o') -> do
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
o' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
fsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errNegative FsPath
openFilePath)
            let cur' :: Word64
cur' = Word64
fsize Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
o'
            FilePtr -> m FilePtr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePtr -> m FilePtr) -> FilePtr -> m FilePtr
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Word64 -> FilePtr
RW Bool
r Bool
w Word64
cur'
          (FilePtr
Append, SeekMode
_, Sign Word64
_) ->
            FsError -> m FilePtr
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errAppend FsPath
openFilePath)
  where
    errPastEnd :: FsPath -> FsError
errPastEnd FsPath
fp  = FsError {
                         fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
                       , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
                       , fsErrorString :: String
fsErrorString = String
"seek past EOF not supported"
                       , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
                       , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
                       , fsLimitation :: Bool
fsLimitation  = Bool
True
                       }
    errAppend :: FsPath -> FsError
errAppend  FsPath
fp  = FsError {
                         fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
                       , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
                       , fsErrorString :: String
fsErrorString = String
"seek in append mode not supported"
                       , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
                       , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
                       , fsLimitation :: Bool
fsLimitation  = Bool
True
                       }
    errNegative :: FsPath -> FsError
errNegative FsPath
fp = FsError {
                         fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
                       , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
                       , fsErrorString :: String
fsErrorString = String
"seek past beginning of file"
                       , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
                       , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
                       , fsLimitation :: Bool
fsLimitation  = Bool
False
                       }

{-------------------------------------------------------------------------------
  Internal utilities for implementing the mock FS
-------------------------------------------------------------------------------}

-- | Modify the mock file system without a file handle
modifyMockFS :: CanSimFS m
             => (MockFS -> m (a, MockFS)) -> m a
modifyMockFS :: forall (m :: * -> *) a.
CanSimFS m =>
(MockFS -> m (a, MockFS)) -> m a
modifyMockFS MockFS -> m (a, MockFS)
f = do
    MockFS
st       <- m MockFS
forall s (m :: * -> *). MonadState s m => m s
get
    (a
a, MockFS
st') <- MockFS -> m (a, MockFS)
f MockFS
st
    MockFS -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put MockFS
st'
    a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Access but do not modify the mock file system state without a file handle
readMockFS :: CanSimFS m
           => (Files -> m a) -> m a
readMockFS :: forall (m :: * -> *) a. CanSimFS m => (Files -> m a) -> m a
readMockFS Files -> m a
f = (MockFS -> m (a, MockFS)) -> m a
forall (m :: * -> *) a.
CanSimFS m =>
(MockFS -> m (a, MockFS)) -> m a
modifyMockFS (\MockFS
fs -> (, MockFS
fs) (a -> (a, MockFS)) -> m a -> m (a, MockFS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Files -> m a
f (MockFS -> Files
mockFiles MockFS
fs))

-- | Require a file handle and may modify the mock file system
withHandleModify :: CanSimFS m
                 => Handle'
                 -> (    MockFS
                      -> HandleState
                      -> m (a, (Files, HandleState))
                    )
                 -> m a
withHandleModify :: forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> HandleState -> m (a, (Files, HandleState))) -> m a
withHandleModify (Handle HandleMock
h FsPath
_) MockFS -> HandleState -> m (a, (Files, HandleState))
f = do
    MockFS
st <- m MockFS
forall s (m :: * -> *). MonadState s m => m s
get
    case HandleMock -> Map HandleMock HandleState -> Maybe HandleState
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HandleMock
h (MockFS -> Map HandleMock HandleState
mockHandles MockFS
st) of
      Just HandleState
hs -> do
        (a
a, (Files
fs', HandleState
hs')) <- MockFS -> HandleState -> m (a, (Files, HandleState))
f MockFS
st HandleState
hs
        MockFS -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (MockFS -> m ()) -> MockFS -> m ()
forall a b. (a -> b) -> a -> b
$ MockFS
st { mockHandles = M.insert h hs' (mockHandles st)
                 , mockFiles   = fs'
                 }
        a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
      Maybe HandleState
Nothing ->
        String -> m a
forall a. HasCallStack => String -> a
error String
"withHandleModify: handle not found"

-- | Require a file handle but do not modify the mock file system
withHandleRead :: CanSimFS m
               => Handle'
               -> (    MockFS
                    -> HandleState
                    -> m (a, HandleState)
                  )
               -> m a
withHandleRead :: forall (m :: * -> *) a.
CanSimFS m =>
Handle' -> (MockFS -> HandleState -> m (a, HandleState)) -> m a
withHandleRead Handle'
h MockFS -> HandleState -> m (a, HandleState)
f =
    Handle'
-> (MockFS -> HandleState -> m (a, (Files, HandleState))) -> m a
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> HandleState -> m (a, (Files, HandleState))) -> m a
withHandleModify Handle'
h ((MockFS -> HandleState -> m (a, (Files, HandleState))) -> m a)
-> (MockFS -> HandleState -> m (a, (Files, HandleState))) -> m a
forall a b. (a -> b) -> a -> b
$ \MockFS
fs HandleState
hs ->
      (HandleState -> (Files, HandleState))
-> (a, HandleState) -> (a, (Files, HandleState))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (MockFS -> Files
mockFiles MockFS
fs, ) ((a, HandleState) -> (a, (Files, HandleState)))
-> m (a, HandleState) -> m (a, (Files, HandleState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockFS -> HandleState -> m (a, HandleState)
f MockFS
fs HandleState
hs

-- | Require an open file handle to modify the mock file system
withOpenHandleModify :: CanSimFS m
                     => Handle'
                     -> (    MockFS
                          -> OpenHandleState
                          -> m (a, (Files, OpenHandleState))
                        )
                     -> m a
withOpenHandleModify :: forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, (Files, OpenHandleState)))
-> m a
withOpenHandleModify Handle'
h MockFS -> OpenHandleState -> m (a, (Files, OpenHandleState))
f =
    Handle'
-> (MockFS -> HandleState -> m (a, (Files, HandleState))) -> m a
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> HandleState -> m (a, (Files, HandleState))) -> m a
withHandleModify Handle'
h ((MockFS -> HandleState -> m (a, (Files, HandleState))) -> m a)
-> (MockFS -> HandleState -> m (a, (Files, HandleState))) -> m a
forall a b. (a -> b) -> a -> b
$ \MockFS
fs -> \case
      HandleOpen OpenHandleState
hs ->
        ((Files, OpenHandleState) -> (Files, HandleState))
-> (a, (Files, OpenHandleState)) -> (a, (Files, HandleState))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((OpenHandleState -> HandleState)
-> (Files, OpenHandleState) -> (Files, HandleState)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second OpenHandleState -> HandleState
HandleOpen) ((a, (Files, OpenHandleState)) -> (a, (Files, HandleState)))
-> m (a, (Files, OpenHandleState)) -> m (a, (Files, HandleState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockFS -> OpenHandleState -> m (a, (Files, OpenHandleState))
f MockFS
fs OpenHandleState
hs
      HandleClosed ClosedHandle{FsPath
closedFilePath :: ClosedHandleState -> FsPath
closedFilePath :: FsPath
..} ->
        FsError -> m (a, (Files, HandleState))
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
            fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsIllegalOperation
          , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
closedFilePath
          , fsErrorString :: String
fsErrorString = String
"handle closed"
          , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
          , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
          , fsLimitation :: Bool
fsLimitation  = Bool
False
          }

-- | Require an open file handle but do not modify the mock file system
withOpenHandleRead :: CanSimFS m
                   => Handle'
                   -> (    MockFS
                        -> OpenHandleState
                        -> m (a, OpenHandleState)
                      )
                   -> m a
withOpenHandleRead :: forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, OpenHandleState)) -> m a
withOpenHandleRead Handle'
h MockFS -> OpenHandleState -> m (a, OpenHandleState)
f =
    Handle' -> (MockFS -> HandleState -> m (a, HandleState)) -> m a
forall (m :: * -> *) a.
CanSimFS m =>
Handle' -> (MockFS -> HandleState -> m (a, HandleState)) -> m a
withHandleRead Handle'
h ((MockFS -> HandleState -> m (a, HandleState)) -> m a)
-> (MockFS -> HandleState -> m (a, HandleState)) -> m a
forall a b. (a -> b) -> a -> b
$ \MockFS
fs -> \case
      HandleOpen OpenHandleState
hs ->
        (OpenHandleState -> HandleState)
-> (a, OpenHandleState) -> (a, HandleState)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second OpenHandleState -> HandleState
HandleOpen ((a, OpenHandleState) -> (a, HandleState))
-> m (a, OpenHandleState) -> m (a, HandleState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockFS -> OpenHandleState -> m (a, OpenHandleState)
f MockFS
fs OpenHandleState
hs
      HandleClosed ClosedHandle{FsPath
closedFilePath :: ClosedHandleState -> FsPath
closedFilePath :: FsPath
..} ->
        FsError -> m (a, HandleState)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
            fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsIllegalOperation
          , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
closedFilePath
          , fsErrorString :: String
fsErrorString = String
"handle closed"
          , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
          , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
          , fsLimitation :: Bool
fsLimitation  = Bool
False
          }

{-------------------------------------------------------------------------------
  Debugging
-------------------------------------------------------------------------------}

dumpState :: CanSimFS m => m String
dumpState :: forall (m :: * -> *). CanSimFS m => m String
dumpState = MockFS -> String
pretty (MockFS -> String) -> m MockFS -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m MockFS
forall s (m :: * -> *). MonadState s m => m s
get

{-------------------------------------------------------------------------------
  Internal auxiliary
-------------------------------------------------------------------------------}

checkFsTree' :: (MonadError FsError m, HasCallStack)
             => Either FsTreeError a -> m (Either FsPath a)
checkFsTree' :: forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m (Either FsPath a)
checkFsTree' = Either FsTreeError a -> m (Either FsPath a)
forall {m :: * -> *} {b}.
MonadError FsError m =>
Either FsTreeError b -> m (Either FsPath b)
go
  where
    go :: Either FsTreeError b -> m (Either FsPath b)
go (Left (FsExpectedDir FsPath
fp NonEmpty Text
_)) =
        FsError -> m (Either FsPath b)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
            fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsResourceInappropriateType
          , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
          , fsErrorString :: String
fsErrorString = String
"expected directory"
          , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
          , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
          , fsLimitation :: Bool
fsLimitation  = Bool
False
          }
    go (Left (FsExpectedFile FsPath
fp)) =
        FsError -> m (Either FsPath b)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
            fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsResourceInappropriateType
          , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
          , fsErrorString :: String
fsErrorString = String
"expected file"
          , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
          , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
          , fsLimitation :: Bool
fsLimitation  = Bool
False
          }
    go (Left (FsMissing FsPath
fp NonEmpty Text
_)) =
        Either FsPath b -> m (Either FsPath b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FsPath -> Either FsPath b
forall a b. a -> Either a b
Left FsPath
fp)
    go (Left (FsExists FsPath
fp)) =
        FsError -> m (Either FsPath b)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
            fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsResourceAlreadyExist
          , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
          , fsErrorString :: String
fsErrorString = String
"file exists"
          , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
          , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
          , fsLimitation :: Bool
fsLimitation  = Bool
False
          }
    go (Right b
a) =
        Either FsPath b -> m (Either FsPath b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either FsPath b
forall a b. b -> Either a b
Right b
a)

checkFsTree :: (MonadError FsError m, HasCallStack)
            => Either FsTreeError a -> m a
checkFsTree :: forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree Either FsTreeError a
ma = do
    Either FsPath a
ma' <- Either FsTreeError a -> m (Either FsPath a)
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m (Either FsPath a)
checkFsTree' Either FsTreeError a
ma
    case Either FsPath a
ma' of
      Left FsPath
fp -> FsError -> m a
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
                     fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsResourceDoesNotExist
                   , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
                   , fsErrorString :: String
fsErrorString = String
"does not exist"
                   , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
                   , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
                   , fsLimitation :: Bool
fsLimitation  = Bool
False
                   }
      Right a
a -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

checkDoesNotExist :: (MonadError FsError m, HasCallStack)
                  => MockFS -> FsPath -> m ()
checkDoesNotExist :: forall (m :: * -> *).
(MonadError FsError m, HasCallStack) =>
MockFS -> FsPath -> m ()
checkDoesNotExist MockFS
fs FsPath
fp = do
    Bool
exists <- (Either FsPath Files -> Bool) -> m (Either FsPath Files) -> m Bool
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either FsPath Files -> Bool
forall a b. Either a b -> Bool
pathExists (m (Either FsPath Files) -> m Bool)
-> m (Either FsPath Files) -> m Bool
forall a b. (a -> b) -> a -> b
$ Either FsTreeError Files -> m (Either FsPath Files)
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m (Either FsPath a)
checkFsTree' (Either FsTreeError Files -> m (Either FsPath Files))
-> Either FsTreeError Files -> m (Either FsPath Files)
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError Files
forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
FS.index FsPath
fp (MockFS -> Files
mockFiles MockFS
fs)
    if Bool
exists
      then FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
               fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsResourceAlreadyExist
             , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
             , fsErrorString :: String
fsErrorString = String
"already exists"
             , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
             , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
             , fsLimitation :: Bool
fsLimitation  = Bool
False
             }
      else () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    pathExists :: Either a b -> Bool
    pathExists :: forall a b. Either a b -> Bool
pathExists (Left a
_)  = Bool
False
    pathExists (Right b
_) = Bool
True

newHandle :: MockFS -> OpenHandleState -> (Handle', MockFS)
newHandle :: MockFS -> OpenHandleState -> (Handle', MockFS)
newHandle MockFS
fs OpenHandleState
hs = (
      HandleMock -> FsPath -> Handle'
forall h. h -> FsPath -> Handle h
Handle (MockFS -> HandleMock
mockNextHandle MockFS
fs) (OpenHandleState -> FsPath
openFilePath OpenHandleState
hs)
    , MockFS
fs { mockNextHandle = succ (mockNextHandle fs)
         , mockHandles    = M.insert (mockNextHandle fs)
                                     (HandleOpen hs)
                                     (mockHandles fs)
         }
    )

{-------------------------------------------------------------------------------
  Operations on files
-------------------------------------------------------------------------------}

-- | Mock implementation of 'hOpen'.
--
-- NOTE: Differences from Posix:
--
-- * We do not support opening directories.
-- * We do not support more than one concurrent writer
--   (we do however allow a writer and multiple concurrent readers)
-- * We do not support create file on ReadMode.
hOpen :: CanSimFS m => FsPath -> OpenMode -> m Handle'
hOpen :: forall (m :: * -> *). CanSimFS m => FsPath -> OpenMode -> m Handle'
hOpen FsPath
fp OpenMode
openMode = do
    Bool
dirExists <- FsPath -> m Bool
forall (m :: * -> *). CanSimFS m => FsPath -> m Bool
doesDirectoryExist FsPath
fp
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
dirExists (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsResourceInappropriateType
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"hOpen: directories not supported"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }
    (MockFS -> m (Handle', MockFS)) -> m Handle'
forall (m :: * -> *) a.
CanSimFS m =>
(MockFS -> m (a, MockFS)) -> m a
modifyMockFS ((MockFS -> m (Handle', MockFS)) -> m Handle')
-> (MockFS -> m (Handle', MockFS)) -> m Handle'
forall a b. (a -> b) -> a -> b
$ \MockFS
fs -> do
      let alreadyHasWriter :: Bool
alreadyHasWriter =
            (OpenHandleState -> Bool) -> [OpenHandleState] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\OpenHandleState
hs -> OpenHandleState -> FsPath
openFilePath OpenHandleState
hs FsPath -> FsPath -> Bool
forall a. Eq a => a -> a -> Bool
== FsPath
fp Bool -> Bool -> Bool
&& OpenHandleState -> Bool
isWriteHandle OpenHandleState
hs) ([OpenHandleState] -> Bool) -> [OpenHandleState] -> Bool
forall a b. (a -> b) -> a -> b
$
            MockFS -> [OpenHandleState]
openHandles MockFS
fs
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OpenMode
openMode OpenMode -> OpenMode -> Bool
forall a. Eq a => a -> a -> Bool
/= OpenMode
ReadMode Bool -> Bool -> Bool
&& Bool
alreadyHasWriter) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
            fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
          , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
          , fsErrorString :: String
fsErrorString = String
"more than one concurrent writer not supported"
          , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
          , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
          , fsLimitation :: Bool
fsLimitation  = Bool
True
          }
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OpenMode
openMode OpenMode -> OpenMode -> Bool
forall a. Eq a => a -> a -> Bool
== OpenMode
ReadMode) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m ByteString -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ByteString -> m ()) -> m ByteString -> m ()
forall a b. (a -> b) -> a -> b
$
        Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
fp (MockFS -> Files
mockFiles MockFS
fs)
      Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> AllowExisting -> Files -> Either FsTreeError Files
forall a.
Monoid a =>
FsPath
-> AllowExisting -> FsTree a -> Either FsTreeError (FsTree a)
FS.openFile FsPath
fp AllowExisting
ex (MockFS -> Files
mockFiles MockFS
fs)
      (Handle', MockFS) -> m (Handle', MockFS)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Handle', MockFS) -> m (Handle', MockFS))
-> (Handle', MockFS) -> m (Handle', MockFS)
forall a b. (a -> b) -> a -> b
$ MockFS -> OpenHandleState -> (Handle', MockFS)
newHandle (MockFS
fs { mockFiles = files' })
                         (FsPath -> FilePtr -> OpenHandleState
OpenHandle FsPath
fp (OpenMode -> FilePtr
filePtr OpenMode
openMode))
  where
    ex :: AllowExisting
    ex :: AllowExisting
ex = OpenMode -> AllowExisting
allowExisting OpenMode
openMode

    filePtr :: OpenMode -> FilePtr
    filePtr :: OpenMode -> FilePtr
filePtr OpenMode
ReadMode          = Bool -> Bool -> Word64 -> FilePtr
RW Bool
True  Bool
False Word64
0
    filePtr (WriteMode     AllowExisting
_) = Bool -> Bool -> Word64 -> FilePtr
RW Bool
False Bool
True  Word64
0
    filePtr (ReadWriteMode AllowExisting
_) = Bool -> Bool -> Word64 -> FilePtr
RW Bool
True  Bool
True  Word64
0
    filePtr (AppendMode    AllowExisting
_) = FilePtr
Append

-- | Mock implementation of 'hClose'
hClose :: CanSimFS m => Handle' -> m ()
hClose :: forall (m :: * -> *). CanSimFS m => Handle' -> m ()
hClose Handle'
h = Handle' -> (MockFS -> HandleState -> m ((), HandleState)) -> m ()
forall (m :: * -> *) a.
CanSimFS m =>
Handle' -> (MockFS -> HandleState -> m (a, HandleState)) -> m a
withHandleRead Handle'
h ((MockFS -> HandleState -> m ((), HandleState)) -> m ())
-> (MockFS -> HandleState -> m ((), HandleState)) -> m ()
forall a b. (a -> b) -> a -> b
$ \MockFS
_fs -> \case
    HandleOpen OpenHandleState
hs ->
      ((), HandleState) -> m ((), HandleState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), ClosedHandleState -> HandleState
HandleClosed (FsPath -> ClosedHandleState
ClosedHandle (OpenHandleState -> FsPath
openFilePath OpenHandleState
hs)))
    HandleClosed ClosedHandleState
hs ->
      ((), HandleState) -> m ((), HandleState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), ClosedHandleState -> HandleState
HandleClosed ClosedHandleState
hs)

-- | Mock implementation of 'hIsOpen'
hIsOpen :: CanSimFS m => Handle' -> m Bool
hIsOpen :: forall (m :: * -> *). CanSimFS m => Handle' -> m Bool
hIsOpen Handle'
h = (MockFS -> Bool) -> m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (MockFS -> HandleMock -> Bool
`handleIsOpen` Handle' -> HandleMock
forall h. Handle h -> h
handleRaw Handle'
h)

-- | Mock implementation of 'hSeek'
--
-- NOTE: This is more restricted than the IO version, because seek has some
-- odd properties:
--
-- * We do not allow seeking at all on files in append mode
-- * We do not allow seeking past the end of the file
--   (this means that when using 'IO.SeekFromEnd', the only valid offset is 0)
-- * We do /not/ return the new file offset
hSeek :: CanSimFS m
      => Handle' -> SeekMode -> Int64 -> m ()
hSeek :: forall (m :: * -> *).
CanSimFS m =>
Handle' -> SeekMode -> Int64 -> m ()
hSeek Handle'
h SeekMode
seekMode Int64
o = Handle'
-> (MockFS -> OpenHandleState -> m ((), OpenHandleState)) -> m ()
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, OpenHandleState)) -> m a
withOpenHandleRead Handle'
h ((MockFS -> OpenHandleState -> m ((), OpenHandleState)) -> m ())
-> (MockFS -> OpenHandleState -> m ((), OpenHandleState)) -> m ()
forall a b. (a -> b) -> a -> b
$ \MockFS
fs OpenHandleState
hs -> do
    FilePtr
openPtr' <- MockFS -> Handle' -> SeekMode -> Int64 -> m FilePtr
forall (m :: * -> *).
MonadError FsError m =>
MockFS -> Handle' -> SeekMode -> Int64 -> m FilePtr
seekFilePtr MockFS
fs Handle'
h SeekMode
seekMode Int64
o
    ((), OpenHandleState) -> m ((), OpenHandleState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), OpenHandleState
hs { openPtr = openPtr' })

-- | Get bytes from handle
--
-- NOTE: Unlike real I/O, we disallow 'hGetSome' on a handle in append mode.
hGetSome :: CanSimFS m => Handle' -> Word64 -> m ByteString
hGetSome :: forall (m :: * -> *).
CanSimFS m =>
Handle' -> Word64 -> m ByteString
hGetSome Handle'
h Word64
n =
    Handle'
-> (MockFS -> OpenHandleState -> m (ByteString, OpenHandleState))
-> m ByteString
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, OpenHandleState)) -> m a
withOpenHandleRead Handle'
h ((MockFS -> OpenHandleState -> m (ByteString, OpenHandleState))
 -> m ByteString)
-> (MockFS -> OpenHandleState -> m (ByteString, OpenHandleState))
-> m ByteString
forall a b. (a -> b) -> a -> b
$ \MockFS
fs hs :: OpenHandleState
hs@OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} -> do
      ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath (MockFS -> Files
mockFiles MockFS
fs)
      case FilePtr
openPtr of
        RW Bool
r Bool
w Word64
o -> do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
r (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoReadAccess FsPath
openFilePath String
"write")
          let bs :: ByteString
bs = Int -> ByteString -> ByteString
BS.take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
o) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
file
          (ByteString, OpenHandleState) -> m (ByteString, OpenHandleState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, OpenHandleState
hs { openPtr = RW True w (o + fromIntegral (BS.length bs)) })
        FilePtr
Append -> FsError -> m (ByteString, OpenHandleState)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoReadAccess FsPath
openFilePath String
"append")
  where
    errNoReadAccess :: FsPath -> String -> FsError
errNoReadAccess FsPath
fp String
mode = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"cannot hGetSome in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
mode String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" mode"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

-- | Thread safe version of 'hGetSome', which doesn't modify or read the file
-- offset.
hGetSomeAt :: CanSimFS m
           => Handle'
           -> Word64
           -> AbsOffset
           -> m ByteString
hGetSomeAt :: forall (m :: * -> *).
CanSimFS m =>
Handle' -> Word64 -> AbsOffset -> m ByteString
hGetSomeAt Handle'
h Word64
n AbsOffset
o =
  Handle'
-> (MockFS -> OpenHandleState -> m (ByteString, OpenHandleState))
-> m ByteString
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, OpenHandleState)) -> m a
withOpenHandleRead Handle'
h ((MockFS -> OpenHandleState -> m (ByteString, OpenHandleState))
 -> m ByteString)
-> (MockFS -> OpenHandleState -> m (ByteString, OpenHandleState))
-> m ByteString
forall a b. (a -> b) -> a -> b
$ \MockFS
fs hs :: OpenHandleState
hs@OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} -> do
      ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath (MockFS -> Files
mockFiles MockFS
fs)
      let o' :: Word64
o' = AbsOffset -> Word64
unAbsOffset AbsOffset
o
      let fsize :: Word64
fsize = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
file) :: Word64
      case FilePtr
openPtr  of
        RW Bool
r Bool
_ Word64
_ -> do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
r (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoReadAccess FsPath
openFilePath String
"write")
          let bs :: ByteString
bs = Int -> ByteString -> ByteString
BS.take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
o') (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
file
          -- This is the same fsLimitation we get when we seek past the end of
          -- EOF, in AbsoluteSeek mode.
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
o' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
fsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errPastEnd FsPath
openFilePath)
          (ByteString, OpenHandleState) -> m (ByteString, OpenHandleState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, OpenHandleState
hs)
        FilePtr
Append -> FsError -> m (ByteString, OpenHandleState)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoReadAccess FsPath
openFilePath String
"append")
  where
    errNoReadAccess :: FsPath -> String -> FsError
errNoReadAccess FsPath
fp String
mode = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"cannot hGetSomeAt in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
mode String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" mode"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

    errPastEnd :: FsPath -> FsError
errPastEnd FsPath
fp = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"hGetSomeAt offset past EOF not supported"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

hPutSome :: CanSimFS m => Handle' -> ByteString -> m Word64
hPutSome :: forall (m :: * -> *).
CanSimFS m =>
Handle' -> ByteString -> m Word64
hPutSome Handle'
h ByteString
toWrite =
    Handle'
-> (MockFS
    -> OpenHandleState -> m (Word64, (Files, OpenHandleState)))
-> m Word64
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, (Files, OpenHandleState)))
-> m a
withOpenHandleModify Handle'
h ((MockFS
  -> OpenHandleState -> m (Word64, (Files, OpenHandleState)))
 -> m Word64)
-> (MockFS
    -> OpenHandleState -> m (Word64, (Files, OpenHandleState)))
-> m Word64
forall a b. (a -> b) -> a -> b
$ \MockFS
fs hs :: OpenHandleState
hs@OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} -> do
      case FilePtr
openPtr of
        RW Bool
r Bool
w Word64
o -> do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
w (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errReadOnly FsPath
openFilePath)
          ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath (MockFS -> Files
mockFiles MockFS
fs)
          let file' :: ByteString
file' = Word64 -> ByteString -> ByteString -> ByteString
replace Word64
o ByteString
toWrite ByteString
file
          Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> ByteString -> Files -> Either FsTreeError Files
forall a. FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a)
FS.replace FsPath
openFilePath ByteString
file' (MockFS -> Files
mockFiles MockFS
fs)
          (Word64, (Files, OpenHandleState))
-> m (Word64, (Files, OpenHandleState))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
written, (Files
files', OpenHandleState
hs { openPtr = RW r w (o + written) }))
        FilePtr
Append -> do
          ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath (MockFS -> Files
mockFiles MockFS
fs)
          let file' :: ByteString
file' = ByteString
file ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
toWrite
          Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> ByteString -> Files -> Either FsTreeError Files
forall a. FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a)
FS.replace FsPath
openFilePath ByteString
file' (MockFS -> Files
mockFiles MockFS
fs)
          (Word64, (Files, OpenHandleState))
-> m (Word64, (Files, OpenHandleState))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
written, (Files
files', OpenHandleState
hs))
  where
    written :: Word64
written = Int -> Word64
forall a. Enum a => Int -> a
toEnum (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
toWrite

    errReadOnly :: FsPath -> FsError
errReadOnly FsPath
fp = FsError {
                         fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
                       , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
                       , fsErrorString :: String
fsErrorString = String
"handle is read-only"
                       , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
                       , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
                       , fsLimitation :: Bool
fsLimitation  = Bool
False
                       }

-- | Truncate a file
--
-- NOTE: Differences from Posix:
--
-- * Although this corresponds to Posix @ftruncate@, this can only be used
--   to make files /smaller/, not larger.
-- * We only support this in append mode. The reason is that Posix
--   @ftruncate@ does not modify the file offset, and adds padding with zeroes
--   on subsequent writes. This is however not behaviour we want to emulate.
--   In append mode however the Posix file offset is not used (and we don't
--   even record it at all), appends always happen at the end of the file.
hTruncate :: CanSimFS m => Handle' -> Word64 -> m ()
hTruncate :: forall (m :: * -> *). CanSimFS m => Handle' -> Word64 -> m ()
hTruncate Handle'
h Word64
sz =
    Handle'
-> (MockFS -> OpenHandleState -> m ((), (Files, OpenHandleState)))
-> m ()
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, (Files, OpenHandleState)))
-> m a
withOpenHandleModify Handle'
h ((MockFS -> OpenHandleState -> m ((), (Files, OpenHandleState)))
 -> m ())
-> (MockFS -> OpenHandleState -> m ((), (Files, OpenHandleState)))
-> m ()
forall a b. (a -> b) -> a -> b
$ \MockFS
fs hs :: OpenHandleState
hs@OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} -> do
      ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath (MockFS -> Files
mockFiles MockFS
fs)
      FilePtr
ptr' <- case (Word64
sz Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
file), FilePtr
openPtr) of
                (Bool
True, FilePtr
_) ->
                  FsError -> m FilePtr
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
                      fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
                    , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
openFilePath
                    , fsErrorString :: String
fsErrorString = String
"truncate cannot make the file larger"
                    , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
                    , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
                    , fsLimitation :: Bool
fsLimitation  = Bool
True
                    }
                (Bool
False, RW{}) ->
                  FsError -> m FilePtr
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
                      fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
                    , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
openFilePath
                    , fsErrorString :: String
fsErrorString = String
"truncate only supported in append mode"
                    , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
                    , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
                    , fsLimitation :: Bool
fsLimitation  = Bool
True
                    }
                (Bool
False, FilePtr
Append) ->
                  FilePtr -> m FilePtr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePtr
Append
      let file' :: ByteString
file' = Int -> ByteString -> ByteString
BS.take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sz) ByteString
file
      Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> ByteString -> Files -> Either FsTreeError Files
forall a. FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a)
FS.replace FsPath
openFilePath ByteString
file' (MockFS -> Files
mockFiles MockFS
fs)
      -- TODO: Don't replace the file pointer (not changed)
      ((), (Files, OpenHandleState)) -> m ((), (Files, OpenHandleState))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), (Files
files', OpenHandleState
hs { openPtr = ptr' }))

-- | Get file size
--
-- NOTE: In the mock implementation this is thread safe, because there can be
-- only one writer, so concurrent threads cannot change the size of the file.
hGetSize :: CanSimFS m => Handle' -> m Word64
hGetSize :: forall (m :: * -> *). CanSimFS m => Handle' -> m Word64
hGetSize Handle'
h =
    Handle'
-> (MockFS -> OpenHandleState -> m (Word64, OpenHandleState))
-> m Word64
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, OpenHandleState)) -> m a
withOpenHandleRead Handle'
h ((MockFS -> OpenHandleState -> m (Word64, OpenHandleState))
 -> m Word64)
-> (MockFS -> OpenHandleState -> m (Word64, OpenHandleState))
-> m Word64
forall a b. (a -> b) -> a -> b
$ \MockFS
fs hs :: OpenHandleState
hs@OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} -> do
      ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath (MockFS -> Files
mockFiles MockFS
fs)
      (Word64, OpenHandleState) -> m (Word64, OpenHandleState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
file), OpenHandleState
hs)

{-------------------------------------------------------------------------------
  Operations on directories
-------------------------------------------------------------------------------}

createDirectory :: CanSimFS m => FsPath -> m ()
createDirectory :: forall (m :: * -> *). CanSimFS m => FsPath -> m ()
createDirectory FsPath
dir = (MockFS -> m ((), MockFS)) -> m ()
forall (m :: * -> *) a.
CanSimFS m =>
(MockFS -> m (a, MockFS)) -> m a
modifyMockFS ((MockFS -> m ((), MockFS)) -> m ())
-> (MockFS -> m ((), MockFS)) -> m ()
forall a b. (a -> b) -> a -> b
$ \MockFS
fs -> do
    MockFS -> FsPath -> m ()
forall (m :: * -> *).
(MonadError FsError m, HasCallStack) =>
MockFS -> FsPath -> m ()
checkDoesNotExist MockFS
fs FsPath
dir
    Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError Files
forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
FS.createDirIfMissing FsPath
dir (MockFS -> Files
mockFiles MockFS
fs)
    ((), MockFS) -> m ((), MockFS)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), MockFS
fs { mockFiles = files' })

createDirectoryIfMissing :: CanSimFS m
                         => Bool -> FsPath -> m ()
createDirectoryIfMissing :: forall (m :: * -> *). CanSimFS m => Bool -> FsPath -> m ()
createDirectoryIfMissing Bool
createParents FsPath
dir = do
    -- Although @createDirectoryIfMissing /a/b/c@ will fail ("inappropriate
    -- type") if @b@ is a file (not a directory), for some strange reason it
    -- throws "already exists" if @c@ is is a file
    Bool
fileExists <- FsPath -> m Bool
forall (m :: * -> *). CanSimFS m => FsPath -> m Bool
doesFileExist FsPath
dir
    if Bool
fileExists then
      FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
          fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsResourceAlreadyExist
        , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
dir
        , fsErrorString :: String
fsErrorString = String
"a file with that name already exists"
        , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
        , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
        , fsLimitation :: Bool
fsLimitation  = Bool
False
        }
    else (MockFS -> m ((), MockFS)) -> m ()
forall (m :: * -> *) a.
CanSimFS m =>
(MockFS -> m (a, MockFS)) -> m a
modifyMockFS ((MockFS -> m ((), MockFS)) -> m ())
-> (MockFS -> m ((), MockFS)) -> m ()
forall a b. (a -> b) -> a -> b
$ \MockFS
fs -> do
      Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ Bool -> Files -> Either FsTreeError Files
go Bool
createParents (MockFS -> Files
mockFiles MockFS
fs)
      ((), MockFS) -> m ((), MockFS)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), MockFS
fs { mockFiles = files' })
  where
    go :: Bool -> Files -> Either FsTreeError Files
    go :: Bool -> Files -> Either FsTreeError Files
go Bool
True  = FsPath -> Files -> Either FsTreeError Files
forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
FS.createDirWithParents FsPath
dir
    go Bool
False = FsPath -> Files -> Either FsTreeError Files
forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
FS.createDirIfMissing   FsPath
dir

listDirectory :: CanSimFS m
              => FsPath -> m (Set String)
listDirectory :: forall (m :: * -> *). CanSimFS m => FsPath -> m (Set String)
listDirectory FsPath
fp = (Files -> m (Set String)) -> m (Set String)
forall (m :: * -> *) a. CanSimFS m => (Files -> m a) -> m a
readMockFS ((Files -> m (Set String)) -> m (Set String))
-> (Files -> m (Set String)) -> m (Set String)
forall a b. (a -> b) -> a -> b
$
      (Map Text Files -> Set String)
-> m (Map Text Files) -> m (Set String)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> (Map Text Files -> [String]) -> Map Text Files -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack ([Text] -> [String])
-> (Map Text Files -> [Text]) -> Map Text Files -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Files -> [Text]
forall k a. Map k a -> [k]
M.keys)
    (m (Map Text Files) -> m (Set String))
-> (Files -> m (Map Text Files)) -> Files -> m (Set String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either FsTreeError (Map Text Files) -> m (Map Text Files)
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree
    (Either FsTreeError (Map Text Files) -> m (Map Text Files))
-> (Files -> Either FsTreeError (Map Text Files))
-> Files
-> m (Map Text Files)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsPath -> Files -> Either FsTreeError (Map Text Files)
forall a. FsPath -> FsTree a -> Either FsTreeError (Folder a)
FS.getDir FsPath
fp

-- | Check if directory exists
--
-- It seems real I/O maps what would be "inapproriate device" errors to False.
doesDirectoryExist :: CanSimFS m => FsPath -> m Bool
doesDirectoryExist :: forall (m :: * -> *). CanSimFS m => FsPath -> m Bool
doesDirectoryExist FsPath
fp = (Files -> m Bool) -> m Bool
forall (m :: * -> *) a. CanSimFS m => (Files -> m a) -> m a
readMockFS ((Files -> m Bool) -> m Bool) -> (Files -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \Files
fs ->
    Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ case FsPath -> Files -> Either FsTreeError (Map Text Files)
forall a. FsPath -> FsTree a -> Either FsTreeError (Folder a)
FS.getDir FsPath
fp Files
fs of
               Left  FsTreeError
_ -> Bool
False
               Right Map Text Files
_ -> Bool
True

-- | Check if file exists
--
-- See comments for 'doesDirectoryExist'.
doesFileExist :: CanSimFS m => FsPath -> m Bool
doesFileExist :: forall (m :: * -> *). CanSimFS m => FsPath -> m Bool
doesFileExist FsPath
fp = (Files -> m Bool) -> m Bool
forall (m :: * -> *) a. CanSimFS m => (Files -> m a) -> m a
readMockFS ((Files -> m Bool) -> m Bool) -> (Files -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \Files
fs ->
    Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ case FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
fp Files
fs of
               Left  FsTreeError
_ -> Bool
False
               Right ByteString
_ -> Bool
True

-- | Remove a directory and its contents
--
-- Same limitations as 'removeFile'.
removeDirectoryRecursive :: CanSimFS m => FsPath -> m ()
removeDirectoryRecursive :: forall (m :: * -> *). CanSimFS m => FsPath -> m ()
removeDirectoryRecursive FsPath
fp = do
    (MockFS -> m ((), MockFS)) -> m ()
forall (m :: * -> *) a.
CanSimFS m =>
(MockFS -> m (a, MockFS)) -> m a
modifyMockFS ((MockFS -> m ((), MockFS)) -> m ())
-> (MockFS -> m ((), MockFS)) -> m ()
forall a b. (a -> b) -> a -> b
$ \MockFS
fs -> do
      Set FsPath
reachablePaths <- ([FsPath] -> Set FsPath) -> m [FsPath] -> m (Set FsPath)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FsPath] -> Set FsPath
forall a. Ord a => [a] -> Set a
S.fromList (m [FsPath] -> m (Set FsPath)) -> m [FsPath] -> m (Set FsPath)
forall a b. (a -> b) -> a -> b
$ Either FsTreeError [FsPath] -> m [FsPath]
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError [FsPath] -> m [FsPath])
-> Either FsTreeError [FsPath] -> m [FsPath]
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError [FsPath]
forall a. FsPath -> FsTree a -> Either FsTreeError [FsPath]
FS.find FsPath
fp (MockFS -> Files
mockFiles MockFS
fs)
      let openReachablePaths :: Set FsPath
openReachablePaths = Set FsPath
reachablePaths Set FsPath -> Set FsPath -> Set FsPath
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` MockFS -> Set FsPath
openFilePaths MockFS
fs
      case FsPath -> [Text]
fsPathToList FsPath
fp of
        []
          -> FsError -> m ((), MockFS)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
                 fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsIllegalOperation
               , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
               , fsErrorString :: String
fsErrorString = String
"cannot remove the root directory"
               , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
               , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
               , fsLimitation :: Bool
fsLimitation  = Bool
True
               }
        [Text]
_ | Set FsPath
openReachablePaths Set FsPath -> Set FsPath -> Bool
forall a. Eq a => a -> a -> Bool
/= Set FsPath
forall a. Monoid a => a
mempty
          -> FsError -> m ((), MockFS)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
                 fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsIllegalOperation
               , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
               , fsErrorString :: String
fsErrorString =  String
"cannot remove an open file. "
                               String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"The following files are reachable from "
                               String -> ShowS
forall a. [a] -> [a] -> [a]
++ FsPath -> String
forall a. Show a => a -> String
show FsPath
fp
                               String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"and are still open: "
                               String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set FsPath -> String
forall a. Show a => a -> String
show Set FsPath
openReachablePaths
               , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
               , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
               , fsLimitation :: Bool
fsLimitation  = Bool
True
               }
        [Text]
_ -> do
          Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError Files
forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
FS.removeDirRecursive FsPath
fp (MockFS -> Files
mockFiles MockFS
fs)
          ((), MockFS) -> m ((), MockFS)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), MockFS
fs { mockFiles = files' })

-- | Remove a file
--
-- The behaviour of @unlink@ is to remove the file after all open file handles
-- that refer to it are closed. The open file handles referring to the file
-- can still be used to write\/read to\/from, while at the same time, the file
-- is invisible for all other operations.
--
-- We do not implement this behaviour and consider this a limitation of the
-- mock file system, and throw an error when removing a file that still has
-- open file handles to it.
--
-- In the state machine tests, removing the root directory may cause the IO
-- implementation to throw an 'FsInsufficientPermissions' error, depending on
-- the permissions of the temporary directory used to run the tests in. In
-- theory it should throw a 'FsResourceInappropriateType' error. To avoid this
-- mismatch during testing, we also consider removing the root folder a
-- limitation of the mock file system.
removeFile :: CanSimFS m => FsPath -> m ()
removeFile :: forall (m :: * -> *). CanSimFS m => FsPath -> m ()
removeFile FsPath
fp =
    (MockFS -> m ((), MockFS)) -> m ()
forall (m :: * -> *) a.
CanSimFS m =>
(MockFS -> m (a, MockFS)) -> m a
modifyMockFS ((MockFS -> m ((), MockFS)) -> m ())
-> (MockFS -> m ((), MockFS)) -> m ()
forall a b. (a -> b) -> a -> b
$ \MockFS
fs -> case FsPath -> [Text]
fsPathToList FsPath
fp of
      []
        -> FsError -> m ((), MockFS)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
               fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsIllegalOperation
             , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
             , fsErrorString :: String
fsErrorString = String
"cannot remove the root directory"
             , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
             , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
             , fsLimitation :: Bool
fsLimitation  = Bool
True
             }
      [Text]
_ | FsPath
fp FsPath -> Set FsPath -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` MockFS -> Set FsPath
openFilePaths MockFS
fs
        -> FsError -> m ((), MockFS)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FsError {
               fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsIllegalOperation
             , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
             , fsErrorString :: String
fsErrorString = String
"cannot remove an open file"
             , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
             , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
             , fsLimitation :: Bool
fsLimitation  = Bool
True
             }
      [Text]
_ -> do
        Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError Files
forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
FS.removeFile FsPath
fp (MockFS -> Files
mockFiles MockFS
fs)
        ((), MockFS) -> m ((), MockFS)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), MockFS
fs { mockFiles = files' })

renameFile :: CanSimFS m => FsPath -> FsPath -> m ()
renameFile :: forall (m :: * -> *). CanSimFS m => FsPath -> FsPath -> m ()
renameFile FsPath
fpOld FsPath
fpNew =
    (MockFS -> m ((), MockFS)) -> m ()
forall (m :: * -> *) a.
CanSimFS m =>
(MockFS -> m (a, MockFS)) -> m a
modifyMockFS ((MockFS -> m ((), MockFS)) -> m ())
-> (MockFS -> m ((), MockFS)) -> m ()
forall a b. (a -> b) -> a -> b
$ \MockFS
fs -> if
      | Bool -> Bool
not (FsPath -> FsPath -> Bool
sameDir FsPath
fpOld FsPath
fpNew) ->
        FsError -> m ((), MockFS)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsError -> m ((), MockFS)) -> FsError -> m ((), MockFS)
forall a b. (a -> b) -> a -> b
$ FsPath -> FsError
errDifferentDir FsPath
fpOld
      | FsPath
fpOld FsPath -> Set FsPath -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` MockFS -> Set FsPath
openFilePaths MockFS
fs ->
        FsError -> m ((), MockFS)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsError -> m ((), MockFS)) -> FsError -> m ((), MockFS)
forall a b. (a -> b) -> a -> b
$ FsPath -> FsError
errRenameOpenFile FsPath
fpOld
      | FsPath
fpNew FsPath -> Set FsPath -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` MockFS -> Set FsPath
openFilePaths MockFS
fs ->
        FsError -> m ((), MockFS)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsError -> m ((), MockFS)) -> FsError -> m ((), MockFS)
forall a b. (a -> b) -> a -> b
$ FsPath -> FsError
errRenameOpenFile FsPath
fpNew
      | Right Map Text Files
_ <- FsPath -> Files -> Either FsTreeError (Map Text Files)
forall a. FsPath -> FsTree a -> Either FsTreeError (Folder a)
FS.getDir FsPath
fpNew (MockFS -> Files
mockFiles MockFS
fs) ->
        FsError -> m ((), MockFS)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsError -> m ((), MockFS)) -> FsError -> m ((), MockFS)
forall a b. (a -> b) -> a -> b
$ FsPath -> FsError
errRenameDir FsPath
fpNew
      | Bool
otherwise -> do
        Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> FsPath -> Files -> Either FsTreeError Files
forall a.
FsPath -> FsPath -> FsTree a -> Either FsTreeError (FsTree a)
FS.renameFile FsPath
fpOld FsPath
fpNew (MockFS -> Files
mockFiles MockFS
fs)
        ((), MockFS) -> m ((), MockFS)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), MockFS
fs { mockFiles = files' })
  where
    sameDir :: FsPath -> FsPath -> Bool
sameDir FsPath
fp1 FsPath
fp2 =
        ((FsPath, Text) -> FsPath
forall a b. (a, b) -> a
fst ((FsPath, Text) -> FsPath) -> Maybe (FsPath, Text) -> Maybe FsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FsPath -> Maybe (FsPath, Text)
fsPathSplit FsPath
fp1) Maybe FsPath -> Maybe FsPath -> Bool
forall a. Eq a => a -> a -> Bool
== ((FsPath, Text) -> FsPath
forall a b. (a, b) -> a
fst ((FsPath, Text) -> FsPath) -> Maybe (FsPath, Text) -> Maybe FsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FsPath -> Maybe (FsPath, Text)
fsPathSplit FsPath
fp2)

    errRenameOpenFile :: FsPath -> FsError
errRenameOpenFile FsPath
fp = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsIllegalOperation
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"cannot rename opened file"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

    errRenameDir :: FsPath -> FsError
errRenameDir FsPath
fp = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsResourceInappropriateType
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"is a directory"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

    errDifferentDir :: FsPath -> FsError
errDifferentDir FsPath
fp = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsIllegalOperation
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"files must be in the same directory"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

{-------------------------------------------------------------------------------
  Pretty-printing
-------------------------------------------------------------------------------}

-- | Renders the 'MockFS' in a human-readable fashion.
pretty :: MockFS -> String
-- TODO: Right now does this not show the state of the handles.
pretty :: MockFS -> String
pretty = (ByteString -> String) -> Files -> String
forall a. (a -> String) -> FsTree a -> String
FS.pretty ByteString -> String
renderFile (Files -> String) -> (MockFS -> Files) -> MockFS -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockFS -> Files
mockFiles
  where
    renderFile :: ByteString -> String
    renderFile :: ByteString -> String
renderFile = ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
hexDump (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode

    hexDump :: ByteString -> ByteString
    hexDump :: ByteString -> ByteString
hexDump = (ByteString, Int) -> ByteString
forall a b. (a, b) -> a
fst
            ((ByteString, Int) -> ByteString)
-> (ByteString -> (ByteString, Int)) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Int) -> Word8 -> (ByteString, Int))
-> (ByteString, Int) -> ByteString -> (ByteString, Int)
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\(ByteString
acc, Int
n) Word8
w8 ->
                            if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 then (ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
BS.singleton Word8
w8, Int
1)
                                      else (ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
BS.singleton Word8
w8, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                        ) (ByteString
forall a. Monoid a => a
mempty, Int
0 :: Int)

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

data Sign a = Negative a | Positive a
  deriving ((forall a b. (a -> b) -> Sign a -> Sign b)
-> (forall a b. a -> Sign b -> Sign a) -> Functor Sign
forall a b. a -> Sign b -> Sign a
forall a b. (a -> b) -> Sign a -> Sign b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Sign a -> Sign b
fmap :: forall a b. (a -> b) -> Sign a -> Sign b
$c<$ :: forall a b. a -> Sign b -> Sign a
<$ :: forall a b. a -> Sign b -> Sign a
Functor)

sign :: (Num a, Ord a) => a -> Sign a
sign :: forall a. (Num a, Ord a) => a -> Sign a
sign a
a | a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0     = a -> Sign a
forall a. a -> Sign a
Negative (a -> a
forall a. Num a => a -> a
negate a
a)
       | Bool
otherwise = a -> Sign a
forall a. a -> Sign a
Positive a
a

sign64 :: Int64 -> Sign Word64
sign64 :: Int64 -> Sign Word64
sign64 = (Int64 -> Word64) -> Sign Int64 -> Sign Word64
forall a b. (a -> b) -> Sign a -> Sign b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Sign Int64 -> Sign Word64)
-> (Int64 -> Sign Int64) -> Int64 -> Sign Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Sign Int64
forall a. (Num a, Ord a) => a -> Sign a
sign

{-------------------------------------------------------------------------------
  ByteString
-------------------------------------------------------------------------------}

-- Given
--
-- >        A        B         C
-- > |-----------|-------.-----------|
-- >             n       .
-- >                     .
-- >                 D   .
-- >             |-------|
--
-- return A <> D <> C
replace :: Word64 -> ByteString -> ByteString -> ByteString
replace :: Word64 -> ByteString -> ByteString -> ByteString
replace Word64
n ByteString
d ByteString
abc = ByteString
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
d ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
c
  where
    (ByteString
a, ByteString
c) = Int -> Int -> ByteString -> (ByteString, ByteString)
snip (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) (ByteString -> Int
BS.length ByteString
d) ByteString
abc

-- Given
--
-- >       A         B         C
-- > |-----------|-------|-----------|
-- >             n
-- >             <------->
-- >                 m
--
-- return (A, C)
snip :: Int -> Int -> ByteString -> (ByteString, ByteString)
snip :: Int -> Int -> ByteString -> (ByteString, ByteString)
snip Int
n Int
m ByteString
bs = (ByteString
a, ByteString
c)
  where
    (ByteString
a, ByteString
bc) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
n ByteString
bs
    c :: ByteString
c       = Int -> ByteString -> ByteString
BS.drop Int
m ByteString
bc

{-------------------------------------------------------------------------------
  HasBufFS
-------------------------------------------------------------------------------}

packMutableByteArray :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> [Word8] -> m ()
packMutableByteArray :: forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> BufferOffset -> [Word8] -> m ()
packMutableByteArray MutableByteArray (PrimState m)
mba BufferOffset
i [Word8]
bytes = [(Int, Word8)] -> ((Int, Word8) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Word8] -> [(Int, Word8)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BufferOffset -> Int
unBufferOffset BufferOffset
i..] [Word8]
bytes) (((Int, Word8) -> m ()) -> m ()) -> ((Int, Word8) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ (Int -> Word8 -> m ()) -> (Int, Word8) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (MutableByteArray (PrimState m) -> Int -> Word8 -> m ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
P.writeByteArray MutableByteArray (PrimState m)
mba)

intoBuffer :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteString -> m Bool
intoBuffer :: forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset -> ByteString -> m Bool
intoBuffer MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteString
bs = do
    Int
bufSize <- MutableByteArray (PrimState m) -> m Int
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m Int
P.getSizeofMutableByteArray MutableByteArray (PrimState m)
buf
    let remaining :: Int
remaining = Int
bufSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- BufferOffset -> Int
unBufferOffset BufferOffset
bufOff
    if ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
remaining
      then Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      else MutableByteArray (PrimState m) -> BufferOffset -> [Word8] -> m ()
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> BufferOffset -> [Word8] -> m ()
packMutableByteArray MutableByteArray (PrimState m)
buf BufferOffset
bufOff (ByteString -> [Word8]
BS.unpack ByteString
bs)
        m () -> m Bool -> m Bool
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

unpackMutableByteArray :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m [Word8]
unpackMutableByteArray :: forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset -> ByteCount -> m [Word8]
unpackMutableByteArray MutableByteArray (PrimState m)
mba BufferOffset
i ByteCount
c = [Int] -> (Int -> m Word8) -> m [Word8]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [BufferOffset -> Int
unBufferOffset BufferOffset
i .. BufferOffset -> Int
unBufferOffset BufferOffset
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> m Word8) -> m [Word8]) -> (Int -> m Word8) -> m [Word8]
forall a b. (a -> b) -> a -> b
$ MutableByteArray (PrimState m) -> Int -> m Word8
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
P.readByteArray MutableByteArray (PrimState m)
mba

fromBuffer :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m (Maybe ByteString)
fromBuffer :: forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset -> ByteCount -> m (Maybe ByteString)
fromBuffer MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c = do
  Int
bufSize <- MutableByteArray (PrimState m) -> m Int
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m Int
P.getSizeofMutableByteArray MutableByteArray (PrimState m)
buf
  let remaining :: Int
remaining = Int
bufSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- BufferOffset -> Int
unBufferOffset BufferOffset
bufOff
  if ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
remaining
    then Maybe ByteString -> m (Maybe ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
    else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> ([Word8] -> ByteString) -> [Word8] -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> Maybe ByteString) -> m [Word8] -> m (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableByteArray (PrimState m)
-> BufferOffset -> ByteCount -> m [Word8]
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset -> ByteCount -> m [Word8]
unpackMutableByteArray MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c

hGetBufSome :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount
hGetBufSome :: forall (m :: * -> *).
(CanSimFS m, PrimMonad m) =>
Handle'
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufSome Handle'
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
n =
    Handle'
-> (MockFS -> OpenHandleState -> m (ByteCount, OpenHandleState))
-> m ByteCount
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, OpenHandleState)) -> m a
withOpenHandleRead Handle'
h ((MockFS -> OpenHandleState -> m (ByteCount, OpenHandleState))
 -> m ByteCount)
-> (MockFS -> OpenHandleState -> m (ByteCount, OpenHandleState))
-> m ByteCount
forall a b. (a -> b) -> a -> b
$ \MockFS
fs hs :: OpenHandleState
hs@OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} -> do
      ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath (MockFS -> Files
mockFiles MockFS
fs)
      case FilePtr
openPtr  of
        RW Bool
r Bool
w Word64
o -> do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
r (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoReadAccess FsPath
openFilePath String
"write")
          let bs :: ByteString
bs = Int -> ByteString -> ByteString
BS.take (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
n) (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
o) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
file
          Bool
success <- MutableByteArray (PrimState m)
-> BufferOffset -> ByteString -> m Bool
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset -> ByteString -> m Bool
intoBuffer MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteString
bs
          -- we can't read more bytes than the buffer size
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errWritePastBufEnd FsPath
openFilePath)
          let readBytes :: ByteCount
readBytes = Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs)
          (ByteCount, OpenHandleState) -> m (ByteCount, OpenHandleState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteCount
readBytes, OpenHandleState
hs { openPtr = RW True w (o + fromIntegral readBytes)})
        FilePtr
Append -> FsError -> m (ByteCount, OpenHandleState)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoReadAccess FsPath
openFilePath String
"append")
  where
    errNoReadAccess :: FsPath -> String -> FsError
errNoReadAccess FsPath
fp String
mode = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"cannot hGetBufSomeAt in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
mode String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" mode"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

    errWritePastBufEnd :: FsPath -> FsError
errWritePastBufEnd FsPath
fp = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"hPutBufSomeAt: writing into buffer past end not supported"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

hGetBufSomeAt :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount
hGetBufSomeAt :: forall (m :: * -> *).
(CanSimFS m, PrimMonad m) =>
Handle'
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hGetBufSomeAt Handle'
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
n AbsOffset
o =
    Handle'
-> (MockFS -> OpenHandleState -> m (ByteCount, OpenHandleState))
-> m ByteCount
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, OpenHandleState)) -> m a
withOpenHandleRead Handle'
h ((MockFS -> OpenHandleState -> m (ByteCount, OpenHandleState))
 -> m ByteCount)
-> (MockFS -> OpenHandleState -> m (ByteCount, OpenHandleState))
-> m ByteCount
forall a b. (a -> b) -> a -> b
$ \MockFS
fs hs :: OpenHandleState
hs@OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} -> do
      ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath (MockFS -> Files
mockFiles MockFS
fs)
      let o' :: Word64
o' = AbsOffset -> Word64
unAbsOffset AbsOffset
o
      let fsize :: Word64
fsize = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
file) :: Word64
      case FilePtr
openPtr  of
        RW Bool
r Bool
_ Word64
_ -> do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
r (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoReadAccess FsPath
openFilePath String
"write")
          -- This is the same fsLimitation we get when we seek past the end of
          -- EOF, in AbsoluteSeek mode.
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
o' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
fsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errPastEnd FsPath
openFilePath)
          let bs :: ByteString
bs = Int -> ByteString -> ByteString
BS.take (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
n) (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
o') (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
file
          Bool
success <- MutableByteArray (PrimState m)
-> BufferOffset -> ByteString -> m Bool
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset -> ByteString -> m Bool
intoBuffer MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteString
bs
          -- we can't read more bytes than the buffer size
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errWritePastBufEnd FsPath
openFilePath)
          (ByteCount, OpenHandleState) -> m (ByteCount, OpenHandleState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs), OpenHandleState
hs)
        FilePtr
Append -> FsError -> m (ByteCount, OpenHandleState)
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoReadAccess FsPath
openFilePath String
"append")
  where
    errNoReadAccess :: FsPath -> String -> FsError
errNoReadAccess FsPath
fp String
mode = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"cannot hGetBufSomeAt in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
mode String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" mode"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

    errPastEnd :: FsPath -> FsError
errPastEnd FsPath
fp = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"hGetBufSomeAt offset past EOF not supported"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

    errWritePastBufEnd :: FsPath -> FsError
errWritePastBufEnd FsPath
fp = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"hPutBufSomeAt: writing into buffer past end not supported"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

hPutBufSome :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount
hPutBufSome :: forall (m :: * -> *).
(CanSimFS m, PrimMonad m) =>
Handle'
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hPutBufSome Handle'
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
n = do
    Handle'
-> (MockFS
    -> OpenHandleState -> m (ByteCount, (Files, OpenHandleState)))
-> m ByteCount
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, (Files, OpenHandleState)))
-> m a
withOpenHandleModify Handle'
h ((MockFS
  -> OpenHandleState -> m (ByteCount, (Files, OpenHandleState)))
 -> m ByteCount)
-> (MockFS
    -> OpenHandleState -> m (ByteCount, (Files, OpenHandleState)))
-> m ByteCount
forall a b. (a -> b) -> a -> b
$ \MockFS
fs hs :: OpenHandleState
hs@OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} -> do
      ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath (MockFS -> Files
mockFiles MockFS
fs)
      case FilePtr
openPtr of
        RW Bool
r Bool
w Word64
o -> do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
w (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoWriteAccess FsPath
openFilePath String
"read")
          -- We can't write more bytes than the buffer size
          ByteString
toWrite <- MutableByteArray (PrimState m)
-> BufferOffset -> ByteCount -> m (Maybe ByteString)
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset -> ByteCount -> m (Maybe ByteString)
fromBuffer MutableByteArray (PrimState m)
buf BufferOffset
bufOff  ByteCount
n m (Maybe ByteString)
-> (Maybe ByteString -> 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 ByteString
Nothing -> FsError -> m ByteString
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errReadPastBufEnd FsPath
openFilePath)
            Just ByteString
bs -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
          let file' :: ByteString
file' = Word64 -> ByteString -> ByteString -> ByteString
replace Word64
o ByteString
toWrite ByteString
file
          Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> ByteString -> Files -> Either FsTreeError Files
forall a. FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a)
FS.replace FsPath
openFilePath ByteString
file' (MockFS -> Files
mockFiles MockFS
fs)
          let written :: ByteCount
written = Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> ByteCount) -> Int -> ByteCount
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
toWrite
          (ByteCount, (Files, OpenHandleState))
-> m (ByteCount, (Files, OpenHandleState))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteCount
written, (Files
files', OpenHandleState
hs { openPtr = RW r w (o + fromIntegral written)}))
        FilePtr
Append -> do
          -- We can't write more bytes than the buffer size
          ByteString
toWrite <- MutableByteArray (PrimState m)
-> BufferOffset -> ByteCount -> m (Maybe ByteString)
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset -> ByteCount -> m (Maybe ByteString)
fromBuffer MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
n m (Maybe ByteString)
-> (Maybe ByteString -> 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 ByteString
Nothing -> FsError -> m ByteString
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errReadPastBufEnd FsPath
openFilePath)
            Just ByteString
bs -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
          let file' :: ByteString
file' = ByteString
file ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
toWrite
          Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> ByteString -> Files -> Either FsTreeError Files
forall a. FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a)
FS.replace FsPath
openFilePath ByteString
file' (MockFS -> Files
mockFiles MockFS
fs)
          let written :: ByteCount
written = Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> ByteCount) -> Int -> ByteCount
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
toWrite
          (ByteCount, (Files, OpenHandleState))
-> m (ByteCount, (Files, OpenHandleState))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteCount
written, (Files
files', OpenHandleState
hs))
  where
    errNoWriteAccess :: FsPath -> String -> FsError
errNoWriteAccess FsPath
fp String
mode = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"cannot hPutBufSomeAt in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
mode String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" mode"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

    errReadPastBufEnd :: FsPath -> FsError
errReadPastBufEnd FsPath
fp = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"hPutBufSomeAt: reading from buffer past end not supported"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

hPutBufSomeAt :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount
hPutBufSomeAt :: forall (m :: * -> *).
(CanSimFS m, PrimMonad m) =>
Handle'
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSomeAt Handle'
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
n AbsOffset
o = do
    Handle'
-> (MockFS
    -> OpenHandleState -> m (ByteCount, (Files, OpenHandleState)))
-> m ByteCount
forall (m :: * -> *) a.
CanSimFS m =>
Handle'
-> (MockFS -> OpenHandleState -> m (a, (Files, OpenHandleState)))
-> m a
withOpenHandleModify Handle'
h ((MockFS
  -> OpenHandleState -> m (ByteCount, (Files, OpenHandleState)))
 -> m ByteCount)
-> (MockFS
    -> OpenHandleState -> m (ByteCount, (Files, OpenHandleState)))
-> m ByteCount
forall a b. (a -> b) -> a -> b
$ \MockFS
fs hs :: OpenHandleState
hs@OpenHandle{FsPath
FilePtr
openFilePath :: OpenHandleState -> FsPath
openPtr :: OpenHandleState -> FilePtr
openFilePath :: FsPath
openPtr :: FilePtr
..} -> do
      ByteString
file <- Either FsTreeError ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError ByteString -> m ByteString)
-> Either FsTreeError ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FsPath -> Files -> Either FsTreeError ByteString
forall a. FsPath -> FsTree a -> Either FsTreeError a
FS.getFile FsPath
openFilePath (MockFS -> Files
mockFiles MockFS
fs)
      let o' :: Word64
o'    = AbsOffset -> Word64
unAbsOffset AbsOffset
o
      let fsize :: Word64
fsize = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
file)
      case FilePtr
openPtr of
        RW Bool
_ Bool
w Word64
_ -> do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
w (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoWriteAccess FsPath
openFilePath String
"read")
          -- This is the same fsLimitation we get when we seek past the end of
          -- EOF, in AbsoluteSeek mode.
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
o' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
fsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errPastEnd FsPath
openFilePath)
          -- We can't write more bytes than the buffer size
          ByteString
toWrite <- MutableByteArray (PrimState m)
-> BufferOffset -> ByteCount -> m (Maybe ByteString)
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> BufferOffset -> ByteCount -> m (Maybe ByteString)
fromBuffer MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
n m (Maybe ByteString)
-> (Maybe ByteString -> 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 ByteString
Nothing -> FsError -> m ByteString
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> FsError
errReadPastBufEnd FsPath
openFilePath)
            Just ByteString
bs -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
          let file' :: ByteString
file' = Word64 -> ByteString -> ByteString -> ByteString
replace Word64
o' ByteString
toWrite ByteString
file
          Files
files' <- Either FsTreeError Files -> m Files
forall (m :: * -> *) a.
(MonadError FsError m, HasCallStack) =>
Either FsTreeError a -> m a
checkFsTree (Either FsTreeError Files -> m Files)
-> Either FsTreeError Files -> m Files
forall a b. (a -> b) -> a -> b
$ FsPath -> ByteString -> Files -> Either FsTreeError Files
forall a. FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a)
FS.replace FsPath
openFilePath ByteString
file' (MockFS -> Files
mockFiles MockFS
fs)
          let written :: ByteCount
written = Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> ByteCount) -> Int -> ByteCount
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
toWrite
          (ByteCount, (Files, OpenHandleState))
-> m (ByteCount, (Files, OpenHandleState))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteCount
written, (Files
files', OpenHandleState
hs))
        FilePtr
Append -> FsError -> m (ByteCount, (Files, OpenHandleState))
forall a. FsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FsPath -> String -> FsError
errNoWriteAccess FsPath
openFilePath String
"append")
  where
    errNoWriteAccess :: FsPath -> String -> FsError
errNoWriteAccess FsPath
fp String
mode = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"cannot hPutBufSomeAt in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
mode String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" mode"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

    errPastEnd :: FsPath -> FsError
errPastEnd FsPath
fp = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"hPutBufSomeAt offset past EOF not supported"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }

    errReadPastBufEnd :: FsPath -> FsError
errReadPastBufEnd FsPath
fp = FsError {
        fsErrorType :: FsErrorType
fsErrorType   = FsErrorType
FsInvalidArgument
      , fsErrorPath :: FsErrorPath
fsErrorPath   = FsPath -> FsErrorPath
fsToFsErrorPathUnmounted FsPath
fp
      , fsErrorString :: String
fsErrorString = String
"hPutBufSomeAt: reading from buffer past end not supported"
      , fsErrorNo :: Maybe Errno
fsErrorNo     = Maybe Errno
forall a. Maybe a
Nothing
      , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      , fsLimitation :: Bool
fsLimitation  = Bool
True
      }