{-# 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.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 {
      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
      }