2016-05-09 14:53:31 +00:00
|
|
|
-- |
|
|
|
|
-- Module : HPath.IO.Errors
|
|
|
|
-- Copyright : © 2016 Julian Ospald
|
2016-06-03 22:20:41 +00:00
|
|
|
-- License : BSD3
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
|
|
|
-- Maintainer : Julian Ospald <hasufell@posteo.de>
|
|
|
|
-- Stability : experimental
|
|
|
|
-- Portability : portable
|
|
|
|
--
|
|
|
|
-- Provides error handling.
|
|
|
|
|
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
|
2016-05-09 22:35:33 +00:00
|
|
|
module HPath.IO.Errors
|
|
|
|
(
|
|
|
|
-- * Types
|
|
|
|
HPathIOException(..)
|
|
|
|
|
|
|
|
-- * Exception identifiers
|
|
|
|
, isFileDoesNotExist
|
|
|
|
, isDirDoesNotExist
|
|
|
|
, isSameFile
|
|
|
|
, isDestinationInSource
|
|
|
|
, isFileDoesExist
|
|
|
|
, isDirDoesExist
|
|
|
|
, isInvalidOperation
|
|
|
|
, isCan'tOpenDirectory
|
|
|
|
, isCopyFailed
|
|
|
|
|
|
|
|
-- * Path based functions
|
|
|
|
, throwFileDoesExist
|
|
|
|
, throwDirDoesExist
|
|
|
|
, throwFileDoesNotExist
|
|
|
|
, throwDirDoesNotExist
|
|
|
|
, throwSameFile
|
|
|
|
, sameFile
|
|
|
|
, throwDestinationInSource
|
|
|
|
, doesFileExist
|
|
|
|
, doesDirectoryExist
|
|
|
|
, isWritable
|
|
|
|
, canOpenDirectory
|
|
|
|
, throwCantOpenDirectory
|
|
|
|
|
|
|
|
-- * Error handling functions
|
|
|
|
, catchErrno
|
|
|
|
, rethrowErrnoAs
|
|
|
|
, handleIOError
|
|
|
|
, bracketeer
|
|
|
|
, reactOnError
|
|
|
|
)
|
|
|
|
where
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
2016-05-09 16:53:26 +00:00
|
|
|
import Control.Applicative
|
|
|
|
(
|
|
|
|
(<$>)
|
|
|
|
)
|
2016-05-09 14:53:31 +00:00
|
|
|
import Control.Exception
|
|
|
|
import Control.Monad
|
|
|
|
(
|
|
|
|
forM
|
|
|
|
, when
|
|
|
|
)
|
|
|
|
import Data.ByteString
|
|
|
|
(
|
|
|
|
ByteString
|
|
|
|
)
|
2016-05-18 02:11:40 +00:00
|
|
|
import Data.ByteString.UTF8
|
|
|
|
(
|
|
|
|
toString
|
|
|
|
)
|
2016-05-09 14:53:31 +00:00
|
|
|
import Data.Data
|
|
|
|
(
|
|
|
|
Data(..)
|
|
|
|
)
|
|
|
|
import Data.Typeable
|
|
|
|
import Foreign.C.Error
|
|
|
|
(
|
|
|
|
getErrno
|
|
|
|
, Errno
|
|
|
|
)
|
|
|
|
import GHC.IO.Exception
|
|
|
|
(
|
|
|
|
IOErrorType
|
|
|
|
)
|
|
|
|
import HPath
|
2016-05-09 22:11:42 +00:00
|
|
|
import {-# SOURCE #-} HPath.IO
|
|
|
|
(
|
|
|
|
canonicalizePath
|
|
|
|
)
|
2016-05-09 14:53:31 +00:00
|
|
|
import HPath.IO.Utils
|
|
|
|
import System.IO.Error
|
|
|
|
(
|
|
|
|
catchIOError
|
|
|
|
, ioeGetErrorType
|
|
|
|
)
|
|
|
|
|
|
|
|
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 = FileDoesNotExist ByteString
|
|
|
|
| DirDoesNotExist ByteString
|
|
|
|
| SameFile ByteString ByteString
|
|
|
|
| DestinationInSource ByteString ByteString
|
|
|
|
| FileDoesExist ByteString
|
|
|
|
| DirDoesExist ByteString
|
|
|
|
| InvalidOperation String
|
|
|
|
| Can'tOpenDirectory ByteString
|
|
|
|
| CopyFailed String
|
|
|
|
deriving (Typeable, Eq, Data)
|
|
|
|
|
|
|
|
|
|
|
|
instance Show HPathIOException where
|
2016-05-18 02:11:40 +00:00
|
|
|
show (FileDoesNotExist fp) = "File does not exist:" ++ toString fp
|
2016-05-09 14:53:31 +00:00
|
|
|
show (DirDoesNotExist fp) = "Directory does not exist: "
|
2016-05-18 02:11:40 +00:00
|
|
|
++ toString fp
|
|
|
|
show (SameFile fp1 fp2) = toString fp1
|
|
|
|
++ " and " ++ toString fp2
|
2016-05-09 14:53:31 +00:00
|
|
|
++ " are the same file!"
|
2016-05-18 02:11:40 +00:00
|
|
|
show (DestinationInSource fp1 fp2) = toString fp1
|
2016-05-09 14:53:31 +00:00
|
|
|
++ " is contained in "
|
2016-05-18 02:11:40 +00:00
|
|
|
++ toString fp2
|
|
|
|
show (FileDoesExist fp) = "File does exist: " ++ toString fp
|
|
|
|
show (DirDoesExist fp) = "Directory does exist: " ++ toString fp
|
2016-05-09 14:53:31 +00:00
|
|
|
show (InvalidOperation str) = "Invalid operation: " ++ str
|
|
|
|
show (Can'tOpenDirectory fp) = "Can't open directory: "
|
2016-05-18 02:11:40 +00:00
|
|
|
++ toString fp
|
2016-05-09 14:53:31 +00:00
|
|
|
show (CopyFailed str) = "Copying failed: " ++ str
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
instance Exception HPathIOException
|
|
|
|
|
|
|
|
|
2016-05-09 22:35:33 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-----------------------------
|
|
|
|
--[ Exception identifiers ]--
|
|
|
|
-----------------------------
|
|
|
|
|
2016-05-09 22:13:14 +00:00
|
|
|
isFileDoesNotExist, isDirDoesNotExist, isSameFile, isDestinationInSource, isFileDoesExist, isDirDoesExist, isInvalidOperation, isCan'tOpenDirectory, isCopyFailed :: HPathIOException -> Bool
|
|
|
|
isFileDoesNotExist ex = toConstr (ex :: HPathIOException) == toConstr FileDoesNotExist{}
|
|
|
|
isDirDoesNotExist ex = toConstr (ex :: HPathIOException) == toConstr DirDoesNotExist{}
|
|
|
|
isSameFile ex = toConstr (ex :: HPathIOException) == toConstr SameFile{}
|
|
|
|
isDestinationInSource ex = toConstr (ex :: HPathIOException) == toConstr DestinationInSource{}
|
|
|
|
isFileDoesExist ex = toConstr (ex :: HPathIOException) == toConstr FileDoesExist{}
|
|
|
|
isDirDoesExist ex = toConstr (ex :: HPathIOException) == toConstr DirDoesExist{}
|
|
|
|
isInvalidOperation ex = toConstr (ex :: HPathIOException) == toConstr InvalidOperation{}
|
|
|
|
isCan'tOpenDirectory ex = toConstr (ex :: HPathIOException) == toConstr Can'tOpenDirectory{}
|
|
|
|
isCopyFailed ex = toConstr (ex :: HPathIOException) == toConstr CopyFailed{}
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
----------------------------
|
|
|
|
--[ Path based functions ]--
|
|
|
|
----------------------------
|
|
|
|
|
|
|
|
|
|
|
|
throwFileDoesExist :: Path Abs -> IO ()
|
|
|
|
throwFileDoesExist fp =
|
|
|
|
whenM (doesFileExist fp) (throwIO . FileDoesExist
|
|
|
|
. fromAbs $ fp)
|
|
|
|
|
|
|
|
|
|
|
|
throwDirDoesExist :: Path Abs -> IO ()
|
|
|
|
throwDirDoesExist fp =
|
|
|
|
whenM (doesDirectoryExist fp) (throwIO . DirDoesExist
|
|
|
|
. fromAbs $ fp)
|
|
|
|
|
|
|
|
|
|
|
|
throwFileDoesNotExist :: Path Abs -> IO ()
|
|
|
|
throwFileDoesNotExist fp =
|
|
|
|
unlessM (doesFileExist fp) (throwIO . FileDoesNotExist
|
|
|
|
. fromAbs $ fp)
|
|
|
|
|
|
|
|
|
|
|
|
throwDirDoesNotExist :: Path Abs -> IO ()
|
|
|
|
throwDirDoesNotExist fp =
|
|
|
|
unlessM (doesDirectoryExist fp) (throwIO . DirDoesNotExist
|
|
|
|
. fromAbs $ fp)
|
|
|
|
|
|
|
|
|
|
|
|
-- |Uses `isSameFile` and throws `SameFile` if it returns True.
|
|
|
|
throwSameFile :: Path Abs
|
|
|
|
-> Path Abs
|
|
|
|
-> IO ()
|
|
|
|
throwSameFile fp1 fp2 =
|
|
|
|
whenM (sameFile fp1 fp2)
|
|
|
|
(throwIO $ SameFile (fromAbs fp1) (fromAbs fp2))
|
|
|
|
|
|
|
|
|
|
|
|
-- |Check if the files are the same by examining device and file id.
|
|
|
|
-- This follows symbolic links.
|
|
|
|
sameFile :: Path Abs -> Path Abs -> IO Bool
|
|
|
|
sameFile fp1 fp2 =
|
|
|
|
withAbsPath fp1 $ \fp1' -> withAbsPath fp2 $ \fp2' ->
|
|
|
|
handleIOError (\_ -> return False) $ do
|
|
|
|
fs1 <- getFileStatus fp1'
|
|
|
|
fs2 <- getFileStatus fp2'
|
|
|
|
|
|
|
|
if ((PF.deviceID fs1, PF.fileID fs1) ==
|
|
|
|
(PF.deviceID fs2, PF.fileID fs2))
|
|
|
|
then return True
|
|
|
|
else return False
|
|
|
|
|
|
|
|
|
2016-05-24 01:25:27 +00:00
|
|
|
-- TODO: make this more robust when destination does not exist
|
2016-05-09 14:53:31 +00:00
|
|
|
-- |Checks whether the destination directory is contained
|
|
|
|
-- within the source directory by comparing the device+file ID of the
|
|
|
|
-- source directory with all device+file IDs of the parent directories
|
|
|
|
-- of the destination.
|
|
|
|
throwDestinationInSource :: Path Abs -- ^ source dir
|
2016-05-22 11:41:39 +00:00
|
|
|
-> Path Abs -- ^ full destination, @dirname dest@
|
2016-05-09 14:53:31 +00:00
|
|
|
-- must exist
|
|
|
|
-> IO ()
|
|
|
|
throwDestinationInSource source dest = do
|
|
|
|
dest' <- (\x -> maybe x (\y -> x </> y) $ basename dest)
|
2016-05-09 22:11:42 +00:00
|
|
|
<$> (canonicalizePath $ dirname dest)
|
2016-05-09 14:53:31 +00:00
|
|
|
dids <- forM (getAllParents dest') $ \p -> do
|
|
|
|
fs <- PF.getSymbolicLinkStatus (fromAbs p)
|
|
|
|
return (PF.deviceID fs, PF.fileID fs)
|
|
|
|
sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
|
|
|
|
$ PF.getFileStatus (fromAbs source)
|
|
|
|
when (elem sid dids)
|
|
|
|
(throwIO $ DestinationInSource (fromAbs dest)
|
|
|
|
(fromAbs source))
|
|
|
|
|
|
|
|
|
|
|
|
-- |Checks if the given file exists and is not a directory.
|
|
|
|
-- Does not follow symlinks.
|
|
|
|
doesFileExist :: Path Abs -> IO Bool
|
|
|
|
doesFileExist fp =
|
|
|
|
handleIOError (\_ -> return False) $ do
|
|
|
|
fs <- PF.getSymbolicLinkStatus (fromAbs fp)
|
|
|
|
return $ not . PF.isDirectory $ fs
|
|
|
|
|
|
|
|
|
|
|
|
-- |Checks if the given file exists and is a directory.
|
|
|
|
-- Does not follow symlinks.
|
|
|
|
doesDirectoryExist :: Path Abs -> IO Bool
|
|
|
|
doesDirectoryExist fp =
|
|
|
|
handleIOError (\_ -> return False) $ do
|
|
|
|
fs <- PF.getSymbolicLinkStatus (fromAbs fp)
|
|
|
|
return $ PF.isDirectory fs
|
|
|
|
|
|
|
|
|
|
|
|
-- |Checks whether a file or folder is writable.
|
|
|
|
isWritable :: Path Abs -> IO Bool
|
|
|
|
isWritable fp =
|
|
|
|
handleIOError (\_ -> return False) $
|
|
|
|
fileAccess (fromAbs fp) False True False
|
|
|
|
|
|
|
|
|
|
|
|
-- |Checks whether the directory at the given path exists and can be
|
|
|
|
-- opened. This invokes `openDirStream` which follows symlinks.
|
|
|
|
canOpenDirectory :: Path Abs -> IO Bool
|
|
|
|
canOpenDirectory fp =
|
|
|
|
handleIOError (\_ -> return False) $ do
|
|
|
|
bracket (PFD.openDirStream . fromAbs $ fp)
|
|
|
|
PFD.closeDirStream
|
|
|
|
(\_ -> return ())
|
|
|
|
return True
|
|
|
|
|
|
|
|
|
2016-05-10 00:02:05 +00:00
|
|
|
-- |Throws a `Can'tOpenDirectory` HPathIOException if the directory at the given
|
2016-05-09 14:53:31 +00:00
|
|
|
-- path cannot be opened.
|
|
|
|
throwCantOpenDirectory :: Path Abs -> IO ()
|
|
|
|
throwCantOpenDirectory fp =
|
|
|
|
unlessM (canOpenDirectory fp)
|
|
|
|
(throwIO . Can'tOpenDirectory . fromAbs $ fp)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
--------------------------------
|
|
|
|
--[ Error handling functions ]--
|
|
|
|
--------------------------------
|
|
|
|
|
|
|
|
|
|
|
|
-- |Carries out an action, then checks if there is an IOException and
|
|
|
|
-- a specific errno. If so, then it carries out another action, otherwise
|
|
|
|
-- it rethrows the error.
|
|
|
|
catchErrno :: [Errno] -- ^ errno to catch
|
|
|
|
-> IO a -- ^ action to try, which can raise an IOException
|
|
|
|
-> IO a -- ^ action to carry out in case of an IOException and
|
|
|
|
-- if errno matches
|
|
|
|
-> IO a
|
|
|
|
catchErrno en a1 a2 =
|
|
|
|
catchIOError a1 $ \e -> do
|
|
|
|
errno <- getErrno
|
|
|
|
if errno `elem` en
|
|
|
|
then a2
|
|
|
|
else ioError e
|
|
|
|
|
|
|
|
|
|
|
|
-- |Execute the given action and retrow IO exceptions as a new Exception
|
|
|
|
-- that have the given errno. If errno does not match the exception is rethrown
|
|
|
|
-- as is.
|
|
|
|
rethrowErrnoAs :: Exception e
|
|
|
|
=> [Errno] -- ^ errno to catch
|
|
|
|
-> e -- ^ rethrow as if errno matches
|
|
|
|
-> IO a -- ^ action to try
|
|
|
|
-> IO a
|
|
|
|
rethrowErrnoAs en fmex action = catchErrno en action (throwIO fmex)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- |Like `catchIOError`, with arguments swapped.
|
|
|
|
handleIOError :: (IOError -> IO a) -> IO a -> IO a
|
|
|
|
handleIOError = flip catchIOError
|
|
|
|
|
|
|
|
|
|
|
|
-- |Like `bracket`, but allows to have different clean-up
|
|
|
|
-- actions depending on whether the in-between computation
|
|
|
|
-- has raised an exception or not.
|
|
|
|
bracketeer :: IO a -- ^ computation to run first
|
|
|
|
-> (a -> IO b) -- ^ computation to run last, when
|
|
|
|
-- no exception was raised
|
|
|
|
-> (a -> IO b) -- ^ computation to run last,
|
|
|
|
-- when an exception was raised
|
|
|
|
-> (a -> IO c) -- ^ computation to run in-between
|
|
|
|
-> IO c
|
|
|
|
bracketeer before after afterEx thing =
|
|
|
|
mask $ \restore -> do
|
|
|
|
a <- before
|
|
|
|
r <- restore (thing a) `onException` afterEx a
|
|
|
|
_ <- after a
|
|
|
|
return r
|
|
|
|
|
|
|
|
|
|
|
|
reactOnError :: IO a
|
2016-05-10 00:02:05 +00:00
|
|
|
-> [(IOErrorType, IO a)] -- ^ reaction on IO errors
|
|
|
|
-> [(HPathIOException, IO a)] -- ^ reaction on HPathIOException
|
2016-05-09 14:53:31 +00:00
|
|
|
-> IO a
|
|
|
|
reactOnError a ios fmios =
|
|
|
|
a `catches` [iohandler, fmiohandler]
|
|
|
|
where
|
|
|
|
iohandler = Handler $
|
|
|
|
\(ex :: IOException) ->
|
|
|
|
foldr (\(t, a') y -> if ioeGetErrorType ex == t
|
|
|
|
then a'
|
|
|
|
else y)
|
|
|
|
(throwIO ex)
|
|
|
|
ios
|
|
|
|
fmiohandler = Handler $
|
|
|
|
\(ex :: HPathIOException) ->
|
|
|
|
foldr (\(t, a') y -> if toConstr ex == toConstr t
|
|
|
|
then a'
|
|
|
|
else y)
|
|
|
|
(throwIO ex)
|
|
|
|
fmios
|