diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hpath-directory + +## 0.1.0.0 -- 2020-01-26 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020, Julian Ospald + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Julian Ospald nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/dirutils.c b/cbits/dirutils.c new file mode 100644 --- /dev/null +++ b/cbits/dirutils.c @@ -0,0 +1,7 @@ +#include "dirutils.h" +unsigned int + __posixdir_d_type(struct dirent* d) + { + return(d -> d_type); + } + diff --git a/cbits/dirutils.h b/cbits/dirutils.h new file mode 100644 --- /dev/null +++ b/cbits/dirutils.h @@ -0,0 +1,13 @@ +#ifndef POSIXPATHS_CBITS_DIRUTILS_H +#define POSIXPATHS_CBITS_DIRUTILS_H + +#include +#include +#include +#include +#include + +extern unsigned int + __posixdir_d_type(struct dirent* d) + ; +#endif diff --git a/hpath-directory.cabal b/hpath-directory.cabal new file mode 100644 --- /dev/null +++ b/hpath-directory.cabal @@ -0,0 +1,117 @@ +cabal-version: >=1.10 + +name: hpath-directory +version: 0.13.0 +synopsis: Alternative to 'directory' package with ByteString based filepaths +description: This provides a safer alternative to the 'directory' + package. FilePaths are ByteString based, so this + package only works on POSIX systems. + + For a more high-level version of this with + proper Path type, use 'hpath-io', which makes + use of this package. +homepage: https://github.com/hasufell/hpath +bug-reports: https://github.com/hasufell/hpath/issues +license: BSD3 +license-file: LICENSE +author: Julian Ospald +maintainer: Julian Ospald +copyright: Julian Ospald 2020 +category: Filesystem +build-type: Simple +extra-source-files: CHANGELOG.md + cbits/dirutils.h +tested-with: GHC==7.10.3 + , GHC==8.0.2 + , GHC==8.2.2 + , GHC==8.4.4 + , GHC==8.6.5 + , GHC==8.8.1 + +library + if os(windows) + build-depends: unbuildable<0 + buildable: False + exposed-modules: System.Posix.RawFilePath.Directory + System.Posix.RawFilePath.Directory.Errors + System.Posix.RawFilePath.Directory.Traversals + System.Posix.Foreign, + System.Posix.FD + -- other-modules: + -- other-extensions: + c-sources: cbits/dirutils.c + build-depends: base >= 4.8 && <5 + , IfElse + , bytestring >= 0.10 + , exceptions >= 0.10 + , hpath-filepath >= 0.10.3 + , safe-exceptions >= 0.1 + , streamly >= 0.7 + , streamly-bytestring >= 0.1 + , time >= 1.8 + , unix >= 2.5 + , unix-bytestring >= 0.3 + , utf8-string + if impl(ghc < 8.0) + build-depends: + fail >= 4.9 + + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: PackageImports + +test-suite spec + if os(windows) + build-depends: unbuildable<0 + buildable: False + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: test + Main-Is: Main.hs + other-modules: + System.Posix.RawFilePath.Directory.AppendFileSpec + System.Posix.RawFilePath.Directory.CanonicalizePathSpec + System.Posix.RawFilePath.Directory.CopyDirRecursiveCollectFailuresSpec + System.Posix.RawFilePath.Directory.CopyDirRecursiveOverwriteSpec + System.Posix.RawFilePath.Directory.CopyDirRecursiveSpec + System.Posix.RawFilePath.Directory.CopyFileOverwriteSpec + System.Posix.RawFilePath.Directory.CopyFileSpec + System.Posix.RawFilePath.Directory.CreateDirIfMissingSpec + System.Posix.RawFilePath.Directory.CreateDirRecursiveSpec + System.Posix.RawFilePath.Directory.CreateDirSpec + System.Posix.RawFilePath.Directory.CreateRegularFileSpec + System.Posix.RawFilePath.Directory.CreateSymlinkSpec + System.Posix.RawFilePath.Directory.DeleteDirRecursiveSpec + System.Posix.RawFilePath.Directory.DeleteDirSpec + System.Posix.RawFilePath.Directory.DeleteFileSpec + System.Posix.RawFilePath.Directory.GetDirsFilesSpec + System.Posix.RawFilePath.Directory.GetFileTypeSpec + System.Posix.RawFilePath.Directory.MoveFileOverwriteSpec + System.Posix.RawFilePath.Directory.MoveFileSpec + System.Posix.RawFilePath.Directory.ReadFileSpec + System.Posix.RawFilePath.Directory.RecreateSymlinkOverwriteSpec + System.Posix.RawFilePath.Directory.RecreateSymlinkSpec + System.Posix.RawFilePath.Directory.RenameFileSpec + System.Posix.RawFilePath.Directory.ToAbsSpec + System.Posix.RawFilePath.Directory.WriteFileLSpec + System.Posix.RawFilePath.Directory.WriteFileSpec + Spec + Utils + GHC-Options: -Wall + Build-Depends: base + , HUnit + , IfElse + , bytestring >= 0.10.0.0 + , hpath-directory + , hpath-filepath >= 0.10 + , hspec >= 1.3 + , process + , time >= 1.8 + , unix + , unix-bytestring + , utf8-string + default-extensions: PackageImports + +source-repository head + type: git + location: https://github.com/hasufell/hpath diff --git a/src/System/Posix/FD.hs b/src/System/Posix/FD.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/FD.hs @@ -0,0 +1,75 @@ +-- | +-- Module : System.Posix.FD +-- Copyright : © 2016 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- Provides an alternative for `System.Posix.IO.ByteString.openFd` +-- which gives us more control on what status flags to pass to the +-- low-level @open(2)@ call, in contrast to the unix package. + + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -Wall #-} + + +module System.Posix.FD ( + openFd +) where + + +import Foreign.C.String +import Foreign.C.Types +import System.Posix.Foreign +import qualified System.Posix as Posix +import System.Posix.ByteString.FilePath + + +foreign import ccall unsafe "open" + c_open :: CString -> CInt -> Posix.CMode -> IO CInt + + +open_ :: CString + -> Posix.OpenMode + -> [Flags] + -> Maybe Posix.FileMode + -> IO Posix.Fd +open_ str how optional_flags maybe_mode = do + fd <- c_open str all_flags mode_w + return (Posix.Fd fd) + where + all_flags = unionFlags $ optional_flags ++ [open_mode] ++ creat + + + (creat, mode_w) = case maybe_mode of + Nothing -> ([],0) + Just x -> ([oCreat], x) + + open_mode = case how of + Posix.ReadOnly -> oRdonly + Posix.WriteOnly -> oWronly + Posix.ReadWrite -> oRdwr + + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +-- +-- Note that passing @Just x@ as the 4th argument triggers the +-- `oCreat` status flag, which must be set when you pass in `oExcl` +-- to the status flags. Also see the manpage for @open(2)@. +openFd :: RawFilePath + -> Posix.OpenMode + -> [Flags] -- ^ status flags of @open(2)@ + -> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist. + -> IO Posix.Fd +openFd name how optional_flags maybe_mode = + withFilePath name $ \str -> + throwErrnoPathIfMinus1Retry "openFd" name $ + open_ str how optional_flags maybe_mode + diff --git a/src/System/Posix/Foreign.hsc b/src/System/Posix/Foreign.hsc new file mode 100644 --- /dev/null +++ b/src/System/Posix/Foreign.hsc @@ -0,0 +1,55 @@ +module System.Posix.Foreign where + +import Data.Bits +import Data.List (foldl') +import Foreign.C.Types + +#include +#include +#include +#include +#include +#include + +newtype DirType = DirType Int deriving (Eq, Show) +data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show) + +unFlags :: Flags -> Int +unFlags (Flags i) = i +unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform") + +-- |Returns @True@ if posix-paths was compiled with support for the provided +-- flag. (As of this writing, the only flag for which this check may be +-- necessary is 'oCloexec'; all other flags will always yield @True@.) +isSupported :: Flags -> Bool +isSupported (Flags _) = True +isSupported _ = False + +-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use +-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was +-- compiled into your version of posix-paths. (If not, using @oCloexec@ will +-- throw an exception.) +oCloexec :: Flags +#ifdef O_CLOEXEC +oCloexec = Flags #{const O_CLOEXEC} +#else +{-# WARNING oCloexec + "This version of posix-paths was compiled without @O_CLOEXEC@ support." #-} +oCloexec = UnsupportedFlag "O_CLOEXEC" +#endif + + + +-- If these enum declarations occur earlier in the file, haddock +-- gets royally confused about the above doc comments. +-- Probably http://trac.haskell.org/haddock/ticket/138 + +#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN} + +#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, O_SYNC, O_TRUNC} + +pathMax :: Int +pathMax = #{const PATH_MAX} + +unionFlags :: [Flags] -> CInt +unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0 diff --git a/src/System/Posix/RawFilePath/Directory.hs b/src/System/Posix/RawFilePath/Directory.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/RawFilePath/Directory.hs @@ -0,0 +1,1214 @@ +-- | +-- Module : System.Posix.RawFilePath.Directory +-- Copyright : © 2020 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- This module provides IO related file operations like +-- copy, delete, move and so on, similar to the 'directory' package. +-- +-- Some of these operations are due to their nature __not atomic__, which +-- means they may do multiple syscalls which form one context. Some +-- of them also have to examine the filetypes explicitly before the +-- syscalls, so a reasonable decision can be made. That means +-- the result is undefined if another process changes that context +-- while the non-atomic operation is still happening. However, where +-- possible, as few syscalls as possible are used and the underlying +-- exception handling is kept. +-- +-- Note: `BlockDevice`, `CharacterDevice`, `NamedPipe` and `Socket` +-- are ignored by some of the more high-level functions (like `easyCopy`). +-- For other functions (like `copyFile`), the behavior on these file types is +-- unreliable/unsafe. Check the documentation of those functions for details. +-- +-- Import as: +-- > import System.Posix.RawFilePath.Directory + +{-# LANGUAGE CPP #-} + +module System.Posix.RawFilePath.Directory + ( + -- * Types + FileType(..) + , RecursiveErrorMode(..) + , CopyMode(..) + -- * File copying + , copyDirRecursive + , recreateSymlink + , copyFile + , easyCopy + -- * File deletion + , deleteFile + , deleteDir + , deleteDirRecursive + , easyDelete + -- * File opening + , openFile + , executeFile + -- * File creation + , createRegularFile + , createDir + , createDirIfMissing + , createDirRecursive + , createSymlink + -- * File renaming/moving + , renameFile + , moveFile + -- * File reading + , readFile + , readFileStream + -- * File writing + , writeFile + , writeFileL + , appendFile + -- * File permissions + , newFilePerms + , newDirPerms + -- * File checks + , doesExist + , doesFileExist + , doesDirectoryExist + , isReadable + , isWritable + , isExecutable + , canOpenDirectory + -- * File times + , getModificationTime + , setModificationTime + , setModificationTimeHiRes + -- * Directory reading + , getDirsFiles + , getDirsFiles' + -- * Filetype operations + , getFileType + -- * Others + , canonicalizePath + , toAbs + ) +where + + +import Control.Applicative ( (<$>) ) +import Control.Exception.Safe ( IOException + , bracket + , bracketOnError + , throwIO + , finally + ) +import Control.Monad ( unless + , void + , when + ) +import Control.Monad.Catch ( MonadThrow(..) ) +import Control.Monad.Fail ( MonadFail ) +import Control.Monad.IfElse ( unlessM ) +import qualified Data.ByteString as BS +import Data.ByteString ( ByteString ) +import Data.Traversable ( for ) +import Data.Functor ( ($>) ) +#if MIN_VERSION_bytestring(0,10,2) +import Data.ByteString.Builder +#else +import Data.ByteString.Lazy.Builder +#endif + ( Builder + , byteString + , toLazyByteString + ) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Unsafe ( unsafePackCStringFinalizer ) +import qualified Data.ByteString.UTF8 as UTF8 +import Data.Foldable ( for_ ) +import Data.IORef ( IORef + , modifyIORef + , newIORef + , readIORef + ) +import Data.Maybe ( catMaybes ) +import Data.Monoid ( (<>) + , mempty + ) +import Data.Time.Clock +import Data.Time.Clock.POSIX ( getPOSIXTime + , posixSecondsToUTCTime + , POSIXTime + ) +import Data.Word ( Word8 ) +import Foreign.C.Error ( eEXIST + , eNOENT + , eNOTEMPTY + , eXDEV + , getErrno + ) +import Foreign.C.Types ( CSize ) +import Foreign.Marshal.Alloc ( allocaBytes ) +import Foreign.Ptr ( Ptr ) +import GHC.IO.Exception ( IOErrorType(..) ) +import Prelude hiding ( appendFile + , readFile + , writeFile + ) +import Streamly +import Streamly.External.ByteString +import qualified Streamly.External.ByteString.Lazy + as SL +import qualified Streamly.Data.Fold as FL +import Streamly.Memory.Array +import qualified Streamly.FileSystem.Handle as FH +import qualified Streamly.Internal.Data.Unfold as SU +import qualified Streamly.Internal.FileSystem.Handle + as IFH +import qualified Streamly.Internal.Memory.ArrayStream + as AS +import qualified Streamly.Prelude as S +import qualified System.IO as SIO +import System.IO.Error ( catchIOError + , ioeGetErrorType + ) +import System.Posix.FilePath +import System.Posix.ByteString ( exclusive ) +import System.Posix.RawFilePath.Directory.Errors +import System.Posix.Directory.ByteString + ( createDirectory + , closeDirStream + , getWorkingDirectory + , openDirStream + , removeDirectory + ) +import System.Posix.RawFilePath.Directory.Traversals + ( getDirectoryContents' ) +import System.Posix.Files.ByteString ( createSymbolicLink + , fileAccess + , fileMode + , getFdStatus + , groupExecuteMode + , groupReadMode + , groupWriteMode + , otherExecuteMode + , otherReadMode + , otherWriteMode + , ownerModes + , ownerReadMode + , ownerWriteMode + , readSymbolicLink + , removeLink + , rename + , setFileMode + , unionFileModes + ) +import qualified System.Posix.FilePath as FP +import qualified System.Posix.Files.ByteString as PF +import qualified "unix" System.Posix.IO.ByteString + as SPI +import qualified "unix-bytestring" System.Posix.IO.ByteString + as SPB +import System.Posix.FD ( openFd ) +import qualified System.Posix.RawFilePath.Directory.Traversals + as SPDT +import qualified System.Posix.Foreign as SPDF +import qualified System.Posix.Process.ByteString + as SPP +import System.Posix.Types ( FileMode + , ProcessID + , Fd + , EpochTime + ) +import System.Posix.Time + + + + + + ------------- + --[ Types ]-- + ------------- + + +data FileType = Directory + | RegularFile + | SymbolicLink + | BlockDevice + | CharacterDevice + | NamedPipe + | Socket + deriving (Eq, Show) + + + +-- |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 +-- for IO operations. +-- +-- 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. Also note that +-- `RecursiveFailure` does not give any guarantees on the ordering +-- of the collected exceptions. +data RecursiveErrorMode = FailEarly + | CollectFailures + + +-- |The mode for copy and file moves. +-- Overwrite mode is usually not very well defined, but is a convenience +-- shortcut. +data CopyMode = Strict -- ^ fail if any target exists + | Overwrite -- ^ overwrite targets + + + + + -------------------- + --[ File Copying ]-- + -------------------- + + + +-- |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: +-- +-- @ +-- cp -a \/source\/dir \/destination\/somedir +-- @ +-- +-- For directory contents, this will ignore any file type that is not +-- `RegularFile`, `SymbolicLink` or `Directory`. +-- +-- For `Overwrite` copy mode this does not prune destination directory +-- contents, so the destination might contain more files than the source after +-- the operation has completed. Permissions of existing directories are +-- fixed. +-- +-- Safety/reliability concerns: +-- +-- * not atomic +-- * examines filetypes explicitly +-- * an explicit check `throwDestinationInSource` is carried out for the +-- top directory for basic sanity, because otherwise we might end up +-- with an infinite copy loop... however, this operation is not +-- carried out recursively (because it's slow) +-- +-- Throws: +-- +-- - `NoSuchThing` if source directory does not exist +-- - `PermissionDenied` if source directory can't be opened +-- - `SameFile` if source and destination are the same file +-- (`HPathIOException`) +-- - `DestinationInSource` if destination is contained in source +-- (`HPathIOException`) +-- +-- Throws in `FailEarly` RecursiveErrorMode only: +-- +-- - `PermissionDenied` if output directory is not writable +-- - `InvalidArgument` if source directory is wrong type (symlink) +-- - `InappropriateType` if source directory is wrong type (regular file) +-- +-- Throws in `CollectFailures` RecursiveErrorMode only: +-- +-- - `RecursiveFailure` if any of the recursive operations that are not +-- part of the top-directory sanity-checks fail (`HPathIOException`) +-- +-- Throws in `Strict` CopyMode only: +-- +-- - `AlreadyExists` if destination already exists +-- +-- Note: may call `getcwd` (only if destination is a relative path) +copyDirRecursive :: RawFilePath -- ^ source dir + -> RawFilePath -- ^ destination (parent dirs + -- are not automatically created) + -> CopyMode + -> RecursiveErrorMode + -> IO () +copyDirRecursive fromp destdirp cm rm = do + ce <- newIORef [] + -- for performance, sanity checks are only done for the top dir + throwSameFile fromp destdirp + throwDestinationInSource fromp destdirp + go ce fromp destdirp + collectedExceptions <- readIORef ce + unless (null collectedExceptions) + (throwIO . RecursiveFailure $ collectedExceptions) + where + basename :: MonadFail m => RawFilePath -> m RawFilePath + basename x = + let b = takeBaseName x + in if BS.null b then fail ("No base name" :: String) else pure b + + go :: IORef [(RecursiveFailureHint, IOException)] + -> RawFilePath + -> RawFilePath + -> IO () + go ce from destdir = do + + -- NOTE: order is important here, so we don't get empty directories + -- on failure + + -- get the contents of the source dir + contents <- handleIOE (ReadContentsFailed from destdir) ce [] $ do + contents <- getDirsFiles from + + -- create the destination dir and + -- only return contents if we succeed + handleIOE (CreateDirFailed from destdir) ce [] $ do + fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus from + case cm of + Strict -> createDirectory destdir fmode' + Overwrite -> catchIOError (createDirectory destdir fmode') $ \e -> + case ioeGetErrorType e of + AlreadyExists -> setFileMode destdir fmode' + _ -> ioError e + return contents + + -- 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 <- (destdir ) <$> basename f + case ftype of + SymbolicLink -> + handleIOE (RecreateSymlinkFailed f newdest) ce () + $ recreateSymlink f newdest cm + Directory -> go ce f newdest + RegularFile -> + handleIOE (CopyFileFailed f newdest) ce () $ copyFile f newdest cm + _ -> return () + + -- 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) + + +-- |Recreate a symlink. +-- +-- In `Overwrite` copy mode only files and empty directories are deleted. +-- +-- Safety/reliability concerns: +-- +-- * `Overwrite` mode is inherently non-atomic +-- +-- Throws: +-- +-- - `InvalidArgument` if source file is wrong type (not a symlink) +-- - `PermissionDenied` if output directory cannot be written to +-- - `PermissionDenied` if source directory cannot be opened +-- - `SameFile` if source and destination are the same file +-- (`HPathIOException`) +-- +-- +-- Throws in `Strict` mode only: +-- +-- - `AlreadyExists` if destination already exists +-- +-- Throws in `Overwrite` mode only: +-- +-- - `UnsatisfiedConstraints` if destination file is non-empty directory +-- +-- Notes: +-- +-- - calls `symlink` +-- - calls `getcwd` in Overwrite mode (if destination is a relative path) +recreateSymlink :: RawFilePath -- ^ the old symlink file + -> RawFilePath -- ^ destination file + -> CopyMode + -> IO () +recreateSymlink symsource newsym cm = do + throwSameFile symsource newsym + sympoint <- readSymbolicLink symsource + case cm of + Strict -> return () + Overwrite -> do + writable <- do + e <- doesExist newsym + if e then isWritable newsym else pure False + isfile <- doesFileExist newsym + isdir <- doesDirectoryExist newsym + when (writable && isfile) (deleteFile newsym) + when (writable && isdir) (deleteDir newsym) + createSymbolicLink sympoint newsym + + +-- |Copies the given regular file to the given destination. +-- Neither follows symbolic links, nor accepts them. +-- For "copying" symbolic links, use `recreateSymlink` instead. +-- +-- Note that this is still sort of a low-level function and doesn't +-- examine file types. For a more high-level version, use `easyCopy` +-- instead. +-- +-- In `Overwrite` copy mode only overwrites actual files, not directories. +-- In `Strict` mode the destination file must not exist. +-- +-- Safety/reliability concerns: +-- +-- * `Overwrite` mode is not atomic +-- * when used on `CharacterDevice`, reads the "contents" and copies +-- them to a regular file, which might take indefinitely +-- * when used on `BlockDevice`, may either read the "contents" +-- and copy them to a regular file (potentially hanging indefinitely) +-- or may create a regular empty destination file +-- * when used on `NamedPipe`, will hang indefinitely +-- +-- Throws: +-- +-- - `NoSuchThing` if source file does not exist +-- - `NoSuchThing` if source file is a a `Socket` +-- - `PermissionDenied` if output directory is not writable +-- - `PermissionDenied` if source directory can't be opened +-- - `InvalidArgument` if source file is wrong type (symlink or directory) +-- - `SameFile` if source and destination are the same file +-- (`HPathIOException`) +-- +-- Throws in `Strict` mode only: +-- +-- - `AlreadyExists` if destination already exists +-- +-- Notes: +-- +-- - may call `getcwd` in Overwrite mode (if destination is a relative path) +copyFile :: RawFilePath -- ^ source file + -> RawFilePath -- ^ destination file + -> CopyMode + -> IO () +copyFile from to cm = do + throwSameFile from to + bracket + (do + fd <- openFd from SPI.ReadOnly [SPDF.oNofollow] Nothing + handle <- SPI.fdToHandle fd + pure (fd, handle) + ) + (\(_, handle) -> SIO.hClose handle) + $ \(fromFd, fH) -> do + sourceFileMode <- System.Posix.Files.ByteString.fileMode + <$> getFdStatus fromFd + let dflags = + [ SPDF.oNofollow + , case cm of + Strict -> SPDF.oExcl + Overwrite -> SPDF.oTrunc + ] + bracketeer + (do + fd <- openFd to SPI.WriteOnly dflags $ Just sourceFileMode + handle <- SPI.fdToHandle fd + pure (fd, handle) + ) + (\(_, handle) -> SIO.hClose handle) + (\(_, handle) -> do + SIO.hClose handle + case cm of + -- if we created the file and copying failed, it's + -- safe to clean up + Strict -> deleteFile to + Overwrite -> pure () + ) + $ \(_, tH) -> do + SIO.hSetBinaryMode fH True + SIO.hSetBinaryMode tH True + streamlyCopy (fH, tH) + where + streamlyCopy (fH, tH) = + S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH + +-- |Copies a regular file, directory or symbolic link. In case of a +-- symbolic link it is just recreated, even if it points to a directory. +-- Any other file type is ignored. +-- +-- Safety/reliability concerns: +-- +-- * examines filetypes explicitly +-- * calls `copyDirRecursive` for directories +-- +-- Note: may call `getcwd` in Overwrite mode (if destination is a relative path) +easyCopy :: RawFilePath + -> RawFilePath + -> CopyMode + -> RecursiveErrorMode + -> IO () +easyCopy from to cm rm = do + ftype <- getFileType from + case ftype of + SymbolicLink -> recreateSymlink from to cm + RegularFile -> copyFile from to cm + Directory -> copyDirRecursive from to cm rm + _ -> return () + + + + + + --------------------- + --[ File Deletion ]-- + --------------------- + + +-- |Deletes the given file. Raises `eISDIR` +-- if run on a directory. Does not follow symbolic links. +-- +-- Throws: +-- +-- - `InappropriateType` for wrong file type (directory) +-- - `NoSuchThing` if the file does not exist +-- - `PermissionDenied` if the directory cannot be read +-- +-- Notes: calls `unlink` +deleteFile :: RawFilePath -> IO () +deleteFile = removeLink + + +-- |Deletes the given directory, which must be empty, never symlinks. +-- +-- Throws: +-- +-- - `InappropriateType` for wrong file type (symlink to directory) +-- - `InappropriateType` for wrong file type (regular file) +-- - `NoSuchThing` if directory does not exist +-- - `UnsatisfiedConstraints` if directory is not empty +-- - `PermissionDenied` if we can't open or write to parent directory +-- +-- Notes: calls `rmdir` +deleteDir :: RawFilePath -> IO () +deleteDir = removeDirectory + + +-- |Deletes the given directory recursively. Does not follow symbolic +-- links. Tries `deleteDir` first before attemtping a recursive +-- deletion. +-- +-- On directory contents this behaves like `easyDelete` +-- and thus will ignore any file type that is not `RegularFile`, +-- `SymbolicLink` or `Directory`. +-- +-- Safety/reliability concerns: +-- +-- * not atomic +-- * examines filetypes explicitly +-- +-- Throws: +-- +-- - `InappropriateType` for wrong file type (symlink to directory) +-- - `InappropriateType` for wrong file type (regular file) +-- - `NoSuchThing` if directory does not exist +-- - `PermissionDenied` if we can't open or write to parent directory +deleteDirRecursive :: RawFilePath -> IO () +deleteDirRecursive p = catchErrno [eNOTEMPTY, eEXIST] (deleteDir p) $ do + files <- getDirsFiles p + for_ files $ \file -> do + ftype <- getFileType file + case ftype of + SymbolicLink -> deleteFile file + Directory -> deleteDirRecursive file + RegularFile -> deleteFile file + _ -> return () + removeDirectory p + + +-- |Deletes a file, directory or symlink. +-- In case of directory, performs recursive deletion. In case of +-- a symlink, the symlink file is deleted. +-- Any other file type is ignored. +-- +-- Safety/reliability concerns: +-- +-- * examines filetypes explicitly +-- * calls `deleteDirRecursive` for directories +easyDelete :: RawFilePath -> IO () +easyDelete p = do + ftype <- getFileType p + case ftype of + SymbolicLink -> deleteFile p + Directory -> deleteDirRecursive p + RegularFile -> deleteFile p + _ -> return () + + + + + -------------------- + --[ File Opening ]-- + -------------------- + + +-- |Opens a file appropriately by invoking xdg-open. The file type +-- is not checked. This forks a process. +openFile :: RawFilePath -> IO ProcessID +openFile fp = SPP.forkProcess + $ SPP.executeFile (UTF8.fromString "xdg-open") True [fp] Nothing + + +-- |Executes a program with the given arguments. This forks a process. +executeFile :: RawFilePath -- ^ program + -> [ByteString] -- ^ arguments + -> IO ProcessID +executeFile fp args = SPP.forkProcess $ SPP.executeFile fp True args Nothing + + + + + --------------------- + --[ File Creation ]-- + --------------------- + + +-- |Create an empty regular file at the given directory with the given +-- filename. +-- +-- Throws: +-- +-- - `PermissionDenied` if output directory cannot be written to +-- - `AlreadyExists` if destination already exists +-- - `NoSuchThing` if any of the parent components of the path +-- do not exist +createRegularFile :: FileMode -> RawFilePath -> IO () +createRegularFile fm destBS = bracket + (SPI.openFd destBS + SPI.WriteOnly + (Just fm) + (SPI.defaultFileFlags { exclusive = True }) + ) + SPI.closeFd + (\_ -> return ()) + + +-- |Create an empty directory at the given directory with the given filename. +-- +-- Throws: +-- +-- - `PermissionDenied` if output directory cannot be written to +-- - `AlreadyExists` if destination already exists +-- - `NoSuchThing` if any of the parent components of the path +-- do not exist +createDir :: FileMode -> RawFilePath -> IO () +createDir fm destBS = createDirectory destBS fm + +-- |Create an empty directory at the given directory with the given filename. +-- +-- Throws: +-- +-- - `PermissionDenied` if output directory cannot be written to +-- - `NoSuchThing` if any of the parent components of the path +-- do not exist +createDirIfMissing :: FileMode -> RawFilePath -> IO () +createDirIfMissing fm destBS = + hideError AlreadyExists $ createDirectory destBS 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 +-- +-- Note: calls `getcwd` if the input path is a relative path +createDirRecursive :: FileMode -> RawFilePath -> IO () +createDirRecursive fm p = go p + where + go :: RawFilePath -> IO () + go dest = do + catchIOError (createDirectory dest fm) $ \e -> do + errno <- getErrno + case errno of + en + | en == eEXIST + -> unlessM (doesDirectoryExist dest) (ioError e) + | en == eNOENT + -> createDirRecursive fm (takeDirectory dest) + >> createDirectory 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 :: RawFilePath -- ^ destination file + -> RawFilePath -- ^ path the symlink points to + -> IO () +createSymlink destBS sympoint = createSymbolicLink sympoint destBS + + + + ---------------------------- + --[ File Renaming/Moving ]-- + ---------------------------- + + +-- |Rename a given file with the provided filename. Destination and source +-- must be on the same device, otherwise `eXDEV` will be raised. +-- +-- Does not follow symbolic links, but renames the symbolic link file. +-- +-- Safety/reliability concerns: +-- +-- * has a separate set of exception handling, apart from the syscall +-- +-- Throws: +-- +-- - `NoSuchThing` if source file does not exist +-- - `PermissionDenied` if output directory cannot be written to +-- - `PermissionDenied` if source directory cannot be opened +-- - `UnsupportedOperation` if source and destination are on different +-- devices +-- - `AlreadyExists` if destination already exists +-- - `SameFile` if destination and source are the same file +-- (`HPathIOException`) +-- +-- Note: calls `rename` (but does not allow to rename over existing files) +renameFile :: RawFilePath -> RawFilePath -> IO () +renameFile fromf tof = do + throwSameFile fromf tof + throwFileDoesExist tof + throwDirDoesExist tof + rename fromf tof + + +-- |Move a file. This also works across devices by copy-delete fallback. +-- And also works on directories. +-- +-- Does not follow symbolic links, but renames the symbolic link file. +-- +-- +-- Safety/reliability concerns: +-- +-- * `Overwrite` mode is not atomic +-- * copy-delete fallback is inherently non-atomic +-- * since this function calls `easyCopy` and `easyDelete` as a fallback +-- to `renameFile`, file types that are not `RegularFile`, `SymbolicLink` +-- or `Directory` may be ignored +-- * for `Overwrite` mode, the destination will be deleted (not recursively) +-- before moving +-- +-- Throws: +-- +-- - `NoSuchThing` if source file does not exist +-- - `PermissionDenied` if output directory cannot be written to +-- - `PermissionDenied` if source directory cannot be opened +-- - `SameFile` if destination and source are the same file +-- (`HPathIOException`) +-- +-- Throws in `Strict` mode only: +-- +-- - `AlreadyExists` if destination already exists +-- +-- Notes: +-- +-- - calls `rename` (but does not allow to rename over existing files) +-- - calls `getcwd` in Overwrite mode if destination is a relative path +moveFile :: RawFilePath -- ^ file to move + -> RawFilePath -- ^ destination + -> CopyMode + -> IO () +moveFile from to cm = do + throwSameFile from to + case cm of + Strict -> catchErrno [eXDEV] (renameFile from to) $ do + easyCopy from to Strict FailEarly + easyDelete from + Overwrite -> do + ft <- getFileType from + writable <- do + e <- doesFileExist to + if e then isWritable to else pure False + + case ft of + RegularFile -> do + exists <- doesFileExist to + when (exists && writable) (deleteFile to) + SymbolicLink -> do + exists <- doesFileExist to + when (exists && writable) (deleteFile to) + Directory -> do + exists <- doesDirectoryExist to + when (exists && writable) (deleteDir to) + _ -> return () + moveFile from to Strict + + + + + + -------------------- + --[ File Reading ]-- + -------------------- + + +-- |Read the given file *at once* into memory as a lazy ByteString. +-- Symbolic links are followed, no sanity checks on file size +-- or file type. File must exist. Uses Builders under the hood +-- (hence lazy ByteString). +-- +-- Safety/reliability concerns: +-- +-- * the whole file is read into memory, this doesn't read lazily +-- +-- 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 :: RawFilePath -> IO L.ByteString +readFile path = do + stream <- readFileStream path + toLazyByteString <$> S.fold FL.mconcat (fmap byteString stream) + + + +-- | Open the given file as a filestream. Once the filestream +-- exits, the filehandle is cleaned up. +-- +-- 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 +readFileStream :: RawFilePath -> IO (SerialT IO ByteString) +readFileStream fp = do + fd <- openFd fp SPI.ReadOnly [] Nothing + handle <- SPI.fdToHandle fd + let stream = + fmap fromArray (S.unfold (SU.finally (\h -> putStrLn "lol" >> SIO.hClose h) FH.readChunks) handle) + pure stream + + + + + -------------------- + --[ File Writing ]-- + -------------------- + + +-- |Write a given ByteString to a file, truncating the file beforehand. +-- 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 :: RawFilePath + -> Maybe FileMode -- ^ if Nothing, file must exist + -> ByteString + -> IO () +writeFile fp fmode bs = + bracket (openFd fp SPI.WriteOnly [SPDF.oTrunc] fmode) (SPI.closeFd) + $ \fd -> void $ SPB.fdWrite fd bs + + +-- |Write a given lazy ByteString to a file, truncating the file beforehand. +-- 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 +-- +-- Note: uses streamly under the hood +writeFileL :: RawFilePath + -> Maybe FileMode -- ^ if Nothing, file must exist + -> L.ByteString + -> IO () +writeFileL fp fmode lbs = do + handle <- + bracketOnError (openFd fp SPI.WriteOnly [SPDF.oTrunc] fmode) (SPI.closeFd) + $ SPI.fdToHandle + finally (streamlyCopy handle) (SIO.hClose handle) + where streamlyCopy tH = S.fold (FH.writeChunks tH) $ SL.toChunks lbs + + +-- |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 :: RawFilePath -> ByteString -> IO () +appendFile fp bs = + bracket (openFd fp SPI.WriteOnly [SPDF.oAppend] Nothing) (SPI.closeFd) + $ \fd -> void $ SPB.fdWrite fd bs + + + + + ----------------------- + --[ File Permissions]-- + ----------------------- + + +-- |Default permissions for a new file. +newFilePerms :: FileMode +newFilePerms = + ownerWriteMode + `unionFileModes` ownerReadMode + `unionFileModes` groupWriteMode + `unionFileModes` groupReadMode + `unionFileModes` otherWriteMode + `unionFileModes` otherReadMode + + +-- |Default permissions for a new directory. +newDirPerms :: FileMode +newDirPerms = + ownerModes + `unionFileModes` groupExecuteMode + `unionFileModes` groupReadMode + `unionFileModes` otherExecuteMode + `unionFileModes` otherReadMode + + + + + ------------------- + --[ File checks ]-- + ------------------- + + +-- |Checks if the given file exists. +-- Does not follow symlinks. +-- +-- Only eNOENT is catched (and returns False). +doesExist :: RawFilePath -> IO Bool +doesExist bs = + catchErrno + [eNOENT] + (do + _ <- PF.getSymbolicLinkStatus bs + return $ True + ) + $ return False + + +-- |Checks if the given file exists and is not a directory. +-- Does not follow symlinks. +-- +-- Only eNOENT is catched (and returns False). +doesFileExist :: RawFilePath -> IO Bool +doesFileExist bs = + catchErrno + [eNOENT] + (do + fs <- PF.getSymbolicLinkStatus bs + return $ not . PF.isDirectory $ fs + ) + $ return False + + +-- |Checks if the given file exists and is a directory. +-- Does not follow symlinks. +-- +-- Only eNOENT is catched (and returns False). +doesDirectoryExist :: RawFilePath -> IO Bool +doesDirectoryExist bs = + catchErrno + [eNOENT] + (do + fs <- PF.getSymbolicLinkStatus bs + return $ PF.isDirectory fs + ) + $ return False + + +-- |Checks whether a file or folder is readable. +-- +-- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False). +-- +-- Throws: +-- +-- - `NoSuchThing` if the file does not exist +isReadable :: RawFilePath -> IO Bool +isReadable bs = fileAccess bs True False False + +-- |Checks whether a file or folder is writable. +-- +-- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False). +-- +-- Throws: +-- +-- - `NoSuchThing` if the file does not exist +isWritable :: RawFilePath -> IO Bool +isWritable bs = fileAccess bs False True False + + +-- |Checks whether a file or folder is executable. +-- +-- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False). +-- +-- Throws: +-- +-- - `NoSuchThing` if the file does not exist +isExecutable :: RawFilePath -> IO Bool +isExecutable bs = fileAccess bs False False True + + + +-- |Checks whether the directory at the given path exists and can be +-- opened. This invokes `openDirStream` which follows symlinks. +canOpenDirectory :: RawFilePath -> IO Bool +canOpenDirectory bs = handleIOError (\_ -> return False) $ do + bracket (openDirStream bs) closeDirStream (\_ -> return ()) + return True + + + + + ------------------ + --[ File times ]-- + ------------------ + + +getModificationTime :: RawFilePath -> IO UTCTime +getModificationTime bs = do + fs <- PF.getFileStatus bs + pure $ posixSecondsToUTCTime $ PF.modificationTimeHiRes fs + +setModificationTime :: RawFilePath -> EpochTime -> IO () +setModificationTime bs t = do + -- TODO: setFileTimes doesn't allow to pass NULL to utime + ctime <- epochTime + PF.setFileTimes bs ctime t + +setModificationTimeHiRes :: RawFilePath -> POSIXTime -> IO () +setModificationTimeHiRes bs t = do + -- TODO: setFileTimesHiRes doesn't allow to pass NULL to utimes + ctime <- getPOSIXTime + PF.setFileTimesHiRes bs ctime t + + + + ------------------------- + --[ Directory reading ]-- + ------------------------- + + +-- |Gets all filenames of the given directory. This excludes "." and "..". +-- This version does not follow symbolic links. +-- +-- The contents are not sorted and there is no guarantee on the ordering. +-- +-- Throws: +-- +-- - `NoSuchThing` if directory does not exist +-- - `InappropriateType` if file type is wrong (file) +-- - `InappropriateType` if file type is wrong (symlink to file) +-- - `InappropriateType` if file type is wrong (symlink to dir) +-- - `PermissionDenied` if directory cannot be opened +getDirsFiles :: RawFilePath -- ^ dir to read + -> IO [RawFilePath] +getDirsFiles p = do + contents <- getDirsFiles' p + pure $ fmap (p ) contents + + +-- | Like 'getDirsFiles', but returns the filename only, instead +-- of prepending the base path. +getDirsFiles' :: RawFilePath -- ^ dir to read + -> IO [RawFilePath] +getDirsFiles' fp = do + fd <- openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing + rawContents <- getDirectoryContents' fd + fmap catMaybes $ for rawContents $ \(_, f) -> + if FP.isSpecialDirectoryEntry f then pure Nothing else pure $ Just f + + + + + --------------------------- + --[ FileType operations ]-- + --------------------------- + + +-- |Get the file type of the file located at the given path. Does +-- not follow symbolic links. +-- +-- Throws: +-- +-- - `NoSuchThing` if the file does not exist +-- - `PermissionDenied` if any part of the path is not accessible +getFileType :: RawFilePath -> IO FileType +getFileType fp = do + fs <- PF.getSymbolicLinkStatus fp + decide fs + where + decide fs | PF.isDirectory fs = return Directory + | PF.isRegularFile fs = return RegularFile + | PF.isSymbolicLink fs = return SymbolicLink + | PF.isBlockDevice fs = return BlockDevice + | PF.isCharacterDevice fs = return CharacterDevice + | PF.isNamedPipe fs = return NamedPipe + | PF.isSocket fs = return Socket + | otherwise = ioError $ userError "No filetype?!" + + + + -------------- + --[ Others ]-- + -------------- + + + +-- |Applies `realpath` on the given path. +-- +-- Throws: +-- +-- - `NoSuchThing` if the file at the given path does not exist +-- - `NoSuchThing` if the symlink is broken +canonicalizePath :: RawFilePath -> IO RawFilePath +canonicalizePath = SPDT.realpath + + +-- |Converts any path to an absolute path. +-- This is done in the following way: +-- +-- - if the path is already an absolute one, just return it +-- - if it's a relative path, prepend the current directory to it +toAbs :: RawFilePath -> IO RawFilePath +toAbs bs = do + case isAbsolute bs of + True -> return bs + False -> do + cwd <- getWorkingDirectory + return $ cwd bs diff --git a/src/System/Posix/RawFilePath/Directory.hs-boot b/src/System/Posix/RawFilePath/Directory.hs-boot new file mode 100644 --- /dev/null +++ b/src/System/Posix/RawFilePath/Directory.hs-boot @@ -0,0 +1,15 @@ +module System.Posix.RawFilePath.Directory where + +import System.Posix.ByteString.FilePath (RawFilePath) + +canonicalizePath :: RawFilePath -> IO RawFilePath + +toAbs :: RawFilePath -> IO RawFilePath + +doesFileExist :: RawFilePath -> IO Bool + +doesDirectoryExist :: RawFilePath -> IO Bool + +isWritable :: RawFilePath -> IO Bool + +canOpenDirectory :: RawFilePath -> IO Bool diff --git a/src/System/Posix/RawFilePath/Directory/Errors.hs b/src/System/Posix/RawFilePath/Directory/Errors.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/RawFilePath/Directory/Errors.hs @@ -0,0 +1,327 @@ +-- | +-- Module : System.Posix.RawFilePath.Directory.Errors +-- Copyright : © 2016 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- Provides error handling. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module System.Posix.RawFilePath.Directory.Errors + ( + -- * Types + HPathIOException(..) + , RecursiveFailureHint(..) + + -- * Exception identifiers + , isSameFile + , isDestinationInSource + , isRecursiveFailure + , isReadContentsFailed + , isCreateDirFailed + , isCopyFileFailed + , isRecreateSymlinkFailed + + -- * Path based functions + , throwFileDoesExist + , throwDirDoesExist + , throwSameFile + , sameFile + , throwDestinationInSource + + -- * Error handling functions + , 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 + + +-- |Additional generic IO exceptions that the posix functions +-- do not provide. +data HPathIOException = SameFile ByteString ByteString + | DestinationInSource ByteString ByteString + | RecursiveFailure [(RecursiveFailureHint, IOException)] + deriving (Eq, Show, Typeable) + + +-- |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 ByteString ByteString + | CreateDirFailed ByteString ByteString + | CopyFileFailed ByteString ByteString + | RecreateSymlinkFailed ByteString ByteString + deriving (Eq, Show) + + +instance Exception HPathIOException + + +toConstr :: HPathIOException -> String +toConstr SameFile {} = "SameFile" +toConstr DestinationInSource {} = "DestinationInSource" +toConstr RecursiveFailure {} = "RecursiveFailure" + + + + + + ----------------------------- + --[ Exception identifiers ]-- + ----------------------------- + + +isSameFile, isDestinationInSource, isRecursiveFailure :: HPathIOException -> Bool +isSameFile ex = toConstr (ex :: HPathIOException) == toConstr (SameFile mempty mempty) +isDestinationInSource ex = toConstr (ex :: HPathIOException) == (toConstr $ DestinationInSource mempty mempty) +isRecursiveFailure ex = toConstr (ex :: HPathIOException) == (toConstr $ RecursiveFailure mempty) + + +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 :: RawFilePath -> IO () +throwFileDoesExist bs = + whenM (doesFileExist bs) + (ioError . mkIOError + alreadyExistsErrorType + "File already exists" + Nothing + $ (Just (toString $ bs)) + ) + + +-- |Throws `AlreadyExists` `IOError` if directory exists. +throwDirDoesExist :: RawFilePath -> IO () +throwDirDoesExist bs = + whenM (doesDirectoryExist bs) + (ioError . mkIOError + alreadyExistsErrorType + "Directory already exists" + Nothing + $ (Just (toString $ bs)) + ) + + +-- |Uses `isSameFile` and throws `SameFile` if it returns True. +throwSameFile :: RawFilePath + -> RawFilePath + -> IO () +throwSameFile bs1 bs2 = + whenM (sameFile bs1 bs2) + (throwIO $ SameFile bs1 bs2) + + +-- |Check if the files are the same by examining device and file id. +-- This follows symbolic links. +sameFile :: RawFilePath -> RawFilePath -> IO Bool +sameFile fp1 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 + + +-- TODO: make this more robust when destination does not exist +-- |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 :: RawFilePath -- ^ source dir + -> RawFilePath -- ^ full destination, @dirname dest@ + -- must exist + -> IO () +throwDestinationInSource sbs dbs = do + destAbs <- toAbs dbs + dest' <- (\x -> maybe x (\y -> x y) $ basename dbs) + <$> (canonicalizePath $ takeDirectory destAbs) + dids <- forM (takeAllParents dest') $ \p -> do + fs <- PF.getSymbolicLinkStatus p + return (PF.deviceID fs, PF.fileID fs) + sid <- fmap (\x -> (PF.deviceID x, PF.fileID x)) + $ PF.getFileStatus sbs + when (elem sid dids) + (throwIO $ DestinationInSource dbs sbs) + where + basename x = let b = takeBaseName x + in if BS.null b then Nothing else Just b + + + + -------------------------------- + --[ 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 + + +hideError :: IOErrorType -> IO () -> IO () +hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else ioError e) + + +-- |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 + -> [(IOErrorType, IO a)] -- ^ reaction on IO errors + -> [(HPathIOException, IO a)] -- ^ reaction on HPathIOException + -> 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 + + diff --git a/src/System/Posix/RawFilePath/Directory/Traversals.hs b/src/System/Posix/RawFilePath/Directory/Traversals.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/RawFilePath/Directory/Traversals.hs @@ -0,0 +1,263 @@ +-- | +-- Module : System.Posix.RawFilePath.Directory.Traversals +-- Copyright : © 2016 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- Traversal and read operations on directories. + + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall #-} + + +module System.Posix.RawFilePath.Directory.Traversals ( + + getDirectoryContents +, getDirectoryContents' + +, allDirectoryContents +, allDirectoryContents' +, traverseDirectory + +-- lower-level stuff +, readDirEnt +, packDirStream +, unpackDirStream +, fdOpendir + +, realpath +) where + + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import Control.Monad +import System.Posix.FilePath (()) +import System.Posix.Foreign + +import qualified System.Posix as Posix +import System.IO.Error +import Control.Exception +import qualified Data.ByteString.Char8 as BS +import System.Posix.ByteString.FilePath +import System.Posix.Directory.ByteString as PosixBS +import System.Posix.Files.ByteString + +import System.IO.Unsafe +import "unix" System.Posix.IO.ByteString (closeFd) +import Unsafe.Coerce (unsafeCoerce) +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc (alloca,allocaBytes) +import Foreign.Ptr +import Foreign.Storable + + + + +---------------------------------------------------------- + +-- | Get all files from a directory and its subdirectories. +-- +-- Upon entering a directory, 'allDirectoryContents' will get all entries +-- strictly. However the returned list is lazy in that directories will only +-- be accessed on demand. +-- +-- Follows symbolic links for the input dir. +allDirectoryContents :: RawFilePath -> IO [RawFilePath] +allDirectoryContents topdir = do + namesAndTypes <- getDirectoryContents topdir + let properNames = filter ((`notElem` [".", ".."]) . snd) namesAndTypes + paths <- forM properNames $ \(typ,name) -> unsafeInterleaveIO $ do + let path = topdir name + case () of + () | typ == dtDir -> allDirectoryContents path + | typ == dtUnknown -> do + isDir <- isDirectory <$> getFileStatus path + if isDir + then allDirectoryContents path + else return [path] + | otherwise -> return [path] + return (topdir : concat paths) + +-- | Get all files from a directory and its subdirectories strictly. +-- +-- Follows symbolic links for the input dir. +allDirectoryContents' :: RawFilePath -> IO [RawFilePath] +allDirectoryContents' = fmap reverse . traverseDirectory (\acc fp -> return (fp:acc)) [] +-- this uses traverseDirectory because it's more efficient than forcing the +-- lazy version. + +-- | Recursively apply the 'action' to the parent directory and all +-- files/subdirectories. +-- +-- This function allows for memory-efficient traversals. +-- +-- Follows symbolic links for the input dir. +traverseDirectory :: (s -> RawFilePath -> IO s) -> s -> RawFilePath -> IO s +traverseDirectory act s0 topdir = toploop + where + toploop = do + isDir <- isDirectory <$> getFileStatus topdir + s' <- act s0 topdir + if isDir then actOnDirContents topdir s' loop + else return s' + loop typ path acc = do + isDir <- case () of + () | typ == dtDir -> return True + | typ == dtUnknown -> isDirectory <$> getFileStatus path + | otherwise -> return False + if isDir + then act acc path >>= \acc' -> actOnDirContents path acc' loop + else act acc path + +actOnDirContents :: RawFilePath + -> b + -> (DirType -> RawFilePath -> b -> IO b) + -> IO b +actOnDirContents pathRelToTop b f = + modifyIOError ((`ioeSetFileName` (BS.unpack pathRelToTop)) . + (`ioeSetLocation` "findBSTypRel")) $ + bracket + (openDirStream pathRelToTop) + Posix.closeDirStream + (\dirp -> loop dirp b) + where + loop dirp b' = do + (typ,e) <- readDirEnt dirp + if (e == "") + then return b' + else + if (e == "." || e == "..") + then loop dirp b' + else f typ (pathRelToTop e) b' >>= loop dirp + + +---------------------------------------------------------- +-- dodgy stuff + +type CDir = () +type CDirent = () + +-- Posix doesn't export DirStream, so to re-use that type we need to use +-- unsafeCoerce. It's just a newtype, so this is a legitimate usage. +-- ugly trick. +unpackDirStream :: DirStream -> Ptr CDir +unpackDirStream = unsafeCoerce + +packDirStream :: Ptr CDir -> DirStream +packDirStream = unsafeCoerce + +-- the __hscore_* functions are defined in the unix package. We can import them and let +-- the linker figure it out. +foreign import ccall unsafe "__hscore_readdir" + c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt + +foreign import ccall unsafe "__hscore_free_dirent" + c_freeDirEnt :: Ptr CDirent -> IO () + +foreign import ccall unsafe "__hscore_d_name" + c_name :: Ptr CDirent -> IO CString + +foreign import ccall unsafe "__posixdir_d_type" + c_type :: Ptr CDirent -> IO DirType + +foreign import ccall "realpath" + c_realpath :: CString -> CString -> IO CString + +foreign import ccall unsafe "fdopendir" + c_fdopendir :: Posix.Fd -> IO (Ptr ()) + +---------------------------------------------------------- +-- less dodgy but still lower-level + + +readDirEnt :: DirStream -> IO (DirType, RawFilePath) +readDirEnt (unpackDirStream -> dirp) = + alloca $ \ptr_dEnt -> loop ptr_dEnt + where + loop ptr_dEnt = do + resetErrno + r <- c_readdir dirp ptr_dEnt + if (r == 0) + then do + dEnt <- peek ptr_dEnt + if (dEnt == nullPtr) + then return (dtUnknown,BS.empty) + else do + dName <- c_name dEnt >>= peekFilePath + dType <- c_type dEnt + c_freeDirEnt dEnt + return (dType, dName) + else do + errno <- getErrno + if (errno == eINTR) + then loop ptr_dEnt + else do + let (Errno eo) = errno + if (eo == 0) + then return (dtUnknown,BS.empty) + else throwErrno "readDirEnt" + + +-- |Gets all directory contents (not recursively). +getDirectoryContents :: RawFilePath -> IO [(DirType, RawFilePath)] +getDirectoryContents path = + modifyIOError ((`ioeSetFileName` (BS.unpack path)) . + (`ioeSetLocation` "System.Posix.RawFilePath.Directory.Traversals.getDirectoryContents")) $ + bracket + (PosixBS.openDirStream path) + PosixBS.closeDirStream + _dirloop + + +-- |Binding to @fdopendir(3)@. +fdOpendir :: Posix.Fd -> IO DirStream +fdOpendir fd = + packDirStream <$> throwErrnoIfNull "fdOpendir" (c_fdopendir fd) + + +-- |Like `getDirectoryContents` except for a file descriptor. +-- +-- To avoid complicated error checks, the file descriptor is +-- __always__ closed, even if `fdOpendir` fails. Usually, this +-- only happens on successful `fdOpendir` and after the directory +-- stream is closed. Also see the manpage of @fdopendir(3)@ for +-- more details. +getDirectoryContents' :: Posix.Fd -> IO [(DirType, RawFilePath)] +getDirectoryContents' fd = do + dirstream <- fdOpendir fd `catchIOError` \e -> do + closeFd fd + ioError e + -- closeDirStream closes the filedescriptor + finally (_dirloop dirstream) (PosixBS.closeDirStream dirstream) + + +_dirloop :: DirStream -> IO [(DirType, RawFilePath)] +{-# INLINE _dirloop #-} +_dirloop dirp = do + t@(_typ,e) <- readDirEnt dirp + if BS.null e then return [] else do + es <- _dirloop dirp + return (t:es) + + +-- | return the canonicalized absolute pathname +-- +-- like canonicalizePath, but uses @realpath(3)@ +realpath :: RawFilePath -> IO RawFilePath +realpath inp = + allocaBytes pathMax $ \tmp -> do + void $ BS.useAsCString inp $ \cstr -> throwErrnoIfNull "realpath" $ c_realpath cstr tmp + BS.packCString tmp diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +import qualified Data.ByteString as BS +import Data.IORef +import Test.Hspec +import Test.Hspec.Runner +import Test.Hspec.Formatters +import qualified Spec +import Utils +import System.Posix.Temp.ByteString (mkdtemp) + + +-- TODO: chardev, blockdev, namedpipe, socket + + +main :: IO () +main = do + tmpBase <- mkdtemp "/tmp/" + writeIORef baseTmpDir (Just (tmpBase `BS.append` "/")) + putStrLn $ ("Temporary test directory at: " ++ show tmpBase) + hspecWith + defaultConfig { configFormatter = Just progress } + $ afterAll_ deleteBaseTmpDir + $ Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- file test/Spec.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/test/System/Posix/RawFilePath/Directory/AppendFileSpec.hs b/test/System/Posix/RawFilePath/Directory/AppendFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/AppendFileSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module System.Posix.RawFilePath.Directory.AppendFileSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "AppendFileSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createRegularFile' "fileWithContent" + createRegularFile' "fileWithoutContent" + createSymlink' "inputFileSymL" "fileWithContent" + createDir' "alreadyExistsD" + createRegularFile' "noPerms" + noPerms "noPerms" + createDir' "noPermsD" + createRegularFile' "noPermsD/inputFile" + noPerms "noPermsD" + writeFile' "fileWithContent" "BLKASL" + + +cleanupFiles :: IO () +cleanupFiles = do + deleteFile' "fileWithContent" + deleteFile' "fileWithoutContent" + deleteFile' "inputFileSymL" + deleteDir' "alreadyExistsD" + normalFilePerms "noPerms" + deleteFile' "noPerms" + normalDirPerms "noPermsD" + deleteFile' "noPermsD/inputFile" + deleteDir' "noPermsD" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.appendFile" $ do + + -- successes -- + it "appendFile file with content, everything clear" $ do + appendFile' "fileWithContent" "blahfaselllll" + out <- readFile' "fileWithContent" + out `shouldBe` "BLKASLblahfaselllll" + + it "appendFile file with content, everything clear" $ do + appendFile' "fileWithContent" "gagagaga" + out <- readFile' "fileWithContent" + out `shouldBe` "BLKASLblahfaselllllgagagaga" + + it "appendFile file with content, everything clear" $ do + appendFile' "fileWithContent" "" + out <- readFile' "fileWithContent" + out `shouldBe` "BLKASLblahfaselllllgagagaga" + + it "appendFile file without content, everything clear" $ do + appendFile' "fileWithoutContent" "blahfaselllll" + out <- readFile' "fileWithoutContent" + out `shouldBe` "blahfaselllll" + + it "appendFile, everything clear" $ do + appendFile' "fileWithoutContent" "gagagaga" + out <- readFile' "fileWithoutContent" + out `shouldBe` "blahfaselllllgagagaga" + + it "appendFile symlink, everything clear" $ do + appendFile' "inputFileSymL" "blahfaselllll" + out <- readFile' "inputFileSymL" + out `shouldBe` "BLKASLblahfaselllllgagagagablahfaselllll" + + it "appendFile symlink, everything clear" $ do + appendFile' "inputFileSymL" "gagagaga" + out <- readFile' "inputFileSymL" + out `shouldBe` "BLKASLblahfaselllllgagagagablahfaselllllgagagaga" + + + -- posix failures -- + it "appendFile to dir, inappropriate type" $ do + appendFile' "alreadyExistsD" "" + `shouldThrow` (\e -> ioeGetErrorType e == InappropriateType) + + it "appendFile, no permissions to file" $ do + appendFile' "noPerms" "" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "appendFile, no permissions to file" $ do + appendFile' "noPermsD/inputFile" "" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "appendFile, file does not exist" $ do + appendFile' "gaga" "" + `shouldThrow` (\e -> ioeGetErrorType e == NoSuchThing) diff --git a/test/System/Posix/RawFilePath/Directory/CanonicalizePathSpec.hs b/test/System/Posix/RawFilePath/Directory/CanonicalizePathSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CanonicalizePathSpec.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.CanonicalizePathSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CanonicalizePathSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createRegularFile' "file" + createDir' "dir" + createSymlink' "dirSym" "dir/" + createSymlink' "brokenSym" "nothing" + createSymlink' "fileSym" "file" + +cleanupFiles :: IO () +cleanupFiles = do + deleteFile' "file" + deleteDir' "dir" + deleteFile' "dirSym" + deleteFile' "brokenSym" + deleteFile' "fileSym" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.canonicalizePath" $ do + + -- successes -- + it "canonicalizePath, all fine" $ do + path <- withTmpDir "file" return + canonicalizePath' "file" + `shouldReturn` path + + it "canonicalizePath, all fine" $ do + path <- withTmpDir "dir" return + canonicalizePath' "dir" + `shouldReturn` path + + it "canonicalizePath, all fine" $ do + path <- withTmpDir "file" return + canonicalizePath' "fileSym" + `shouldReturn` path + + it "canonicalizePath, all fine" $ do + path <- withTmpDir "dir" return + canonicalizePath' "dirSym" + `shouldReturn` path + + + -- posix failures -- + it "canonicalizePath, broken symlink" $ + canonicalizePath' "brokenSym" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "canonicalizePath, file does not exist" $ + canonicalizePath' "nothingBlah" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + diff --git a/test/System/Posix/RawFilePath/Directory/CopyDirRecursiveCollectFailuresSpec.hs b/test/System/Posix/RawFilePath/Directory/CopyDirRecursiveCollectFailuresSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CopyDirRecursiveCollectFailuresSpec.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module System.Posix.RawFilePath.Directory.CopyDirRecursiveCollectFailuresSpec where + + +import Test.Hspec +import Data.List (sort) +import "hpath-directory" System.Posix.RawFilePath.Directory +import System.Posix.RawFilePath.Directory.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import System.Exit +import System.Process +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CopyDirRecursiveCollectFailuresSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createRegularFile' "alreadyExists" + createRegularFile' "wrongInput" + createSymlink' "wrongInputSymL" "inputDir/" + createDir' "alreadyExistsD" + createDir' "noPerms" + createDir' "noWritePerm" + + createDir' "inputDir" + createDir' "inputDir/bar" + createDir' "inputDir/foo" + createRegularFile' "inputDir/foo/inputFile1" + createRegularFile' "inputDir/inputFile2" + createRegularFile' "inputDir/bar/inputFile3" + writeFile' "inputDir/foo/inputFile1" "SDAADSdsada" + writeFile' "inputDir/inputFile2" "Blahfaselgagaga" + writeFile' "inputDir/bar/inputFile3" + "fdfdssdffsd3223sasdasdasdadasasddasdasdasasd4" + + createDir' "inputDir1" + createDir' "inputDir1/foo2" + createDir' "inputDir1/foo2/foo3" + createDir' "inputDir1/foo2/foo4" + createRegularFile' "inputDir1/foo2/inputFile1" + createRegularFile' "inputDir1/foo2/inputFile2" + createRegularFile' "inputDir1/foo2/inputFile3" + createRegularFile' "inputDir1/foo2/foo4/inputFile4" + createRegularFile' "inputDir1/foo2/foo4/inputFile6" + createRegularFile' "inputDir1/foo2/foo3/inputFile5" + noPerms "inputDir1/foo2/foo3" + + createDir' "outputDir1" + createDir' "outputDir1/foo2" + createDir' "outputDir1/foo2/foo4" + createDir' "outputDir1/foo2/foo4/inputFile4" + createRegularFile' "outputDir1/foo2/foo4/inputFile6" + noPerms "outputDir1/foo2/foo4/inputFile4" + noPerms "outputDir1/foo2/foo4" + + noPerms "noPerms" + noWritableDirPerms "noWritePerm" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerm" + + normalDirPerms "inputDir1/foo2/foo3" + deleteFile' "inputDir1/foo2/foo4/inputFile4" + deleteFile' "inputDir1/foo2/foo4/inputFile6" + deleteFile' "inputDir1/foo2/inputFile1" + deleteFile' "inputDir1/foo2/inputFile2" + deleteFile' "inputDir1/foo2/inputFile3" + deleteFile' "inputDir1/foo2/foo3/inputFile5" + deleteDir' "inputDir1/foo2/foo3" + deleteDir' "inputDir1/foo2/foo4" + deleteDir' "inputDir1/foo2" + deleteDir' "inputDir1" + + normalDirPerms "outputDir1/foo2/foo4" + normalDirPerms "outputDir1/foo2/foo4/inputFile4" + deleteFile' "outputDir1/foo2/foo4/inputFile6" + deleteDir' "outputDir1/foo2/foo4/inputFile4" + deleteDir' "outputDir1/foo2/foo4" + deleteDir' "outputDir1/foo2" + deleteDir' "outputDir1" + + deleteFile' "alreadyExists" + deleteFile' "wrongInput" + deleteFile' "wrongInputSymL" + deleteDir' "alreadyExistsD" + deleteDir' "noPerms" + deleteDir' "noWritePerm" + deleteFile' "inputDir/foo/inputFile1" + deleteFile' "inputDir/inputFile2" + deleteFile' "inputDir/bar/inputFile3" + deleteDir' "inputDir/foo" + deleteDir' "inputDir/bar" + deleteDir' "inputDir" + + + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.copyDirRecursive" $ do + + -- successes -- + it "copyDirRecursive (Strict, CollectFailures), all fine and compare" $ do + tmpDir' <- getRawTmpDir + copyDirRecursive' "inputDir" + "outputDir" + Strict + CollectFailures + (system $ "diff -r --no-dereference " + ++ toString tmpDir' ++ "inputDir" ++ " " + ++ toString tmpDir' ++ "outputDir" + ++ " >/dev/null") + `shouldReturn` ExitSuccess + removeDirIfExists "outputDir" + + -- posix failures -- + it "copyDirRecursive (Strict, CollectFailures), source directory does not exist" $ + copyDirRecursive' "doesNotExist" + "outputDir" + Strict + CollectFailures + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "copyDirRecursive (Strict, CollectFailures), cannot open source dir" $ + copyDirRecursive' "noPerms/inputDir" + "foo" + Strict + CollectFailures + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + + -- custom failures + it "copyDirRecursive (Overwrite, CollectFailures), various failures" $ do + copyDirRecursive' "inputDir1/foo2" + "outputDir1/foo2" + Overwrite + CollectFailures + `shouldThrow` + (\(RecursiveFailure 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" + tmpDir' <- getRawTmpDir + let shouldC = (fmap (\x -> tmpDir' `BS.append` x) + ["outputDir1" + ,"outputDir1/foo2" + ,"outputDir1/foo2/inputFile1" + ,"outputDir1/foo2/inputFile2" + ,"outputDir1/foo2/inputFile3" + ,"outputDir1/foo2/foo4" + ,"outputDir1/foo2/foo4/inputFile6" + ,"outputDir1/foo2/foo4/inputFile4"]) + deleteFile' "outputDir1/foo2/inputFile1" + deleteFile' "outputDir1/foo2/inputFile2" + deleteFile' "outputDir1/foo2/inputFile3" + sort c `shouldBe` sort shouldC + + + it "copyDirRecursive (Strict, CollectFailures), no write permission on output dir" $ + copyDirRecursive' "inputDir" + "noWritePerm/foo" + Strict + CollectFailures + `shouldThrow` + (\(RecursiveFailure [(CreateDirFailed{}, e)]) -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursive (Strict, CollectFailures), cannot open output dir" $ + copyDirRecursive' "inputDir" + "noPerms/foo" + Strict + CollectFailures + `shouldThrow` + isRecursiveFailure + + it "copyDirRecursive (Strict, CollectFailures), destination dir already exists" $ + copyDirRecursive' "inputDir" + "alreadyExistsD" + Strict + CollectFailures + `shouldThrow` + (\(RecursiveFailure [(CreateDirFailed{}, e)]) -> ioeGetErrorType e == AlreadyExists) + + it "copyDirRecursive (Strict, CollectFailures), destination already exists and is a file" $ + copyDirRecursive' "inputDir" + "alreadyExists" + Strict + CollectFailures + `shouldThrow` + isRecursiveFailure + + it "copyDirRecursive (Strict, CollectFailures), wrong input (regular file)" $ + copyDirRecursive' "wrongInput" + "outputDir" + Strict + CollectFailures + `shouldThrow` + (\(RecursiveFailure [(ReadContentsFailed{}, e)]) -> ioeGetErrorType e == InappropriateType) + + it "copyDirRecursive (Strict, CollectFailures), wrong input (symlink to directory)" $ + copyDirRecursive' "wrongInputSymL" + "outputDir" + Strict + CollectFailures + `shouldThrow` + (\(RecursiveFailure [(ReadContentsFailed{}, e)]) -> ioeGetErrorType e == InvalidArgument) + + it "copyDirRecursive (Strict, CollectFailures), destination in source" $ + copyDirRecursive' "inputDir" + "inputDir/foo" + Strict + CollectFailures + `shouldThrow` + isDestinationInSource + + it "copyDirRecursive (Strict, CollectFailures), destination and source same directory" $ + copyDirRecursive' "inputDir" + "inputDir" + Strict + CollectFailures + `shouldThrow` + isSameFile + + diff --git a/test/System/Posix/RawFilePath/Directory/CopyDirRecursiveOverwriteSpec.hs b/test/System/Posix/RawFilePath/Directory/CopyDirRecursiveOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CopyDirRecursiveOverwriteSpec.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module System.Posix.RawFilePath.Directory.CopyDirRecursiveOverwriteSpec where + + +import Test.Hspec +import "hpath-directory" System.Posix.RawFilePath.Directory +import System.Posix.RawFilePath.Directory.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import System.Exit +import System.Process +import Utils +import Data.ByteString.UTF8 (toString) + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CopyDirRecursiveOverwriteSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "alreadyExists" + createRegularFile' "wrongInput" + createSymlink' "wrongInputSymL" "inputDir/" + createDir' "noPerms" + createDir' "noWritePerm" + + createDir' "inputDir" + createDir' "inputDir/bar" + createDir' "inputDir/foo" + createRegularFile' "inputDir/foo/inputFile1" + createRegularFile' "inputDir/inputFile2" + createRegularFile' "inputDir/bar/inputFile3" + writeFile' "inputDir/foo/inputFile1" "SDAADSdsada" + writeFile' "inputDir/inputFile2" "Blahfaselgagaga" + writeFile' "inputDir/bar/inputFile3" + "fdfdssdffsd3223sasdasdasdadasasddasdasdasasd4" + + createDir' "alreadyExistsD" + createDir' "alreadyExistsD/bar" + createDir' "alreadyExistsD/foo" + createRegularFile' "alreadyExistsD/foo/inputFile1" + createRegularFile' "alreadyExistsD/inputFile2" + createRegularFile' "alreadyExistsD/bar/inputFile3" + writeFile' "alreadyExistsD/foo/inputFile1" "DAAsada" + writeFile' "alreadyExistsD/inputFile2" "ahfaagaga" + writeFile' "alreadyExistsD/bar/inputFile3" + "f3223sasdasdaasdasdasasd4" + + noPerms "noPerms" + noWritableDirPerms "noWritePerm" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerm" + deleteFile' "alreadyExists" + deleteFile' "wrongInput" + deleteFile' "wrongInputSymL" + deleteDir' "noPerms" + deleteDir' "noWritePerm" + deleteFile' "inputDir/foo/inputFile1" + deleteFile' "inputDir/inputFile2" + deleteFile' "inputDir/bar/inputFile3" + deleteDir' "inputDir/foo" + deleteDir' "inputDir/bar" + deleteDir' "inputDir" + deleteFile' "alreadyExistsD/foo/inputFile1" + deleteFile' "alreadyExistsD/inputFile2" + deleteFile' "alreadyExistsD/bar/inputFile3" + deleteDir' "alreadyExistsD/foo" + deleteDir' "alreadyExistsD/bar" + deleteDir' "alreadyExistsD" + + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.copyDirRecursive" $ do + + -- successes -- + it "copyDirRecursive (Overwrite, FailEarly), all fine" $ do + copyDirRecursive' "inputDir" + "outputDir" + Overwrite + FailEarly + removeDirIfExists "outputDir" + + it "copyDirRecursive (Overwrite, FailEarly), all fine and compare" $ do + tmpDir' <- getRawTmpDir + copyDirRecursive' "inputDir" + "outputDir" + Overwrite + FailEarly + (system $ "diff -r --no-dereference " + ++ toString tmpDir' ++ "inputDir" ++ " " + ++ toString tmpDir' ++ "outputDir" + ++ " >/dev/null") + `shouldReturn` ExitSuccess + removeDirIfExists "outputDir" + + it "copyDirRecursive (Overwrite, FailEarly), destination dir already exists" $ do + tmpDir' <- getRawTmpDir + (system $ "diff -r --no-dereference " + ++ toString tmpDir' ++ "inputDir" ++ " " + ++ toString tmpDir' ++ "alreadyExistsD" + ++ " >/dev/null") + `shouldReturn` (ExitFailure 1) + copyDirRecursive' "inputDir" + "alreadyExistsD" + Overwrite + FailEarly + (system $ "diff -r --no-dereference " + ++ toString tmpDir' ++ "inputDir" ++ " " + ++ toString tmpDir' ++ "alreadyExistsD" + ++ " >/dev/null") + `shouldReturn` ExitSuccess + removeDirIfExists "outputDir" + + + -- posix failures -- + it "copyDirRecursive, source directory does not exist" $ + copyDirRecursive' "doesNotExist" + "outputDir" + Overwrite + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "copyDirRecursive, no write permission on output dir" $ + copyDirRecursive' "inputDir" + "noWritePerm/foo" + Overwrite + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursive, cannot open output dir" $ + copyDirRecursive' "inputDir" + "noPerms/foo" + Overwrite + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursive, cannot open source dir" $ + copyDirRecursive' "noPerms/inputDir" + "foo" + Overwrite + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursive, destination already exists and is a file" $ + copyDirRecursive' "inputDir" + "alreadyExists" + Overwrite + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "copyDirRecursive, wrong input (regular file)" $ + copyDirRecursive' "wrongInput" + "outputDir" + Overwrite + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "copyDirRecursive, wrong input (symlink to directory)" $ + copyDirRecursive' "wrongInputSymL" + "outputDir" + Overwrite + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + -- custom failures + it "copyDirRecursive (Overwrite, FailEarly), destination in source" $ + copyDirRecursive' "inputDir" + "inputDir/foo" + Overwrite + FailEarly + `shouldThrow` + isDestinationInSource + + it "copyDirRecursive (Overwrite, FailEarly), destination and source same directory" $ + copyDirRecursive' "inputDir" + "inputDir" + Overwrite + FailEarly + `shouldThrow` + isSameFile diff --git a/test/System/Posix/RawFilePath/Directory/CopyDirRecursiveSpec.hs b/test/System/Posix/RawFilePath/Directory/CopyDirRecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CopyDirRecursiveSpec.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module System.Posix.RawFilePath.Directory.CopyDirRecursiveSpec where + + +import Test.Hspec +import "hpath-directory" System.Posix.RawFilePath.Directory +import System.Posix.RawFilePath.Directory.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import System.Exit +import System.Process +import Utils +import Data.ByteString.UTF8 (toString) + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CopyDirRecursiveSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createRegularFile' "alreadyExists" + createRegularFile' "wrongInput" + createSymlink' "wrongInputSymL" "inputDir/" + createDir' "alreadyExistsD" + createDir' "noPerms" + createDir' "noWritePerm" + + createDir' "inputDir" + createDir' "inputDir/bar" + createDir' "inputDir/foo" + createRegularFile' "inputDir/foo/inputFile1" + createRegularFile' "inputDir/inputFile2" + createRegularFile' "inputDir/bar/inputFile3" + writeFile' "inputDir/foo/inputFile1" "SDAADSdsada" + writeFile' "inputDir/inputFile2" "Blahfaselgagaga" + writeFile' "inputDir/bar/inputFile3" + "fdfdssdffsd3223sasdasdasdadasasddasdasdasasd4" + + noPerms "noPerms" + noWritableDirPerms "noWritePerm" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerm" + deleteFile' "alreadyExists" + deleteFile' "wrongInput" + deleteFile' "wrongInputSymL" + deleteDir' "alreadyExistsD" + deleteDir' "noPerms" + deleteDir' "noWritePerm" + deleteFile' "inputDir/foo/inputFile1" + deleteFile' "inputDir/inputFile2" + deleteFile' "inputDir/bar/inputFile3" + deleteDir' "inputDir/foo" + deleteDir' "inputDir/bar" + deleteDir' "inputDir" + + + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.copyDirRecursive" $ do + + -- successes -- + it "copyDirRecursive (Strict, FailEarly), all fine" $ do + copyDirRecursive' "inputDir" + "outputDir" + Strict + FailEarly + removeDirIfExists "outputDir" + + it "copyDirRecursive (Strict, FailEarly), all fine and compare" $ do + tmpDir' <- getRawTmpDir + copyDirRecursive' "inputDir" + "outputDir" + Strict + FailEarly + (system $ "diff -r --no-dereference " + ++ toString tmpDir' ++ "inputDir" ++ " " + ++ toString tmpDir' ++ "outputDir" + ++ " >/dev/null") + `shouldReturn` ExitSuccess + removeDirIfExists "outputDir" + + -- posix failures -- + it "copyDirRecursive (Strict, FailEarly), source directory does not exist" $ + copyDirRecursive' "doesNotExist" + "outputDir" + Strict + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "copyDirRecursive (Strict, FailEarly), no write permission on output dir" $ + copyDirRecursive' "inputDir" + "noWritePerm/foo" + Strict + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursive (Strict, FailEarly), cannot open output dir" $ + copyDirRecursive' "inputDir" + "noPerms/foo" + Strict + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursive (Strict, FailEarly), cannot open source dir" $ + copyDirRecursive' "noPerms/inputDir" + "foo" + Strict + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursive (Strict, FailEarly), destination dir already exists" $ + copyDirRecursive' "inputDir" + "alreadyExistsD" + Strict + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "copyDirRecursive (Strict, FailEarly), destination already exists and is a file" $ + copyDirRecursive' "inputDir" + "alreadyExists" + Strict + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "copyDirRecursive (Strict, FailEarly), wrong input (regular file)" $ + copyDirRecursive' "wrongInput" + "outputDir" + Strict + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "copyDirRecursive (Strict, FailEarly), wrong input (symlink to directory)" $ + copyDirRecursive' "wrongInputSymL" + "outputDir" + Strict + FailEarly + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + -- custom failures + it "copyDirRecursive (Strict, FailEarly), destination in source" $ + copyDirRecursive' "inputDir" + "inputDir/foo" + Strict + FailEarly + `shouldThrow` + isDestinationInSource + + it "copyDirRecursive (Strict, FailEarly), destination and source same directory" $ + copyDirRecursive' "inputDir" + "inputDir" + Strict + FailEarly + `shouldThrow` + isSameFile + + diff --git a/test/System/Posix/RawFilePath/Directory/CopyFileOverwriteSpec.hs b/test/System/Posix/RawFilePath/Directory/CopyFileOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CopyFileOverwriteSpec.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.CopyFileOverwriteSpec where + + +import Test.Hspec +import "hpath-directory" System.Posix.RawFilePath.Directory +import System.Posix.RawFilePath.Directory.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import System.Exit +import System.Process +import Utils +import Data.ByteString.UTF8 (toString) + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CopyFileOverwriteSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "inputFile" + createRegularFile' "alreadyExists" + createSymlink' "inputFileSymL" "inputFile" + createDir' "alreadyExistsD" + createDir' "noPerms" + createRegularFile' "noPerms/inputFile" + createDir' "outputDirNoWrite" + createDir' "wrongInput" + noPerms "noPerms" + noWritableDirPerms "outputDirNoWrite" + writeFile' "inputFile" "Blahfaselgagaga" + writeFile' "alreadyExists" "dsaldsalkaklsdlkasksdadasl" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "outputDirNoWrite" + deleteFile' "noPerms/inputFile" + deleteFile' "inputFile" + deleteFile' "alreadyExists" + deleteFile' "inputFileSymL" + deleteDir' "alreadyExistsD" + deleteDir' "noPerms" + deleteDir' "outputDirNoWrite" + deleteDir' "wrongInput" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.copyFile" $ do + + -- successes -- + it "copyFile (Overwrite), everything clear" $ do + copyFile' "inputFile" + "outputFile" + Overwrite + removeFileIfExists "outputFile" + + it "copyFile (Overwrite), output file already exists, all clear" $ do + tmpDir' <- getRawTmpDir + copyFile' "alreadyExists" "alreadyExists.bak" Strict + copyFile' "inputFile" "alreadyExists" Overwrite + (system $ "cmp -s " ++ toString tmpDir' ++ "inputFile" ++ " " + ++ toString tmpDir' ++ "alreadyExists") + `shouldReturn` ExitSuccess + removeFileIfExists "alreadyExists" + copyFile' "alreadyExists.bak" "alreadyExists" Strict + removeFileIfExists "alreadyExists.bak" + + it "copyFile (Overwrite), and compare" $ do + tmpDir' <- getRawTmpDir + copyFile' "inputFile" + "outputFile" + Overwrite + (system $ "cmp -s " ++ toString tmpDir' ++ "inputFile" ++ " " + ++ toString tmpDir' ++ "outputFile") + `shouldReturn` ExitSuccess + removeFileIfExists "outputFile" + + + -- posix failures -- + it "copyFile (Overwrite), input file does not exist" $ + copyFile' "noSuchFile" + "outputFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "copyFile (Overwrite), no permission to write to output directory" $ + copyFile' "inputFile" + "outputDirNoWrite/outputFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFile (Overwrite), cannot open output directory" $ + copyFile' "inputFile" + "noPerms/outputFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFile (Overwrite), cannot open source directory" $ + copyFile' "noPerms/inputFile" + "outputFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFile (Overwrite), wrong input type (symlink)" $ + copyFile' "inputFileSymL" + "outputFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "copyFile (Overwrite), wrong input type (directory)" $ + copyFile' "wrongInput" + "outputFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "copyFile (Overwrite), output file already exists and is a dir" $ + copyFile' "inputFile" + "alreadyExistsD" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + -- custom failures -- + it "copyFile (Overwrite), output and input are same file" $ + copyFile' "inputFile" + "inputFile" + Overwrite + `shouldThrow` isSameFile diff --git a/test/System/Posix/RawFilePath/Directory/CopyFileSpec.hs b/test/System/Posix/RawFilePath/Directory/CopyFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CopyFileSpec.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module System.Posix.RawFilePath.Directory.CopyFileSpec where + + +import Test.Hspec +import "hpath-directory" System.Posix.RawFilePath.Directory +import System.Posix.RawFilePath.Directory.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import System.Exit +import System.Process +import Utils +import Data.ByteString.UTF8 (toString) + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CopyFileSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createRegularFile' "inputFile" + createRegularFile' "alreadyExists" + createSymlink' "inputFileSymL" "inputFile" + createDir' "alreadyExistsD" + createDir' "noPerms" + createRegularFile' "noPerms/inputFile" + createDir' "outputDirNoWrite" + createDir' "wrongInput" + noPerms "noPerms" + noWritableDirPerms "outputDirNoWrite" + writeFile' "inputFile" "Blahfaselgagaga" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "outputDirNoWrite" + deleteFile' "noPerms/inputFile" + deleteFile' "inputFile" + deleteFile' "alreadyExists" + deleteFile' "inputFileSymL" + deleteDir' "alreadyExistsD" + deleteDir' "noPerms" + deleteDir' "outputDirNoWrite" + deleteDir' "wrongInput" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.copyFile" $ do + + -- successes -- + it "copyFile (Strict), everything clear" $ do + copyFile' "inputFile" + "outputFile" + Strict + removeFileIfExists "outputFile" + + it "copyFile (Strict), and compare" $ do + tmpDir' <- getRawTmpDir + copyFile' "inputFile" + "outputFile" + Strict + (system $ "cmp -s " ++ toString tmpDir' ++ "inputFile" ++ " " + ++ toString tmpDir' ++ "outputFile") + `shouldReturn` ExitSuccess + removeFileIfExists "outputFile" + + -- posix failures -- + it "copyFile (Strict), input file does not exist" $ + copyFile' "noSuchFile" + "outputFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "copyFile (Strict), no permission to write to output directory" $ + copyFile' "inputFile" + "outputDirNoWrite/outputFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFile (Strict), cannot open output directory" $ + copyFile' "inputFile" + "noPerms/outputFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFile (Strict), cannot open source directory" $ + copyFile' "noPerms/inputFile" + "outputFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFile (Strict), wrong input type (symlink)" $ + copyFile' "inputFileSymL" + "outputFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "copyFile (Strict), wrong input type (directory)" $ + copyFile' "wrongInput" + "outputFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "copyFile (Strict), output file already exists" $ + copyFile' "inputFile" + "alreadyExists" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "copyFile (Strict), output file already exists and is a dir" $ + copyFile' "inputFile" + "alreadyExistsD" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + -- custom failures -- + it "copyFile (Strict), output and input are same file" $ + copyFile' "inputFile" + "inputFile" + Strict + `shouldThrow` + isSameFile diff --git a/test/System/Posix/RawFilePath/Directory/CreateDirIfMissingSpec.hs b/test/System/Posix/RawFilePath/Directory/CreateDirIfMissingSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CreateDirIfMissingSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.CreateDirIfMissingSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CreateDirIfMissingSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createDir' "alreadyExists" + createDir' "noPerms" + createDir' "noWritePerms" + noPerms "noPerms" + noWritableDirPerms "noWritePerms" + + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerms" + deleteDir' "alreadyExists" + deleteDir' "noPerms" + deleteDir' "noWritePerms" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.CreateDirIfMissing" $ do + + -- successes -- + it "createDirIfMissing, all fine" $ do + createDirIfMissing' "newDir" + removeDirIfExists "newDir" + + it "createDirIfMissing, destination directory already exists" $ + createDirIfMissing' "alreadyExists" + + -- posix failures -- + it "createDirIfMissing, parent directories do not exist" $ + createDirIfMissing' "some/thing/dada" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "createDirIfMissing, can't write to output directory" $ + createDirIfMissing' "noWritePerms/newDir" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createDirIfMissing, can't open output directory" $ + createDirIfMissing' "noPerms/newDir" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) diff --git a/test/System/Posix/RawFilePath/Directory/CreateDirRecursiveSpec.hs b/test/System/Posix/RawFilePath/Directory/CreateDirRecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CreateDirRecursiveSpec.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.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 "System.Posix.RawFilePath.Directory.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/System/Posix/RawFilePath/Directory/CreateDirSpec.hs b/test/System/Posix/RawFilePath/Directory/CreateDirSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CreateDirSpec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.CreateDirSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CreateDirSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createDir' "alreadyExists" + createDir' "noPerms" + createDir' "noWritePerms" + noPerms "noPerms" + noWritableDirPerms "noWritePerms" + + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerms" + deleteDir' "alreadyExists" + deleteDir' "noPerms" + deleteDir' "noWritePerms" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.createDir" $ do + + -- successes -- + it "createDir, all fine" $ do + createDir' "newDir" + 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` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createDir, can't open output directory" $ + createDir' "noPerms/newDir" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createDir, destination directory already exists" $ + createDir' "alreadyExists" + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + diff --git a/test/System/Posix/RawFilePath/Directory/CreateRegularFileSpec.hs b/test/System/Posix/RawFilePath/Directory/CreateRegularFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CreateRegularFileSpec.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.CreateRegularFileSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CreateRegularFileSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createRegularFile' "alreadyExists" + createDir' "noPerms" + createDir' "noWritePerms" + noPerms "noPerms" + noWritableDirPerms "noWritePerms" + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerms" + deleteFile' "alreadyExists" + deleteDir' "noPerms" + deleteDir' "noWritePerms" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.createRegularFile" $ do + + -- successes -- + it "createRegularFile, all fine" $ do + createRegularFile' "newDir" + 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` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createRegularFile, can't write to destination directory" $ + createRegularFile' "noPerms/newDir" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createRegularFile, destination file already exists" $ + createRegularFile' "alreadyExists" + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + diff --git a/test/System/Posix/RawFilePath/Directory/CreateSymlinkSpec.hs b/test/System/Posix/RawFilePath/Directory/CreateSymlinkSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/CreateSymlinkSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.CreateSymlinkSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CreateSymlinkSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "alreadyExists" + createDir' "noPerms" + createDir' "noWritePerms" + noPerms "noPerms" + noWritableDirPerms "noWritePerms" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerms" + deleteFile' "alreadyExists" + deleteDir' "noPerms" + deleteDir' "noWritePerms" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.createSymlink" $ do + + -- successes -- + it "createSymlink, all fine" $ do + createSymlink' "newSymL" "alreadyExists/" + 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` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createSymlink, can't write to destination directory" $ + createSymlink' "noPerms/newDir" "lala" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createSymlink, destination file already exists" $ + createSymlink' "alreadyExists" "lala" + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + diff --git a/test/System/Posix/RawFilePath/Directory/DeleteDirRecursiveSpec.hs b/test/System/Posix/RawFilePath/Directory/DeleteDirRecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/DeleteDirRecursiveSpec.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.DeleteDirRecursiveSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import System.Posix.Files.ByteString + ( + getSymbolicLinkStatus + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "DeleteDirRecursiveSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "file" + createDir' "dir" + createRegularFile' "dir/.keep" + createSymlink' "dirSym" "dir/" + createDir' "noPerms" + createRegularFile' "noPerms/.keep" + createDir' "noWritable" + createRegularFile' "noWritable/.keep" + + +cleanupFiles :: IO () +cleanupFiles = do + deleteFile' "file" + deleteFile' "dir/.keep" + deleteDir' "dir" + deleteFile' "dirSym" + deleteFile' "noPerms/.keep" + deleteDir' "noPerms" + deleteFile' "noWritable/.keep" + deleteDir' "noWritable" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.deleteDirRecursive" $ do + + -- successes -- + it "deleteDirRecursive, empty directory, all fine" $ do + createDir' "testDir" + deleteDirRecursive' "testDir" + getSymbolicLinkStatus "testDir" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "deleteDirRecursive, empty directory with null permissions, all fine" $ do + createDir' "noPerms/testDir" + noPerms "noPerms/testDir" + deleteDirRecursive' "noPerms/testDir" + + it "deleteDirRecursive, non-empty directory, all fine" $ do + createDir' "nonEmpty" + createDir' "nonEmpty/dir1" + createDir' "nonEmpty/dir2" + createDir' "nonEmpty/dir2/dir3" + createRegularFile' "nonEmpty/file1" + createRegularFile' "nonEmpty/dir1/file2" + deleteDirRecursive' "nonEmpty" + getSymbolicLinkStatus "nonEmpty" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + -- posix failures -- + it "deleteDirRecursive, can't open parent directory" $ do + createDir' "noPerms/foo" + noPerms "noPerms" + (deleteDirRecursive' "noPerms/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + normalDirPerms "noPerms" + deleteDir' "noPerms/foo" + + it "deleteDirRecursive, can't write to parent directory" $ do + createDir' "noWritable/foo" + noWritableDirPerms "noWritable" + (deleteDirRecursive' "noWritable/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + normalDirPerms "noWritable" + deleteDir' "noWritable/foo" + + it "deleteDirRecursive, wrong file type (symlink to directory)" $ + deleteDirRecursive' "dirSym" + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "deleteDirRecursive, wrong file type (regular file)" $ + deleteDirRecursive' "file" + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "deleteDirRecursive, directory does not exist" $ + deleteDirRecursive' "doesNotExist" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + diff --git a/test/System/Posix/RawFilePath/Directory/DeleteDirSpec.hs b/test/System/Posix/RawFilePath/Directory/DeleteDirSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/DeleteDirSpec.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.DeleteDirSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import System.Posix.Files.ByteString + ( + getSymbolicLinkStatus + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "DeleteDirSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "file" + createDir' "dir" + createRegularFile' "dir/.keep" + createSymlink' "dirSym" "dir/" + createDir' "noPerms" + createRegularFile' "noPerms/.keep" + createDir' "noWritable" + createRegularFile' "noWritable/.keep" + + +cleanupFiles :: IO () +cleanupFiles = do + deleteFile' "file" + deleteFile' "dir/.keep" + deleteDir' "dir" + deleteFile' "dirSym" + deleteFile' "noPerms/.keep" + deleteDir' "noPerms" + deleteFile' "noWritable/.keep" + deleteDir' "noWritable" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.deleteDir" $ do + + -- successes -- + it "deleteDir, empty directory, all fine" $ do + createDir' "testDir" + deleteDir' "testDir" + getSymbolicLinkStatus "testDir" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "deleteDir, directory with null permissions, all fine" $ do + createDir' "noPerms/testDir" + noPerms "noPerms/testDir" + deleteDir' "noPerms/testDir" + getSymbolicLinkStatus "testDir" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + -- posix failures -- + it "deleteDir, wrong file type (symlink to directory)" $ + deleteDir' "dirSym" + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "deleteDir, wrong file type (regular file)" $ + deleteDir' "file" + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "deleteDir, directory does not exist" $ + deleteDir' "doesNotExist" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "deleteDir, directory not empty" $ + deleteDir' "dir" + `shouldThrow` + (\e -> ioeGetErrorType e == UnsatisfiedConstraints) + + it "deleteDir, can't open parent directory" $ do + createDir' "noPerms/foo" + noPerms "noPerms" + (deleteDir' "noPerms/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + normalDirPerms "noPerms" + deleteDir' "noPerms/foo" + + it "deleteDir, can't write to parent directory, still fine" $ do + createDir' "noWritable/foo" + noWritableDirPerms "noWritable" + (deleteDir' "noWritable/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + normalDirPerms "noWritable" + deleteDir' "noWritable/foo" + + + diff --git a/test/System/Posix/RawFilePath/Directory/DeleteFileSpec.hs b/test/System/Posix/RawFilePath/Directory/DeleteFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/DeleteFileSpec.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.DeleteFileSpec where + + +import Test.Hspec +import "hpath-directory" System.Posix.RawFilePath.Directory +import System.IO.Error + ( + ioeGetErrorType + ) +import System.Posix.Files.ByteString + ( + getSymbolicLinkStatus + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "DeleteFileSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "foo" + createSymlink' "syml" "foo" + createDir' "dir" + createDir' "noPerms" + noPerms "noPerms" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + deleteFile' "foo" + deleteFile' "syml" + deleteDir' "dir" + deleteDir' "noPerms" + + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.deleteFile" $ do + + -- successes -- + it "deleteFile, regular file, all fine" $ do + createRegularFile' "testFile" + deleteFile' "testFile" + getSymbolicLinkStatus "testFile" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "deleteFile, symlink, all fine" $ do + recreateSymlink' "syml" + "testFile" + Strict + deleteFile' "testFile" + getSymbolicLinkStatus "testFile" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + -- posix failures -- + it "deleteFile, wrong file type (directory)" $ + deleteFile' "dir" + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "deleteFile, file does not exist" $ + deleteFile' "doesNotExist" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "deleteFile, can't read directory" $ + deleteFile' "noPerms/blah" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + diff --git a/test/System/Posix/RawFilePath/Directory/GetDirsFilesSpec.hs b/test/System/Posix/RawFilePath/Directory/GetDirsFilesSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/GetDirsFilesSpec.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.GetDirsFilesSpec where + + +import Data.List + ( + sort + ) +import "hpath-directory" System.Posix.RawFilePath.Directory hiding (getDirsFiles') +import System.Posix.FilePath +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "GetDirsFilesSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "file" + createRegularFile' "Lala" + createRegularFile' ".hidden" + createSymlink' "syml" "Lala" + createDir' "dir" + createSymlink' "dirsym" "dir" + createDir' "noPerms" + noPerms "noPerms" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + deleteFile' "file" + deleteFile' "Lala" + deleteFile' ".hidden" + deleteFile' "syml" + deleteDir' "dir" + deleteFile' "dirsym" + deleteDir' "noPerms" + + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.getDirsFiles" $ do + + -- successes -- + it "getDirsFiles, all fine" $ + withRawTmpDir $ \p -> do + let expectedFiles = [".hidden" + ,"Lala" + ,"dir" + ,"dirsym" + ,"file" + ,"noPerms" + ,"syml"] + (fmap sort $ getDirsFiles p) + `shouldReturn` fmap (p ) expectedFiles + + -- posix failures -- + it "getDirsFiles, nonexistent directory" $ + getDirsFiles' "nothingHere" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "getDirsFiles, wrong file type (file)" $ + getDirsFiles' "file" + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "getDirsFiles, wrong file type (symlink to file)" $ + getDirsFiles' "syml" + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "getDirsFiles, wrong file type (symlink to dir)" $ + getDirsFiles' "dirsym" + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "getDirsFiles, can't open directory" $ + getDirsFiles' "noPerms" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + + + diff --git a/test/System/Posix/RawFilePath/Directory/GetFileTypeSpec.hs b/test/System/Posix/RawFilePath/Directory/GetFileTypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/GetFileTypeSpec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.GetFileTypeSpec where + + +import "hpath-directory" System.Posix.RawFilePath.Directory +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "GetFileTypeSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "regularfile" + createSymlink' "symlink" "regularfile" + createSymlink' "brokenSymlink" "broken" + createDir' "directory" + createSymlink' "symlinkD" "directory" + createDir' "noPerms" + noPerms "noPerms" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + deleteFile' "regularfile" + deleteFile' "symlink" + deleteFile' "brokenSymlink" + deleteDir' "directory" + deleteFile' "symlinkD" + deleteDir' "noPerms" + + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.getFileType" $ do + + -- successes -- + it "getFileType, regular file" $ + getFileType' "regularfile" + `shouldReturn` RegularFile + + it "getFileType, directory" $ + getFileType' "directory" + `shouldReturn` Directory + + it "getFileType, directory with null permissions" $ + getFileType' "noPerms" + `shouldReturn` Directory + + it "getFileType, symlink to file" $ + getFileType' "symlink" + `shouldReturn` SymbolicLink + + it "getFileType, symlink to directory" $ + getFileType' "symlinkD" + `shouldReturn` SymbolicLink + + it "getFileType, broken symlink" $ + getFileType' "brokenSymlink" + `shouldReturn` SymbolicLink + + -- posix failures -- + it "getFileType, file does not exist" $ + getFileType' "nothingHere" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "getFileType, can't open directory" $ + getFileType' "noPerms/forz" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + diff --git a/test/System/Posix/RawFilePath/Directory/MoveFileOverwriteSpec.hs b/test/System/Posix/RawFilePath/Directory/MoveFileOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/MoveFileOverwriteSpec.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.MoveFileOverwriteSpec where + + +import Test.Hspec +import "hpath-directory" System.Posix.RawFilePath.Directory +import System.Posix.RawFilePath.Directory.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "MoveFileOverwriteSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "myFile" + createSymlink' "myFileL" "myFile" + createDir' "alreadyExistsD" + createDir' "dir" + createDir' "noPerms" + createDir' "noWritePerm" + noPerms "noPerms" + noWritableDirPerms "noWritePerm" + writeFile' "myFile" "Blahfaselgagaga" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerm" + deleteFile' "myFile" + deleteFile' "myFileL" + deleteDir' "alreadyExistsD" + deleteDir' "dir" + deleteDir' "noPerms" + deleteDir' "noWritePerm" + + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.moveFile" $ do + + -- successes -- + it "moveFile (Overwrite), all fine" $ + moveFile' "myFile" + "movedFile" + Overwrite + + it "moveFile (Overwrite), all fine" $ + moveFile' "myFile" + "dir/movedFile" + Overwrite + + it "moveFile (Overwrite), all fine on symlink" $ + moveFile' "myFileL" + "movedFile" + Overwrite + + it "moveFile (Overwrite), all fine on directory" $ + moveFile' "dir" + "movedFile" + Overwrite + + it "moveFile (Overwrite), destination file already exists" $ + moveFile' "myFile" + "alreadyExists" + Overwrite + + -- posix failures -- + it "moveFile (Overwrite), source file does not exist" $ + moveFile' "fileDoesNotExist" + "movedFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "moveFile (Overwrite), can't write to destination directory" $ + moveFile' "myFile" + "noWritePerm/movedFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "moveFile (Overwrite), can't open destination directory" $ + moveFile' "myFile" + "noPerms/movedFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "moveFile (Overwrite), can't open source directory" $ + moveFile' "noPerms/myFile" + "movedFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + -- custom failures -- + + it "moveFile (Overwrite), move from file to dir" $ + moveFile' "myFile" + "alreadyExistsD" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "moveFile (Overwrite), source and dest are same file" $ + moveFile' "myFile" + "myFile" + Overwrite + `shouldThrow` + isSameFile diff --git a/test/System/Posix/RawFilePath/Directory/MoveFileSpec.hs b/test/System/Posix/RawFilePath/Directory/MoveFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/MoveFileSpec.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.MoveFileSpec where + + +import Test.Hspec +import "hpath-directory" System.Posix.RawFilePath.Directory +import System.Posix.RawFilePath.Directory.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "MoveFileSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "myFile" + createSymlink' "myFileL" "myFile" + createRegularFile' "alreadyExists" + createDir' "alreadyExistsD" + createDir' "dir" + createDir' "noPerms" + createDir' "noWritePerm" + noPerms "noPerms" + noWritableDirPerms "noWritePerm" + writeFile' "myFile" "Blahfaselgagaga" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerm" + deleteFile' "myFile" + deleteFile' "myFileL" + deleteFile' "alreadyExists" + deleteDir' "alreadyExistsD" + deleteDir' "dir" + deleteDir' "noPerms" + deleteDir' "noWritePerm" + + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.moveFile" $ do + + -- successes -- + it "moveFile (Strict), all fine" $ + moveFile' "myFile" + "movedFile" + Strict + + it "moveFile (Strict), all fine" $ + moveFile' "myFile" + "dir/movedFile" + Strict + + it "moveFile (Strict), all fine on symlink" $ + moveFile' "myFileL" + "movedFile" + Strict + + it "moveFile (Strict), all fine on directory" $ + moveFile' "dir" + "movedFile" + Strict + + -- posix failures -- + it "moveFile (Strict), source file does not exist" $ + moveFile' "fileDoesNotExist" + "movedFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "moveFile (Strict), can't write to destination directory" $ + moveFile' "myFile" + "noWritePerm/movedFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "moveFile (Strict), can't open destination directory" $ + moveFile' "myFile" + "noPerms/movedFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "moveFile (Strict), can't open source directory" $ + moveFile' "noPerms/myFile" + "movedFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + -- custom failures -- + it "moveFile (Strict), destination file already exists" $ + moveFile' "myFile" + "alreadyExists" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "moveFile (Strict), move from file to dir" $ + moveFile' "myFile" + "alreadyExistsD" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "moveFile (Strict), source and dest are same file" $ + moveFile' "myFile" + "myFile" + Strict + `shouldThrow` + isSameFile diff --git a/test/System/Posix/RawFilePath/Directory/ReadFileSpec.hs b/test/System/Posix/RawFilePath/Directory/ReadFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/ReadFileSpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module System.Posix.RawFilePath.Directory.ReadFileSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "ReadFileSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createRegularFile' "fileWithContent" + createRegularFile' "fileWithoutContent" + createSymlink' "inputFileSymL" "fileWithContent" + createDir' "alreadyExistsD" + createRegularFile' "noPerms" + noPerms "noPerms" + createDir' "noPermsD" + createRegularFile' "noPermsD/inputFile" + noPerms "noPermsD" + writeFile' "fileWithContent" "Blahfaselgagaga" + + +cleanupFiles :: IO () +cleanupFiles = do + deleteFile' "fileWithContent" + deleteFile' "fileWithoutContent" + deleteFile' "inputFileSymL" + deleteDir' "alreadyExistsD" + normalFilePerms "noPerms" + deleteFile' "noPerms" + normalDirPerms "noPermsD" + deleteFile' "noPermsD/inputFile" + deleteDir' "noPermsD" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.readFile" $ do + + -- successes -- + it "readFile (Strict) file with content, everything clear" $ do + out <- readFile' "fileWithContent" + out `shouldBe` "Blahfaselgagaga" + + it "readFile (Strict) symlink, everything clear" $ do + out <- readFile' "inputFileSymL" + out `shouldBe` "Blahfaselgagaga" + + it "readFile (Strict) empty file, everything clear" $ do + out <- readFile' "fileWithoutContent" + out `shouldBe` "" + + + -- posix failures -- + it "readFile (Strict) directory, wrong file type" $ do + readFile' "alreadyExistsD" + `shouldThrow` (\e -> ioeGetErrorType e == InappropriateType) + + it "readFile (Strict) file, no permissions" $ do + readFile' "noPerms" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "readFile (Strict) file, no permissions on dir" $ do + readFile' "noPermsD/inputFile" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "readFile (Strict) file, no such file" $ do + readFile' "lalala" + `shouldThrow` (\e -> ioeGetErrorType e == NoSuchThing) diff --git a/test/System/Posix/RawFilePath/Directory/RecreateSymlinkOverwriteSpec.hs b/test/System/Posix/RawFilePath/Directory/RecreateSymlinkOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/RecreateSymlinkOverwriteSpec.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.RecreateSymlinkOverwriteSpec where + + +-- TODO: exception if destination exists but is not a file + `OverWrite` CopyMode + + +import Test.Hspec +import "hpath-directory" System.Posix.RawFilePath.Directory +import System.Posix.RawFilePath.Directory.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "RecreateSymlinkOverwriteSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "myFile" + createSymlink' "myFileL" "myFile" + createRegularFile' "alreadyExists" + createDir' "alreadyExistsD" + createDir' "dir" + createDir' "noPerms" + createDir' "noWritePerm" + createDir' "alreadyExistsD2" + createRegularFile' "alreadyExistsD2/lala" + noPerms "noPerms" + noWritableDirPerms "noWritePerm" + writeFile' "myFile" "Blahfaselgagaga" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerm" + deleteFile' "myFile" + deleteFile' "myFileL" + deleteFile' "alreadyExists" + deleteFile' "alreadyExistsD2/lala" + deleteDir' "alreadyExistsD" + deleteDir' "alreadyExistsD2" + deleteDir' "dir" + deleteDir' "noPerms" + deleteDir' "noWritePerm" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.recreateSymlink" $ do + + -- successes -- + it "recreateSymLink (Overwrite), all fine" $ do + recreateSymlink' "myFileL" + "movedFile" + Overwrite + removeFileIfExists "movedFile" + + it "recreateSymLink (Overwrite), all fine" $ do + recreateSymlink' "myFileL" + "dir/movedFile" + Overwrite + removeFileIfExists "dir/movedFile" + + it "recreateSymLink (Overwrite), destination file already exists" $ + recreateSymlink' "myFileL" + "alreadyExists" + Overwrite + + it "recreateSymLink (Overwrite), destination already exists and is an empty dir" $ do + recreateSymlink' "myFileL" + "alreadyExistsD" + Overwrite + deleteFile' "alreadyExistsD" + createDir' "alreadyExistsD" + + -- posix failures -- + it "recreateSymLink (Overwrite), destination already exists and is a non-empty dir" $ + recreateSymlink' "myFileL" + "alreadyExistsD2" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == UnsatisfiedConstraints) + + it "recreateSymLink (Overwrite), wrong input type (file)" $ + recreateSymlink' "myFile" + "movedFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "recreateSymLink (Overwrite), wrong input type (directory)" $ + recreateSymlink' "dir" + "movedFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "recreateSymLink (Overwrite), can't write to destination directory" $ + recreateSymlink' "myFileL" + "noWritePerm/movedFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "recreateSymLink (Overwrite), can't open destination directory" $ + recreateSymlink' "myFileL" + "noPerms/movedFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "recreateSymLink (Overwrite), can't open source directory" $ + recreateSymlink' "noPerms/myFileL" + "movedFile" + Overwrite + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + -- custom failures -- + it "recreateSymLink (Overwrite), source and destination are the same file" $ + recreateSymlink' "myFileL" + "myFileL" + Overwrite + `shouldThrow` + isSameFile + diff --git a/test/System/Posix/RawFilePath/Directory/RecreateSymlinkSpec.hs b/test/System/Posix/RawFilePath/Directory/RecreateSymlinkSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/RecreateSymlinkSpec.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.RecreateSymlinkSpec where + + + + +import Test.Hspec +import "hpath-directory" System.Posix.RawFilePath.Directory +import System.Posix.RawFilePath.Directory.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "RecreateSymlinkSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "myFile" + createSymlink' "myFileL" "myFile" + createRegularFile' "alreadyExists" + createDir' "alreadyExistsD" + createDir' "dir" + createDir' "noPerms" + createDir' "noWritePerm" + noPerms "noPerms" + noWritableDirPerms "noWritePerm" + writeFile' "myFile" "Blahfaselgagaga" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerm" + deleteFile' "myFile" + deleteFile' "myFileL" + deleteFile' "alreadyExists" + deleteDir' "alreadyExistsD" + deleteDir' "dir" + deleteDir' "noPerms" + deleteDir' "noWritePerm" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.recreateSymlink" $ do + + -- successes -- + it "recreateSymLink (Strict), all fine" $ do + recreateSymlink' "myFileL" + "movedFile" + Strict + removeFileIfExists "movedFile" + + it "recreateSymLink (Strict), all fine" $ do + recreateSymlink' "myFileL" + "dir/movedFile" + Strict + removeFileIfExists "dir/movedFile" + + -- posix failures -- + it "recreateSymLink (Strict), wrong input type (file)" $ + recreateSymlink' "myFile" + "movedFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "recreateSymLink (Strict), wrong input type (directory)" $ + recreateSymlink' "dir" + "movedFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "recreateSymLink (Strict), can't write to destination directory" $ + recreateSymlink' "myFileL" + "noWritePerm/movedFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "recreateSymLink (Strict), can't open destination directory" $ + recreateSymlink' "myFileL" + "noPerms/movedFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "recreateSymLink (Strict), can't open source directory" $ + recreateSymlink' "noPerms/myFileL" + "movedFile" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "recreateSymLink (Strict), destination file already exists" $ + recreateSymlink' "myFileL" + "alreadyExists" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "recreateSymLink (Strict), destination already exists and is a dir" $ + recreateSymlink' "myFileL" + "alreadyExistsD" + Strict + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + -- custom failures -- + it "recreateSymLink (Strict), source and destination are the same file" $ + recreateSymlink' "myFileL" + "myFileL" + Strict + `shouldThrow` + isSameFile + diff --git a/test/System/Posix/RawFilePath/Directory/RenameFileSpec.hs b/test/System/Posix/RawFilePath/Directory/RenameFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/RenameFileSpec.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.RawFilePath.Directory.RenameFileSpec where + + +import Test.Hspec +import System.Posix.RawFilePath.Directory.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "RenameFileSpec" + createTmpDir + + +setupFiles :: IO () +setupFiles = do + createRegularFile' "myFile" + createSymlink' "myFileL" "myFile" + createRegularFile' "alreadyExists" + createDir' "alreadyExistsD" + createDir' "dir" + createDir' "noPerms" + createDir' "noWritePerm" + noPerms "noPerms" + noWritableDirPerms "noWritePerm" + writeFile' "myFile" "Blahfaselgagaga" + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerm" + deleteFile' "myFile" + deleteFile' "myFileL" + deleteFile' "alreadyExists" + deleteDir' "alreadyExistsD" + deleteDir' "dir" + deleteDir' "noPerms" + deleteDir' "noWritePerm" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.renameFile" $ do + + -- successes -- + it "renameFile, all fine" $ + renameFile' "myFile" + "renamedFile" + + it "renameFile, all fine" $ + renameFile' "myFile" + "dir/renamedFile" + + it "renameFile, all fine on symlink" $ + renameFile' "myFileL" + "renamedFile" + + it "renameFile, all fine on directory" $ + renameFile' "dir" + "renamedFile" + + -- posix failures -- + it "renameFile, source file does not exist" $ + renameFile' "fileDoesNotExist" + "renamedFile" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "renameFile, can't write to output directory" $ + renameFile' "myFile" + "noWritePerm/renamedFile" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "renameFile, can't open output directory" $ + renameFile' "myFile" + "noPerms/renamedFile" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "renameFile, can't open source directory" $ + renameFile' "noPerms/myFile" + "renamedFile" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + -- custom failures -- + it "renameFile, destination file already exists" $ + renameFile' "myFile" + "alreadyExists" + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "renameFile, move from file to dir" $ + renameFile' "myFile" + "alreadyExistsD" + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "renameFile, source and dest are same file" $ + renameFile' "myFile" + "myFile" + `shouldThrow` + isSameFile + diff --git a/test/System/Posix/RawFilePath/Directory/ToAbsSpec.hs b/test/System/Posix/RawFilePath/Directory/ToAbsSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/ToAbsSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module System.Posix.RawFilePath.Directory.ToAbsSpec where + + +import Test.Hspec +import "hpath-directory" System.Posix.RawFilePath.Directory + + + +spec :: Spec +spec = describe "System.Posix.RawFilePath.Directory.toAbs" $ do + + -- successes -- + it "toAbs returns absolute paths unchanged" $ do + let p1 = "/a/b/c/d" + to <- toAbs p1 + p1 `shouldBe` to + + it "toAbs returns even existing absolute paths unchanged" $ do + let p1 = "/home" + to <- toAbs p1 + p1 `shouldBe` to + + diff --git a/test/System/Posix/RawFilePath/Directory/WriteFileLSpec.hs b/test/System/Posix/RawFilePath/Directory/WriteFileLSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/WriteFileLSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module System.Posix.RawFilePath.Directory.WriteFileLSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "WriteFileLSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createRegularFile' "fileWithContent" + createRegularFile' "fileWithoutContent" + createSymlink' "inputFileSymL" "fileWithContent" + createDir' "alreadyExistsD" + createRegularFile' "noPerms" + noPerms "noPerms" + createDir' "noPermsD" + createRegularFile' "noPermsD/inputFile" + noPerms "noPermsD" + writeFile' "fileWithContent" "BLKASL" + + +cleanupFiles :: IO () +cleanupFiles = do + deleteFile' "fileWithContent" + deleteFile' "fileWithoutContent" + deleteFile' "inputFileSymL" + deleteDir' "alreadyExistsD" + normalFilePerms "noPerms" + deleteFile' "noPerms" + normalDirPerms "noPermsD" + deleteFile' "noPermsD/inputFile" + deleteDir' "noPermsD" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.WriteFileL" $ do + + -- successes -- + it "WriteFileL file with content, everything clear" $ do + writeFileL' "fileWithContent" "blahfaselllll" + out <- readFile' "fileWithContent" + out `shouldBe` "blahfaselllll" + + it "WriteFileL file with content, everything clear" $ do + writeFileL' "fileWithContent" "gagagaga" + out <- readFile' "fileWithContent" + out `shouldBe` "gagagaga" + + it "WriteFileL file with content, everything clear" $ do + writeFileL' "fileWithContent" "" + out <- readFile' "fileWithContent" + out `shouldBe` "" + + it "WriteFileL file without content, everything clear" $ do + writeFileL' "fileWithoutContent" "blahfaselllll" + out <- readFile' "fileWithoutContent" + out `shouldBe` "blahfaselllll" + + it "WriteFileL, everything clear" $ do + writeFileL' "fileWithoutContent" "gagagaga" + out <- readFile' "fileWithoutContent" + out `shouldBe` "gagagaga" + + it "WriteFileL symlink, everything clear" $ do + writeFileL' "inputFileSymL" "blahfaselllll" + out <- readFile' "inputFileSymL" + out `shouldBe` "blahfaselllll" + + it "WriteFileL symlink, everything clear" $ do + writeFileL' "inputFileSymL" "gagagaga" + out <- readFile' "inputFileSymL" + out `shouldBe` "gagagaga" + + + -- posix failures -- + it "WriteFileL to dir, inappropriate type" $ do + writeFileL' "alreadyExistsD" "" + `shouldThrow` (\e -> ioeGetErrorType e == InappropriateType) + + it "WriteFileL, no permissions to file" $ do + writeFileL' "noPerms" "" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "WriteFileL, no permissions to file" $ do + writeFileL' "noPermsD/inputFile" "" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "WriteFileL, file does not exist" $ do + writeFileL' "gaga" "" + `shouldThrow` (\e -> ioeGetErrorType e == NoSuchThing) diff --git a/test/System/Posix/RawFilePath/Directory/WriteFileSpec.hs b/test/System/Posix/RawFilePath/Directory/WriteFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/RawFilePath/Directory/WriteFileSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module System.Posix.RawFilePath.Directory.WriteFileSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "WriteFileSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createRegularFile' "fileWithContent" + createRegularFile' "fileWithoutContent" + createSymlink' "inputFileSymL" "fileWithContent" + createDir' "alreadyExistsD" + createRegularFile' "noPerms" + noPerms "noPerms" + createDir' "noPermsD" + createRegularFile' "noPermsD/inputFile" + noPerms "noPermsD" + writeFile' "fileWithContent" "BLKASL" + + +cleanupFiles :: IO () +cleanupFiles = do + deleteFile' "fileWithContent" + deleteFile' "fileWithoutContent" + deleteFile' "inputFileSymL" + deleteDir' "alreadyExistsD" + normalFilePerms "noPerms" + deleteFile' "noPerms" + normalDirPerms "noPermsD" + deleteFile' "noPermsD/inputFile" + deleteDir' "noPermsD" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "System.Posix.RawFilePath.Directory.writeFile" $ do + + -- successes -- + it "writeFile file with content, everything clear" $ do + writeFile' "fileWithContent" "blahfaselllll" + out <- readFile' "fileWithContent" + out `shouldBe` "blahfaselllll" + + it "writeFile file with content, everything clear" $ do + writeFile' "fileWithContent" "gagagaga" + out <- readFile' "fileWithContent" + out `shouldBe` "gagagaga" + + it "writeFile file with content, everything clear" $ do + writeFile' "fileWithContent" "" + out <- readFile' "fileWithContent" + out `shouldBe` "" + + it "writeFile file without content, everything clear" $ do + writeFile' "fileWithoutContent" "blahfaselllll" + out <- readFile' "fileWithoutContent" + out `shouldBe` "blahfaselllll" + + it "writeFile, everything clear" $ do + writeFile' "fileWithoutContent" "gagagaga" + out <- readFile' "fileWithoutContent" + out `shouldBe` "gagagaga" + + it "writeFile symlink, everything clear" $ do + writeFile' "inputFileSymL" "blahfaselllll" + out <- readFile' "inputFileSymL" + out `shouldBe` "blahfaselllll" + + it "writeFile symlink, everything clear" $ do + writeFile' "inputFileSymL" "gagagaga" + out <- readFile' "inputFileSymL" + out `shouldBe` "gagagaga" + + + -- posix failures -- + it "writeFile to dir, inappropriate type" $ do + writeFile' "alreadyExistsD" "" + `shouldThrow` (\e -> ioeGetErrorType e == InappropriateType) + + it "writeFile, no permissions to file" $ do + writeFile' "noPerms" "" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "writeFile, no permissions to file" $ do + writeFile' "noPermsD/inputFile" "" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "writeFile, file does not exist" $ do + writeFile' "gaga" "" + `shouldThrow` (\e -> ioeGetErrorType e == NoSuchThing) diff --git a/test/Utils.hs b/test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Utils.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Utils where + + +import Control.Applicative + ( + (<$>) + ) +import Control.Monad + ( + forM_ + , void + ) +import Control.Monad.IfElse + ( + whenM + ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.IORef + ( + newIORef + , readIORef + , writeIORef + , IORef + ) +import "hpath-directory" System.Posix.RawFilePath.Directory +import Prelude hiding (appendFile, readFile, writeFile) +import Data.Maybe + ( + fromJust + ) +import System.IO.Unsafe + ( + unsafePerformIO + ) +import qualified System.Posix.RawFilePath.Directory.Traversals as DT +import Data.ByteString + ( + ByteString + ) +import qualified Data.ByteString.Lazy as L +import System.Posix.FilePath +import System.Posix.Files.ByteString + ( + groupExecuteMode + , groupReadMode + , nullFileMode + , otherExecuteMode + , otherReadMode + , ownerExecuteMode + , ownerReadMode + , setFileMode + , unionFileModes + ) + +baseTmpDir :: IORef (Maybe ByteString) +{-# NOINLINE baseTmpDir #-} +baseTmpDir = unsafePerformIO (newIORef Nothing) + + +tmpDir :: IORef (Maybe ByteString) +{-# NOINLINE tmpDir #-} +tmpDir = unsafePerformIO (newIORef Nothing) + + + + ----------------- + --[ Utilities ]-- + ----------------- + + +setTmpDir :: ByteString -> IO () +{-# NOINLINE setTmpDir #-} +setTmpDir bs = do + tmp <- fromJust <$> readIORef baseTmpDir + writeIORef tmpDir (Just (tmp `BS.append` bs)) + + +createTmpDir :: IO () +{-# NOINLINE createTmpDir #-} +createTmpDir = do + tmp <- fromJust <$> readIORef tmpDir + void $ createDir newDirPerms tmp + + +deleteTmpDir :: IO () +{-# NOINLINE deleteTmpDir #-} +deleteTmpDir = do + tmp <- fromJust <$> readIORef tmpDir + void $ deleteDir tmp + + +deleteBaseTmpDir :: IO () +{-# NOINLINE deleteBaseTmpDir #-} +deleteBaseTmpDir = do + tmp <- fromJust <$> readIORef baseTmpDir + contents <- getDirsFiles tmp + forM_ contents deleteDir + void $ deleteDir tmp + + +withRawTmpDir :: (ByteString -> IO a) -> IO a +{-# NOINLINE withRawTmpDir #-} +withRawTmpDir f = do + tmp <- fromJust <$> readIORef tmpDir + f tmp + + +getRawTmpDir :: IO ByteString +{-# NOINLINE getRawTmpDir #-} +getRawTmpDir = withRawTmpDir (return . flip BS.append "/") + + +withTmpDir :: ByteString -> (ByteString -> IO a) -> IO a +{-# NOINLINE withTmpDir #-} +withTmpDir ip f = do + tmp <- fromJust <$> readIORef tmpDir + let p = tmp ip + f p + + +withTmpDir' :: ByteString + -> ByteString + -> (ByteString -> ByteString -> IO a) + -> IO a +{-# NOINLINE withTmpDir' #-} +withTmpDir' ip1 ip2 f = do + tmp <- fromJust <$> readIORef tmpDir + let p1 = tmp ip1 + let p2 = tmp ip2 + f p1 p2 + + +removeFileIfExists :: ByteString -> IO () +{-# NOINLINE removeFileIfExists #-} +removeFileIfExists bs = + withTmpDir bs $ \p -> whenM (doesFileExist p) (deleteFile p) + + +removeDirIfExists :: ByteString -> IO () +{-# NOINLINE removeDirIfExists #-} +removeDirIfExists bs = + withTmpDir bs $ \p -> whenM (doesDirectoryExist p) (deleteDirRecursive p) + + +copyFile' :: ByteString -> ByteString -> CopyMode -> IO () +{-# NOINLINE copyFile' #-} +copyFile' inputFileP outputFileP cm = + withTmpDir' inputFileP outputFileP (\p1 p2 -> copyFile p1 p2 cm) + + +copyDirRecursive' :: ByteString -> ByteString + -> CopyMode -> RecursiveErrorMode -> IO () +{-# NOINLINE copyDirRecursive' #-} +copyDirRecursive' inputDirP outputDirP cm rm = + withTmpDir' inputDirP outputDirP (\p1 p2 -> copyDirRecursive p1 p2 cm rm) + + +createDir' :: ByteString -> IO () +{-# NOINLINE createDir' #-} +createDir' dest = withTmpDir dest (createDir newDirPerms) + +createDirIfMissing' :: ByteString -> IO () +{-# NOINLINE createDirIfMissing' #-} +createDirIfMissing' dest = withTmpDir dest (createDirIfMissing newDirPerms) + +createDirRecursive' :: ByteString -> IO () +{-# NOINLINE createDirRecursive' #-} +createDirRecursive' dest = withTmpDir dest (createDirRecursive newDirPerms) + +createRegularFile' :: ByteString -> IO () +{-# NOINLINE createRegularFile' #-} +createRegularFile' dest = withTmpDir dest (createRegularFile newFilePerms) + + +createSymlink' :: ByteString -> ByteString -> IO () +{-# NOINLINE createSymlink' #-} +createSymlink' dest sympoint = withTmpDir dest + (\x -> createSymlink x sympoint) + + +renameFile' :: ByteString -> ByteString -> IO () +{-# NOINLINE renameFile' #-} +renameFile' inputFileP outputFileP = + withTmpDir' inputFileP outputFileP $ \i o -> do + renameFile i o + renameFile o i + + +moveFile' :: ByteString -> ByteString -> CopyMode -> IO () +{-# NOINLINE moveFile' #-} +moveFile' inputFileP outputFileP cm = + withTmpDir' inputFileP outputFileP $ \i o -> do + moveFile i o cm + moveFile o i Strict + + +recreateSymlink' :: ByteString -> ByteString -> CopyMode -> IO () +{-# NOINLINE recreateSymlink' #-} +recreateSymlink' inputFileP outputFileP cm = + withTmpDir' inputFileP outputFileP (\p1 p2 -> recreateSymlink p1 p2 cm) + + +noWritableDirPerms :: ByteString -> IO () +{-# NOINLINE noWritableDirPerms #-} +noWritableDirPerms path = withTmpDir path $ \p -> + setFileMode p perms + where + perms = ownerReadMode + `unionFileModes` ownerExecuteMode + `unionFileModes` groupReadMode + `unionFileModes` groupExecuteMode + `unionFileModes` otherReadMode + `unionFileModes` otherExecuteMode + + +noPerms :: ByteString -> IO () +{-# NOINLINE noPerms #-} +noPerms path = withTmpDir path $ \p -> setFileMode p nullFileMode + + +normalDirPerms :: ByteString -> IO () +{-# NOINLINE normalDirPerms #-} +normalDirPerms path = + withTmpDir path $ \p -> setFileMode p newDirPerms + + +normalFilePerms :: ByteString -> IO () +{-# NOINLINE normalFilePerms #-} +normalFilePerms path = + withTmpDir path $ \p -> setFileMode p newFilePerms + + +getFileType' :: ByteString -> IO FileType +{-# NOINLINE getFileType' #-} +getFileType' path = withTmpDir path getFileType + + +getDirsFiles' :: ByteString -> IO [ByteString] +{-# NOINLINE getDirsFiles' #-} +getDirsFiles' path = withTmpDir path getDirsFiles + + +deleteFile' :: ByteString -> IO () +{-# NOINLINE deleteFile' #-} +deleteFile' p = withTmpDir p deleteFile + + +deleteDir' :: ByteString -> IO () +{-# NOINLINE deleteDir' #-} +deleteDir' p = withTmpDir p deleteDir + + +deleteDirRecursive' :: ByteString -> IO () +{-# NOINLINE deleteDirRecursive' #-} +deleteDirRecursive' p = withTmpDir p deleteDirRecursive + + +canonicalizePath' :: ByteString -> IO ByteString +{-# NOINLINE canonicalizePath' #-} +canonicalizePath' p = withTmpDir p canonicalizePath + + +writeFile' :: ByteString -> ByteString -> IO () +{-# NOINLINE writeFile' #-} +writeFile' ip bs = + withTmpDir ip $ \p -> writeFile p Nothing bs + +writeFileL' :: ByteString -> BSL.ByteString -> IO () +{-# NOINLINE writeFileL' #-} +writeFileL' ip bs = + withTmpDir ip $ \p -> writeFileL p Nothing 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 + + +readFile' :: ByteString -> IO ByteString +{-# NOINLINE readFile' #-} +readFile' p = withTmpDir p (fmap L.toStrict . readFile) +