MockFS.hs

{-# 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
  , openHandles
  , 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, 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.FS.API (BufferOffset (..))
import System.FS.API.Types
import System.FS.CallStack
import System.FS.Sim.FsTree (FsTree (..), FsTreeError (..))
import qualified System.FS.Sim.FsTree as FS
import System.Posix.Types (ByteCount)

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

data MockFS = MockFS
  { mockFiles :: !Files
  , mockHandles :: !(Map HandleMock HandleState)
  , mockNextHandle :: !HandleMock
  }
  deriving (Generic, 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 (Show, Eq, Ord, Generic)
  deriving newtype Enum

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

-- | Mock handle internal state
data HandleState
  = HandleOpen !OpenHandleState
  | HandleClosed !ClosedHandleState
  deriving (Show, Generic)

data OpenHandleState = OpenHandle
  { openFilePath :: !FsPath
  , openPtr :: !FilePtr
  }
  deriving (Show, Generic)

-- | Check whether the file handle is in write/append mode.
isWriteHandle :: OpenHandleState -> Bool
isWriteHandle OpenHandle{..} = case openPtr of
  RW _ True _ -> True
  Append -> True
  _ -> 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 (Show, Generic)

data ClosedHandleState = ClosedHandle
  { closedFilePath :: FsPath
  }
  deriving (Show, Generic)

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

empty :: MockFS
empty = MockFS FS.empty M.empty (HandleMock 0)

example :: MockFS
example = 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{..} h =
  case M.lookup h mockHandles of
    Nothing ->
      error "handleIOMode: unknown handle"
    Just (HandleOpen OpenHandle{}) -> True
    Just (HandleClosed _) -> False

openHandles :: MockFS -> [OpenHandleState]
openHandles MockFS{..} = mapMaybe isOpen $ M.elems mockHandles
 where
  isOpen :: HandleState -> Maybe OpenHandleState
  isOpen (HandleOpen hs) = Just hs
  isOpen (HandleClosed _) = Nothing

-- | A set containing each file path that some open handle refers to.
openFilePaths :: MockFS -> Set FsPath
openFilePaths MockFS{..} = foldMap handleOpenFilePath $ M.elems mockHandles
 where
  handleOpenFilePath :: HandleState -> Set FsPath
  handleOpenFilePath (HandleOpen hs) = S.singleton $ openFilePath hs
  handleOpenFilePath (HandleClosed _) = S.empty

-- | Number of open handles
numOpenHandles :: MockFS -> Int
numOpenHandles = length . 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 MockFS{..} (Handle h _) seekMode o = do
  case mockHandles M.! h of
    HandleClosed ClosedHandle{..} ->
      throwError
        FsError
          { fsErrorType = FsIllegalOperation
          , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath
          , fsErrorString = "handle closed"
          , fsErrorNo = Nothing
          , fsErrorStack = prettyCallStack
          , fsLimitation = False
          }
    HandleOpen OpenHandle{..} -> do
      file <- checkFsTree $ FS.getFile openFilePath mockFiles
      let fsize = fromIntegral (BS.length file) :: Word64
      case (openPtr, seekMode, sign64 o) of
        (RW r w _cur, AbsoluteSeek, Positive o') -> do
          when (o' > fsize) $ throwError (errPastEnd openFilePath)
          return $ RW r w o'
        (_, AbsoluteSeek, Negative _) ->
          throwError $ errNegative openFilePath
        (RW r w cur, RelativeSeek, Positive o') -> do
          let cur' = cur + o'
          when (cur' > fsize) $ throwError (errPastEnd openFilePath)
          return $ RW r w cur'
        (RW r w cur, RelativeSeek, Negative o') -> do
          when (o' > cur) $ throwError (errNegative openFilePath)
          let cur' = cur - o'
          return $ RW r w cur'
        (RW r w _cur, SeekFromEnd, Positive 0) ->
          return $ RW r w fsize
        (RW _ _ _, SeekFromEnd, Positive _) ->
          throwError (errPastEnd openFilePath)
        (RW r w _, SeekFromEnd, Negative o') -> do
          when (o' > fsize) $ throwError (errNegative openFilePath)
          let cur' = fsize - o'
          return $ RW r w cur'
        (Append, _, _) ->
          throwError (errAppend openFilePath)
 where
  errPastEnd fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "seek past EOF not supported"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }
  errAppend fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "seek in append mode not supported"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }
  errNegative fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "seek past beginning of file"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = 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 f = do
  st <- get
  (a, st') <- f st
  put st'
  return a

-- | Access but do not modify the mock file system state without a file handle
readMockFS ::
  CanSimFS m =>
  (Files -> m a) -> m a
readMockFS f = modifyMockFS (\fs -> (,fs) <$> f (mockFiles 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 (Handle h _) f = do
  st <- get
  case M.lookup h (mockHandles st) of
    Just hs -> do
      (a, (fs', hs')) <- f st hs
      put $
        st
          { mockHandles = M.insert h hs' (mockHandles st)
          , mockFiles = fs'
          }
      return a
    Nothing ->
      error "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 h f =
  withHandleModify h $ \fs hs ->
    second (mockFiles fs,) <$> f fs 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 h f =
  withHandleModify h $ \fs -> \case
    HandleOpen hs ->
      second (second HandleOpen) <$> f fs hs
    HandleClosed ClosedHandle{..} ->
      throwError
        FsError
          { fsErrorType = FsIllegalOperation
          , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath
          , fsErrorString = "handle closed"
          , fsErrorNo = Nothing
          , fsErrorStack = prettyCallStack
          , fsLimitation = 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 h f =
  withHandleRead h $ \fs -> \case
    HandleOpen hs ->
      second HandleOpen <$> f fs hs
    HandleClosed ClosedHandle{..} ->
      throwError
        FsError
          { fsErrorType = FsIllegalOperation
          , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath
          , fsErrorString = "handle closed"
          , fsErrorNo = Nothing
          , fsErrorStack = prettyCallStack
          , fsLimitation = False
          }

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

dumpState :: CanSimFS m => m String
dumpState = pretty <$> get

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

checkFsTree' ::
  (MonadError FsError m, HasCallStack) =>
  Either FsTreeError a -> m (Either FsPath a)
checkFsTree' = go
 where
  go (Left (FsExpectedDir fp _)) =
    throwError
      FsError
        { fsErrorType = FsResourceInappropriateType
        , fsErrorPath = fsToFsErrorPathUnmounted fp
        , fsErrorString = "expected directory"
        , fsErrorNo = Nothing
        , fsErrorStack = prettyCallStack
        , fsLimitation = False
        }
  go (Left (FsExpectedFile fp)) =
    throwError
      FsError
        { fsErrorType = FsResourceInappropriateType
        , fsErrorPath = fsToFsErrorPathUnmounted fp
        , fsErrorString = "expected file"
        , fsErrorNo = Nothing
        , fsErrorStack = prettyCallStack
        , fsLimitation = False
        }
  go (Left (FsMissing fp _)) =
    return (Left fp)
  go (Left (FsExists fp)) =
    throwError
      FsError
        { fsErrorType = FsResourceAlreadyExist
        , fsErrorPath = fsToFsErrorPathUnmounted fp
        , fsErrorString = "file exists"
        , fsErrorNo = Nothing
        , fsErrorStack = prettyCallStack
        , fsLimitation = False
        }
  go (Right a) =
    return (Right a)

checkFsTree ::
  (MonadError FsError m, HasCallStack) =>
  Either FsTreeError a -> m a
checkFsTree ma = do
  ma' <- checkFsTree' ma
  case ma' of
    Left fp ->
      throwError
        FsError
          { fsErrorType = FsResourceDoesNotExist
          , fsErrorPath = fsToFsErrorPathUnmounted fp
          , fsErrorString = "does not exist"
          , fsErrorNo = Nothing
          , fsErrorStack = prettyCallStack
          , fsLimitation = False
          }
    Right a -> return a

checkDoesNotExist ::
  (MonadError FsError m, HasCallStack) =>
  MockFS -> FsPath -> m ()
checkDoesNotExist fs fp = do
  exists <- fmap pathExists $ checkFsTree' $ FS.index fp (mockFiles fs)
  if exists
    then
      throwError
        FsError
          { fsErrorType = FsResourceAlreadyExist
          , fsErrorPath = fsToFsErrorPathUnmounted fp
          , fsErrorString = "already exists"
          , fsErrorNo = Nothing
          , fsErrorStack = prettyCallStack
          , fsLimitation = False
          }
    else return ()
 where
  pathExists :: Either a b -> Bool
  pathExists (Left _) = False
  pathExists (Right _) = True

newHandle :: MockFS -> OpenHandleState -> (Handle', MockFS)
newHandle fs hs =
  ( Handle (mockNextHandle fs) (openFilePath hs)
  , 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 fp openMode = do
  dirExists <- doesDirectoryExist fp
  when dirExists $
    throwError
      FsError
        { fsErrorType = FsResourceInappropriateType
        , fsErrorPath = fsToFsErrorPathUnmounted fp
        , fsErrorString = "hOpen: directories not supported"
        , fsErrorNo = Nothing
        , fsErrorStack = prettyCallStack
        , fsLimitation = True
        }
  modifyMockFS $ \fs -> do
    let alreadyHasWriter =
          any (\hs -> openFilePath hs == fp && isWriteHandle hs) $
            openHandles fs
    when (openMode /= ReadMode && alreadyHasWriter) $
      throwError
        FsError
          { fsErrorType = FsInvalidArgument
          , fsErrorPath = fsToFsErrorPathUnmounted fp
          , fsErrorString = "more than one concurrent writer not supported"
          , fsErrorNo = Nothing
          , fsErrorStack = prettyCallStack
          , fsLimitation = True
          }
    files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs)
    return $
      newHandle
        (fs{mockFiles = files'})
        (OpenHandle fp (filePtr openMode))
 where
  ex :: AllowExisting
  ex = allowExisting openMode

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

-- | Mock implementation of 'hClose'
hClose :: CanSimFS m => Handle' -> m ()
hClose h = withHandleRead h $ \_fs -> \case
  HandleOpen hs ->
    return ((), HandleClosed (ClosedHandle (openFilePath hs)))
  HandleClosed hs ->
    return ((), HandleClosed hs)

-- | Mock implementation of 'hIsOpen'
hIsOpen :: CanSimFS m => Handle' -> m Bool
hIsOpen h = gets (`handleIsOpen` handleRaw 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 h seekMode o = withOpenHandleRead h $ \fs hs -> do
  openPtr' <- seekFilePtr fs h seekMode o
  return ((), 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 h n =
  withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do
    file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)
    case openPtr of
      RW r w o -> do
        unless r $ throwError (errNoReadAccess openFilePath "write")
        let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file
        return (bs, hs{openPtr = RW True w (o + fromIntegral (BS.length bs))})
      Append -> throwError (errNoReadAccess openFilePath "append")
 where
  errNoReadAccess fp mode =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "cannot hGetSome in " <> mode <> " mode"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

-- | Thread safe version of 'hGetSome', which doesn't modify or read the file
-- offset.
hGetSomeAt ::
  CanSimFS m =>
  Handle' ->
  Word64 ->
  AbsOffset ->
  m ByteString
hGetSomeAt h n o =
  withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do
    file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)
    let o' = unAbsOffset o
    let fsize = fromIntegral (BS.length file) :: Word64
    case openPtr of
      RW r _ _ -> do
        unless r $ throwError (errNoReadAccess openFilePath "write")
        let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file
        -- This is the same fsLimitation we get when we seek past the end of
        -- EOF, in AbsoluteSeek mode.
        when (o' > fsize) $ throwError (errPastEnd openFilePath)
        return (bs, hs)
      Append -> throwError (errNoReadAccess openFilePath "append")
 where
  errNoReadAccess fp mode =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "cannot hGetSomeAt in " <> mode <> " mode"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

  errPastEnd fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "hGetSomeAt offset past EOF not supported"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

hPutSome :: CanSimFS m => Handle' -> ByteString -> m Word64
hPutSome h toWrite =
  withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do
    case openPtr of
      RW r w o -> do
        unless w $ throwError (errReadOnly openFilePath)
        file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)
        let file' = replace o toWrite file
        files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)
        return (written, (files', hs{openPtr = RW r w (o + written)}))
      Append -> do
        file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)
        let file' = file <> toWrite
        files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)
        return (written, (files', hs))
 where
  written = toEnum $ BS.length toWrite

  errReadOnly fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "handle is read-only"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = 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 h sz =
  withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do
    file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)
    ptr' <- case (sz > fromIntegral (BS.length file), openPtr) of
      (True, _) ->
        throwError
          FsError
            { fsErrorType = FsInvalidArgument
            , fsErrorPath = fsToFsErrorPathUnmounted openFilePath
            , fsErrorString = "truncate cannot make the file larger"
            , fsErrorNo = Nothing
            , fsErrorStack = prettyCallStack
            , fsLimitation = True
            }
      (False, RW{}) ->
        throwError
          FsError
            { fsErrorType = FsInvalidArgument
            , fsErrorPath = fsToFsErrorPathUnmounted openFilePath
            , fsErrorString = "truncate only supported in append mode"
            , fsErrorNo = Nothing
            , fsErrorStack = prettyCallStack
            , fsLimitation = True
            }
      (False, Append) ->
        return Append
    let file' = BS.take (fromIntegral sz) file
    files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)
    -- TODO: Don't replace the file pointer (not changed)
    return ((), (files', 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 h =
  withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do
    file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)
    return (fromIntegral (BS.length file), hs)

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

createDirectory :: CanSimFS m => FsPath -> m ()
createDirectory dir = modifyMockFS $ \fs -> do
  checkDoesNotExist fs dir
  files' <- checkFsTree $ FS.createDirIfMissing dir (mockFiles fs)
  return ((), fs{mockFiles = files'})

createDirectoryIfMissing ::
  CanSimFS m =>
  Bool -> FsPath -> m ()
createDirectoryIfMissing createParents 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
  fileExists <- doesFileExist dir
  if fileExists
    then
      throwError
        FsError
          { fsErrorType = FsResourceAlreadyExist
          , fsErrorPath = fsToFsErrorPathUnmounted dir
          , fsErrorString = "a file with that name already exists"
          , fsErrorNo = Nothing
          , fsErrorStack = prettyCallStack
          , fsLimitation = False
          }
    else modifyMockFS $ \fs -> do
      files' <- checkFsTree $ go createParents (mockFiles fs)
      return ((), fs{mockFiles = files'})
 where
  go :: Bool -> Files -> Either FsTreeError Files
  go True = FS.createDirWithParents dir
  go False = FS.createDirIfMissing dir

listDirectory ::
  CanSimFS m =>
  FsPath -> m (Set String)
listDirectory fp =
  readMockFS $
    fmap (S.fromList . map Text.unpack . M.keys)
      . checkFsTree
      . FS.getDir 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 fp = readMockFS $ \fs ->
  return $ case FS.getDir fp fs of
    Left _ -> False
    Right _ -> True

-- | Check if file exists
--
-- See comments for 'doesDirectoryExist'.
doesFileExist :: CanSimFS m => FsPath -> m Bool
doesFileExist fp = readMockFS $ \fs ->
  return $ case FS.getFile fp fs of
    Left _ -> False
    Right _ -> True

-- | Remove a directory and its contents
--
-- Same limitations as 'removeFile'.
removeDirectoryRecursive :: CanSimFS m => FsPath -> m ()
removeDirectoryRecursive fp = do
  modifyMockFS $ \fs -> do
    reachablePaths <- fmap S.fromList $ checkFsTree $ FS.find fp (mockFiles fs)
    let openReachablePaths = reachablePaths `S.intersection` openFilePaths fs
    case fsPathToList fp of
      [] ->
        throwError
          FsError
            { fsErrorType = FsIllegalOperation
            , fsErrorPath = fsToFsErrorPathUnmounted fp
            , fsErrorString = "cannot remove the root directory"
            , fsErrorNo = Nothing
            , fsErrorStack = prettyCallStack
            , fsLimitation = True
            }
      _
        | openReachablePaths /= mempty ->
            throwError
              FsError
                { fsErrorType = FsIllegalOperation
                , fsErrorPath = fsToFsErrorPathUnmounted fp
                , fsErrorString =
                    "cannot remove an open file. "
                      ++ "The following files are reachable from "
                      ++ show fp
                      ++ "and are still open: "
                      ++ show openReachablePaths
                , fsErrorNo = Nothing
                , fsErrorStack = prettyCallStack
                , fsLimitation = True
                }
      _ -> do
        files' <- checkFsTree $ FS.removeDirRecursive fp (mockFiles fs)
        return ((), 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 fp =
  modifyMockFS $ \fs -> case fsPathToList fp of
    [] ->
      throwError
        FsError
          { fsErrorType = FsIllegalOperation
          , fsErrorPath = fsToFsErrorPathUnmounted fp
          , fsErrorString = "cannot remove the root directory"
          , fsErrorNo = Nothing
          , fsErrorStack = prettyCallStack
          , fsLimitation = True
          }
    _
      | fp `S.member` openFilePaths fs ->
          throwError
            FsError
              { fsErrorType = FsIllegalOperation
              , fsErrorPath = fsToFsErrorPathUnmounted fp
              , fsErrorString = "cannot remove an open file"
              , fsErrorNo = Nothing
              , fsErrorStack = prettyCallStack
              , fsLimitation = True
              }
    _ -> do
      files' <- checkFsTree $ FS.removeFile fp (mockFiles fs)
      return ((), fs{mockFiles = files'})

renameFile :: CanSimFS m => FsPath -> FsPath -> m ()
renameFile fpOld fpNew =
  modifyMockFS $ \fs ->
    if
      | not (sameDir fpOld fpNew) ->
          throwError $ errDifferentDir fpOld
      | fpOld `S.member` openFilePaths fs ->
          throwError $ errRenameOpenFile fpOld
      | fpNew `S.member` openFilePaths fs ->
          throwError $ errRenameOpenFile fpNew
      | Right _ <- FS.getDir fpNew (mockFiles fs) ->
          throwError $ errRenameDir fpNew
      | otherwise -> do
          files' <- checkFsTree $ FS.renameFile fpOld fpNew (mockFiles fs)
          return ((), fs{mockFiles = files'})
 where
  sameDir fp1 fp2 =
    (fst <$> fsPathSplit fp1) == (fst <$> fsPathSplit fp2)

  errRenameOpenFile fp =
    FsError
      { fsErrorType = FsIllegalOperation
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "cannot rename opened file"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

  errRenameDir fp =
    FsError
      { fsErrorType = FsResourceInappropriateType
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "is a directory"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

  errDifferentDir fp =
    FsError
      { fsErrorType = FsIllegalOperation
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "files must be in the same directory"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = 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 = FS.pretty renderFile . mockFiles
 where
  renderFile :: ByteString -> String
  renderFile = show . hexDump . B16.encode

  hexDump :: ByteString -> ByteString
  hexDump =
    fst
      . BS.foldl'
        ( \(acc, n) w8 ->
            if n == 2
              then (acc <> " " <> BS.singleton w8, 1)
              else (acc <> BS.singleton w8, n + 1)
        )
        (mempty, 0 :: Int)

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

data Sign a = Negative a | Positive a
  deriving Functor

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

sign64 :: Int64 -> Sign Word64
sign64 = fmap fromIntegral . sign

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

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

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

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

packMutableByteArray ::
  PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> [Word8] -> m ()
packMutableByteArray mba i bytes = forM_ (zip [unBufferOffset i ..] bytes) $ uncurry (P.writeByteArray mba)

intoBuffer ::
  PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteString -> m Bool
intoBuffer buf bufOff bs = do
  bufSize <- P.getSizeofMutableByteArray buf
  let remaining = bufSize - unBufferOffset bufOff
  if BS.length bs > remaining
    then pure False
    else
      packMutableByteArray buf bufOff (BS.unpack bs)
        >> pure True

unpackMutableByteArray ::
  PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m [Word8]
unpackMutableByteArray mba i c = forM [unBufferOffset i .. unBufferOffset i + fromIntegral c - 1] $ P.readByteArray mba

fromBuffer ::
  PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m (Maybe ByteString)
fromBuffer buf bufOff c = do
  bufSize <- P.getSizeofMutableByteArray buf
  let remaining = bufSize - unBufferOffset bufOff
  if fromIntegral c > remaining
    then pure Nothing
    else Just . BS.pack <$> unpackMutableByteArray buf bufOff c

hGetBufSome ::
  (CanSimFS m, PrimMonad m) =>
  Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount
hGetBufSome h buf bufOff n =
  withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do
    file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)
    case openPtr of
      RW r w o -> do
        unless r $ throwError (errNoReadAccess openFilePath "write")
        let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file
        success <- intoBuffer buf bufOff bs
        -- we can't read more bytes than the buffer size
        unless success $ throwError (errWritePastBufEnd openFilePath)
        let readBytes = fromIntegral (BS.length bs)
        return (readBytes, hs{openPtr = RW True w (o + fromIntegral readBytes)})
      Append -> throwError (errNoReadAccess openFilePath "append")
 where
  errNoReadAccess fp mode =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "cannot hGetBufSomeAt in " <> mode <> " mode"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

  errWritePastBufEnd fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "hPutBufSomeAt: writing into buffer past end not supported"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

hGetBufSomeAt ::
  (CanSimFS m, PrimMonad m) =>
  Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount
hGetBufSomeAt h buf bufOff n o =
  withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do
    file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)
    let o' = unAbsOffset o
    let fsize = fromIntegral (BS.length file) :: Word64
    case openPtr of
      RW r _ _ -> do
        unless r $ throwError (errNoReadAccess openFilePath "write")
        -- This is the same fsLimitation we get when we seek past the end of
        -- EOF, in AbsoluteSeek mode.
        when (o' > fsize) $ throwError (errPastEnd openFilePath)
        let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file
        success <- intoBuffer buf bufOff bs
        -- we can't read more bytes than the buffer size
        unless success $ throwError (errWritePastBufEnd openFilePath)
        return (fromIntegral (BS.length bs), hs)
      Append -> throwError (errNoReadAccess openFilePath "append")
 where
  errNoReadAccess fp mode =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "cannot hGetBufSomeAt in " <> mode <> " mode"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

  errPastEnd fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "hGetBufSomeAt offset past EOF not supported"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

  errWritePastBufEnd fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "hPutBufSomeAt: writing into buffer past end not supported"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

hPutBufSome ::
  (CanSimFS m, PrimMonad m) =>
  Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount
hPutBufSome h buf bufOff n = do
  withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do
    file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)
    case openPtr of
      RW r w o -> do
        unless w $ throwError (errNoWriteAccess openFilePath "read")
        -- We can't write more bytes than the buffer size
        toWrite <-
          fromBuffer buf bufOff n >>= \case
            Nothing -> throwError (errReadPastBufEnd openFilePath)
            Just bs -> pure bs
        let file' = replace o toWrite file
        files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)
        let written = fromIntegral $ BS.length toWrite
        return (written, (files', hs{openPtr = RW r w (o + fromIntegral written)}))
      Append -> do
        -- We can't write more bytes than the buffer size
        toWrite <-
          fromBuffer buf bufOff n >>= \case
            Nothing -> throwError (errReadPastBufEnd openFilePath)
            Just bs -> pure bs
        let file' = file <> toWrite
        files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)
        let written = fromIntegral $ BS.length toWrite
        return (written, (files', hs))
 where
  errNoWriteAccess fp mode =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "cannot hPutBufSomeAt in " <> mode <> " mode"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

  errReadPastBufEnd fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "hPutBufSomeAt: reading from buffer past end not supported"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

hPutBufSomeAt ::
  (CanSimFS m, PrimMonad m) =>
  Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount
hPutBufSomeAt h buf bufOff n o = do
  withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do
    file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)
    let o' = unAbsOffset o
    let fsize = fromIntegral (BS.length file)
    case openPtr of
      RW _ w _ -> do
        unless w $ throwError (errNoWriteAccess openFilePath "read")
        -- This is the same fsLimitation we get when we seek past the end of
        -- EOF, in AbsoluteSeek mode.
        when (o' > fsize) $ throwError (errPastEnd openFilePath)
        -- We can't write more bytes than the buffer size
        toWrite <-
          fromBuffer buf bufOff n >>= \case
            Nothing -> throwError (errReadPastBufEnd openFilePath)
            Just bs -> pure bs
        let file' = replace o' toWrite file
        files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)
        let written = fromIntegral $ BS.length toWrite
        return (written, (files', hs))
      Append -> throwError (errNoWriteAccess openFilePath "append")
 where
  errNoWriteAccess fp mode =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "cannot hPutBufSomeAt in " <> mode <> " mode"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

  errPastEnd fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "hPutBufSomeAt offset past EOF not supported"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }

  errReadPastBufEnd fp =
    FsError
      { fsErrorType = FsInvalidArgument
      , fsErrorPath = fsToFsErrorPathUnmounted fp
      , fsErrorString = "hPutBufSomeAt: reading from buffer past end not supported"
      , fsErrorNo = Nothing
      , fsErrorStack = prettyCallStack
      , fsLimitation = True
      }