{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE StandaloneDeriving         #-}

-- For Show Errno and Condense SeekMode instances
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Storage.FS.API.Types (
    -- * Modes
    AllowExisting (..)
  , OpenMode (..)
  , SeekMode (..)
  , allowExisting
    -- * Paths
  , MountPoint (..)
  , fsFromFilePath
  , fsPathFromList
  , fsPathInit
  , fsPathSplit
  , fsPathToList
  , fsToFilePath
  , mkFsPath
    -- ** 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 (force)
import           Control.Exception
import           Data.Function (on)
import           Data.List (intercalate, stripPrefix)
import           Data.Maybe (isJust)
import qualified Data.Text as Strict
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           NoThunks.Class (InspectHeap (..), InspectHeapNamed (..),
                     NoThunks (..))
import           System.FilePath
import           System.IO (SeekMode (..))
import qualified System.IO.Error as IO

import           Ouroboros.Consensus.Util.CallStack
import           Ouroboros.Consensus.Util.Condense

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

-- | How to '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
/= :: OpenMode -> OpenMode -> Bool
$c/= :: OpenMode -> OpenMode -> Bool
== :: OpenMode -> OpenMode -> Bool
$c== :: 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
showList :: [OpenMode] -> ShowS
$cshowList :: [OpenMode] -> ShowS
show :: OpenMode -> String
$cshow :: OpenMode -> String
showsPrec :: Int -> OpenMode -> ShowS
$cshowsPrec :: Int -> OpenMode -> ShowS
Show)

-- | When 'hOpen'ing 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
/= :: AllowExisting -> AllowExisting -> Bool
$c/= :: AllowExisting -> AllowExisting -> Bool
== :: AllowExisting -> AllowExisting -> Bool
$c== :: 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
showList :: [AllowExisting] -> ShowS
$cshowList :: [AllowExisting] -> ShowS
show :: AllowExisting -> String
$cshow :: AllowExisting -> String
showsPrec :: Int -> AllowExisting -> ShowS
$cshowsPrec :: Int -> 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
-------------------------------------------------------------------------------}

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
/= :: FsPath -> FsPath -> Bool
$c/= :: FsPath -> FsPath -> Bool
== :: FsPath -> FsPath -> Bool
$c== :: 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
min :: FsPath -> FsPath -> FsPath
$cmin :: FsPath -> FsPath -> FsPath
max :: FsPath -> FsPath -> FsPath
$cmax :: FsPath -> FsPath -> FsPath
>= :: FsPath -> FsPath -> Bool
$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
compare :: FsPath -> FsPath -> Ordering
$ccompare :: FsPath -> FsPath -> Ordering
$cp1Ord :: Eq 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
$cto :: forall x. Rep FsPath x -> FsPath
$cfrom :: forall x. FsPath -> Rep FsPath x
Generic)
  deriving Context -> FsPath -> IO (Maybe ThunkInfo)
Proxy FsPath -> String
(Context -> FsPath -> IO (Maybe ThunkInfo))
-> (Context -> FsPath -> IO (Maybe ThunkInfo))
-> (Proxy FsPath -> String)
-> NoThunks FsPath
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy FsPath -> String
$cshowTypeOf :: Proxy FsPath -> String
wNoThunks :: Context -> FsPath -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> FsPath -> IO (Maybe ThunkInfo)
noThunks :: Context -> FsPath -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> FsPath -> IO (Maybe ThunkInfo)
NoThunks via InspectHeap FsPath

fsPathFromList :: [Strict.Text] -> FsPath
fsPathFromList :: [Text] -> FsPath
fsPathFromList = [Text] -> FsPath
UnsafeFsPath ([Text] -> FsPath) -> ([Text] -> [Text]) -> [Text] -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. NFData a => a -> a
force

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

-- | 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
</> (String -> ShowS) -> String -> Context -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> ShowS
(</>) String
"" ((Text -> String) -> [Text] -> Context
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Strict.unpack ([Text] -> Context) -> [Text] -> Context
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 = Context -> FsPath
mkFsPath (Context -> FsPath) -> Maybe Context -> Maybe FsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Context -> Context -> Maybe Context
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (String -> Context
splitDirectories String
mp) (String -> Context
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
      Handle h -> h
handleRaw  :: !h

      -- | The path corresponding to this handle
      --
      -- This is primarily useful for error reporting.
    , 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
$cto :: forall h x. Rep (Handle h) x -> Handle h
$cfrom :: forall h x. Handle h -> Rep (Handle h) x
Generic)
  deriving Context -> Handle h -> IO (Maybe ThunkInfo)
Proxy (Handle h) -> String
(Context -> Handle h -> IO (Maybe ThunkInfo))
-> (Context -> Handle h -> IO (Maybe ThunkInfo))
-> (Proxy (Handle h) -> String)
-> NoThunks (Handle h)
forall h. Context -> Handle h -> IO (Maybe ThunkInfo)
forall h. Proxy (Handle h) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (Handle h) -> String
$cshowTypeOf :: forall h. Proxy (Handle h) -> String
wNoThunks :: Context -> Handle h -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall h. Context -> Handle h -> IO (Maybe ThunkInfo)
noThunks :: Context -> Handle h -> IO (Maybe ThunkInfo)
$cnoThunks :: forall h. Context -> Handle h -> IO (Maybe ThunkInfo)
NoThunks via InspectHeapNamed "Handle" (Handle h)

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

deriving instance Show Errno

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
showList :: [FsErrorType] -> ShowS
$cshowList :: [FsErrorType] -> ShowS
show :: FsErrorType -> String
$cshow :: FsErrorType -> String
showsPrec :: Int -> FsErrorType -> ShowS
$cshowsPrec :: Int -> FsErrorType -> ShowS
Show, FsErrorType -> FsErrorType -> Bool
(FsErrorType -> FsErrorType -> Bool)
-> (FsErrorType -> FsErrorType -> Bool) -> Eq FsErrorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FsErrorType -> FsErrorType -> Bool
$c/= :: FsErrorType -> FsErrorType -> Bool
== :: FsErrorType -> FsErrorType -> Bool
$c== :: 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
fsLimitation :: Bool
fsErrorStack :: PrettyCallStack
fsErrorNo :: Maybe Errno
fsErrorString :: String
fsErrorPath :: FsErrorPath
fsErrorType :: FsErrorType
fsLimitation :: FsError -> Bool
fsErrorStack :: FsError -> PrettyCallStack
fsErrorNo :: FsError -> Maybe Errno
fsErrorString :: FsError -> String
fsErrorPath :: FsError -> FsErrorPath
fsErrorType :: FsError -> FsErrorType
..} = Context -> 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 :: FsErrorPath -> IOError -> FsError
ioToFsError FsErrorPath
fep IOError
ioErr = FsError :: FsErrorType
-> FsErrorPath
-> String
-> Maybe Errno
-> PrettyCallStack
-> Bool
-> FsError
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 '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