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-io + +## 0.9.3 -- YYYY-mm-dd + +* 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +# HPath-IO + +[![Gitter chat](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/hasufell/hpath?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [![Hackage version](https://img.shields.io/hackage/v/hpath-io.svg?label=Hackage)](https://hackage.haskell.org/package/hpath-io) [![Build Status](https://api.travis-ci.org/hasufell/hpath.png?branch=master)](http://travis-ci.org/hasufell/hpath) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/hpath-io.svg)](http://packdeps.haskellers.com/feed?needle=hpath-io) + +High-level IO operations on files/directories, utilizing type-safe Paths. + +## Motivation + +The motivation came during development of +[hsfm](https://github.com/hasufell/hsfm) +in order to have a proper high-level API of file related operations, +while utilizing type-safe Paths. + +## Goals + +* high-level API to file operations like recursive directory copy +* still allowing sufficient control to interact with the underlying low-level calls +* unit-testing exceptions (because yes, people may rely on them) + +Note: this library was written for __posix__ systems and it will probably not support other systems. + +## Differences to 'posix-paths' + +* has a custom versions of `openFd` which allows more control over the flags than its unix package counterpart +* adds a `getDirectoryContents'` version that works on Fd + 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-io.cabal b/hpath-io.cabal new file mode 100644 --- /dev/null +++ b/hpath-io.cabal @@ -0,0 +1,100 @@ +name: hpath-io +version: 0.10.0 +synopsis: High-level IO operations on files/directories +description: High-level IO operations on files/directories, utilizing type-safe Paths +-- bug-reports: +license: BSD3 +license-file: LICENSE +author: Julian Ospald +maintainer: Julian Ospald +copyright: Julian Ospald 2016 +category: Filesystem +build-type: Simple +cabal-version: 1.14 +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 +extra-source-files: README.md + CHANGELOG.md + cbits/dirutils.h + +library + if os(windows) + build-depends: unbuildable<0 + buildable: False + exposed-modules: HPath.IO, + HPath.IO.Errors, + System.Posix.Directory.Foreign, + System.Posix.Directory.Traversals, + System.Posix.FD + c-sources: cbits/dirutils.c + + -- other-modules: + -- other-extensions: + build-depends: base >= 4.8 && <5 + , IfElse + , bytestring >= 0.10.0.0 + , hpath >= 0.10 && < 0.11 + , hpath-filepath >= 0.10 && < 0.11 + , streamly >= 0.7 + , unix >= 2.5 + , unix-bytestring + , utf8-string + hs-source-dirs: src + default-language: Haskell2010 + +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: + HPath.IO.AppendFileSpec + HPath.IO.CanonicalizePathSpec + HPath.IO.CopyDirRecursiveCollectFailuresSpec + HPath.IO.CopyDirRecursiveOverwriteSpec + HPath.IO.CopyDirRecursiveSpec + HPath.IO.CopyFileOverwriteSpec + HPath.IO.CopyFileSpec + HPath.IO.CreateDirRecursiveSpec + HPath.IO.CreateDirSpec + HPath.IO.CreateRegularFileSpec + HPath.IO.CreateSymlinkSpec + HPath.IO.DeleteDirRecursiveSpec + HPath.IO.DeleteDirSpec + HPath.IO.DeleteFileSpec + HPath.IO.GetDirsFilesSpec + HPath.IO.GetFileTypeSpec + HPath.IO.MoveFileOverwriteSpec + HPath.IO.MoveFileSpec + HPath.IO.ReadFileEOFSpec + HPath.IO.ReadFileSpec + HPath.IO.RecreateSymlinkOverwriteSpec + HPath.IO.RecreateSymlinkSpec + HPath.IO.RenameFileSpec + HPath.IO.ToAbsSpec + HPath.IO.WriteFileSpec + Spec + Utils + GHC-Options: -Wall + Build-Depends: base + , HUnit + , IfElse + , bytestring >= 0.10.0.0 + , hpath + , hpath-io + , hspec >= 1.3 + , process + , unix + , unix-bytestring + , utf8-string + +source-repository head + type: git + location: https://github.com/hasufell/hpath diff --git a/src/HPath/IO.hs b/src/HPath/IO.hs new file mode 100644 --- /dev/null +++ b/src/HPath/IO.hs @@ -0,0 +1,1075 @@ +-- | +-- Module : HPath.IO +-- Copyright : © 2016 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- This module provides high-level IO related file operations like +-- copy, delete, move and so on. It only operates on /Path x/ which +-- guarantees us well-typed paths. Passing in /Path Abs/ to any +-- of these functions generally increases safety. Passing /Path Rel/ +-- may trigger looking up the current directory via `getcwd` in some +-- cases where it cannot be avoided. +-- +-- Some functions are just path-safe wrappers around +-- unix functions, others have stricter exception handling +-- and some implement functionality that doesn't have a unix +-- counterpart (like `copyDirRecursive`). +-- +-- 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. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO + ( + -- * Types + FileType(..) + , RecursiveErrorMode(..) + , CopyMode(..) + -- * File copying + , copyDirRecursive + , recreateSymlink + , copyFile + , easyCopy + -- * File deletion + , deleteFile + , deleteDir + , deleteDirRecursive + , easyDelete + -- * File opening + , openFile + , executeFile + -- * File creation + , createRegularFile + , createDir + , createDirRecursive + , createSymlink + -- * File renaming/moving + , renameFile + , moveFile + -- * File reading + , readFile + , readFileEOF + -- * File writing + , writeFile + , appendFile + -- * File permissions + , newFilePerms + , newDirPerms + -- * Directory reading + , getDirsFiles + -- * Filetype operations + , getFileType + -- * Others + , canonicalizePath + , toAbs + ) + where + + +import Control.Applicative + ( + (<$>) + ) +import Control.Exception + ( + IOException + , bracket + , throwIO + ) +import Control.Monad + ( + unless + , void + , when + ) +import Control.Monad.IfElse + ( + unlessM + ) +import Data.ByteString + ( + ByteString + ) +#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 Data.Foldable + ( + for_ + ) +import Data.IORef + ( + IORef + , modifyIORef + , newIORef + , readIORef + ) +import Data.Maybe + ( + catMaybes + ) +import Data.Monoid + ( + (<>) + , mempty + ) +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 HPath +import HPath.Internal +import HPath.IO.Errors +import Prelude hiding (appendFile, readFile, writeFile) +import qualified Streamly.FileSystem.Handle as FH +import qualified Streamly.Internal.FileSystem.Handle as IFH +import qualified Streamly.Prelude as S +import qualified System.IO as SIO +import System.IO.Error + ( + catchIOError + , ioeGetErrorType + ) +import System.Posix.ByteString + ( + exclusive + ) +import System.Posix.Directory.ByteString + ( + createDirectory + , getWorkingDirectory + , removeDirectory + ) +import System.Posix.Directory.Traversals + ( + getDirectoryContents' + ) +import System.Posix.Files.ByteString + ( + createSymbolicLink + , fileMode + , getFdStatus + , groupExecuteMode + , groupReadMode + , groupWriteMode + , otherExecuteMode + , otherReadMode + , otherWriteMode + , ownerModes + , ownerReadMode + , ownerWriteMode + , readSymbolicLink + , removeLink + , rename + , setFileMode + , unionFileModes + ) +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.Directory.Traversals as SPDT +import qualified System.Posix.Directory.Foreign as SPDF +import qualified System.Posix.Process.ByteString as SPP +import System.Posix.Types + ( + FileMode + , ProcessID + , Fd + ) + + + + + + ------------- + --[ 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 :: Path b1 -- ^ source dir + -> Path b2 -- ^ 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 + go :: IORef [(RecursiveFailureHint, IOException)] + -> Path b1 -> Path b2 -> IO () + go ce fromp'@(MkPath fromBS) destdirp'@(MkPath destdirpBS) = 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 fromBS destdirpBS) ce [] $ do + contents <- getDirsFiles fromp' + + -- create the destination dir and + -- only return contents if we succeed + handleIOE (CreateDirFailed fromBS destdirpBS) ce [] $ do + fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus fromBS + case cm of + Strict -> createDirectory destdirpBS fmode' + Overwrite -> catchIOError (createDirectory destdirpBS + fmode') + $ \e -> + case ioeGetErrorType e of + AlreadyExists -> setFileMode destdirpBS + 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 <- (destdirp' ) <$> basename f + case ftype of + SymbolicLink -> handleIOE (RecreateSymlinkFailed (toFilePath f) (toFilePath newdest)) ce () + $ recreateSymlink f newdest cm + Directory -> go ce f newdest + RegularFile -> handleIOE (CopyFileFailed (toFilePath f) (toFilePath 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 :: Path b1 -- ^ the old symlink file + -> Path b2 -- ^ destination file + -> CopyMode + -> IO () +recreateSymlink symsource@(MkPath symsourceBS) newsym@(MkPath newsymBS) cm + = do + throwSameFile symsource newsym + sympoint <- readSymbolicLink symsourceBS + case cm of + Strict -> return () + Overwrite -> do + writable <- toAbs newsym >>= isWritable + isfile <- doesFileExist newsym + isdir <- doesDirectoryExist newsym + when (writable && isfile) (deleteFile newsym) + when (writable && isdir) (deleteDir newsym) + createSymbolicLink sympoint newsymBS + + +-- |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 :: Path b1 -- ^ source file + -> Path b2 -- ^ destination file + -> CopyMode + -> IO () +copyFile fp@(MkPath from) tp@(MkPath to) cm = do + throwSameFile fp tp + 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 tp + 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 :: Path b1 + -> Path b2 + -> 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 +deleteFile :: Path b -> IO () +deleteFile (MkPath p) = removeLink p + + +-- |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 :: Path b -> IO () +deleteDir (MkPath p) = removeDirectory p + + +-- |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 :: Path b -> 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 . toFilePath $ 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 :: Path b -> 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 :: Path b + -> IO ProcessID +openFile (MkPath fp) = + SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing + + +-- |Executes a program with the given arguments. This forks a process. +executeFile :: Path b -- ^ program + -> [ByteString] -- ^ arguments + -> IO ProcessID +executeFile (MkPath 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 -> Path b -> IO () +createRegularFile fm (MkPath 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 -> Path b -> IO () +createDir fm (MkPath destBS) = 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 -> Path b -> IO () +createDirRecursive fm p = + toAbs p >>= go + where + go :: Path Abs -> IO () + go dest@(MkPath destBS) = do + catchIOError (createDirectory destBS fm) $ \e -> do + errno <- getErrno + case errno of + en | en == eEXIST -> unlessM (doesDirectoryExist dest) (ioError e) + | en == eNOENT -> createDirRecursive fm (dirname dest) + >> createDirectory destBS fm + | otherwise -> ioError e + + +-- |Create a symlink. +-- +-- Throws: +-- +-- - `PermissionDenied` if output directory cannot be written to +-- - `AlreadyExists` if destination file already exists +-- - `NoSuchThing` if any of the parent components of the path +-- do not exist +-- +-- Note: calls `symlink` +createSymlink :: Path b -- ^ destination file + -> ByteString -- ^ path the symlink points to + -> IO () +createSymlink (MkPath 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 :: Path b1 -> Path b2 -> IO () +renameFile fromf@(MkPath fromfBS) tof@(MkPath tofBS) = do + throwSameFile fromf tof + throwFileDoesExist tof + throwDirDoesExist tof + rename fromfBS tofBS + + +-- |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 :: Path b1 -- ^ file to move + -> Path b2 -- ^ 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 <- toAbs to >>= isWritable + 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 strict ByteString. +-- Symbolic links are followed, no sanity checks on file size +-- or file type. File must exist. +-- +-- Note: the size of the file is determined in advance, as to only +-- have one allocation. +-- +-- Safety/reliability concerns: +-- +-- * since amount of bytes to read is determined in advance, +-- the file might be read partially only if something else is +-- appending to it while reading +-- * the whole file is read into memory! +-- +-- Throws: +-- +-- - `InappropriateType` if file is not a regular file or a symlink +-- - `PermissionDenied` if we cannot read the file or the directory +-- containting it +-- - `NoSuchThing` if the file does not exist +readFile :: Path b -> IO ByteString +readFile (MkPath fp) = + bracket (openFd fp SPI.ReadOnly [] Nothing) (SPI.closeFd) $ \fd -> do + stat <- PF.getFdStatus fd + let fsize = PF.fileSize stat + SPB.fdRead fd (fromIntegral fsize) + + +-- |Read the given file in chunks of size `8192` into memory until +-- `fread` returns 0. Returns a lazy ByteString, because it uses +-- Builders under the hood. +-- +-- Safety/reliability concerns: +-- +-- * the whole file is read into memory! +-- +-- Throws: +-- +-- - `InappropriateType` if file is not a regular file or a symlink +-- - `PermissionDenied` if we cannot read the file or the directory +-- containting it +-- - `NoSuchThing` if the file does not exist +readFileEOF :: Path b -> IO L.ByteString +readFileEOF (MkPath fp) = + bracket (openFd fp SPI.ReadOnly [] Nothing) (SPI.closeFd) $ \fd -> + allocaBytes (fromIntegral bufSize) $ \buf -> read' fd buf mempty + where + bufSize :: CSize + bufSize = 8192 + read' :: Fd -> Ptr Word8 -> Builder -> IO L.ByteString + read' fd buf builder = do + size <- SPB.fdReadBuf fd buf bufSize + if size == 0 + then return $ toLazyByteString builder + else do + readBS <- unsafePackCStringFinalizer buf + (fromIntegral size) + (return ()) + read' fd buf (builder <> byteString readBS) + + + + + -------------------- + --[ File Writing ]-- + -------------------- + + +-- |Write a given ByteString to a file, truncating the file beforehand. +-- The file must exist. Follows symlinks. +-- +-- Throws: +-- +-- - `InappropriateType` if file is not a regular file or a symlink +-- - `PermissionDenied` if we cannot read the file or the directory +-- containting it +-- - `NoSuchThing` if the file does not exist +writeFile :: Path b -> ByteString -> IO () +writeFile (MkPath fp) bs = + bracket (openFd fp SPI.WriteOnly [SPDF.oTrunc] Nothing) (SPI.closeFd) $ \fd -> + void $ SPB.fdWrite fd bs + + +-- |Append a given ByteString to a file. +-- The file must exist. Follows symlinks. +-- +-- Throws: +-- +-- - `InappropriateType` if file is not a regular file or a symlink +-- - `PermissionDenied` if we cannot read the file or the directory +-- containting it +-- - `NoSuchThing` if the file does not exist +appendFile :: Path b -> ByteString -> IO () +appendFile (MkPath 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 + + + + ------------------------- + --[ 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 :: Path b -- ^ dir to read + -> IO [Path b] +getDirsFiles p@(MkPath fp) = do + fd <- openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing + return + . catMaybes + . fmap (\x -> () p <$> (parseMaybe . snd $ x)) + =<< getDirectoryContents' fd + where + parseMaybe :: ByteString -> Maybe (Path Fn) + parseMaybe = parseFn + + + + + --------------------------- + --[ 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 :: Path b -> IO FileType +getFileType (MkPath 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 :: Path b -> IO (Path Abs) +canonicalizePath (MkPath l) = do + nl <- SPDT.realpath l + return $ MkPath nl + + +-- |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 :: Path b -> IO (Path Abs) +toAbs (MkPath bs) = do + let mabs = parseAbs bs :: Maybe (Path Abs) + case mabs of + Just a -> return a + Nothing -> do + cwd <- getWorkingDirectory >>= parseAbs + rel <- parseRel bs -- we know it must be relative now + return $ cwd rel diff --git a/src/HPath/IO.hs-boot b/src/HPath/IO.hs-boot new file mode 100644 --- /dev/null +++ b/src/HPath/IO.hs-boot @@ -0,0 +1,8 @@ +module HPath.IO where + + +import HPath + +canonicalizePath :: Path b -> IO (Path Abs) + +toAbs :: Path b -> IO (Path Abs) diff --git a/src/HPath/IO/Errors.hs b/src/HPath/IO/Errors.hs new file mode 100644 --- /dev/null +++ b/src/HPath/IO/Errors.hs @@ -0,0 +1,360 @@ +-- | +-- Module : HPath.IO.Errors +-- Copyright : © 2016 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- Provides error handling. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HPath.IO.Errors + ( + -- * Types + HPathIOException(..) + , RecursiveFailureHint(..) + + -- * Exception identifiers + , isSameFile + , isDestinationInSource + , isRecursiveFailure + , isReadContentsFailed + , isCreateDirFailed + , isCopyFileFailed + , isRecreateSymlinkFailed + + -- * Path based functions + , throwFileDoesExist + , throwDirDoesExist + , throwSameFile + , sameFile + , throwDestinationInSource + , doesFileExist + , doesDirectoryExist + , isWritable + , canOpenDirectory + + -- * Error handling functions + , catchErrno + , rethrowErrnoAs + , handleIOError + , bracketeer + , reactOnError + ) + where + + +import Control.Applicative + ( + (<$>) + ) +import Control.Exception +import Control.Monad + ( + forM + , when + ) +import Control.Monad.IfElse + ( + whenM + ) +import Data.ByteString + ( + ByteString + ) +import Data.ByteString.UTF8 + ( + toString + ) +import Data.Typeable + ( + Typeable + ) +import Foreign.C.Error + ( + getErrno + , Errno + ) +import GHC.IO.Exception + ( + IOErrorType + ) +import HPath +import HPath.Internal + ( + Path(..) + ) +import {-# SOURCE #-} HPath.IO + ( + canonicalizePath + , toAbs + ) +import System.IO.Error + ( + alreadyExistsErrorType + , catchIOError + , ioeGetErrorType + , mkIOError + ) + +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 :: Path b -> IO () +throwFileDoesExist fp@(MkPath bs) = + whenM (doesFileExist fp) + (ioError . mkIOError + alreadyExistsErrorType + "File already exists" + Nothing + $ (Just (toString $ bs)) + ) + + +-- |Throws `AlreadyExists` `IOError` if directory exists. +throwDirDoesExist :: Path b -> IO () +throwDirDoesExist fp@(MkPath bs) = + whenM (doesDirectoryExist fp) + (ioError . mkIOError + alreadyExistsErrorType + "Directory already exists" + Nothing + $ (Just (toString $ bs)) + ) + + +-- |Uses `isSameFile` and throws `SameFile` if it returns True. +throwSameFile :: Path b1 + -> Path b2 + -> IO () +throwSameFile fp1@(MkPath bs1) fp2@(MkPath bs2) = + whenM (sameFile fp1 fp2) + (throwIO $ SameFile bs1 bs2) + + +-- |Check if the files are the same by examining device and file id. +-- This follows symbolic links. +sameFile :: Path b1 -> Path b2 -> IO Bool +sameFile (MkPath fp1) (MkPath 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 :: Path b1 -- ^ source dir + -> Path b2 -- ^ full destination, @dirname dest@ + -- must exist + -> IO () +throwDestinationInSource (MkPath sbs) dest@(MkPath dbs) = do + destAbs <- toAbs dest + dest' <- (\x -> maybe x (\y -> x y) $ basename dest) + <$> (canonicalizePath $ dirname destAbs) + dids <- forM (getAllParents dest') $ \p -> do + fs <- PF.getSymbolicLinkStatus (fromAbs p) + return (PF.deviceID fs, PF.fileID fs) + sid <- fmap (\x -> (PF.deviceID x, PF.fileID x)) + $ PF.getFileStatus sbs + when (elem sid dids) + (throwIO $ DestinationInSource dbs sbs) + + +-- |Checks if the given file exists and is not a directory. +-- Does not follow symlinks. +doesFileExist :: Path b -> IO Bool +doesFileExist (MkPath bs) = + handleIOError (\_ -> return False) $ do + fs <- PF.getSymbolicLinkStatus bs + return $ not . PF.isDirectory $ fs + + +-- |Checks if the given file exists and is a directory. +-- Does not follow symlinks. +doesDirectoryExist :: Path b -> IO Bool +doesDirectoryExist (MkPath bs) = + handleIOError (\_ -> return False) $ do + fs <- PF.getSymbolicLinkStatus bs + return $ PF.isDirectory fs + + +-- |Checks whether a file or folder is writable. +isWritable :: Path b -> IO Bool +isWritable (MkPath bs) = + handleIOError (\_ -> return False) $ + fileAccess bs False True False + + +-- |Checks whether the directory at the given path exists and can be +-- opened. This invokes `openDirStream` which follows symlinks. +canOpenDirectory :: Path b -> IO Bool +canOpenDirectory (MkPath bs) = + handleIOError (\_ -> return False) $ do + bracket (PFD.openDirStream bs) + PFD.closeDirStream + (\_ -> return ()) + return True + + + + + -------------------------------- + --[ Error handling functions ]-- + -------------------------------- + + +-- |Carries out an action, then checks if there is an IOException and +-- a specific errno. If so, then it carries out another action, otherwise +-- it rethrows the error. +catchErrno :: [Errno] -- ^ errno to catch + -> IO a -- ^ action to try, which can raise an IOException + -> IO a -- ^ action to carry out in case of an IOException and + -- if errno matches + -> IO a +catchErrno en a1 a2 = + catchIOError a1 $ \e -> do + errno <- getErrno + if errno `elem` en + then a2 + else ioError e + + +-- |Execute the given action and retrow IO exceptions as a new Exception +-- that have the given errno. If errno does not match the exception is rethrown +-- as is. +rethrowErrnoAs :: Exception e + => [Errno] -- ^ errno to catch + -> e -- ^ rethrow as if errno matches + -> IO a -- ^ action to try + -> IO a +rethrowErrnoAs en fmex action = catchErrno en action (throwIO fmex) + + + +-- |Like `catchIOError`, with arguments swapped. +handleIOError :: (IOError -> IO a) -> IO a -> IO a +handleIOError = flip catchIOError + + +-- |Like `bracket`, but allows to have different clean-up +-- actions depending on whether the in-between computation +-- has raised an exception or not. +bracketeer :: IO a -- ^ computation to run first + -> (a -> IO b) -- ^ computation to run last, when + -- no exception was raised + -> (a -> IO b) -- ^ computation to run last, + -- when an exception was raised + -> (a -> IO c) -- ^ computation to run in-between + -> IO c +bracketeer before after afterEx thing = + mask $ \restore -> do + a <- before + r <- restore (thing a) `onException` afterEx a + _ <- after a + return r + + +reactOnError :: IO a + -> [(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/Directory/Foreign.hsc b/src/System/Posix/Directory/Foreign.hsc new file mode 100644 --- /dev/null +++ b/src/System/Posix/Directory/Foreign.hsc @@ -0,0 +1,55 @@ +module System.Posix.Directory.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/Directory/Traversals.hs b/src/System/Posix/Directory/Traversals.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/Directory/Traversals.hs @@ -0,0 +1,264 @@ +-- | +-- Module : System.Posix.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 PackageImports #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall #-} + + +module System.Posix.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.Directory.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.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/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.Directory.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/test/HPath/IO/AppendFileSpec.hs b/test/HPath/IO/AppendFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/AppendFileSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module HPath.IO.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 "HPath.IO.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/HPath/IO/CanonicalizePathSpec.hs b/test/HPath/IO/CanonicalizePathSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CanonicalizePathSpec.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.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 "HPath.IO.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/HPath/IO/CopyDirRecursiveCollectFailuresSpec.hs b/test/HPath/IO/CopyDirRecursiveCollectFailuresSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CopyDirRecursiveCollectFailuresSpec.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module HPath.IO.CopyDirRecursiveCollectFailuresSpec where + + +import Test.Hspec +import Data.List (sort) +import HPath.IO +import HPath.IO.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 "HPath.IO.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/HPath/IO/CopyDirRecursiveOverwriteSpec.hs b/test/HPath/IO/CopyDirRecursiveOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CopyDirRecursiveOverwriteSpec.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module HPath.IO.CopyDirRecursiveOverwriteSpec where + + +import Test.Hspec +import HPath.IO +import HPath.IO.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 "HPath.IO.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/HPath/IO/CopyDirRecursiveSpec.hs b/test/HPath/IO/CopyDirRecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CopyDirRecursiveSpec.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module HPath.IO.CopyDirRecursiveSpec where + + +import Test.Hspec +import HPath.IO +import HPath.IO.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 "HPath.IO.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/HPath/IO/CopyFileOverwriteSpec.hs b/test/HPath/IO/CopyFileOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CopyFileOverwriteSpec.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.CopyFileOverwriteSpec where + + +import Test.Hspec +import HPath.IO +import HPath.IO.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 "HPath.IO.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/HPath/IO/CopyFileSpec.hs b/test/HPath/IO/CopyFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CopyFileSpec.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module HPath.IO.CopyFileSpec where + + +import Test.Hspec +import HPath.IO +import HPath.IO.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 "HPath.IO.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/HPath/IO/CreateDirRecursiveSpec.hs b/test/HPath/IO/CreateDirRecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CreateDirRecursiveSpec.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.CreateDirRecursiveSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CreateDirRecursiveSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createDir' "alreadyExists" + createRegularFile' "alreadyExistsF" + createDir' "noPerms" + createDir' "noWritePerms" + noPerms "noPerms" + noWritableDirPerms "noWritePerms" + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerms" + deleteDir' "alreadyExists" + deleteDir' "noPerms" + deleteDir' "noWritePerms" + deleteFile' "alreadyExistsF" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "HPath.IO.createDirRecursive" $ do + + -- successes -- + it "createDirRecursive, all fine" $ do + createDirRecursive' "newDir" + deleteDir' "newDir" + + it "createDirRecursive, parent directories do not exist" $ do + createDirRecursive' "some/thing/dada" + deleteDir' "some/thing/dada" + deleteDir' "some/thing" + deleteDir' "some" + + it "createDirRecursive, destination directory already exists" $ + createDirRecursive' "alreadyExists" + + -- posix failures -- + it "createDirRecursive, destination already exists and is a file" $ + createDirRecursive' "alreadyExistsF" + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "createDirRecursive, can't write to output directory" $ + createDirRecursive' "noWritePerms/newDir" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createDirRecursive, can't open output directory" $ + createDirRecursive' "noPerms/newDir" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + + diff --git a/test/HPath/IO/CreateDirSpec.hs b/test/HPath/IO/CreateDirSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CreateDirSpec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.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 "HPath.IO.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/HPath/IO/CreateRegularFileSpec.hs b/test/HPath/IO/CreateRegularFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CreateRegularFileSpec.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.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 "HPath.IO.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/HPath/IO/CreateSymlinkSpec.hs b/test/HPath/IO/CreateSymlinkSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CreateSymlinkSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.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 "HPath.IO.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/HPath/IO/DeleteDirRecursiveSpec.hs b/test/HPath/IO/DeleteDirRecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/DeleteDirRecursiveSpec.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.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 "HPath.IO.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/HPath/IO/DeleteDirSpec.hs b/test/HPath/IO/DeleteDirSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/DeleteDirSpec.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.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 "HPath.IO.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/HPath/IO/DeleteFileSpec.hs b/test/HPath/IO/DeleteFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/DeleteFileSpec.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.DeleteFileSpec where + + +import Test.Hspec +import HPath.IO +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 "HPath.IO.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/HPath/IO/GetDirsFilesSpec.hs b/test/HPath/IO/GetDirsFilesSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/GetDirsFilesSpec.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.GetDirsFilesSpec where + + +import Data.List + ( + sort + ) +import qualified HPath as P +import HPath.IO +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 "HPath.IO.getDirsFiles" $ do + + -- successes -- + it "getDirsFiles, all fine" $ + withRawTmpDir $ \p -> do + expectedFiles <- mapM P.parseRel [".hidden" + ,"Lala" + ,"dir" + ,"dirsym" + ,"file" + ,"noPerms" + ,"syml"] + (fmap sort $ getDirsFiles p) + `shouldReturn` fmap (p 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/HPath/IO/GetFileTypeSpec.hs b/test/HPath/IO/GetFileTypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/GetFileTypeSpec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.GetFileTypeSpec where + + +import HPath.IO +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 "HPath.IO.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/HPath/IO/MoveFileOverwriteSpec.hs b/test/HPath/IO/MoveFileOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/MoveFileOverwriteSpec.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.MoveFileOverwriteSpec where + + +import Test.Hspec +import HPath.IO +import HPath.IO.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 "HPath.IO.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/HPath/IO/MoveFileSpec.hs b/test/HPath/IO/MoveFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/MoveFileSpec.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.MoveFileSpec where + + +import Test.Hspec +import HPath.IO +import HPath.IO.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 "HPath.IO.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/HPath/IO/ReadFileEOFSpec.hs b/test/HPath/IO/ReadFileEOFSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/ReadFileEOFSpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module HPath.IO.ReadFileEOFSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "ReadFileEOFSpec" + 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 "HPath.IO.readFileEOF" $ do + + -- successes -- + it "readFileEOF (Strict) file with content, everything clear" $ do + out <- readFileEOF' "fileWithContent" + out `shouldBe` "Blahfaselgagaga" + + it "readFileEOF (Strict) symlink, everything clear" $ do + out <- readFileEOF' "inputFileSymL" + out `shouldBe` "Blahfaselgagaga" + + it "readFileEOF (Strict) empty file, everything clear" $ do + out <- readFileEOF' "fileWithoutContent" + out `shouldBe` "" + + + -- posix failures -- + it "readFileEOF (Strict) directory, wrong file type" $ do + readFileEOF' "alreadyExistsD" + `shouldThrow` (\e -> ioeGetErrorType e == InappropriateType) + + it "readFileEOF (Strict) file, no permissions" $ do + readFileEOF' "noPerms" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "readFileEOF (Strict) file, no permissions on dir" $ do + readFileEOF' "noPermsD/inputFile" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "readFileEOF (Strict) file, no such file" $ do + readFileEOF' "lalala" + `shouldThrow` (\e -> ioeGetErrorType e == NoSuchThing) diff --git a/test/HPath/IO/ReadFileSpec.hs b/test/HPath/IO/ReadFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/ReadFileSpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module HPath.IO.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 "HPath.IO.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/HPath/IO/RecreateSymlinkOverwriteSpec.hs b/test/HPath/IO/RecreateSymlinkOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/RecreateSymlinkOverwriteSpec.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.RecreateSymlinkOverwriteSpec where + + +-- TODO: exception if destination exists but is not a file + `OverWrite` CopyMode + + +import Test.Hspec +import HPath.IO +import HPath.IO.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 "HPath.IO.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/HPath/IO/RecreateSymlinkSpec.hs b/test/HPath/IO/RecreateSymlinkSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/RecreateSymlinkSpec.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.RecreateSymlinkSpec where + + + + +import Test.Hspec +import HPath.IO +import HPath.IO.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 "HPath.IO.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/HPath/IO/RenameFileSpec.hs b/test/HPath/IO/RenameFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/RenameFileSpec.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.RenameFileSpec where + + +import Test.Hspec +import HPath.IO.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 "HPath.IO.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/HPath/IO/ToAbsSpec.hs b/test/HPath/IO/ToAbsSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/ToAbsSpec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module HPath.IO.ToAbsSpec where + + +import Test.Hspec +import HPath +import HPath.IO + + + +spec :: Spec +spec = describe "HPath.IO.toAbs" $ do + + -- successes -- + it "toAbs returns absolute paths unchanged" $ do + p1 <- parseAbs "/a/b/c/d" + to <- toAbs p1 + p1 `shouldBe` to + + it "toAbs returns even existing absolute paths unchanged" $ do + p1 <- parseAbs "/home" + to <- toAbs p1 + p1 `shouldBe` to + + diff --git a/test/HPath/IO/WriteFileSpec.hs b/test/HPath/IO/WriteFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/WriteFileSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module HPath.IO.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 "HPath.IO.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/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/Utils.hs b/test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Utils.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + + +module Utils where + + +import Control.Applicative + ( + (<$>) + ) +import Control.Monad + ( + forM_ + , void + ) +import Control.Monad.IfElse + ( + whenM + ) +import qualified Data.ByteString as BS +import Data.IORef + ( + newIORef + , readIORef + , writeIORef + , IORef + ) +import HPath.IO +import HPath.IO.Errors +import Prelude hiding (appendFile, readFile, writeFile) +import Data.Maybe + ( + fromJust + ) +import qualified HPath as P +import System.IO.Unsafe + ( + unsafePerformIO + ) +import qualified System.Posix.Directory.Traversals as DT +import Data.ByteString + ( + ByteString + ) +import qualified Data.ByteString.Lazy as L +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 <- P.parseAbs =<< (fromJust <$> readIORef tmpDir) + void $ createDir newDirPerms tmp + + +deleteTmpDir :: IO () +{-# NOINLINE deleteTmpDir #-} +deleteTmpDir = do + tmp <- P.parseAbs =<< (fromJust <$> readIORef tmpDir) + void $ deleteDir tmp + + +deleteBaseTmpDir :: IO () +{-# NOINLINE deleteBaseTmpDir #-} +deleteBaseTmpDir = do + tmp <- (fromJust <$> readIORef baseTmpDir) >>= P.parseAbs + contents <- getDirsFiles tmp + forM_ contents deleteDir + void $ deleteDir tmp + + +withRawTmpDir :: (P.Path P.Abs -> IO a) -> IO a +{-# NOINLINE withRawTmpDir #-} +withRawTmpDir f = do + tmp <- P.parseAbs =<< (fromJust <$> readIORef tmpDir) + f tmp + + +getRawTmpDir :: IO ByteString +{-# NOINLINE getRawTmpDir #-} +getRawTmpDir = withRawTmpDir (return . flip BS.append "/" . P.fromAbs) + + +withTmpDir :: ByteString -> (P.Path P.Abs -> IO a) -> IO a +{-# NOINLINE withTmpDir #-} +withTmpDir ip f = do + tmp <- P.parseAbs =<< (fromJust <$> readIORef tmpDir) + p <- (tmp P.) <$> P.parseRel ip + f p + + +withTmpDir' :: ByteString + -> ByteString + -> (P.Path P.Abs -> P.Path P.Abs -> IO a) + -> IO a +{-# NOINLINE withTmpDir' #-} +withTmpDir' ip1 ip2 f = do + tmp <- P.parseAbs =<< (fromJust <$> readIORef tmpDir) + p1 <- (tmp P.) <$> P.parseRel ip1 + p2 <- (tmp P.) <$> P.parseRel 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) + +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.fromAbs 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.fromAbs p) nullFileMode + + +normalDirPerms :: ByteString -> IO () +{-# NOINLINE normalDirPerms #-} +normalDirPerms path = + withTmpDir path $ \p -> setFileMode (P.fromAbs p) newDirPerms + + +normalFilePerms :: ByteString -> IO () +{-# NOINLINE normalFilePerms #-} +normalFilePerms path = + withTmpDir path $ \p -> setFileMode (P.fromAbs p) newFilePerms + + +getFileType' :: ByteString -> IO FileType +{-# NOINLINE getFileType' #-} +getFileType' path = withTmpDir path getFileType + + +getDirsFiles' :: ByteString -> IO [P.Path P.Abs] +{-# 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 (P.Path P.Abs) +{-# NOINLINE canonicalizePath' #-} +canonicalizePath' p = withTmpDir p canonicalizePath + + +writeFile' :: ByteString -> ByteString -> IO () +{-# NOINLINE writeFile' #-} +writeFile' ip bs = + withTmpDir ip $ \p -> writeFile p bs + + +appendFile' :: ByteString -> ByteString -> IO () +{-# NOINLINE appendFile' #-} +appendFile' ip bs = + withTmpDir ip $ \p -> appendFile p bs + + +allDirectoryContents' :: ByteString -> IO [ByteString] +{-# NOINLINE allDirectoryContents' #-} +allDirectoryContents' ip = + withTmpDir ip $ \p -> DT.allDirectoryContents' (P.fromAbs p) + + +readFile' :: ByteString -> IO ByteString +{-# NOINLINE readFile' #-} +readFile' p = withTmpDir p readFile + + +readFileEOF' :: ByteString -> IO L.ByteString +{-# NOINLINE readFileEOF' #-} +readFileEOF' p = withTmpDir p readFileEOF +