{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}

-- For Show Errno and Condense SeekMode instances
{-# OPTIONS_GHC -Wno-orphans #-}
module System.FS.API.Types (
    -- * Modes
    AllowExisting (..)
  , OpenMode (..)
  , SeekMode (..)
  , allowExisting
    -- * Paths
  , MountPoint (..)
  , fsFromFilePath
  , fsPathFromList
  , fsPathInit
  , fsPathSplit
  , fsPathToList
  , fsToFilePath
  , mkFsPath
  , (<.>)
  , addExtension
  , (</>)
  , combine
    -- ** opaque
  , FsPath
    -- * Handles
  , Handle (..)
    -- * Offset
  , AbsOffset (..)
    -- * Errors
  , FsError (..)
  , FsErrorPath (..)
  , FsErrorType (..)
  , fsToFsErrorPath
  , fsToFsErrorPathUnmounted
  , hasMountPoint
  , isFsErrorType
  , prettyFsError
  , sameFsError
    -- * From 'IOError' to 'FsError'
  , ioToFsError
  , ioToFsErrorType
  ) where

import           Control.DeepSeq (NFData (..), force)
import           Control.Exception
import           Data.Function (on)
import           Data.List (intercalate, stripPrefix)
import           Data.Maybe (isJust)
import qualified Data.Text as Strict
import qualified Data.Text as Text
import           Data.Word
import           Foreign.C.Error (Errno (..))
import qualified Foreign.C.Error as C
import           GHC.Generics (Generic)
import qualified GHC.IO.Exception as GHC
import           GHC.Show (showCommaSpace)
import qualified System.FilePath as FilePath
import           System.IO (SeekMode (..))
import qualified System.IO.Error as IO

import           System.FS.CallStack
import           System.FS.Condense

{-------------------------------------------------------------------------------
  Modes
-------------------------------------------------------------------------------}

-- | How to 'System.FS.API.hOpen' a new file.
data OpenMode
  = ReadMode
  | WriteMode     AllowExisting
  | AppendMode    AllowExisting
  | ReadWriteMode AllowExisting
  deriving (OpenMode -> OpenMode -> Bool
(OpenMode -> OpenMode -> Bool)
-> (OpenMode -> OpenMode -> Bool) -> Eq OpenMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpenMode -> OpenMode -> Bool
== :: OpenMode -> OpenMode -> Bool
$c/= :: OpenMode -> OpenMode -> Bool
/= :: OpenMode -> OpenMode -> Bool
Eq, Int -> OpenMode -> ShowS
[OpenMode] -> ShowS
OpenMode -> String
(Int -> OpenMode -> ShowS)
-> (OpenMode -> String) -> ([OpenMode] -> ShowS) -> Show OpenMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenMode -> ShowS
showsPrec :: Int -> OpenMode -> ShowS
$cshow :: OpenMode -> String
show :: OpenMode -> String
$cshowList :: [OpenMode] -> ShowS
showList :: [OpenMode] -> ShowS
Show)

-- | When opening a file:
data AllowExisting
  = AllowExisting
    -- ^ The file may already exist. If it does, it is reopened. If it
    -- doesn't, it is created.
  | MustBeNew
    -- ^ The file may not yet exist. If it does, an error
    -- ('FsResourceAlreadyExist') is thrown.
  deriving (AllowExisting -> AllowExisting -> Bool
(AllowExisting -> AllowExisting -> Bool)
-> (AllowExisting -> AllowExisting -> Bool) -> Eq AllowExisting
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AllowExisting -> AllowExisting -> Bool
== :: AllowExisting -> AllowExisting -> Bool
$c/= :: AllowExisting -> AllowExisting -> Bool
/= :: AllowExisting -> AllowExisting -> Bool
Eq, Int -> AllowExisting -> ShowS
[AllowExisting] -> ShowS
AllowExisting -> String
(Int -> AllowExisting -> ShowS)
-> (AllowExisting -> String)
-> ([AllowExisting] -> ShowS)
-> Show AllowExisting
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AllowExisting -> ShowS
showsPrec :: Int -> AllowExisting -> ShowS
$cshow :: AllowExisting -> String
show :: AllowExisting -> String
$cshowList :: [AllowExisting] -> ShowS
showList :: [AllowExisting] -> ShowS
Show)

allowExisting :: OpenMode -> AllowExisting
allowExisting :: OpenMode -> AllowExisting
allowExisting OpenMode
openMode = case OpenMode
openMode of
  OpenMode
ReadMode         -> AllowExisting
AllowExisting
  WriteMode     AllowExisting
ex -> AllowExisting
ex
  AppendMode    AllowExisting
ex -> AllowExisting
ex
  ReadWriteMode AllowExisting
ex -> AllowExisting
ex

{-------------------------------------------------------------------------------
  Paths
-------------------------------------------------------------------------------}

-- | A relative path.
--
-- === Invariant
--
-- The user of this library is tasked with picking sensible names of
-- directories/files on a path. Amongst others, the following should hold:
--
-- * Names are non-empty
--
-- * Names are monotonic, i.e., they are not equal to @..@
--
-- * Names should not contain path separators or drive letters
--
-- In particular, names that satisfy these invariants should result in an
-- 'FsPath' that remains relative to the HasFS instance root. For example, an
-- @'FsPath' ["/"]@ would try to access the root folder, which is most likely
-- outside of the scope of the HasFS instance.
--
-- \"@..@\" should not be used because @fs-sim@ will not be able to follow these
-- types of back-links. @fs-sim@ will interpret \"@..@\" as a directory name
-- instead.
newtype FsPath = UnsafeFsPath { FsPath -> [Text]
fsPathToList :: [Strict.Text] }
  deriving (FsPath -> FsPath -> Bool
(FsPath -> FsPath -> Bool)
-> (FsPath -> FsPath -> Bool) -> Eq FsPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FsPath -> FsPath -> Bool
== :: FsPath -> FsPath -> Bool
$c/= :: FsPath -> FsPath -> Bool
/= :: FsPath -> FsPath -> Bool
Eq, Eq FsPath
Eq FsPath =>
(FsPath -> FsPath -> Ordering)
-> (FsPath -> FsPath -> Bool)
-> (FsPath -> FsPath -> Bool)
-> (FsPath -> FsPath -> Bool)
-> (FsPath -> FsPath -> Bool)
-> (FsPath -> FsPath -> FsPath)
-> (FsPath -> FsPath -> FsPath)
-> Ord FsPath
FsPath -> FsPath -> Bool
FsPath -> FsPath -> Ordering
FsPath -> FsPath -> FsPath
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 :: FsPath -> FsPath -> Ordering
compare :: FsPath -> FsPath -> Ordering
$c< :: FsPath -> FsPath -> Bool
< :: FsPath -> FsPath -> Bool
$c<= :: FsPath -> FsPath -> Bool
<= :: FsPath -> FsPath -> Bool
$c> :: FsPath -> FsPath -> Bool
> :: FsPath -> FsPath -> Bool
$c>= :: FsPath -> FsPath -> Bool
>= :: FsPath -> FsPath -> Bool
$cmax :: FsPath -> FsPath -> FsPath
max :: FsPath -> FsPath -> FsPath
$cmin :: FsPath -> FsPath -> FsPath
min :: FsPath -> FsPath -> FsPath
Ord, (forall x. FsPath -> Rep FsPath x)
-> (forall x. Rep FsPath x -> FsPath) -> Generic FsPath
forall x. Rep FsPath x -> FsPath
forall x. FsPath -> Rep FsPath x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FsPath -> Rep FsPath x
from :: forall x. FsPath -> Rep FsPath x
$cto :: forall x. Rep FsPath x -> FsPath
to :: forall x. Rep FsPath x -> FsPath
Generic)
  deriving newtype FsPath -> ()
(FsPath -> ()) -> NFData FsPath
forall a. (a -> ()) -> NFData a
$crnf :: FsPath -> ()
rnf :: FsPath -> ()
NFData

-- | Create a path from a list of directory/file names. All of the names should
-- be non-empty.
fsPathFromList :: [Strict.Text] -> FsPath
fsPathFromList :: [Text] -> FsPath
fsPathFromList [Text]
xs = [Text] -> FsPath
UnsafeFsPath ([Text] -> [Text]
forall a. NFData a => a -> a
force [Text]
xs)

instance Show FsPath where
  show :: FsPath -> String
show = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String] -> String) -> (FsPath -> [String]) -> FsPath -> 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
Strict.unpack ([Text] -> [String]) -> (FsPath -> [Text]) -> FsPath -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsPath -> [Text]
fsPathToList

instance Condense FsPath where
  condense :: FsPath -> String
condense = FsPath -> String
forall a. Show a => a -> String
show

-- | Constructor for 'FsPath' ensures path is in normal form
mkFsPath :: [String] -> FsPath
mkFsPath :: [String] -> FsPath
mkFsPath = [Text] -> FsPath
fsPathFromList ([Text] -> FsPath) -> ([String] -> [Text]) -> [String] -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Strict.pack

-- | Split 'FsPath' is essentially @(init fp, last fp)@
--
-- Like @init@ and @last@, 'Nothing' if empty.
fsPathSplit :: FsPath -> Maybe (FsPath, Strict.Text)
fsPathSplit :: FsPath -> Maybe (FsPath, Text)
fsPathSplit FsPath
fp =
    case [Text] -> [Text]
forall a. [a] -> [a]
reverse (FsPath -> [Text]
fsPathToList FsPath
fp) of
      []   -> Maybe (FsPath, Text)
forall a. Maybe a
Nothing
      Text
p:[Text]
ps -> (FsPath, Text) -> Maybe (FsPath, Text)
forall a. a -> Maybe a
Just ([Text] -> FsPath
fsPathFromList ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
ps), Text
p)

-- | Drop the final component of the path
--
-- Undefined if the path is empty.
fsPathInit :: HasCallStack => FsPath -> FsPath
fsPathInit :: HasCallStack => FsPath -> FsPath
fsPathInit FsPath
fp = case FsPath -> Maybe (FsPath, Text)
fsPathSplit FsPath
fp of
                  Maybe (FsPath, Text)
Nothing       -> String -> FsPath
forall a. HasCallStack => String -> a
error (String -> FsPath) -> String -> FsPath
forall a b. (a -> b) -> a -> b
$ String
"fsPathInit: empty path"
                  Just (FsPath
fp', Text
_) -> FsPath
fp'

-- | An alias for '<.>'.
addExtension :: FsPath -> String -> FsPath
addExtension :: FsPath -> String -> FsPath
addExtension = FsPath -> String -> FsPath
(<.>)

infixr 7 <.>
-- | Add an extension, even if there is already one there.
--
-- This works similarly to 'Filepath.<.>'.
(<.>) :: FsPath -> String -> FsPath
FsPath
path <.> :: FsPath -> String -> FsPath
<.> [] = FsPath
path
FsPath
path <.> String
ext = case FsPath -> Maybe (FsPath, Text)
fsPathSplit FsPath
path of
    Maybe (FsPath, Text)
Nothing          -> [String] -> FsPath
mkFsPath [String
ext']
    Just (FsPath
dir, Text
file) -> FsPath
dir FsPath -> FsPath -> FsPath
</> [Text] -> FsPath
UnsafeFsPath [Text
file Text -> Text -> Text
`Text.append` String -> Text
Text.pack String
ext']
  where
    ext' :: String
ext' = case String
ext of
      Char
'.':String
_ -> String
ext
      String
_     -> Char
'.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
ext

-- | An alias for '</>'.
combine :: FsPath -> FsPath -> FsPath
combine :: FsPath -> FsPath -> FsPath
combine = FsPath -> FsPath -> FsPath
(</>)

infixr 5 </>
-- | Combine two paths with a path separator.
--
-- This works similarly to 'Filepath.</>', but since the arguments are
-- relative paths, the corner cases for 'FilePath.</>' do not apply.
-- Specifically, the second path will never start with a path separator or a
-- drive letter, so the result is simply the concatenation of the two paths.
--
-- If either operand is empty, the other operand is returned. The result of
-- combining two empty paths is the empty path
(</>) :: FsPath -> FsPath -> FsPath
UnsafeFsPath [Text]
x </> :: FsPath -> FsPath -> FsPath
</> UnsafeFsPath [Text]
y = case ([Text]
x, [Text]
y) of
    ([], [Text]
_) -> [Text] -> FsPath
UnsafeFsPath [Text]
y
    ([Text]
_, []) -> [Text] -> FsPath
UnsafeFsPath [Text]
x
    ([Text], [Text])
_       -> [Text] -> FsPath
fsPathFromList ([Text]
x [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
y)

-- | Mount point
--
-- 'FsPath's are not absolute paths, but must be interpreted with respect to
-- a particualar mount point.
newtype MountPoint = MountPoint FilePath

fsToFilePath :: MountPoint -> FsPath -> FilePath
fsToFilePath :: MountPoint -> FsPath -> String
fsToFilePath (MountPoint String
mp) FsPath
fp =
    String
mp String -> ShowS
FilePath.</> (String -> ShowS) -> String -> [String] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> ShowS
(FilePath.</>) String
"" ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Strict.unpack ([Text] -> [String]) -> [Text] -> [String]
forall a b. (a -> b) -> a -> b
$ FsPath -> [Text]
fsPathToList FsPath
fp)

fsFromFilePath :: MountPoint -> FilePath -> Maybe FsPath
fsFromFilePath :: MountPoint -> String -> Maybe FsPath
fsFromFilePath (MountPoint String
mp) String
path = [String] -> FsPath
mkFsPath ([String] -> FsPath) -> Maybe [String] -> Maybe FsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [String] -> [String] -> Maybe [String]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (String -> [String]
FilePath.splitDirectories String
mp) (String -> [String]
FilePath.splitDirectories String
path)

-- | For better error reporting to the end user, we want to include the
-- mount point of the file. But the mountpoint may not always be available,
-- like when we mock the fs or we simulate fs errors.
data FsErrorPath = FsErrorPath (Maybe MountPoint) FsPath

fsToFsErrorPath :: MountPoint -> FsPath -> FsErrorPath
fsToFsErrorPath :: MountPoint -> FsPath -> FsErrorPath
fsToFsErrorPath MountPoint
mp = Maybe MountPoint -> FsPath -> FsErrorPath
FsErrorPath (MountPoint -> Maybe MountPoint
forall a. a -> Maybe a
Just MountPoint
mp)

-- | Like 'fsToFsErrorPath', but when we don't have a 'MountPoint'
fsToFsErrorPathUnmounted :: FsPath -> FsErrorPath
fsToFsErrorPathUnmounted :: FsPath -> FsErrorPath
fsToFsErrorPathUnmounted = Maybe MountPoint -> FsPath -> FsErrorPath
FsErrorPath Maybe MountPoint
forall a. Maybe a
Nothing

instance Show FsErrorPath where
  show :: FsErrorPath -> String
show (FsErrorPath (Just MountPoint
mp) FsPath
fp) = MountPoint -> FsPath -> String
fsToFilePath MountPoint
mp FsPath
fp
  show (FsErrorPath Maybe MountPoint
Nothing   FsPath
fp) = FsPath -> String
forall a. Show a => a -> String
show FsPath
fp

instance Condense FsErrorPath where
  condense :: FsErrorPath -> String
condense = FsErrorPath -> String
forall a. Show a => a -> String
show

-- | We only care to compare the 'FsPath', because the 'MountPoint' may not
-- exist.
instance Eq FsErrorPath where
  (FsErrorPath Maybe MountPoint
_ FsPath
fp1) == :: FsErrorPath -> FsErrorPath -> Bool
== (FsErrorPath Maybe MountPoint
_ FsPath
fp2) = FsPath
fp1 FsPath -> FsPath -> Bool
forall a. Eq a => a -> a -> Bool
== FsPath
fp2

{-------------------------------------------------------------------------------
  Handles
-------------------------------------------------------------------------------}

data Handle h = Handle {
      -- | The raw underlying handle
      forall h. Handle h -> h
handleRaw  :: !h

      -- | The path corresponding to this handle
      --
      -- This is primarily useful for error reporting.
    , forall h. Handle h -> FsPath
handlePath :: !FsPath
    }
  deriving ((forall x. Handle h -> Rep (Handle h) x)
-> (forall x. Rep (Handle h) x -> Handle h) -> Generic (Handle h)
forall x. Rep (Handle h) x -> Handle h
forall x. Handle h -> Rep (Handle h) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall h x. Rep (Handle h) x -> Handle h
forall h x. Handle h -> Rep (Handle h) x
$cfrom :: forall h x. Handle h -> Rep (Handle h) x
from :: forall x. Handle h -> Rep (Handle h) x
$cto :: forall h x. Rep (Handle h) x -> Handle h
to :: forall x. Rep (Handle h) x -> Handle h
Generic)

instance NFData h => NFData (Handle h) where
    rnf :: Handle h -> ()
rnf (Handle h
handleRaw FsPath
handlePath) = h -> ()
forall a. NFData a => a -> ()
rnf h
handleRaw () -> () -> ()
forall a b. a -> b -> b
`seq` FsPath -> ()
forall a. NFData a => a -> ()
rnf FsPath
handlePath

instance Eq h => Eq (Handle h) where
  == :: Handle h -> Handle h -> Bool
(==) = h -> h -> Bool
forall a. Eq a => a -> a -> Bool
(==) (h -> h -> Bool) -> (Handle h -> h) -> Handle h -> Handle h -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Handle h -> h
forall h. Handle h -> h
handleRaw

instance Show (Handle h) where
  show :: Handle h -> String
show (Handle h
_ FsPath
fp) = String
"<Handle " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MountPoint -> FsPath -> String
fsToFilePath (String -> MountPoint
MountPoint String
"<root>") FsPath
fp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"


{-------------------------------------------------------------------------------
  Offset wrappers
-------------------------------------------------------------------------------}

newtype AbsOffset = AbsOffset { AbsOffset -> Word64
unAbsOffset :: Word64 }
  deriving (AbsOffset -> AbsOffset -> Bool
(AbsOffset -> AbsOffset -> Bool)
-> (AbsOffset -> AbsOffset -> Bool) -> Eq AbsOffset
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AbsOffset -> AbsOffset -> Bool
== :: AbsOffset -> AbsOffset -> Bool
$c/= :: AbsOffset -> AbsOffset -> Bool
/= :: AbsOffset -> AbsOffset -> Bool
Eq, Eq AbsOffset
Eq AbsOffset =>
(AbsOffset -> AbsOffset -> Ordering)
-> (AbsOffset -> AbsOffset -> Bool)
-> (AbsOffset -> AbsOffset -> Bool)
-> (AbsOffset -> AbsOffset -> Bool)
-> (AbsOffset -> AbsOffset -> Bool)
-> (AbsOffset -> AbsOffset -> AbsOffset)
-> (AbsOffset -> AbsOffset -> AbsOffset)
-> Ord AbsOffset
AbsOffset -> AbsOffset -> Bool
AbsOffset -> AbsOffset -> Ordering
AbsOffset -> AbsOffset -> AbsOffset
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 :: AbsOffset -> AbsOffset -> Ordering
compare :: AbsOffset -> AbsOffset -> Ordering
$c< :: AbsOffset -> AbsOffset -> Bool
< :: AbsOffset -> AbsOffset -> Bool
$c<= :: AbsOffset -> AbsOffset -> Bool
<= :: AbsOffset -> AbsOffset -> Bool
$c> :: AbsOffset -> AbsOffset -> Bool
> :: AbsOffset -> AbsOffset -> Bool
$c>= :: AbsOffset -> AbsOffset -> Bool
>= :: AbsOffset -> AbsOffset -> Bool
$cmax :: AbsOffset -> AbsOffset -> AbsOffset
max :: AbsOffset -> AbsOffset -> AbsOffset
$cmin :: AbsOffset -> AbsOffset -> AbsOffset
min :: AbsOffset -> AbsOffset -> AbsOffset
Ord, Int -> AbsOffset
AbsOffset -> Int
AbsOffset -> [AbsOffset]
AbsOffset -> AbsOffset
AbsOffset -> AbsOffset -> [AbsOffset]
AbsOffset -> AbsOffset -> AbsOffset -> [AbsOffset]
(AbsOffset -> AbsOffset)
-> (AbsOffset -> AbsOffset)
-> (Int -> AbsOffset)
-> (AbsOffset -> Int)
-> (AbsOffset -> [AbsOffset])
-> (AbsOffset -> AbsOffset -> [AbsOffset])
-> (AbsOffset -> AbsOffset -> [AbsOffset])
-> (AbsOffset -> AbsOffset -> AbsOffset -> [AbsOffset])
-> Enum AbsOffset
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 :: AbsOffset -> AbsOffset
succ :: AbsOffset -> AbsOffset
$cpred :: AbsOffset -> AbsOffset
pred :: AbsOffset -> AbsOffset
$ctoEnum :: Int -> AbsOffset
toEnum :: Int -> AbsOffset
$cfromEnum :: AbsOffset -> Int
fromEnum :: AbsOffset -> Int
$cenumFrom :: AbsOffset -> [AbsOffset]
enumFrom :: AbsOffset -> [AbsOffset]
$cenumFromThen :: AbsOffset -> AbsOffset -> [AbsOffset]
enumFromThen :: AbsOffset -> AbsOffset -> [AbsOffset]
$cenumFromTo :: AbsOffset -> AbsOffset -> [AbsOffset]
enumFromTo :: AbsOffset -> AbsOffset -> [AbsOffset]
$cenumFromThenTo :: AbsOffset -> AbsOffset -> AbsOffset -> [AbsOffset]
enumFromThenTo :: AbsOffset -> AbsOffset -> AbsOffset -> [AbsOffset]
Enum, AbsOffset
AbsOffset -> AbsOffset -> Bounded AbsOffset
forall a. a -> a -> Bounded a
$cminBound :: AbsOffset
minBound :: AbsOffset
$cmaxBound :: AbsOffset
maxBound :: AbsOffset
Bounded, Integer -> AbsOffset
AbsOffset -> AbsOffset
AbsOffset -> AbsOffset -> AbsOffset
(AbsOffset -> AbsOffset -> AbsOffset)
-> (AbsOffset -> AbsOffset -> AbsOffset)
-> (AbsOffset -> AbsOffset -> AbsOffset)
-> (AbsOffset -> AbsOffset)
-> (AbsOffset -> AbsOffset)
-> (AbsOffset -> AbsOffset)
-> (Integer -> AbsOffset)
-> Num AbsOffset
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: AbsOffset -> AbsOffset -> AbsOffset
+ :: AbsOffset -> AbsOffset -> AbsOffset
$c- :: AbsOffset -> AbsOffset -> AbsOffset
- :: AbsOffset -> AbsOffset -> AbsOffset
$c* :: AbsOffset -> AbsOffset -> AbsOffset
* :: AbsOffset -> AbsOffset -> AbsOffset
$cnegate :: AbsOffset -> AbsOffset
negate :: AbsOffset -> AbsOffset
$cabs :: AbsOffset -> AbsOffset
abs :: AbsOffset -> AbsOffset
$csignum :: AbsOffset -> AbsOffset
signum :: AbsOffset -> AbsOffset
$cfromInteger :: Integer -> AbsOffset
fromInteger :: Integer -> AbsOffset
Num, Int -> AbsOffset -> ShowS
[AbsOffset] -> ShowS
AbsOffset -> String
(Int -> AbsOffset -> ShowS)
-> (AbsOffset -> String)
-> ([AbsOffset] -> ShowS)
-> Show AbsOffset
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AbsOffset -> ShowS
showsPrec :: Int -> AbsOffset -> ShowS
$cshow :: AbsOffset -> String
show :: AbsOffset -> String
$cshowList :: [AbsOffset] -> ShowS
showList :: [AbsOffset] -> ShowS
Show)

{-------------------------------------------------------------------------------
  Errors
-------------------------------------------------------------------------------}

data FsError = FsError {
      -- | Error type
      FsError -> FsErrorType
fsErrorType   :: FsErrorType

      -- | Path to the file
    , FsError -> FsErrorPath
fsErrorPath   :: FsErrorPath

      -- | Human-readable string giving additional information about the error
    , FsError -> String
fsErrorString :: String

      -- | The 'Errno', if available. This is more precise than the
      -- 'FsErrorType'.
    , FsError -> Maybe Errno
fsErrorNo     :: Maybe Errno

      -- | Call stack
    , FsError -> PrettyCallStack
fsErrorStack  :: PrettyCallStack

      -- | Is this error due to a limitation of the mock file system?
      --
      -- The mock file system does not all of Posix's features and quirks.
      -- This flag will be set for such unsupported IO calls. Real I/O calls
      -- would not have thrown an error for these calls.
    , FsError -> Bool
fsLimitation  :: Bool
    }

-- This is a custom instance and not an auto-derive one, since 'Errno' does not
-- have a 'Show' instance, and we don't want to provide an orphan instance for
-- this @base@ type.
instance Show FsError where
  showsPrec :: Int -> FsError -> ShowS
showsPrec Int
n FsError
fserr = Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"FsError {"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"fsErrorType = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsErrorType -> ShowS
forall a. Show a => a -> ShowS
shows FsErrorType
fsErrorType ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showCommaSpace
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"fsErrorPath = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsErrorPath -> ShowS
forall a. Show a => a -> ShowS
shows FsErrorPath
fsErrorPath ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showCommaSpace
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"fsErrorString = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows String
fsErrorString ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showCommaSpace
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"fsErrorNo = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Errno -> ShowS
showsFsErrNo Maybe Errno
fsErrorNo ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showCommaSpace
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"fsErrorStack = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyCallStack -> ShowS
forall a. Show a => a -> ShowS
shows PrettyCallStack
fsErrorStack ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showCommaSpace
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"fsLimitation = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS
forall a. Show a => a -> ShowS
shows Bool
fsLimitation
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"}"
    where
      -- Quite a bit of boilerplate, but it should ensure that we won't silently
      -- change/forget to change the Show instance when fields are
      -- changed/re-ordered/added.
      FsError {
          fsErrorType :: FsError -> FsErrorType
fsErrorType = FsErrorType
fsErrorType :: FsErrorType
        , fsErrorPath :: FsError -> FsErrorPath
fsErrorPath = FsErrorPath
fsErrorPath :: FsErrorPath
        , fsErrorString :: FsError -> String
fsErrorString = String
fsErrorString :: String
        , fsErrorNo :: FsError -> Maybe Errno
fsErrorNo = Maybe Errno
fsErrorNo :: Maybe Errno
        , fsErrorStack :: FsError -> PrettyCallStack
fsErrorStack = PrettyCallStack
fsErrorStack :: PrettyCallStack
        , fsLimitation :: FsError -> Bool
fsLimitation = Bool
fsLimitation :: Bool
        } = FsError
fserr
      _coveredAllCases :: ()
_coveredAllCases = case FsError
fserr of
        FsError (FsErrorType
_ :: FsErrorType) (FsErrorPath
_ :: FsErrorPath) (String
_ :: String)
                (Maybe Errno
_ :: Maybe Errno) (PrettyCallStack
_ :: PrettyCallStack) (Bool
_ :: Bool) -> ()

      showsFsErrNo :: Maybe Errno -> ShowS
showsFsErrNo Maybe Errno
Nothing          = String -> ShowS
showString String
"Nothing"
      showsFsErrNo (Just (Errno CInt
e)) = String -> ShowS
showString String
"Just "
                                    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS -> ShowS
showParen Bool
True (String -> ShowS
showString String
"Errno " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> ShowS
forall a. Show a => a -> ShowS
shows CInt
e)

data FsErrorType
  = FsIllegalOperation
  | FsResourceInappropriateType
  -- ^ e.g the user tried to open a directory with hOpen rather than a file.
  | FsResourceAlreadyInUse
  | FsResourceDoesNotExist
  | FsResourceAlreadyExist
  | FsReachedEOF
  | FsDeviceFull
  | FsTooManyOpenFiles
  | FsInsufficientPermissions
  | FsInvalidArgument
  | FsOther
    -- ^ Used for all other error types
  deriving (Int -> FsErrorType -> ShowS
[FsErrorType] -> ShowS
FsErrorType -> String
(Int -> FsErrorType -> ShowS)
-> (FsErrorType -> String)
-> ([FsErrorType] -> ShowS)
-> Show FsErrorType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FsErrorType -> ShowS
showsPrec :: Int -> FsErrorType -> ShowS
$cshow :: FsErrorType -> String
show :: FsErrorType -> String
$cshowList :: [FsErrorType] -> ShowS
showList :: [FsErrorType] -> ShowS
Show, FsErrorType -> FsErrorType -> Bool
(FsErrorType -> FsErrorType -> Bool)
-> (FsErrorType -> FsErrorType -> Bool) -> Eq FsErrorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FsErrorType -> FsErrorType -> Bool
== :: FsErrorType -> FsErrorType -> Bool
$c/= :: FsErrorType -> FsErrorType -> Bool
/= :: FsErrorType -> FsErrorType -> Bool
Eq)

instance Exception FsError where
    displayException :: FsError -> String
displayException = FsError -> String
prettyFsError

-- | Check if two errors are semantically the same error
--
-- This ignores the error string, the errno, and the callstack.
sameFsError :: FsError -> FsError -> Bool
sameFsError :: FsError -> FsError -> Bool
sameFsError FsError
e FsError
e' = FsError -> FsErrorType
fsErrorType FsError
e FsErrorType -> FsErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== FsError -> FsErrorType
fsErrorType FsError
e'
                Bool -> Bool -> Bool
&& FsError -> FsErrorPath
fsErrorPath FsError
e FsErrorPath -> FsErrorPath -> Bool
forall a. Eq a => a -> a -> Bool
== FsError -> FsErrorPath
fsErrorPath FsError
e'

isFsErrorType :: FsErrorType -> FsError -> Bool
isFsErrorType :: FsErrorType -> FsError -> Bool
isFsErrorType FsErrorType
ty FsError
e = FsError -> FsErrorType
fsErrorType FsError
e FsErrorType -> FsErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== FsErrorType
ty

prettyFsError :: FsError -> String
prettyFsError :: FsError -> String
prettyFsError FsError{Bool
String
Maybe Errno
PrettyCallStack
FsErrorType
FsErrorPath
fsErrorType :: FsError -> FsErrorType
fsErrorPath :: FsError -> FsErrorPath
fsErrorString :: FsError -> String
fsErrorNo :: FsError -> Maybe Errno
fsErrorStack :: FsError -> PrettyCallStack
fsLimitation :: FsError -> Bool
fsErrorType :: FsErrorType
fsErrorPath :: FsErrorPath
fsErrorString :: String
fsErrorNo :: Maybe Errno
fsErrorStack :: PrettyCallStack
fsLimitation :: Bool
..} = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
      FsErrorType -> String
forall a. Show a => a -> String
show FsErrorType
fsErrorType
    , String
" for "
    , FsErrorPath -> String
forall a. Show a => a -> String
show FsErrorPath
fsErrorPath
    , String
": "
    , String
fsErrorString
    , String
" at "
    , PrettyCallStack -> String
forall a. Show a => a -> String
show PrettyCallStack
fsErrorStack
    ]

hasMountPoint :: FsError -> Bool
hasMountPoint :: FsError -> Bool
hasMountPoint FsError{fsErrorPath :: FsError -> FsErrorPath
fsErrorPath = FsErrorPath Maybe MountPoint
mp FsPath
_} = Maybe MountPoint -> Bool
forall a. Maybe a -> Bool
isJust Maybe MountPoint
mp

{-------------------------------------------------------------------------------
  From 'IOError' to 'FsError'
-------------------------------------------------------------------------------}

-- | Translate exceptions thrown by IO functions to 'FsError'
--
-- We take the 'FsPath' as an argument. We could try to translate back from a
-- 'FilePath' to an 'FsPath' (given a 'MountPoint'), but we know the 'FsPath'
-- at all times anyway and not all IO exceptions actually include a filepath.
ioToFsError :: HasCallStack
            => FsErrorPath -> IOError -> FsError
ioToFsError :: HasCallStack => FsErrorPath -> IOError -> FsError
ioToFsError FsErrorPath
fep IOError
ioErr = FsError
    { fsErrorType :: FsErrorType
fsErrorType   = IOError -> FsErrorType
ioToFsErrorType IOError
ioErr
    , fsErrorPath :: FsErrorPath
fsErrorPath   = FsErrorPath
fep
      -- We don't use 'ioeGetErrorString', because that only returns the
      -- description in case 'isUserErrorType' is true, otherwise it will
      -- return 'ioToFsErrorType', which we already include in 'fsErrorType'.
      -- So we use the underlying field directly.
    , fsErrorString :: String
fsErrorString = IOError -> String
GHC.ioe_description IOError
ioErr
    , fsErrorNo :: Maybe Errno
fsErrorNo     = CInt -> Errno
Errno (CInt -> Errno) -> Maybe CInt -> Maybe Errno
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOError -> Maybe CInt
GHC.ioe_errno IOError
ioErr
    , fsErrorStack :: PrettyCallStack
fsErrorStack  = PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
    , fsLimitation :: Bool
fsLimitation  = Bool
False
    }

-- | Assign an 'FsErrorType' to the given 'IOError'.
--
-- Note that we don't always use the classification made by
-- 'Foreign.C.Error.errnoToIOError' (also see 'System.IO.Error') because it
-- combines some errors into one 'IO.IOErrorType', e.g., @EMFILE@ (too many open
-- files) and @ENOSPC@ (no space left on device) both result in
-- 'ResourceExhausted' while we want to keep them separate. For this reason,
-- we do a classification of our own based on the @errno@ while sometimes
-- deferring to the existing classification.
--
-- See the ERRNO(3) man page for the meaning of the different errnos.
ioToFsErrorType :: IOError -> FsErrorType
ioToFsErrorType :: IOError -> FsErrorType
ioToFsErrorType IOError
ioErr = case CInt -> Errno
Errno (CInt -> Errno) -> Maybe CInt -> Maybe Errno
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOError -> Maybe CInt
GHC.ioe_errno IOError
ioErr of
    Just Errno
errno
      |  Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
C.eACCES
      Bool -> Bool -> Bool
|| Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
C.eROFS
      Bool -> Bool -> Bool
|| Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
C.ePERM
      -> FsErrorType
FsInsufficientPermissions

      |  Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
C.eNOSPC
      -> FsErrorType
FsDeviceFull

      |  Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
C.eMFILE
      Bool -> Bool -> Bool
|| Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
C.eNFILE
      -> FsErrorType
FsTooManyOpenFiles

      |  Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
C.eNOENT
      Bool -> Bool -> Bool
|| Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
C.eNXIO
      -> FsErrorType
FsResourceDoesNotExist

    Maybe Errno
_ | IOErrorType -> Bool
IO.isAlreadyInUseErrorType IOErrorType
eType
      -> FsErrorType
FsResourceAlreadyInUse

      | IOErrorType -> Bool
IO.isAlreadyExistsErrorType IOErrorType
eType
      -> FsErrorType
FsResourceAlreadyExist

      | IOErrorType -> Bool
IO.isEOFErrorType IOErrorType
eType
      -> FsErrorType
FsReachedEOF

      | IOErrorType -> Bool
IO.isIllegalOperationErrorType IOErrorType
eType
      -> FsErrorType
FsIllegalOperation

      | IOErrorType
eType IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
GHC.InappropriateType
      -> FsErrorType
FsResourceInappropriateType

      | IOErrorType
eType IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
GHC.InvalidArgument
      -> FsErrorType
FsInvalidArgument

      | Bool
otherwise
      -> FsErrorType
FsOther
  where
    eType :: IO.IOErrorType
    eType :: IOErrorType
eType = IOError -> IOErrorType
IO.ioeGetErrorType IOError
ioErr

{-------------------------------------------------------------------------------
  Condense instances
-------------------------------------------------------------------------------}

instance Condense SeekMode where
  condense :: SeekMode -> String
condense SeekMode
RelativeSeek = String
"r"
  condense SeekMode
AbsoluteSeek = String
"a"
  condense SeekMode
SeekFromEnd  = String
"e"

instance Condense AllowExisting where
  condense :: AllowExisting -> String
condense AllowExisting
AllowExisting = String
""
  condense AllowExisting
MustBeNew     = String
"!"

instance Condense OpenMode where
    condense :: OpenMode -> String
condense OpenMode
ReadMode           = String
"r"
    condense (WriteMode     AllowExisting
ex) = String
"w"  String -> ShowS
forall a. [a] -> [a] -> [a]
++ AllowExisting -> String
forall a. Condense a => a -> String
condense AllowExisting
ex
    condense (ReadWriteMode AllowExisting
ex) = String
"rw" String -> ShowS
forall a. [a] -> [a] -> [a]
++ AllowExisting -> String
forall a. Condense a => a -> String
condense AllowExisting
ex
    condense (AppendMode    AllowExisting
ex) = String
"a"  String -> ShowS
forall a. [a] -> [a] -> [a]
++ AllowExisting -> String
forall a. Condense a => a -> String
condense AllowExisting
ex

instance Condense (Handle h) where
  condense :: Handle h -> String
condense = Handle h -> String
forall a. Show a => a -> String
show