diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,5 @@ +0.8.1 + * add 'readFile', 'readFileEOF', 'writeFile' and 'appendFile' 0.8.0 * 'copyDirRecursiveOverwrite', 'copyFileOverwrite', 'easyCopyOverwrite' and 'moveFileOverwrite' have been removed, instead use the versions without the *Overwrite suffix and pass in 'Strict' (for default behavior) or 'Overwrite' as the CopyMode argument * introduced a new 'RecursiveErrorMode' type to allow controlling recursive behavior of 'copyDirRecursive' (use 'FailEarly' for default behavior) diff --git a/hpath.cabal b/hpath.cabal --- a/hpath.cabal +++ b/hpath.cabal @@ -1,5 +1,5 @@ name: hpath -version: 0.8.0 +version: 0.8.1 synopsis: Support for well-typed paths description: Support for well-typed paths, utilizing ByteString under the hood. license: BSD3 @@ -27,13 +27,13 @@ exposed-modules: HPath, HPath.IO, HPath.IO.Errors, - HPath.IO.Utils, System.Posix.Directory.Foreign, System.Posix.Directory.Traversals, System.Posix.FD, System.Posix.FilePath other-modules: HPath.Internal build-depends: base >= 4.2 && <5 + , IfElse , bytestring >= 0.9.2.0 , deepseq , exceptions @@ -82,6 +82,7 @@ HPath.IO.CopyFileOverwriteSpec HPath.IO.CopyFileSpec HPath.IO.CreateDirSpec + HPath.IO.CreateDirRecursiveSpec HPath.IO.CreateRegularFileSpec HPath.IO.CreateSymlinkSpec HPath.IO.DeleteDirRecursiveSpec @@ -99,6 +100,7 @@ GHC-Options: -Wall Build-Depends: base , HUnit + , IfElse , bytestring , hpath , hspec >= 1.3 diff --git a/src/HPath.hs b/src/HPath.hs --- a/src/HPath.hs +++ b/src/HPath.hs @@ -314,10 +314,6 @@ -- | Extract the directory name of a path. -- --- The following properties hold: --- --- @dirname (p \<\/> a) == dirname p@ --- -- >>> dirname (MkPath "/abc/def/dod") -- "/abc/def" -- >>> dirname (MkPath "/") @@ -335,6 +331,8 @@ -- Throws: `PathException` if given the root path "/" -- -- >>> basename (MkPath "/abc/def/dod") :: Maybe (Path Fn) +-- Just "dod" +-- >>> basename (MkPath "/abc/def/dod/") :: Maybe (Path Fn) -- Just "dod" -- >>> basename (MkPath "/") :: Maybe (Path Fn) -- Nothing diff --git a/src/HPath/IO.hs b/src/HPath/IO.hs --- a/src/HPath/IO.hs +++ b/src/HPath/IO.hs @@ -55,10 +55,17 @@ -- * File creation , createRegularFile , createDir + , createDirRecursive , createSymlink -- * File renaming/moving , renameFile , moveFile + -- * File reading + , readFile + , readFileEOF + -- * File writing + , writeFile + , appendFile -- * File permissions , newFilePerms , newDirPerms @@ -88,10 +95,25 @@ , void , when ) +import Control.Monad.IfElse + ( + unlessM + ) import Data.ByteString ( ByteString ) +import Data.ByteString.Builder + ( + Builder + , byteString + , toLazyByteString + ) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Unsafe + ( + unsafePackCStringFinalizer + ) import Data.Foldable ( for_ @@ -107,6 +129,10 @@ ( catMaybes ) +import Data.Monoid + ( + (<>) + ) import Data.Word ( Word8 @@ -115,9 +141,11 @@ ( eEXIST , eINVAL + , eNOENT , eNOSYS , eNOTEMPTY , eXDEV + , getErrno ) import Foreign.C.Types ( @@ -138,7 +166,7 @@ import HPath import HPath.Internal import HPath.IO.Errors -import Prelude hiding (readFile) +import Prelude hiding (appendFile, readFile, writeFile) import System.IO.Error ( catchIOError @@ -219,7 +247,7 @@ --- |The error mode for any recursive operation. +-- |The error mode for recursive operations. -- -- On `FailEarly` the whole operation fails immediately if any of the -- recursive sub-operations fail, which is sort of the default @@ -227,7 +255,9 @@ -- -- On `CollectFailures` skips errors in the recursion and keeps on recursing. -- However all errors are collected in the `RecursiveFailure` error type, --- which is raised finally if there was any error. +-- which is raised finally if there was any error. Also note that +-- `RecursiveFailure` does not give any guarantees on the ordering +-- of the collected exceptions. data RecursiveErrorMode = FailEarly | CollectFailures @@ -247,12 +277,13 @@ --- |Copies the contents of a directory recursively to the given destination. --- Does not follow symbolic links. This behaves more or less like: +-- |Copies the contents of a directory recursively to the given destination, while preserving permissions. +-- Does not follow symbolic links. This behaves more or less like +-- the following, without descending into the destination if it +-- already exists: -- -- @ --- mkdir \/destination\/dir --- cp -R \/source\/dir\/* \/destination\/dir\/ +-- cp -a \/source\/dir \/destination\/somedir -- @ -- -- For directory contents, this will ignore any file type that is not @@ -263,9 +294,6 @@ -- the operation has completed. Permissions of existing directories are -- fixed. -- --- Note that there is no guaranteed ordering of the exceptions --- contained within `RecursiveFailure` in `CollectFailures` RecursiveErrorMode. --- -- Safety/reliability concerns: -- -- * not atomic @@ -298,8 +326,8 @@ -- Throws in `Strict` CopyMode only: -- -- - `AlreadyExists` if destination already exists -copyDirRecursive :: Path Abs -- ^ copy contents of this source dir - -> Path Abs -- ^ to this full destination (parent dirs +copyDirRecursive :: Path Abs -- ^ source dir + -> Path Abs -- ^ destination (parent dirs -- are not automatically created) -> CopyMode -> RecursiveErrorMode @@ -315,41 +343,56 @@ unless (null collectedExceptions) (throwIO . RecursiveFailure $ collectedExceptions) where - go :: IORef [IOException] -> Path Abs -> Path Abs -> IO () + go :: IORef [(RecursiveFailureHint, IOException)] + -> Path Abs -> Path Abs -> IO () go ce fromp' destdirp' = do - -- order is important here, so we don't get empty directories + -- NOTE: order is important here, so we don't get empty directories -- on failure - contents <- handleIOE ce [] $ do + + -- get the contents of the source dir + contents <- handleIOE (ReadContentsFailed fromp' destdirp') ce [] $ do contents <- getDirsFiles fromp' - fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fromAbs fromp') - case cm of - Strict -> createDirectory (fromAbs destdirp') fmode' - Overwrite -> catchIOError (createDirectory (fromAbs destdirp') - fmode') - $ \e -> - case ioeGetErrorType e of - AlreadyExists -> setFileMode (fromAbs destdirp') - fmode' - _ -> ioError e - return contents + -- create the destination dir and + -- only return contents if we succeed + handleIOE (CreateDirFailed fromp' destdirp') ce [] $ do + fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fromAbs fromp') + case cm of + Strict -> createDirectory (fromAbs destdirp') fmode' + Overwrite -> catchIOError (createDirectory (fromAbs destdirp') + fmode') + $ \e -> + case ioeGetErrorType e of + AlreadyExists -> setFileMode (fromAbs destdirp') + fmode' + _ -> ioError e + return contents - -- we can't use `easyCopy` here, because we want to call `go` + -- NOTE: we can't use `easyCopy` here, because we want to call `go` -- recursively to skip the top-level sanity checks + + -- if reading the contents and creating the destination dir worked, + -- then copy the contents to the destination too for_ contents $ \f -> do ftype <- getFileType f newdest <- (destdirp' ) <$> basename f case ftype of - SymbolicLink -> handleIOE ce () + SymbolicLink -> handleIOE (RecreateSymlinkFailed f newdest) ce () $ recreateSymlink f newdest cm Directory -> go ce f newdest - RegularFile -> handleIOE ce () $ copyFile f newdest cm + RegularFile -> handleIOE (CopyFileFailed f newdest) ce () + $ copyFile f newdest cm _ -> return () - handleIOE :: IORef [IOException] -> a -> IO a -> IO a - handleIOE ce def = case rm of - FailEarly -> handleIOError throwIO - CollectFailures -> handleIOError (\e -> modifyIORef ce (e:) + + -- helper to handle errors for both RecursiveErrorModes and return a + -- default value + handleIOE :: RecursiveFailureHint + -> IORef [(RecursiveFailureHint, IOException)] + -> a -> IO a -> IO a + handleIOE hint ce def = case rm of + FailEarly -> handleIOError throwIO + CollectFailures -> handleIOError (\e -> modifyIORef ce ((hint, e):) >> return def) @@ -372,7 +415,7 @@ -- -- Throws in `Strict` mode only: -- --- - `AlreadyExists` if destination file already exists +-- - `AlreadyExists` if destination already exists -- -- Throws in `Overwrite` mode only: -- @@ -505,8 +548,8 @@ if size == 0 then return $ fromIntegral totalsize else do rsize <- SPB.fdWriteBuf dfd buf size - when (rsize /= size) (throwIO . CopyFailed - $ "wrong size!") + when (rsize /= size) (ioError $ userError + "wrong size!") write' sfd dfd buf (totalsize + fromIntegral size) @@ -660,7 +703,9 @@ -- Throws: -- -- - `PermissionDenied` if output directory cannot be written to --- - `AlreadyExists` if destination file already exists +-- - `AlreadyExists` if destination already exists +-- - `NoSuchThing` if any of the parent components of the path +-- do not exist createRegularFile :: FileMode -> Path Abs -> IO () createRegularFile fm dest = bracket (SPI.openFd (fromAbs dest) SPI.WriteOnly (Just fm) @@ -674,17 +719,50 @@ -- Throws: -- -- - `PermissionDenied` if output directory cannot be written to --- - `AlreadyExists` if destination directory already exists +-- - `AlreadyExists` if destination already exists +-- - `NoSuchThing` if any of the parent components of the path +-- do not exist createDir :: FileMode -> Path Abs -> IO () createDir fm dest = createDirectory (fromAbs dest) fm +-- |Create an empty directory at the given directory with the given filename. +-- All parent directories are created with the same filemode. This +-- basically behaves like: +-- +-- @ +-- mkdir -p \/some\/dir +-- @ +-- +-- Safety/reliability concerns: +-- +-- * not atomic +-- +-- Throws: +-- +-- - `PermissionDenied` if any part of the path components do not +-- exist and cannot be written to +-- - `AlreadyExists` if destination already exists and +-- is not a directory +createDirRecursive :: FileMode -> Path Abs -> IO () +createDirRecursive fm dest = + catchIOError (createDirectory (fromAbs dest) fm) $ \e -> do + errno <- getErrno + case errno of + en | en == eEXIST -> unlessM (doesDirectoryExist dest) (ioError e) + | en == eNOENT -> createDirRecursive fm (dirname dest) + >> createDirectory (fromAbs dest) fm + | otherwise -> ioError e + + -- |Create a symlink. -- -- Throws: -- -- - `PermissionDenied` if output directory cannot be written to -- - `AlreadyExists` if destination file already exists +-- - `NoSuchThing` if any of the parent components of the path +-- do not exist -- -- Note: calls `symlink` createSymlink :: Path Abs -- ^ destination file @@ -716,10 +794,7 @@ -- - `PermissionDenied` if source directory cannot be opened -- - `UnsupportedOperation` if source and destination are on different -- devices --- - `FileDoesExist` if destination file already exists --- (`HPathIOException`) --- - `DirDoesExist` if destination directory already exists --- (`HPathIOException`) +-- - `AlreadyExists` if destination already exists -- - `SameFile` if destination and source are the same file -- (`HPathIOException`) -- @@ -758,9 +833,7 @@ -- -- Throws in `Strict` mode only: -- --- - `FileDoesExist` if destination file already exists (`HPathIOException`) --- - `DirDoesExist` if destination directory already exists --- (`HPathIOException`) +-- - `AlreadyExists` if destination already exists -- -- Note: calls `rename` (but does not allow to rename over existing files) moveFile :: Path Abs -- ^ file to move @@ -790,6 +863,110 @@ moveFile from to Strict + + + + -------------------- + --[ File Reading ]-- + -------------------- + + +-- |Read the given file at once into memory as a strict ByteString. +-- Symbolic links are followed, no sanity checks on file size +-- or file type. File must exist. +-- +-- Note: the size of the file is determined in advance, as to only +-- have one allocation. +-- +-- Safety/reliability concerns: +-- +-- * since amount of bytes to read is determined in advance, +-- the file might be read partially only if something else is +-- appending to it while reading +-- * the whole file is read into memory! +-- +-- Throws: +-- +-- - `InappropriateType` if file is not a regular file or a symlink +-- - `PermissionDenied` if we cannot read the file or the directory +-- containting it +-- - `NoSuchThing` if the file does not exist +readFile :: Path Abs -> IO ByteString +readFile p = withAbsPath p $ \fp -> + bracket (openFd fp SPI.ReadOnly [] Nothing) (SPI.closeFd) $ \fd -> do + stat <- PF.getFdStatus fd + let fsize = PF.fileSize stat + SPB.fdRead fd (fromIntegral fsize) + + +-- |Read the given file in chunks of size `8192` into memory until +-- `fread` returns 0. Returns a lazy ByteString, because it uses +-- Builders under the hood. +-- +-- Safety/reliability concerns: +-- +-- * the whole file is read into memory! +-- +-- Throws: +-- +-- - `InappropriateType` if file is not a regular file or a symlink +-- - `PermissionDenied` if we cannot read the file or the directory +-- containting it +-- - `NoSuchThing` if the file does not exist +readFileEOF :: Path Abs -> IO L.ByteString +readFileEOF p = withAbsPath p $ \fp -> + bracket (openFd fp SPI.ReadOnly [] Nothing) (SPI.closeFd) $ \fd -> + allocaBytes (fromIntegral bufSize) $ \buf -> read' fd buf mempty + where + bufSize :: CSize + bufSize = 8192 + read' :: Fd -> Ptr Word8 -> Builder -> IO L.ByteString + read' fd buf builder = do + size <- SPB.fdReadBuf fd buf bufSize + if size == 0 + then return $ toLazyByteString builder + else do + readBS <- unsafePackCStringFinalizer buf + (fromIntegral size) + mempty + read' fd buf (builder <> byteString readBS) + + + + + -------------------- + --[ File Writing ]-- + -------------------- + + +-- |Write a given ByteString to a file, truncating the file beforehand. +-- The file must exist. Follows symlinks. +-- +-- Throws: +-- +-- - `InappropriateType` if file is not a regular file or a symlink +-- - `PermissionDenied` if we cannot read the file or the directory +-- containting it +-- - `NoSuchThing` if the file does not exist +writeFile :: Path Abs -> ByteString -> IO () +writeFile p bs = withAbsPath p $ \fp -> + bracket (openFd fp SPI.WriteOnly [SPDF.oTrunc] Nothing) (SPI.closeFd) $ \fd -> + void $ SPB.fdWrite fd bs + + +-- |Append a given ByteString to a file. +-- The file must exist. Follows symlinks. +-- +-- Throws: +-- +-- - `InappropriateType` if file is not a regular file or a symlink +-- - `PermissionDenied` if we cannot read the file or the directory +-- containting it +-- - `NoSuchThing` if the file does not exist +appendFile :: Path Abs -> ByteString -> IO () +appendFile p bs = withAbsPath p $ \fp -> + bracket (openFd fp SPI.WriteOnly [SPDF.oAppend] Nothing) + (SPI.closeFd) $ \fd -> void $ SPB.fdWrite fd bs diff --git a/src/HPath/IO/Errors.hs b/src/HPath/IO/Errors.hs --- a/src/HPath/IO/Errors.hs +++ b/src/HPath/IO/Errors.hs @@ -16,24 +16,20 @@ ( -- * Types HPathIOException(..) + , RecursiveFailureHint(..) -- * Exception identifiers - , isFileDoesNotExist - , isDirDoesNotExist , isSameFile , isDestinationInSource - , isFileDoesExist - , isDirDoesExist - , isInvalidOperation - , isCan'tOpenDirectory - , isCopyFailed , isRecursiveFailure + , isReadContentsFailed + , isCreateDirFailed + , isCopyFileFailed + , isRecreateSymlinkFailed -- * Path based functions , throwFileDoesExist , throwDirDoesExist - , throwFileDoesNotExist - , throwDirDoesNotExist , throwSameFile , sameFile , throwDestinationInSource @@ -41,7 +37,6 @@ , doesDirectoryExist , isWritable , canOpenDirectory - , throwCantOpenDirectory -- * Error handling functions , catchErrno @@ -63,6 +58,10 @@ forM , when ) +import Control.Monad.IfElse + ( + whenM + ) import Data.ByteString ( ByteString @@ -72,6 +71,9 @@ toString ) import Data.Typeable + ( + Typeable + ) import Foreign.C.Error ( getErrno @@ -86,11 +88,12 @@ ( canonicalizePath ) -import HPath.IO.Utils import System.IO.Error ( - catchIOError + alreadyExistsErrorType + , catchIOError , ioeGetErrorType + , mkIOError ) import qualified System.Posix.Directory.ByteString as PFD @@ -102,55 +105,34 @@ import qualified System.Posix.Files.ByteString as PF -data HPathIOException = FileDoesNotExist ByteString - | DirDoesNotExist ByteString - | SameFile ByteString ByteString +-- |Additional generic IO exceptions that the posix functions +-- do not provide. +data HPathIOException = SameFile ByteString ByteString | DestinationInSource ByteString ByteString - | FileDoesExist ByteString - | DirDoesExist ByteString - | InvalidOperation String - | Can'tOpenDirectory ByteString - | CopyFailed String - | RecursiveFailure [IOException] - deriving (Typeable, Eq) - - -instance Show HPathIOException where - show (FileDoesNotExist fp) = "File does not exist:" ++ toString fp - show (DirDoesNotExist fp) = "Directory does not exist: " - ++ toString fp - show (SameFile fp1 fp2) = toString fp1 - ++ " and " ++ toString fp2 - ++ " are the same file!" - show (DestinationInSource fp1 fp2) = toString fp1 - ++ " is contained in " - ++ toString fp2 - show (FileDoesExist fp) = "File does exist: " ++ toString fp - show (DirDoesExist fp) = "Directory does exist: " ++ toString fp - show (InvalidOperation str) = "Invalid operation: " ++ str - show (Can'tOpenDirectory fp) = "Can't open directory: " - ++ toString fp - show (CopyFailed str) = "Copying failed: " ++ str - show (RecursiveFailure exs) = "Recursive operation failed: " - ++ show exs + | RecursiveFailure [(RecursiveFailureHint, IOException)] + deriving (Eq, Show, Typeable) -toConstr :: HPathIOException -> String -toConstr FileDoesNotExist {} = "FileDoesNotExist" -toConstr DirDoesNotExist {} = "DirDoesNotExist" -toConstr SameFile {} = "SameFile" -toConstr DestinationInSource {} = "DestinationInSource" -toConstr FileDoesExist {} = "FileDoesExist" -toConstr DirDoesExist {} = "DirDoesExist" -toConstr InvalidOperation {} = "InvalidOperation" -toConstr Can'tOpenDirectory {} = "Can'tOpenDirectory" -toConstr CopyFailed {} = "CopyFailed" -toConstr RecursiveFailure {} = "RecursiveFailure" +-- |A type for giving failure hints on recursive failure, which allows +-- to programmatically make choices without examining +-- the weakly typed I/O error attributes (like `ioeGetFileName`). +-- +-- The first argument to the data constructor is always the +-- source and the second the destination. +data RecursiveFailureHint = ReadContentsFailed (Path Abs) (Path Abs) + | CreateDirFailed (Path Abs) (Path Abs) + | CopyFileFailed (Path Abs) (Path Abs) + | RecreateSymlinkFailed (Path Abs) (Path Abs) + deriving (Eq, Show) +instance Exception HPathIOException -instance Exception HPathIOException +toConstr :: HPathIOException -> String +toConstr SameFile {} = "SameFile" +toConstr DestinationInSource {} = "DestinationInSource" +toConstr RecursiveFailure {} = "RecursiveFailure" @@ -160,47 +142,54 @@ --[ Exception identifiers ]-- ----------------------------- -isFileDoesNotExist, isDirDoesNotExist, isSameFile, isDestinationInSource, isFileDoesExist, isDirDoesExist, isInvalidOperation, isCan'tOpenDirectory, isCopyFailed, isRecursiveFailure :: HPathIOException -> Bool -isFileDoesNotExist ex = toConstr (ex :: HPathIOException) == toConstr FileDoesNotExist{} -isDirDoesNotExist ex = toConstr (ex :: HPathIOException) == toConstr DirDoesNotExist{} + +isSameFile, isDestinationInSource, isRecursiveFailure :: HPathIOException -> Bool 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{} isRecursiveFailure ex = toConstr (ex :: HPathIOException) == toConstr RecursiveFailure{} +isReadContentsFailed, isCreateDirFailed, isCopyFileFailed, isRecreateSymlinkFailed ::RecursiveFailureHint -> Bool +isReadContentsFailed ReadContentsFailed{} = True +isReadContentsFailed _ = False +isCreateDirFailed CreateDirFailed{} = True +isCreateDirFailed _ = False +isCopyFileFailed CopyFileFailed{} = True +isCopyFileFailed _ = False +isRecreateSymlinkFailed RecreateSymlinkFailed{} = True +isRecreateSymlinkFailed _ = False + + + + ---------------------------- --[ Path based functions ]-- ---------------------------- +-- |Throws `AlreadyExists` `IOError` if file exists. throwFileDoesExist :: Path Abs -> IO () throwFileDoesExist fp = - whenM (doesFileExist fp) (throwIO . FileDoesExist - . fromAbs $ fp) + whenM (doesFileExist fp) + (ioError . mkIOError + alreadyExistsErrorType + "File already exists" + Nothing + $ (Just (toString $ fromAbs fp)) + ) +-- |Throws `AlreadyExists` `IOError` if directory exists. 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) + whenM (doesDirectoryExist fp) + (ioError . mkIOError + alreadyExistsErrorType + "Directory already exists" + Nothing + $ (Just (toString $ fromAbs fp)) + ) -- |Uses `isSameFile` and throws `SameFile` if it returns True. @@ -285,15 +274,8 @@ return True --- |Throws a `Can'tOpenDirectory` HPathIOException if the directory at the given --- path cannot be opened. -throwCantOpenDirectory :: Path Abs -> IO () -throwCantOpenDirectory fp = - unlessM (canOpenDirectory fp) - (throwIO . Can'tOpenDirectory . fromAbs $ fp) - -------------------------------- --[ Error handling functions ]-- -------------------------------- @@ -371,3 +353,4 @@ else y) (throwIO ex) fmios + diff --git a/src/HPath/IO/Utils.hs b/src/HPath/IO/Utils.hs deleted file mode 100644 --- a/src/HPath/IO/Utils.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | --- Module : HPath.IO.Utils --- Copyright : © 2016 Julian Ospald --- License : BSD3 --- --- Maintainer : Julian Ospald --- Stability : experimental --- Portability : portable --- --- Random and general IO/monad utilities. - - -module HPath.IO.Utils where - - -import Control.Monad - ( - when - , unless - ) - - --- |If the value of the first argument is True, then execute the action --- provided in the second argument, otherwise do nothing. -whenM :: Monad m => m Bool -> m () -> m () -whenM mb a = mb >>= (`when` a) - - --- |If the value of the first argument is False, then execute the action --- provided in the second argument, otherwise do nothing. -unlessM :: Monad m => m Bool -> m () -> m () -unlessM mb a = mb >>= (`unless` a) diff --git a/test/HPath/IO/CopyDirRecursiveCollectFailuresSpec.hs b/test/HPath/IO/CopyDirRecursiveCollectFailuresSpec.hs --- a/test/HPath/IO/CopyDirRecursiveCollectFailuresSpec.hs +++ b/test/HPath/IO/CopyDirRecursiveCollectFailuresSpec.hs @@ -157,8 +157,10 @@ CollectFailures `shouldThrow` (\(RecursiveFailure ex@[_, _]) -> - any (\e -> ioeGetErrorType e == InappropriateType) ex && - any (\e -> ioeGetErrorType e == PermissionDenied) ex) + any (\(h, e) -> ioeGetErrorType e == InappropriateType + && isCopyFileFailed h) ex && + any (\(h, e) -> ioeGetErrorType e == PermissionDenied + && isReadContentsFailed h) ex) normalDirPerms "outputDir1/foo2/foo4" normalDirPerms "outputDir1/foo2/foo4/inputFile4" c <- allDirectoryContents' "outputDir1" @@ -184,7 +186,7 @@ Strict CollectFailures `shouldThrow` - (\(RecursiveFailure [e]) -> ioeGetErrorType e == PermissionDenied) + (\(RecursiveFailure [(CreateDirFailed{}, e)]) -> ioeGetErrorType e == PermissionDenied) it "copyDirRecursive (Strict, CollectFailures), cannot open output dir" $ copyDirRecursive' "inputDir" @@ -200,7 +202,7 @@ Strict CollectFailures `shouldThrow` - (\(RecursiveFailure [e]) -> ioeGetErrorType e == AlreadyExists) + (\(RecursiveFailure [(CreateDirFailed{}, e)]) -> ioeGetErrorType e == AlreadyExists) it "copyDirRecursive (Strict, CollectFailures), destination already exists and is a file" $ copyDirRecursive' "inputDir" @@ -216,7 +218,7 @@ Strict CollectFailures `shouldThrow` - (\(RecursiveFailure [e]) -> ioeGetErrorType e == InappropriateType) + (\(RecursiveFailure [(ReadContentsFailed{}, e)]) -> ioeGetErrorType e == InappropriateType) it "copyDirRecursive (Strict, CollectFailures), wrong input (symlink to directory)" $ copyDirRecursive' "wrongInputSymL" @@ -224,7 +226,7 @@ Strict CollectFailures `shouldThrow` - (\(RecursiveFailure [e]) -> ioeGetErrorType e == InvalidArgument) + (\(RecursiveFailure [(ReadContentsFailed{}, e)]) -> ioeGetErrorType e == InvalidArgument) it "copyDirRecursive (Strict, CollectFailures), destination in source" $ copyDirRecursive' "inputDir" diff --git a/test/HPath/IO/CreateDirRecursiveSpec.hs b/test/HPath/IO/CreateDirRecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CreateDirRecursiveSpec.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.CreateDirRecursiveSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CreateDirRecursiveSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createDir' "alreadyExists" + createRegularFile' "alreadyExistsF" + createDir' "noPerms" + createDir' "noWritePerms" + noPerms "noPerms" + noWritableDirPerms "noWritePerms" + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerms" + deleteDir' "alreadyExists" + deleteDir' "noPerms" + deleteDir' "noWritePerms" + deleteFile' "alreadyExistsF" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "HPath.IO.createDirRecursive" $ do + + -- successes -- + it "createDirRecursive, all fine" $ do + createDirRecursive' "newDir" + deleteDir' "newDir" + + it "createDirRecursive, parent directories do not exist" $ do + createDirRecursive' "some/thing/dada" + deleteDir' "some/thing/dada" + deleteDir' "some/thing" + deleteDir' "some" + + it "createDirRecursive, destination directory already exists" $ + createDirRecursive' "alreadyExists" + + -- posix failures -- + it "createDirRecursive, destination already exists and is a file" $ + createDirRecursive' "alreadyExistsF" + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "createDirRecursive, can't write to output directory" $ + createDirRecursive' "noWritePerms/newDir" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createDirRecursive, can't open output directory" $ + createDirRecursive' "noPerms/newDir" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + + diff --git a/test/HPath/IO/CreateDirSpec.hs b/test/HPath/IO/CreateDirSpec.hs --- a/test/HPath/IO/CreateDirSpec.hs +++ b/test/HPath/IO/CreateDirSpec.hs @@ -50,6 +50,11 @@ removeDirIfExists "newDir" -- posix failures -- + it "createDir, parent directories do not exist" $ + createDir' "some/thing/dada" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + it "createDir, can't write to output directory" $ createDir' "noWritePerms/newDir" `shouldThrow` diff --git a/test/HPath/IO/CreateRegularFileSpec.hs b/test/HPath/IO/CreateRegularFileSpec.hs --- a/test/HPath/IO/CreateRegularFileSpec.hs +++ b/test/HPath/IO/CreateRegularFileSpec.hs @@ -48,6 +48,11 @@ removeFileIfExists "newDir" -- posix failures -- + it "createRegularFile, parent directories do not exist" $ + createRegularFile' "some/thing/dada" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + it "createRegularFile, can't write to destination directory" $ createRegularFile' "noWritePerms/newDir" `shouldThrow` diff --git a/test/HPath/IO/CreateSymlinkSpec.hs b/test/HPath/IO/CreateSymlinkSpec.hs --- a/test/HPath/IO/CreateSymlinkSpec.hs +++ b/test/HPath/IO/CreateSymlinkSpec.hs @@ -49,6 +49,11 @@ removeFileIfExists "newSymL" -- posix failures -- + it "createSymlink, parent directories do not exist" $ + createSymlink' "some/thing/dada" "lala" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + it "createSymlink, can't write to destination directory" $ createSymlink' "noWritePerms/newDir" "lala" `shouldThrow` diff --git a/test/HPath/IO/MoveFileOverwriteSpec.hs b/test/HPath/IO/MoveFileOverwriteSpec.hs --- a/test/HPath/IO/MoveFileOverwriteSpec.hs +++ b/test/HPath/IO/MoveFileOverwriteSpec.hs @@ -116,7 +116,7 @@ "alreadyExistsD" Overwrite `shouldThrow` - isDirDoesExist + (\e -> ioeGetErrorType e == AlreadyExists) it "moveFile (Overwrite), source and dest are same file" $ moveFile' "myFile" diff --git a/test/HPath/IO/MoveFileSpec.hs b/test/HPath/IO/MoveFileSpec.hs --- a/test/HPath/IO/MoveFileSpec.hs +++ b/test/HPath/IO/MoveFileSpec.hs @@ -112,14 +112,14 @@ "alreadyExists" Strict `shouldThrow` - isFileDoesExist + (\e -> ioeGetErrorType e == AlreadyExists) it "moveFile (Strict), move from file to dir" $ moveFile' "myFile" "alreadyExistsD" Strict `shouldThrow` - isDirDoesExist + (\e -> ioeGetErrorType e == AlreadyExists) it "moveFile (Strict), source and dest are same file" $ moveFile' "myFile" diff --git a/test/HPath/IO/RenameFileSpec.hs b/test/HPath/IO/RenameFileSpec.hs --- a/test/HPath/IO/RenameFileSpec.hs +++ b/test/HPath/IO/RenameFileSpec.hs @@ -101,13 +101,13 @@ renameFile' "myFile" "alreadyExists" `shouldThrow` - isFileDoesExist + (\e -> ioeGetErrorType e == AlreadyExists) it "renameFile, move from file to dir" $ renameFile' "myFile" "alreadyExistsD" `shouldThrow` - isDirDoesExist + (\e -> ioeGetErrorType e == AlreadyExists) it "renameFile, source and dest are same file" $ renameFile' "myFile" diff --git a/test/Utils.hs b/test/Utils.hs --- a/test/Utils.hs +++ b/test/Utils.hs @@ -14,6 +14,10 @@ forM_ , void ) +import Control.Monad.IfElse + ( + whenM + ) import qualified Data.ByteString as BS import Data.IORef ( @@ -24,7 +28,7 @@ ) import HPath.IO import HPath.IO.Errors -import HPath.IO.Utils +import Prelude hiding (appendFile, readFile, writeFile) import Data.Maybe ( fromJust @@ -43,6 +47,7 @@ ( ByteString ) +import qualified Data.ByteString.Lazy as L import System.Posix.Files.ByteString ( groupExecuteMode @@ -179,6 +184,9 @@ {-# NOINLINE createDir' #-} createDir' dest = withTmpDir dest (createDir newDirPerms) +createDirRecursive' :: ByteString -> IO () +{-# NOINLINE createDirRecursive' #-} +createDirRecursive' dest = withTmpDir dest (createDirRecursive newDirPerms) createRegularFile' :: ByteString -> IO () {-# NOINLINE createRegularFile' #-} @@ -237,6 +245,12 @@ withTmpDir path $ \p -> setFileMode (P.fromAbs p) newDirPerms +normalFilePerms :: ByteString -> IO () +{-# NOINLINE normalFilePerms #-} +normalFilePerms path = + withTmpDir path $ \p -> setFileMode (P.fromAbs p) newFilePerms + + getFileType' :: ByteString -> IO FileType {-# NOINLINE getFileType' #-} getFileType' path = withTmpDir path getFileType @@ -270,15 +284,27 @@ writeFile' :: ByteString -> ByteString -> IO () {-# NOINLINE writeFile' #-} writeFile' ip bs = - withTmpDir ip $ \p -> do - fd <- SPI.openFd (P.fromAbs p) SPI.WriteOnly Nothing - SPI.defaultFileFlags - _ <- SPB.fdWrite fd bs - SPI.closeFd fd + withTmpDir ip $ \p -> writeFile p bs +appendFile' :: ByteString -> ByteString -> IO () +{-# NOINLINE appendFile' #-} +appendFile' ip bs = + withTmpDir ip $ \p -> appendFile p bs + + allDirectoryContents' :: ByteString -> IO [ByteString] {-# NOINLINE allDirectoryContents' #-} allDirectoryContents' ip = withTmpDir ip $ \p -> DT.allDirectoryContents' (P.fromAbs p) + + +readFile' :: ByteString -> IO ByteString +{-# NOINLINE readFile' #-} +readFile' p = withTmpDir p readFile + + +readFileEOF' :: ByteString -> IO L.ByteString +{-# NOINLINE readFileEOF' #-} +readFileEOF' p = withTmpDir p readFileEOF