{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.Posix.RawFilePath.Directory.Errors
(
HPathIOException(..)
, RecursiveFailureHint(..)
, isSameFile
, isDestinationInSource
, isRecursiveFailure
, isReadContentsFailed
, isCreateDirFailed
, isCopyFileFailed
, isRecreateSymlinkFailed
, throwFileDoesExist
, throwDirDoesExist
, throwSameFile
, sameFile
, throwDestinationInSource
, catchErrno
, rethrowErrnoAs
, handleIOError
, hideError
, bracketeer
, reactOnError
)
where
import Control.Applicative
(
(<$>)
)
import Control.Exception.Safe hiding (handleIOError)
import Control.Monad
(
forM
, when
)
import Control.Monad.IfElse
(
whenM
)
import Data.ByteString
(
ByteString
)
import qualified Data.ByteString as BS
import Data.ByteString.UTF8
(
toString
)
import Data.Typeable
(
Typeable
)
import Foreign.C.Error
(
getErrno
, Errno
)
import GHC.IO.Exception
(
IOErrorType
)
import {-# SOURCE #-} System.Posix.RawFilePath.Directory
(
canonicalizePath
, toAbs
, doesFileExist
, doesDirectoryExist
, isWritable
, canOpenDirectory
)
import System.IO.Error
(
alreadyExistsErrorType
, ioeGetErrorType
, mkIOError
)
import System.Posix.FilePath
import qualified System.Posix.Directory.ByteString as PFD
import System.Posix.Files.ByteString
(
fileAccess
, getFileStatus
)
import qualified System.Posix.Files.ByteString as PF
data HPathIOException = SameFile ByteString ByteString
| DestinationInSource ByteString ByteString
| RecursiveFailure [(RecursiveFailureHint, IOException)]
deriving (HPathIOException -> HPathIOException -> Bool
(HPathIOException -> HPathIOException -> Bool)
-> (HPathIOException -> HPathIOException -> Bool)
-> Eq HPathIOException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HPathIOException -> HPathIOException -> Bool
$c/= :: HPathIOException -> HPathIOException -> Bool
== :: HPathIOException -> HPathIOException -> Bool
$c== :: HPathIOException -> HPathIOException -> Bool
Eq, Int -> HPathIOException -> ShowS
[HPathIOException] -> ShowS
HPathIOException -> String
(Int -> HPathIOException -> ShowS)
-> (HPathIOException -> String)
-> ([HPathIOException] -> ShowS)
-> Show HPathIOException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HPathIOException] -> ShowS
$cshowList :: [HPathIOException] -> ShowS
show :: HPathIOException -> String
$cshow :: HPathIOException -> String
showsPrec :: Int -> HPathIOException -> ShowS
$cshowsPrec :: Int -> HPathIOException -> ShowS
Show, Typeable)
data RecursiveFailureHint = ReadContentsFailed ByteString ByteString
| CreateDirFailed ByteString ByteString
| CopyFileFailed ByteString ByteString
| RecreateSymlinkFailed ByteString ByteString
deriving (RecursiveFailureHint -> RecursiveFailureHint -> Bool
(RecursiveFailureHint -> RecursiveFailureHint -> Bool)
-> (RecursiveFailureHint -> RecursiveFailureHint -> Bool)
-> Eq RecursiveFailureHint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RecursiveFailureHint -> RecursiveFailureHint -> Bool
$c/= :: RecursiveFailureHint -> RecursiveFailureHint -> Bool
== :: RecursiveFailureHint -> RecursiveFailureHint -> Bool
$c== :: RecursiveFailureHint -> RecursiveFailureHint -> Bool
Eq, Int -> RecursiveFailureHint -> ShowS
[RecursiveFailureHint] -> ShowS
RecursiveFailureHint -> String
(Int -> RecursiveFailureHint -> ShowS)
-> (RecursiveFailureHint -> String)
-> ([RecursiveFailureHint] -> ShowS)
-> Show RecursiveFailureHint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RecursiveFailureHint] -> ShowS
$cshowList :: [RecursiveFailureHint] -> ShowS
show :: RecursiveFailureHint -> String
$cshow :: RecursiveFailureHint -> String
showsPrec :: Int -> RecursiveFailureHint -> ShowS
$cshowsPrec :: Int -> RecursiveFailureHint -> ShowS
Show)
instance Exception HPathIOException
toConstr :: HPathIOException -> String
toConstr :: HPathIOException -> String
toConstr SameFile {} = String
"SameFile"
toConstr DestinationInSource {} = String
"DestinationInSource"
toConstr RecursiveFailure {} = String
"RecursiveFailure"
isSameFile, isDestinationInSource, isRecursiveFailure :: HPathIOException -> Bool
isSameFile :: HPathIOException -> Bool
isSameFile HPathIOException
ex = HPathIOException -> String
toConstr (HPathIOException
ex :: HPathIOException) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== HPathIOException -> String
toConstr (ByteString -> ByteString -> HPathIOException
SameFile ByteString
forall a. Monoid a => a
mempty ByteString
forall a. Monoid a => a
mempty)
isDestinationInSource :: HPathIOException -> Bool
isDestinationInSource HPathIOException
ex = HPathIOException -> String
toConstr (HPathIOException
ex :: HPathIOException) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (HPathIOException -> String
toConstr (HPathIOException -> String) -> HPathIOException -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> HPathIOException
DestinationInSource ByteString
forall a. Monoid a => a
mempty ByteString
forall a. Monoid a => a
mempty)
isRecursiveFailure :: HPathIOException -> Bool
isRecursiveFailure HPathIOException
ex = HPathIOException -> String
toConstr (HPathIOException
ex :: HPathIOException) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (HPathIOException -> String
toConstr (HPathIOException -> String) -> HPathIOException -> String
forall a b. (a -> b) -> a -> b
$ [(RecursiveFailureHint, IOException)] -> HPathIOException
RecursiveFailure [(RecursiveFailureHint, IOException)]
forall a. Monoid a => a
mempty)
isReadContentsFailed, isCreateDirFailed, isCopyFileFailed, isRecreateSymlinkFailed ::RecursiveFailureHint -> Bool
isReadContentsFailed :: RecursiveFailureHint -> Bool
isReadContentsFailed ReadContentsFailed{} = Bool
True
isReadContentsFailed RecursiveFailureHint
_ = Bool
False
isCreateDirFailed :: RecursiveFailureHint -> Bool
isCreateDirFailed CreateDirFailed{} = Bool
True
isCreateDirFailed RecursiveFailureHint
_ = Bool
False
isCopyFileFailed :: RecursiveFailureHint -> Bool
isCopyFileFailed CopyFileFailed{} = Bool
True
isCopyFileFailed RecursiveFailureHint
_ = Bool
False
isRecreateSymlinkFailed :: RecursiveFailureHint -> Bool
isRecreateSymlinkFailed RecreateSymlinkFailed{} = Bool
True
isRecreateSymlinkFailed RecursiveFailureHint
_ = Bool
False
throwFileDoesExist :: RawFilePath -> IO ()
throwFileDoesExist :: ByteString -> IO ()
throwFileDoesExist ByteString
bs =
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (ByteString -> IO Bool
doesFileExist ByteString
bs)
(IOException -> IO ()
forall a. IOException -> IO a
ioError (IOException -> IO ())
-> (Maybe String -> IOException) -> Maybe String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOErrorType
-> String -> Maybe Handle -> Maybe String -> IOException
mkIOError
IOErrorType
alreadyExistsErrorType
String
"File already exists"
Maybe Handle
forall a. Maybe a
Nothing
(Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ (String -> Maybe String
forall a. a -> Maybe a
Just (ByteString -> String
toString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
bs))
)
throwDirDoesExist :: RawFilePath -> IO ()
throwDirDoesExist :: ByteString -> IO ()
throwDirDoesExist ByteString
bs =
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (ByteString -> IO Bool
doesDirectoryExist ByteString
bs)
(IOException -> IO ()
forall a. IOException -> IO a
ioError (IOException -> IO ())
-> (Maybe String -> IOException) -> Maybe String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOErrorType
-> String -> Maybe Handle -> Maybe String -> IOException
mkIOError
IOErrorType
alreadyExistsErrorType
String
"Directory already exists"
Maybe Handle
forall a. Maybe a
Nothing
(Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ (String -> Maybe String
forall a. a -> Maybe a
Just (ByteString -> String
toString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
bs))
)
throwSameFile :: RawFilePath
-> RawFilePath
-> IO ()
throwSameFile :: ByteString -> ByteString -> IO ()
throwSameFile ByteString
bs1 ByteString
bs2 =
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (ByteString -> ByteString -> IO Bool
sameFile ByteString
bs1 ByteString
bs2)
(HPathIOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (HPathIOException -> IO ()) -> HPathIOException -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> HPathIOException
SameFile ByteString
bs1 ByteString
bs2)
sameFile :: RawFilePath -> RawFilePath -> IO Bool
sameFile :: ByteString -> ByteString -> IO Bool
sameFile ByteString
fp1 ByteString
fp2 =
(IOException -> IO Bool) -> IO Bool -> IO Bool
forall a. (IOException -> IO a) -> IO a -> IO a
handleIOError (\IOException
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
FileStatus
fs1 <- ByteString -> IO FileStatus
getFileStatus ByteString
fp1
FileStatus
fs2 <- ByteString -> IO FileStatus
getFileStatus ByteString
fp2
if ((FileStatus -> DeviceID
PF.deviceID FileStatus
fs1, FileStatus -> FileID
PF.fileID FileStatus
fs1) (DeviceID, FileID) -> (DeviceID, FileID) -> Bool
forall a. Eq a => a -> a -> Bool
==
(FileStatus -> DeviceID
PF.deviceID FileStatus
fs2, FileStatus -> FileID
PF.fileID FileStatus
fs2))
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
throwDestinationInSource :: RawFilePath
-> RawFilePath
-> IO ()
throwDestinationInSource :: ByteString -> ByteString -> IO ()
throwDestinationInSource ByteString
sbs ByteString
dbs = do
ByteString
destAbs <- ByteString -> IO ByteString
toAbs ByteString
dbs
ByteString
dest' <- (\ByteString
x -> ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
x (\ByteString
y -> ByteString
x ByteString -> ByteString -> ByteString
</> ByteString
y) (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
basename ByteString
dbs)
(ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> IO ByteString
canonicalizePath (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
takeDirectory ByteString
destAbs)
[(DeviceID, FileID)]
dids <- [ByteString]
-> (ByteString -> IO (DeviceID, FileID)) -> IO [(DeviceID, FileID)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (ByteString -> [ByteString]
takeAllParents ByteString
dest') ((ByteString -> IO (DeviceID, FileID)) -> IO [(DeviceID, FileID)])
-> (ByteString -> IO (DeviceID, FileID)) -> IO [(DeviceID, FileID)]
forall a b. (a -> b) -> a -> b
$ \ByteString
p -> do
FileStatus
fs <- ByteString -> IO FileStatus
PF.getSymbolicLinkStatus ByteString
p
(DeviceID, FileID) -> IO (DeviceID, FileID)
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> DeviceID
PF.deviceID FileStatus
fs, FileStatus -> FileID
PF.fileID FileStatus
fs)
(DeviceID, FileID)
sid <- (FileStatus -> (DeviceID, FileID))
-> IO FileStatus -> IO (DeviceID, FileID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FileStatus
x -> (FileStatus -> DeviceID
PF.deviceID FileStatus
x, FileStatus -> FileID
PF.fileID FileStatus
x))
(IO FileStatus -> IO (DeviceID, FileID))
-> IO FileStatus -> IO (DeviceID, FileID)
forall a b. (a -> b) -> a -> b
$ ByteString -> IO FileStatus
PF.getFileStatus ByteString
sbs
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((DeviceID, FileID) -> [(DeviceID, FileID)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (DeviceID, FileID)
sid [(DeviceID, FileID)]
dids)
(HPathIOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (HPathIOException -> IO ()) -> HPathIOException -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> HPathIOException
DestinationInSource ByteString
dbs ByteString
sbs)
where
basename :: ByteString -> Maybe ByteString
basename ByteString
x = let b :: ByteString
b = ByteString -> ByteString
takeBaseName ByteString
x
in if ByteString -> Bool
BS.null ByteString
b then Maybe ByteString
forall a. Maybe a
Nothing else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
b
catchErrno :: [Errno]
-> IO a
-> IO a
-> IO a
catchErrno :: [Errno] -> IO a -> IO a -> IO a
catchErrno [Errno]
en IO a
a1 IO a
a2 =
IO a -> (IOException -> IO a) -> IO a
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIOError IO a
a1 ((IOException -> IO a) -> IO a) -> (IOException -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \IOException
e -> do
Errno
errno <- IO Errno
getErrno
if Errno
errno Errno -> [Errno] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Errno]
en
then IO a
a2
else IOException -> IO a
forall a. IOException -> IO a
ioError IOException
e
rethrowErrnoAs :: Exception e
=> [Errno]
-> e
-> IO a
-> IO a
rethrowErrnoAs :: [Errno] -> e -> IO a -> IO a
rethrowErrnoAs [Errno]
en e
fmex IO a
action = [Errno] -> IO a -> IO a -> IO a
forall a. [Errno] -> IO a -> IO a -> IO a
catchErrno [Errno]
en IO a
action (e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
fmex)
handleIOError :: (IOError -> IO a) -> IO a -> IO a
handleIOError :: (IOException -> IO a) -> IO a -> IO a
handleIOError = (IO a -> (IOException -> IO a) -> IO a)
-> (IOException -> IO a) -> IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO a -> (IOException -> IO a) -> IO a
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIOError
hideError :: IOErrorType -> IO () -> IO ()
hideError :: IOErrorType -> IO () -> IO ()
hideError IOErrorType
err = (IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> if IOErrorType
err IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOException -> IOErrorType
ioeGetErrorType IOException
e then () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e)
bracketeer :: IO a
-> (a -> IO b)
-> (a -> IO b)
-> (a -> IO c)
-> IO c
bracketeer :: IO a -> (a -> IO b) -> (a -> IO b) -> (a -> IO c) -> IO c
bracketeer IO a
before a -> IO b
after a -> IO b
afterEx a -> IO c
thing =
((forall a. IO a -> IO a) -> IO c) -> IO c
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO c) -> IO c)
-> ((forall a. IO a -> IO a) -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
a
a <- IO a
before
c
r <- IO c -> IO c
forall a. IO a -> IO a
restore (a -> IO c
thing a
a) IO c -> IO b -> IO c
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`onException` a -> IO b
afterEx a
a
b
_ <- a -> IO b
after a
a
c -> IO c
forall (m :: * -> *) a. Monad m => a -> m a
return c
r
reactOnError :: IO a
-> [(IOErrorType, IO a)]
-> [(HPathIOException, IO a)]
-> IO a
reactOnError :: IO a -> [(IOErrorType, IO a)] -> [(HPathIOException, IO a)] -> IO a
reactOnError IO a
a [(IOErrorType, IO a)]
ios [(HPathIOException, IO a)]
fmios =
IO a
a IO a -> [Handler IO a] -> IO a
forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
`catches` [Handler IO a
iohandler, Handler IO a
fmiohandler]
where
iohandler :: Handler IO a
iohandler = (IOException -> IO a) -> Handler IO a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((IOException -> IO a) -> Handler IO a)
-> (IOException -> IO a) -> Handler IO a
forall a b. (a -> b) -> a -> b
$
\(IOException
ex :: IOException) ->
((IOErrorType, IO a) -> IO a -> IO a)
-> IO a -> [(IOErrorType, IO a)] -> IO a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(IOErrorType
t, IO a
a') IO a
y -> if IOException -> IOErrorType
ioeGetErrorType IOException
ex IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
t
then IO a
a'
else IO a
y)
(IOException -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
ex)
[(IOErrorType, IO a)]
ios
fmiohandler :: Handler IO a
fmiohandler = (HPathIOException -> IO a) -> Handler IO a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((HPathIOException -> IO a) -> Handler IO a)
-> (HPathIOException -> IO a) -> Handler IO a
forall a b. (a -> b) -> a -> b
$
\(HPathIOException
ex :: HPathIOException) ->
((HPathIOException, IO a) -> IO a -> IO a)
-> IO a -> [(HPathIOException, IO a)] -> IO a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(HPathIOException
t, IO a
a') IO a
y -> if HPathIOException -> String
toConstr HPathIOException
ex String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== HPathIOException -> String
toConstr HPathIOException
t
then IO a
a'
else IO a
y)
(HPathIOException -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO HPathIOException
ex)
[(HPathIOException, IO a)]
fmios