36 Commits

Author SHA1 Message Date
809ffc7745 Add unsafeToString methods 2018-07-23 10:21:17 +08:00
a0510eaec1 Add stack.yaml 2018-07-19 13:33:55 +08:00
cce2c68cab Update .gitignore 2018-07-19 13:33:55 +08:00
3c5f06f41d Remove redundant imports in tests 2018-07-19 13:33:55 +08:00
6bc5381108 Add hackage-deps badge 2018-06-02 22:38:50 +02:00
ef51863180 Document use of 'getcwd' 2018-04-12 14:28:37 +02:00
09062351f5 Release 0.9.2 2018-04-12 02:23:56 +02:00
ab4137572e Fix travis typo 2018-04-12 02:20:51 +02:00
c03a7ec18f Merge branch 'tighten-base-bound' of https://github.com/gwils/hpath 2018-04-12 02:19:17 +02:00
George Wilson
df298f187e Tighten base bound to prevent building before GHC 7.6 2018-04-12 10:15:08 +10:00
466c72924a Fix travis build for ghc-7.6.3
Cabal sandboxes were introduced in cabal-install 1.18.
2018-04-12 02:12:34 +02:00
9dfb803ba8 Update travis matrix 2018-04-12 02:01:17 +02:00
de46a0c568 Raise required bytestring version
We use Builders, which were introduced in 0.10.0.0.
2018-04-12 01:42:18 +02:00
d9ba67b6f0 Fix build with ghc-7.6 2018-04-12 01:41:32 +02:00
9342abeb7a Release 0.9.1 2018-04-11 23:03:35 +02:00
e8cbc632c9 Fix build with ghc-7.8 2018-04-11 22:36:40 +02:00
c556a3d3e4 Fix build with ghc-7.10 2018-04-11 22:22:03 +02:00
3aee719130 Make "unbuildable on windows" explicit 2018-04-11 12:31:11 +02:00
10662ee803 Bump to 0.9.0 2018-04-11 01:12:12 +02:00
672875f48f Small .cabal cleanup 2018-04-11 01:11:40 +02:00
3e6d93182a Abstract over Path more properly
We don't expect "Path Abs" everywhere anymore. The functions
have been made to be more generic. A user can still pass
absolute paths, so we don't lose any safety. However, some
function implementations may be more tricky.
2018-04-11 01:11:00 +02:00
1c95c9f8f9 Bump to 0.8.1 2018-04-06 17:22:57 +02:00
0ec2cf8ca5 Add writeFile and appendFile 2018-04-06 17:22:38 +02:00
9ac10a6a7d Add file reading functions 2018-04-06 16:42:40 +02:00
1a2c77c6a6 dirname: remove incorrect documentation on properties
Fixes #11
2017-01-14 20:16:25 +01:00
3baecb7b51 Improve CopyDirRecursiveCollectFailures tests 2016-06-14 19:32:33 +02:00
5d5b0ae3c1 Add missing language pragma 2016-06-14 19:32:14 +02:00
f47c8edb42 Fix build for GHC < 7.10 2016-06-14 19:21:03 +02:00
ef66a24f87 Improve error handling
* remove some obsolete functions and error types from HPath.IO.Errors
  that are completely unused
* reworked the RecursiveFailure type to contain more information,
  so we can use it to programmatically make useful choices
  without examining the weakly types IO error attributes (like
  'ioGetFileName')
2016-06-14 19:13:25 +02:00
f6a5cb8668 Add test to basename 2016-06-13 13:51:53 +02:00
4dec385332 Improve createDirRecursive 2016-06-13 01:38:44 +02:00
5b08e14b55 Add createDirRecursive, fixes #6 2016-06-13 01:28:55 +02:00
ac381cbf60 Improve documentation 2016-06-05 22:19:30 +02:00
ce7fdcdcd6 Move documentation note about RecursiveFailure where it belongs 2016-06-05 22:04:16 +02:00
a31c9d1e88 Improve documentation and tests for file creation 2016-06-05 21:59:31 +02:00
a5942ff026 Use IfElse package for whenM/unlessM 2016-06-05 21:52:52 +02:00
26 changed files with 1107 additions and 304 deletions

2
.gitignore vendored
View File

@@ -10,3 +10,5 @@ tags
.stack-work/ .stack-work/
.cabal-sandbox/ .cabal-sandbox/
cabal.sandbox.config cabal.sandbox.config
dist-newstyle/
.ghc.environment.*

View File

@@ -7,12 +7,18 @@ dist: trusty
matrix: matrix:
include: include:
- env: CABALVER=1.18 GHCVER=7.6.3
addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}
- env: CABALVER=1.22 GHCVER=7.8.4 - env: CABALVER=1.22 GHCVER=7.8.4
addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4], sources: [hvr-ghc]}} addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4], sources: [hvr-ghc]}}
- env: CABALVER=1.24 GHCVER=7.10.2 - env: CABALVER=1.24 GHCVER=7.10.2
addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.2], sources: [hvr-ghc]}} addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.2], sources: [hvr-ghc]}}
- env: CABALVER=1.24 GHCVER=8.0.1 - env: CABALVER=1.24 GHCVER=8.0.1
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
- env: CABALVER=2.0 GHCVER=8.2.2
addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}
- env: CABALVER=2.2 GHCVER=8.4.1
addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.1], sources: [hvr-ghc]}}
- env: CABALVER=head GHCVER=head - env: CABALVER=head GHCVER=head
addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}}

View File

@@ -1,3 +1,14 @@
0.9.2
* fix build with ghc-7.6
* raise required bytestring version
* Tighten base bound to prevent building before GHC 7.6 (by George Wilson)
0.9.1
* fix build with ghc-7.8 and 7.10
0.9.0
* don't force "Path Abs" anymore in IO module, abstract more over Path types
* add 'toAbs'
0.8.1
* add 'readFile', 'readFileEOF', 'writeFile' and 'appendFile'
0.8.0 0.8.0
* 'copyDirRecursiveOverwrite', 'copyFileOverwrite', 'easyCopyOverwrite' and 'moveFileOverwrite' have been removed, instead use the versions without the *Overwrite suffix and pass in 'Strict' (for default behavior) or 'Overwrite' as the CopyMode argument * 'copyDirRecursiveOverwrite', 'copyFileOverwrite', 'easyCopyOverwrite' and 'moveFileOverwrite' have been removed, instead use the versions without the *Overwrite suffix and pass in 'Strict' (for default behavior) or 'Overwrite' as the CopyMode argument
* introduced a new 'RecursiveErrorMode' type to allow controlling recursive behavior of 'copyDirRecursive' (use 'FailEarly' for default behavior) * introduced a new 'RecursiveErrorMode' type to allow controlling recursive behavior of 'copyDirRecursive' (use 'FailEarly' for default behavior)

View File

@@ -1,6 +1,6 @@
# HPath # HPath
[![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.svg?label=Hackage)](https://hackage.haskell.org/package/hpath) [![Build Status](https://api.travis-ci.org/hasufell/hpath.png?branch=master)](http://travis-ci.org/hasufell/hpath) [![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.svg?label=Hackage)](https://hackage.haskell.org/package/hpath) [![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.svg)](http://packdeps.haskellers.com/feed?needle=hpath)
Support for well-typed paths in Haskell. Also provides ByteString based filepath Support for well-typed paths in Haskell. Also provides ByteString based filepath
manipulation. manipulation.

View File

@@ -8,6 +8,7 @@ main =
doctest doctest
["-isrc" ["-isrc"
, "-XOverloadedStrings" , "-XOverloadedStrings"
, "-XScopedTypeVariables"
, "src/HPath.hs" , "src/HPath.hs"
] ]

View File

@@ -1,5 +1,5 @@
name: hpath name: hpath
version: 0.8.0 version: 0.9.2
synopsis: Support for well-typed paths synopsis: Support for well-typed paths
description: Support for well-typed paths, utilizing ByteString under the hood. description: Support for well-typed paths, utilizing ByteString under the hood.
license: BSD3 license: BSD3
@@ -9,7 +9,7 @@ maintainer: Julian Ospald <hasufell@posteo.de>
copyright: Julian Ospald 2016 copyright: Julian Ospald 2016
category: Filesystem category: Filesystem
build-type: Simple build-type: Simple
cabal-version: >=1.14 cabal-version: 1.14
extra-source-files: README.md extra-source-files: README.md
CHANGELOG CHANGELOG
cbits/dirutils.h cbits/dirutils.h
@@ -17,6 +17,9 @@ extra-source-files: README.md
doctests-posix.hs doctests-posix.hs
library library
if os(windows)
build-depends: unbuildable<0
buildable: False
hs-source-dirs: src/ hs-source-dirs: src/
default-language: Haskell2010 default-language: Haskell2010
if impl(ghc >= 8.0) if impl(ghc >= 8.0)
@@ -27,14 +30,14 @@ library
exposed-modules: HPath, exposed-modules: HPath,
HPath.IO, HPath.IO,
HPath.IO.Errors, HPath.IO.Errors,
HPath.IO.Utils,
System.Posix.Directory.Foreign, System.Posix.Directory.Foreign,
System.Posix.Directory.Traversals, System.Posix.Directory.Traversals,
System.Posix.FD, System.Posix.FD,
System.Posix.FilePath System.Posix.FilePath
other-modules: HPath.Internal other-modules: HPath.Internal
build-depends: base >= 4.2 && <5 build-depends: base >= 4.6 && <5
, bytestring >= 0.9.2.0 , IfElse
, bytestring >= 0.10.0.0
, deepseq , deepseq
, exceptions , exceptions
, hspec , hspec
@@ -46,6 +49,9 @@ library
test-suite doctests-hpath test-suite doctests-hpath
if os(windows)
build-depends: unbuildable<0
buildable: False
default-language: Haskell2010 default-language: Haskell2010
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
ghc-options: -threaded ghc-options: -threaded
@@ -57,12 +63,15 @@ test-suite doctests-hpath
, hpath , hpath
test-suite doctests-posix test-suite doctests-posix
if os(windows)
build-depends: unbuildable<0
buildable: False
default-language: Haskell2010 default-language: Haskell2010
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
ghc-options: -threaded ghc-options: -threaded
main-is: doctests-posix.hs main-is: doctests-posix.hs
build-depends: base, build-depends: base,
bytestring, bytestring >= 0.10.0.0,
unix, unix,
hpath, hpath,
doctest >= 0.8, doctest >= 0.8,
@@ -70,17 +79,22 @@ test-suite doctests-posix
QuickCheck QuickCheck
test-suite spec test-suite spec
if os(windows)
build-depends: unbuildable<0
buildable: False
Type: exitcode-stdio-1.0 Type: exitcode-stdio-1.0
Default-Language: Haskell2010 Default-Language: Haskell2010
Hs-Source-Dirs: test Hs-Source-Dirs: test
Main-Is: Main.hs Main-Is: Main.hs
other-modules: other-modules:
HPath.IO.AppendFileSpec
HPath.IO.CanonicalizePathSpec HPath.IO.CanonicalizePathSpec
HPath.IO.CopyDirRecursiveCollectFailuresSpec HPath.IO.CopyDirRecursiveCollectFailuresSpec
HPath.IO.CopyDirRecursiveOverwriteSpec HPath.IO.CopyDirRecursiveOverwriteSpec
HPath.IO.CopyDirRecursiveSpec HPath.IO.CopyDirRecursiveSpec
HPath.IO.CopyFileOverwriteSpec HPath.IO.CopyFileOverwriteSpec
HPath.IO.CopyFileSpec HPath.IO.CopyFileSpec
HPath.IO.CreateDirRecursiveSpec
HPath.IO.CreateDirSpec HPath.IO.CreateDirSpec
HPath.IO.CreateRegularFileSpec HPath.IO.CreateRegularFileSpec
HPath.IO.CreateSymlinkSpec HPath.IO.CreateSymlinkSpec
@@ -91,15 +105,20 @@ test-suite spec
HPath.IO.GetFileTypeSpec HPath.IO.GetFileTypeSpec
HPath.IO.MoveFileOverwriteSpec HPath.IO.MoveFileOverwriteSpec
HPath.IO.MoveFileSpec HPath.IO.MoveFileSpec
HPath.IO.ReadFileEOFSpec
HPath.IO.ReadFileSpec
HPath.IO.RecreateSymlinkOverwriteSpec HPath.IO.RecreateSymlinkOverwriteSpec
HPath.IO.RecreateSymlinkSpec HPath.IO.RecreateSymlinkSpec
HPath.IO.RenameFileSpec HPath.IO.RenameFileSpec
HPath.IO.ToAbsSpec
HPath.IO.WriteFileSpec
Spec Spec
Utils Utils
GHC-Options: -Wall GHC-Options: -Wall
Build-Depends: base Build-Depends: base
, HUnit , HUnit
, bytestring , IfElse
, bytestring >= 0.10.0.0
, hpath , hpath
, hspec >= 1.3 , hspec >= 1.3
, process , process

View File

@@ -10,10 +10,14 @@
-- Support for well-typed paths. -- Support for well-typed paths.
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE EmptyDataDecls #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
#endif
{-# LANGUAGE ScopedTypeVariables #-}
module HPath module HPath
( (
@@ -25,8 +29,10 @@ module HPath
,PathParseException ,PathParseException
,PathException ,PathException
,RelC ,RelC
#if __GLASGOW_HASKELL__ >= 708
-- * PatternSynonyms/ViewPatterns -- * PatternSynonyms/ViewPatterns
,pattern Path ,pattern Path
#endif
-- * Path Parsing -- * Path Parsing
,parseAbs ,parseAbs
,parseFn ,parseFn
@@ -35,6 +41,8 @@ module HPath
,fromAbs ,fromAbs
,fromRel ,fromRel
,toFilePath ,toFilePath
,unsafeToString
,unsafeToString'
-- * Path Operations -- * Path Operations
,(</>) ,(</>)
,basename ,basename
@@ -49,8 +57,10 @@ module HPath
) )
where where
import Control.Exception (Exception) import Control.Exception (IOException, Exception, catch)
import Control.Monad ((<$!>))
import Control.Monad.Catch (MonadThrow(..)) import Control.Monad.Catch (MonadThrow(..))
import Data.ByteString.Unsafe(unsafeUseAsCStringLen)
#if MIN_VERSION_bytestring(0,10,8) #if MIN_VERSION_bytestring(0,10,8)
import Data.ByteString(ByteString, stripPrefix) import Data.ByteString(ByteString, stripPrefix)
#else #else
@@ -61,10 +71,17 @@ import qualified Data.ByteString as BS
import Data.Data import Data.Data
import Data.Maybe import Data.Maybe
import Data.Word8 import Data.Word8
import GHC.Foreign(peekCStringLen)
import GHC.IO.Encoding(getLocaleEncoding, TextEncoding)
import HPath.Internal import HPath.Internal
import System.IO.Unsafe(unsafePerformIO)
import System.Posix.FilePath hiding ((</>)) import System.Posix.FilePath hiding ((</>))
-- $setup
-- >>> import GHC.IO.Encoding(utf8)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Types -- Types
@@ -101,7 +118,9 @@ instance RelC Fn
#if __GLASGOW_HASKELL__ >= 710 #if __GLASGOW_HASKELL__ >= 710
pattern Path :: ByteString -> Path a pattern Path :: ByteString -> Path a
#endif #endif
#if __GLASGOW_HASKELL__ >= 708
pattern Path x <- (MkPath x) pattern Path x <- (MkPath x)
#endif
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Path Parsers -- Path Parsers
@@ -226,6 +245,41 @@ fromAbs = toFilePath
fromRel :: RelC r => Path r -> ByteString fromRel :: RelC r => Path r -> ByteString
fromRel = toFilePath fromRel = toFilePath
-- | This converts the underlying bytestring of the path to an unsafe
-- FilePath by assuming the encoding of the current locale setting. This
-- may be utterly wrong, but isn't particularly worse than what the
-- base library does. Blows up on decoding errors.
--
-- >>> unsafeToString (MkPath "/lal/lad")
-- "/lal/lad"
-- >>> unsafeToString (MkPath "/")
-- "/"
-- >>> unsafeToString (MkPath "lad")
-- "lad"
-- >>> catch (Just <$> unsafeToString (MkPath "<22>")) (\(_ :: IOException) -> pure Nothing)
-- Nothing
unsafeToString :: Path b -> IO FilePath
unsafeToString (MkPath p) = do
enc <- getLocaleEncoding
unsafeUseAsCStringLen p (peekCStringLen enc)
-- | Same as @unsafeToString@, except requires the encoding
-- to be passed explicitly. This uses 'unsafePerformIO' and
-- returns 'Nothing' on decoding errors.
--
-- >>> unsafeToString' (MkPath "/lal/lad") utf8
-- Just "/lal/lad"
-- >>> unsafeToString' (MkPath "/") utf8
-- Just "/"
-- >>> unsafeToString' (MkPath "lad") utf8
-- Just "lad"
-- >>> unsafeToString' (MkPath "<22>") utf8
-- Nothing
unsafeToString' :: Path b -> TextEncoding -> Maybe FilePath
unsafeToString' (MkPath !p) enc =
unsafePerformIO $!
catch (Just <$!> unsafeUseAsCStringLen p (peekCStringLen enc))
(\(_ :: IOException) -> pure Nothing)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@@ -314,10 +368,6 @@ getAllParents (MkPath p)
-- | Extract the directory name of a path. -- | Extract the directory name of a path.
-- --
-- The following properties hold:
--
-- @dirname (p \<\/> a) == dirname p@
--
-- >>> dirname (MkPath "/abc/def/dod") -- >>> dirname (MkPath "/abc/def/dod")
-- "/abc/def" -- "/abc/def"
-- >>> dirname (MkPath "/") -- >>> dirname (MkPath "/")
@@ -336,6 +386,8 @@ dirname (MkPath fp) = MkPath (takeDirectory $ dropTrailingPathSeparator fp)
-- --
-- >>> basename (MkPath "/abc/def/dod") :: Maybe (Path Fn) -- >>> basename (MkPath "/abc/def/dod") :: Maybe (Path Fn)
-- Just "dod" -- Just "dod"
-- >>> basename (MkPath "/abc/def/dod/") :: Maybe (Path Fn)
-- Just "dod"
-- >>> basename (MkPath "/") :: Maybe (Path Fn) -- >>> basename (MkPath "/") :: Maybe (Path Fn)
-- Nothing -- Nothing
basename :: MonadThrow m => Path b -> m (Path Fn) basename :: MonadThrow m => Path b -> m (Path Fn)

View File

@@ -8,8 +8,11 @@
-- Portability : portable -- Portability : portable
-- --
-- This module provides high-level IO related file operations like -- This module provides high-level IO related file operations like
-- copy, delete, move and so on. It only operates on /Path Abs/ which -- copy, delete, move and so on. It only operates on /Path x/ which
-- guarantees us well-typed paths which are absolute. -- 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 -- Some functions are just path-safe wrappers around
-- unix functions, others have stricter exception handling -- unix functions, others have stricter exception handling
@@ -30,6 +33,7 @@
-- For other functions (like `copyFile`), the behavior on these file types is -- For other functions (like `copyFile`), the behavior on these file types is
-- unreliable/unsafe. Check the documentation of those functions for details. -- unreliable/unsafe. Check the documentation of those functions for details.
{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@@ -55,10 +59,17 @@ module HPath.IO
-- * File creation -- * File creation
, createRegularFile , createRegularFile
, createDir , createDir
, createDirRecursive
, createSymlink , createSymlink
-- * File renaming/moving -- * File renaming/moving
, renameFile , renameFile
, moveFile , moveFile
-- * File reading
, readFile
, readFileEOF
-- * File writing
, writeFile
, appendFile
-- * File permissions -- * File permissions
, newFilePerms , newFilePerms
, newDirPerms , newDirPerms
@@ -68,6 +79,7 @@ module HPath.IO
, getFileType , getFileType
-- * Others -- * Others
, canonicalizePath , canonicalizePath
, toAbs
) )
where where
@@ -88,10 +100,29 @@ import Control.Monad
, void , void
, when , when
) )
import Control.Monad.IfElse
(
unlessM
)
import Data.ByteString import Data.ByteString
( (
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 import Data.Foldable
( (
for_ for_
@@ -107,6 +138,11 @@ import Data.Maybe
( (
catMaybes catMaybes
) )
import Data.Monoid
(
(<>)
, mempty
)
import Data.Word import Data.Word
( (
Word8 Word8
@@ -115,9 +151,11 @@ import Foreign.C.Error
( (
eEXIST eEXIST
, eINVAL , eINVAL
, eNOENT
, eNOSYS , eNOSYS
, eNOTEMPTY , eNOTEMPTY
, eXDEV , eXDEV
, getErrno
) )
import Foreign.C.Types import Foreign.C.Types
( (
@@ -138,7 +176,7 @@ import GHC.IO.Exception
import HPath import HPath
import HPath.Internal import HPath.Internal
import HPath.IO.Errors import HPath.IO.Errors
import Prelude hiding (readFile) import Prelude hiding (appendFile, readFile, writeFile)
import System.IO.Error import System.IO.Error
( (
catchIOError catchIOError
@@ -156,6 +194,7 @@ import System.Posix.ByteString
import System.Posix.Directory.ByteString import System.Posix.Directory.ByteString
( (
createDirectory createDirectory
, getWorkingDirectory
, removeDirectory , removeDirectory
) )
import System.Posix.Directory.Traversals import System.Posix.Directory.Traversals
@@ -219,7 +258,7 @@ data FileType = Directory
-- |The error mode for any recursive operation. -- |The error mode for recursive operations.
-- --
-- On `FailEarly` the whole operation fails immediately if any of the -- On `FailEarly` the whole operation fails immediately if any of the
-- recursive sub-operations fail, which is sort of the default -- recursive sub-operations fail, which is sort of the default
@@ -227,7 +266,9 @@ data FileType = Directory
-- --
-- On `CollectFailures` skips errors in the recursion and keeps on recursing. -- On `CollectFailures` skips errors in the recursion and keeps on recursing.
-- However all errors are collected in the `RecursiveFailure` error type, -- However all errors are collected in the `RecursiveFailure` error type,
-- which is raised finally if there was any error. -- which is raised finally if there was any error. Also note that
-- `RecursiveFailure` does not give any guarantees on the ordering
-- of the collected exceptions.
data RecursiveErrorMode = FailEarly data RecursiveErrorMode = FailEarly
| CollectFailures | CollectFailures
@@ -247,12 +288,13 @@ data CopyMode = Strict -- ^ fail if any target exists
-- |Copies the contents of a directory recursively to the given destination. -- |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: -- Does not follow symbolic links. This behaves more or less like
-- the following, without descending into the destination if it
-- already exists:
-- --
-- @ -- @
-- mkdir \/destination\/dir -- cp -a \/source\/dir \/destination\/somedir
-- cp -R \/source\/dir\/* \/destination\/dir\/
-- @ -- @
-- --
-- For directory contents, this will ignore any file type that is not -- For directory contents, this will ignore any file type that is not
@@ -263,9 +305,6 @@ data CopyMode = Strict -- ^ fail if any target exists
-- the operation has completed. Permissions of existing directories are -- the operation has completed. Permissions of existing directories are
-- fixed. -- fixed.
-- --
-- Note that there is no guaranteed ordering of the exceptions
-- contained within `RecursiveFailure` in `CollectFailures` RecursiveErrorMode.
--
-- Safety/reliability concerns: -- Safety/reliability concerns:
-- --
-- * not atomic -- * not atomic
@@ -298,9 +337,11 @@ data CopyMode = Strict -- ^ fail if any target exists
-- Throws in `Strict` CopyMode only: -- Throws in `Strict` CopyMode only:
-- --
-- - `AlreadyExists` if destination already exists -- - `AlreadyExists` if destination already exists
copyDirRecursive :: Path Abs -- ^ copy contents of this source dir --
-> Path Abs -- ^ to this full destination (parent dirs -- Note: may call `getcwd` (only if destination is a relative path)
-- are not automatically created) copyDirRecursive :: Path b1 -- ^ source dir
-> Path b2 -- ^ destination (parent dirs
-- are not automatically created)
-> CopyMode -> CopyMode
-> RecursiveErrorMode -> RecursiveErrorMode
-> IO () -> IO ()
@@ -315,41 +356,56 @@ copyDirRecursive fromp destdirp cm rm
unless (null collectedExceptions) unless (null collectedExceptions)
(throwIO . RecursiveFailure $ collectedExceptions) (throwIO . RecursiveFailure $ collectedExceptions)
where where
go :: IORef [IOException] -> Path Abs -> Path Abs -> IO () go :: IORef [(RecursiveFailureHint, IOException)]
go ce fromp' destdirp' = do -> Path b1 -> Path b2 -> IO ()
go ce fromp'@(MkPath fromBS) destdirp'@(MkPath destdirpBS) = do
-- order is important here, so we don't get empty directories -- NOTE: order is important here, so we don't get empty directories
-- on failure -- on failure
contents <- handleIOE ce [] $ do
-- get the contents of the source dir
contents <- handleIOE (ReadContentsFailed fromBS destdirpBS) ce [] $ do
contents <- getDirsFiles fromp' contents <- getDirsFiles fromp'
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fromAbs fromp') -- create the destination dir and
case cm of -- only return contents if we succeed
Strict -> createDirectory (fromAbs destdirp') fmode' handleIOE (CreateDirFailed fromBS destdirpBS) ce [] $ do
Overwrite -> catchIOError (createDirectory (fromAbs destdirp') fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus fromBS
fmode') case cm of
$ \e -> Strict -> createDirectory destdirpBS fmode'
case ioeGetErrorType e of Overwrite -> catchIOError (createDirectory destdirpBS
AlreadyExists -> setFileMode (fromAbs destdirp') fmode')
fmode' $ \e ->
_ -> ioError e case ioeGetErrorType e of
return contents AlreadyExists -> setFileMode destdirpBS
fmode'
_ -> ioError e
return contents
-- we can't use `easyCopy` here, because we want to call `go` -- NOTE: we can't use `easyCopy` here, because we want to call `go`
-- recursively to skip the top-level sanity checks -- 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 for_ contents $ \f -> do
ftype <- getFileType f ftype <- getFileType f
newdest <- (destdirp' </>) <$> basename f newdest <- (destdirp' </>) <$> basename f
case ftype of case ftype of
SymbolicLink -> handleIOE ce () SymbolicLink -> handleIOE (RecreateSymlinkFailed (toFilePath f) (toFilePath newdest)) ce ()
$ recreateSymlink f newdest cm $ recreateSymlink f newdest cm
Directory -> go ce f newdest Directory -> go ce f newdest
RegularFile -> handleIOE ce () $ copyFile f newdest cm RegularFile -> handleIOE (CopyFileFailed (toFilePath f) (toFilePath newdest)) ce ()
$ copyFile f newdest cm
_ -> return () _ -> return ()
handleIOE :: IORef [IOException] -> a -> IO a -> IO a
handleIOE ce def = case rm of -- helper to handle errors for both RecursiveErrorModes and return a
FailEarly -> handleIOError throwIO -- default value
CollectFailures -> handleIOError (\e -> modifyIORef ce (e:) 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) >> return def)
@@ -372,30 +428,33 @@ copyDirRecursive fromp destdirp cm rm
-- --
-- Throws in `Strict` mode only: -- Throws in `Strict` mode only:
-- --
-- - `AlreadyExists` if destination file already exists -- - `AlreadyExists` if destination already exists
-- --
-- Throws in `Overwrite` mode only: -- Throws in `Overwrite` mode only:
-- --
-- - `UnsatisfiedConstraints` if destination file is non-empty directory -- - `UnsatisfiedConstraints` if destination file is non-empty directory
-- --
-- Note: calls `symlink` -- Notes:
recreateSymlink :: Path Abs -- ^ the old symlink file --
-> Path Abs -- ^ destination file -- - 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 -> CopyMode
-> IO () -> IO ()
recreateSymlink symsource newsym cm recreateSymlink symsource@(MkPath symsourceBS) newsym@(MkPath newsymBS) cm
= do = do
throwSameFile symsource newsym throwSameFile symsource newsym
sympoint <- readSymbolicLink (fromAbs symsource) sympoint <- readSymbolicLink symsourceBS
case cm of case cm of
Strict -> return () Strict -> return ()
Overwrite -> do Overwrite -> do
writable <- isWritable (dirname newsym) writable <- toAbs newsym >>= isWritable
isfile <- doesFileExist newsym isfile <- doesFileExist newsym
isdir <- doesDirectoryExist newsym isdir <- doesDirectoryExist newsym
when (writable && isfile) (deleteFile newsym) when (writable && isfile) (deleteFile newsym)
when (writable && isdir) (deleteDir newsym) when (writable && isdir) (deleteDir newsym)
createSymbolicLink sympoint (fromAbs newsym) createSymbolicLink sympoint newsymBS
-- |Copies the given regular file to the given destination. -- |Copies the given regular file to the given destination.
@@ -432,9 +491,12 @@ recreateSymlink symsource newsym cm
-- --
-- - `AlreadyExists` if destination already exists -- - `AlreadyExists` if destination already exists
-- --
-- Note: calls `sendfile` and possibly `read`/`write` as fallback -- Notes:
copyFile :: Path Abs -- ^ source file --
-> Path Abs -- ^ destination file -- - calls `sendfile` and possibly `read`/`write` as fallback
-- - may call `getcwd` in Overwrite mode (if destination is a relative path)
copyFile :: Path b1 -- ^ source file
-> Path b2 -- ^ destination file
-> CopyMode -> CopyMode
-> IO () -> IO ()
copyFile from to cm = do copyFile from to cm = do
@@ -453,8 +515,8 @@ copyFile from to cm = do
-- figure out if we can still copy by deleting it first -- figure out if we can still copy by deleting it first
PermissionDenied -> do PermissionDenied -> do
exists <- doesFileExist to exists <- doesFileExist to
writable <- isWritable (dirname to) writable <- toAbs to >>= isWritable
if exists && writable if (exists && writable)
then deleteFile to >> copyFile from to Strict then deleteFile to >> copyFile from to Strict
else ioError e else ioError e
_ -> ioError e _ -> ioError e
@@ -462,18 +524,17 @@ copyFile from to cm = do
_copyFile :: [SPDF.Flags] _copyFile :: [SPDF.Flags]
-> [SPDF.Flags] -> [SPDF.Flags]
-> Path Abs -- ^ source file -> Path b1 -- ^ source file
-> Path Abs -- ^ destination file -> Path b2 -- ^ destination file
-> IO () -> IO ()
_copyFile sflags dflags from to _copyFile sflags dflags (MkPath fromBS) to@(MkPath toBS)
= =
-- from sendfile(2) manpage: -- from sendfile(2) manpage:
-- Applications may wish to fall back to read(2)/write(2) in -- Applications may wish to fall back to read(2)/write(2) in
-- the case where sendfile() fails with EINVAL or ENOSYS. -- the case where sendfile() fails with EINVAL or ENOSYS.
withAbsPath to $ \to' -> withAbsPath from $ \from' -> catchErrno [eINVAL, eNOSYS]
catchErrno [eINVAL, eNOSYS] (sendFileCopy fromBS toBS)
(sendFileCopy from' to') (void $ readWriteCopy fromBS toBS)
(void $ readWriteCopy from' to')
where where
copyWith copyAction source dest = copyWith copyAction source dest =
bracket (openFd source SPI.ReadOnly sflags Nothing) bracket (openFd source SPI.ReadOnly sflags Nothing)
@@ -505,8 +566,8 @@ _copyFile sflags dflags from to
if size == 0 if size == 0
then return $ fromIntegral totalsize then return $ fromIntegral totalsize
else do rsize <- SPB.fdWriteBuf dfd buf size else do rsize <- SPB.fdWriteBuf dfd buf size
when (rsize /= size) (throwIO . CopyFailed when (rsize /= size) (ioError $ userError
$ "wrong size!") "wrong size!")
write' sfd dfd buf (totalsize + fromIntegral size) write' sfd dfd buf (totalsize + fromIntegral size)
@@ -518,8 +579,10 @@ _copyFile sflags dflags from to
-- --
-- * examines filetypes explicitly -- * examines filetypes explicitly
-- * calls `copyDirRecursive` for directories -- * calls `copyDirRecursive` for directories
easyCopy :: Path Abs --
-> Path Abs -- Note: may call `getcwd` in Overwrite mode (if destination is a relative path)
easyCopy :: Path b1
-> Path b2
-> CopyMode -> CopyMode
-> RecursiveErrorMode -> RecursiveErrorMode
-> IO () -> IO ()
@@ -548,8 +611,8 @@ easyCopy from to cm rm = do
-- - `InappropriateType` for wrong file type (directory) -- - `InappropriateType` for wrong file type (directory)
-- - `NoSuchThing` if the file does not exist -- - `NoSuchThing` if the file does not exist
-- - `PermissionDenied` if the directory cannot be read -- - `PermissionDenied` if the directory cannot be read
deleteFile :: Path Abs -> IO () deleteFile :: Path b -> IO ()
deleteFile p = withAbsPath p removeLink deleteFile (MkPath p) = removeLink p
-- |Deletes the given directory, which must be empty, never symlinks. -- |Deletes the given directory, which must be empty, never symlinks.
@@ -563,8 +626,8 @@ deleteFile p = withAbsPath p removeLink
-- - `PermissionDenied` if we can't open or write to parent directory -- - `PermissionDenied` if we can't open or write to parent directory
-- --
-- Notes: calls `rmdir` -- Notes: calls `rmdir`
deleteDir :: Path Abs -> IO () deleteDir :: Path b -> IO ()
deleteDir p = withAbsPath p removeDirectory deleteDir (MkPath p) = removeDirectory p
-- |Deletes the given directory recursively. Does not follow symbolic -- |Deletes the given directory recursively. Does not follow symbolic
@@ -586,7 +649,7 @@ deleteDir p = withAbsPath p removeDirectory
-- - `InappropriateType` for wrong file type (regular file) -- - `InappropriateType` for wrong file type (regular file)
-- - `NoSuchThing` if directory does not exist -- - `NoSuchThing` if directory does not exist
-- - `PermissionDenied` if we can't open or write to parent directory -- - `PermissionDenied` if we can't open or write to parent directory
deleteDirRecursive :: Path Abs -> IO () deleteDirRecursive :: Path b -> IO ()
deleteDirRecursive p = deleteDirRecursive p =
catchErrno [eNOTEMPTY, eEXIST] catchErrno [eNOTEMPTY, eEXIST]
(deleteDir p) (deleteDir p)
@@ -611,7 +674,7 @@ deleteDirRecursive p =
-- --
-- * examines filetypes explicitly -- * examines filetypes explicitly
-- * calls `deleteDirRecursive` for directories -- * calls `deleteDirRecursive` for directories
easyDelete :: Path Abs -> IO () easyDelete :: Path b -> IO ()
easyDelete p = do easyDelete p = do
ftype <- getFileType p ftype <- getFileType p
case ftype of case ftype of
@@ -630,21 +693,18 @@ easyDelete p = do
-- |Opens a file appropriately by invoking xdg-open. The file type -- |Opens a file appropriately by invoking xdg-open. The file type
-- is not checked. This forks a process. -- is not checked. This forks a process.
openFile :: Path Abs openFile :: Path b
-> IO ProcessID -> IO ProcessID
openFile p = openFile (MkPath fp) =
withAbsPath p $ \fp -> SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
-- |Executes a program with the given arguments. This forks a process. -- |Executes a program with the given arguments. This forks a process.
executeFile :: Path Abs -- ^ program executeFile :: Path b -- ^ program
-> [ByteString] -- ^ arguments -> [ByteString] -- ^ arguments
-> IO ProcessID -> IO ProcessID
executeFile fp args executeFile (MkPath fp) args =
= withAbsPath fp $ \fpb -> SPP.forkProcess $ SPP.executeFile fp True args Nothing
SPP.forkProcess
$ SPP.executeFile fpb True args Nothing
@@ -660,10 +720,12 @@ executeFile fp args
-- Throws: -- Throws:
-- --
-- - `PermissionDenied` if output directory cannot be written to -- - `PermissionDenied` if output directory cannot be written to
-- - `AlreadyExists` if destination file already exists -- - `AlreadyExists` if destination already exists
createRegularFile :: FileMode -> Path Abs -> IO () -- - `NoSuchThing` if any of the parent components of the path
createRegularFile fm dest = -- do not exist
bracket (SPI.openFd (fromAbs dest) SPI.WriteOnly (Just fm) createRegularFile :: FileMode -> Path b -> IO ()
createRegularFile fm (MkPath destBS) =
bracket (SPI.openFd destBS SPI.WriteOnly (Just fm)
(SPI.defaultFileFlags { exclusive = True })) (SPI.defaultFileFlags { exclusive = True }))
SPI.closeFd SPI.closeFd
(\_ -> return ()) (\_ -> return ())
@@ -674,9 +736,46 @@ createRegularFile fm dest =
-- Throws: -- Throws:
-- --
-- - `PermissionDenied` if output directory cannot be written to -- - `PermissionDenied` if output directory cannot be written to
-- - `AlreadyExists` if destination directory already exists -- - `AlreadyExists` if destination already exists
createDir :: FileMode -> Path Abs -> IO () -- - `NoSuchThing` if any of the parent components of the path
createDir fm dest = createDirectory (fromAbs dest) fm -- 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. -- |Create a symlink.
@@ -685,13 +784,15 @@ createDir fm dest = createDirectory (fromAbs dest) fm
-- --
-- - `PermissionDenied` if output directory cannot be written to -- - `PermissionDenied` if output directory cannot be written to
-- - `AlreadyExists` if destination file already exists -- - `AlreadyExists` if destination file already exists
-- - `NoSuchThing` if any of the parent components of the path
-- do not exist
-- --
-- Note: calls `symlink` -- Note: calls `symlink`
createSymlink :: Path Abs -- ^ destination file createSymlink :: Path b -- ^ destination file
-> ByteString -- ^ path the symlink points to -> ByteString -- ^ path the symlink points to
-> IO () -> IO ()
createSymlink dest sympoint createSymlink (MkPath destBS) sympoint
= createSymbolicLink sympoint (fromAbs dest) = createSymbolicLink sympoint destBS
@@ -716,20 +817,17 @@ createSymlink dest sympoint
-- - `PermissionDenied` if source directory cannot be opened -- - `PermissionDenied` if source directory cannot be opened
-- - `UnsupportedOperation` if source and destination are on different -- - `UnsupportedOperation` if source and destination are on different
-- devices -- devices
-- - `FileDoesExist` if destination file already exists -- - `AlreadyExists` if destination already exists
-- (`HPathIOException`)
-- - `DirDoesExist` if destination directory already exists
-- (`HPathIOException`)
-- - `SameFile` if destination and source are the same file -- - `SameFile` if destination and source are the same file
-- (`HPathIOException`) -- (`HPathIOException`)
-- --
-- Note: calls `rename` (but does not allow to rename over existing files) -- Note: calls `rename` (but does not allow to rename over existing files)
renameFile :: Path Abs -> Path Abs -> IO () renameFile :: Path b1 -> Path b2 -> IO ()
renameFile fromf tof = do renameFile fromf@(MkPath fromfBS) tof@(MkPath tofBS) = do
throwSameFile fromf tof throwSameFile fromf tof
throwFileDoesExist tof throwFileDoesExist tof
throwDirDoesExist tof throwDirDoesExist tof
rename (fromAbs fromf) (fromAbs tof) rename fromfBS tofBS
-- |Move a file. This also works across devices by copy-delete fallback. -- |Move a file. This also works across devices by copy-delete fallback.
@@ -758,13 +856,14 @@ renameFile fromf tof = do
-- --
-- Throws in `Strict` mode only: -- Throws in `Strict` mode only:
-- --
-- - `FileDoesExist` if destination file already exists (`HPathIOException`) -- - `AlreadyExists` if destination already exists
-- - `DirDoesExist` if destination directory already exists
-- (`HPathIOException`)
-- --
-- Note: calls `rename` (but does not allow to rename over existing files) -- Notes:
moveFile :: Path Abs -- ^ file to move --
-> Path Abs -- ^ destination -- - 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 -> CopyMode
-> IO () -> IO ()
moveFile from to cm = do moveFile from to cm = do
@@ -775,7 +874,7 @@ moveFile from to cm = do
easyDelete from easyDelete from
Overwrite -> do Overwrite -> do
ft <- getFileType from ft <- getFileType from
writable <- isWritable $ dirname to writable <- toAbs to >>= isWritable
case ft of case ft of
RegularFile -> do RegularFile -> do
exists <- doesFileExist to exists <- doesFileExist to
@@ -793,6 +892,110 @@ moveFile from to cm = do
--------------------
--[ 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]-- --[ File Permissions]--
@@ -838,15 +1041,14 @@ newDirPerms
-- - `InappropriateType` if file type is wrong (symlink to file) -- - `InappropriateType` if file type is wrong (symlink to file)
-- - `InappropriateType` if file type is wrong (symlink to dir) -- - `InappropriateType` if file type is wrong (symlink to dir)
-- - `PermissionDenied` if directory cannot be opened -- - `PermissionDenied` if directory cannot be opened
getDirsFiles :: Path Abs -- ^ dir to read getDirsFiles :: Path b -- ^ dir to read
-> IO [Path Abs] -> IO [Path b]
getDirsFiles p = getDirsFiles p@(MkPath fp) = do
withAbsPath p $ \fp -> do fd <- openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing
fd <- openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing return
return . catMaybes
. catMaybes . fmap (\x -> (</>) p <$> (parseMaybe . snd $ x))
. fmap (\x -> (</>) p <$> (parseMaybe . snd $ x)) =<< getDirectoryContents' fd
=<< getDirectoryContents' fd
where where
parseMaybe :: ByteString -> Maybe (Path Fn) parseMaybe :: ByteString -> Maybe (Path Fn)
parseMaybe = parseFn parseMaybe = parseFn
@@ -866,9 +1068,9 @@ getDirsFiles p =
-- --
-- - `NoSuchThing` if the file does not exist -- - `NoSuchThing` if the file does not exist
-- - `PermissionDenied` if any part of the path is not accessible -- - `PermissionDenied` if any part of the path is not accessible
getFileType :: Path Abs -> IO FileType getFileType :: Path b -> IO FileType
getFileType p = do getFileType (MkPath fp) = do
fs <- PF.getSymbolicLinkStatus (fromAbs p) fs <- PF.getSymbolicLinkStatus fp
decide fs decide fs
where where
decide fs decide fs
@@ -889,13 +1091,29 @@ getFileType p = do
-- |Applies `realpath` on the given absolute path. -- |Applies `realpath` on the given path.
-- --
-- Throws: -- Throws:
-- --
-- - `NoSuchThing` if the file at the given path does not exist -- - `NoSuchThing` if the file at the given path does not exist
-- - `NoSuchThing` if the symlink is broken -- - `NoSuchThing` if the symlink is broken
canonicalizePath :: Path Abs -> IO (Path Abs) canonicalizePath :: Path b -> IO (Path Abs)
canonicalizePath (MkPath l) = do canonicalizePath (MkPath l) = do
nl <- SPDT.realpath l nl <- SPDT.realpath l
return $ MkPath nl 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

View File

@@ -3,5 +3,6 @@ module HPath.IO where
import HPath import HPath
canonicalizePath :: Path Abs -> IO (Path Abs) canonicalizePath :: Path b -> IO (Path Abs)
toAbs :: Path b -> IO (Path Abs)

View File

@@ -16,24 +16,20 @@ module HPath.IO.Errors
( (
-- * Types -- * Types
HPathIOException(..) HPathIOException(..)
, RecursiveFailureHint(..)
-- * Exception identifiers -- * Exception identifiers
, isFileDoesNotExist
, isDirDoesNotExist
, isSameFile , isSameFile
, isDestinationInSource , isDestinationInSource
, isFileDoesExist
, isDirDoesExist
, isInvalidOperation
, isCan'tOpenDirectory
, isCopyFailed
, isRecursiveFailure , isRecursiveFailure
, isReadContentsFailed
, isCreateDirFailed
, isCopyFileFailed
, isRecreateSymlinkFailed
-- * Path based functions -- * Path based functions
, throwFileDoesExist , throwFileDoesExist
, throwDirDoesExist , throwDirDoesExist
, throwFileDoesNotExist
, throwDirDoesNotExist
, throwSameFile , throwSameFile
, sameFile , sameFile
, throwDestinationInSource , throwDestinationInSource
@@ -41,7 +37,6 @@ module HPath.IO.Errors
, doesDirectoryExist , doesDirectoryExist
, isWritable , isWritable
, canOpenDirectory , canOpenDirectory
, throwCantOpenDirectory
-- * Error handling functions -- * Error handling functions
, catchErrno , catchErrno
@@ -63,6 +58,10 @@ import Control.Monad
forM forM
, when , when
) )
import Control.Monad.IfElse
(
whenM
)
import Data.ByteString import Data.ByteString
( (
ByteString ByteString
@@ -72,6 +71,9 @@ import Data.ByteString.UTF8
toString toString
) )
import Data.Typeable import Data.Typeable
(
Typeable
)
import Foreign.C.Error import Foreign.C.Error
( (
getErrno getErrno
@@ -82,15 +84,21 @@ import GHC.IO.Exception
IOErrorType IOErrorType
) )
import HPath import HPath
import HPath.Internal
(
Path(..)
)
import {-# SOURCE #-} HPath.IO import {-# SOURCE #-} HPath.IO
( (
canonicalizePath canonicalizePath
, toAbs
) )
import HPath.IO.Utils
import System.IO.Error import System.IO.Error
( (
catchIOError alreadyExistsErrorType
, catchIOError
, ioeGetErrorType , ioeGetErrorType
, mkIOError
) )
import qualified System.Posix.Directory.ByteString as PFD import qualified System.Posix.Directory.ByteString as PFD
@@ -102,57 +110,36 @@ import System.Posix.Files.ByteString
import qualified System.Posix.Files.ByteString as PF import qualified System.Posix.Files.ByteString as PF
data HPathIOException = FileDoesNotExist ByteString -- |Additional generic IO exceptions that the posix functions
| DirDoesNotExist ByteString -- do not provide.
| SameFile ByteString ByteString data HPathIOException = SameFile ByteString ByteString
| DestinationInSource ByteString ByteString | DestinationInSource ByteString ByteString
| FileDoesExist ByteString | RecursiveFailure [(RecursiveFailureHint, IOException)]
| DirDoesExist ByteString deriving (Eq, Show, Typeable)
| InvalidOperation String
| Can'tOpenDirectory ByteString
| CopyFailed String
| RecursiveFailure [IOException]
deriving (Typeable, Eq)
instance Show HPathIOException where
show (FileDoesNotExist fp) = "File does not exist:" ++ toString fp
show (DirDoesNotExist fp) = "Directory does not exist: "
++ toString fp
show (SameFile fp1 fp2) = toString fp1
++ " and " ++ toString fp2
++ " are the same file!"
show (DestinationInSource fp1 fp2) = toString fp1
++ " is contained in "
++ toString fp2
show (FileDoesExist fp) = "File does exist: " ++ toString fp
show (DirDoesExist fp) = "Directory does exist: " ++ toString fp
show (InvalidOperation str) = "Invalid operation: " ++ str
show (Can'tOpenDirectory fp) = "Can't open directory: "
++ toString fp
show (CopyFailed str) = "Copying failed: " ++ str
show (RecursiveFailure exs) = "Recursive operation failed: "
++ show exs
toConstr :: HPathIOException -> String
toConstr FileDoesNotExist {} = "FileDoesNotExist"
toConstr DirDoesNotExist {} = "DirDoesNotExist"
toConstr SameFile {} = "SameFile"
toConstr DestinationInSource {} = "DestinationInSource"
toConstr FileDoesExist {} = "FileDoesExist"
toConstr DirDoesExist {} = "DirDoesExist"
toConstr InvalidOperation {} = "InvalidOperation"
toConstr Can'tOpenDirectory {} = "Can'tOpenDirectory"
toConstr CopyFailed {} = "CopyFailed"
toConstr RecursiveFailure {} = "RecursiveFailure"
-- |A type for giving failure hints on recursive failure, which allows
-- to programmatically make choices without examining
-- the weakly typed I/O error attributes (like `ioeGetFileName`).
--
-- The first argument to the data constructor is always the
-- source and the second the destination.
data RecursiveFailureHint = ReadContentsFailed ByteString ByteString
| CreateDirFailed ByteString ByteString
| CopyFileFailed ByteString ByteString
| RecreateSymlinkFailed ByteString ByteString
deriving (Eq, Show)
instance Exception HPathIOException instance Exception HPathIOException
toConstr :: HPathIOException -> String
toConstr SameFile {} = "SameFile"
toConstr DestinationInSource {} = "DestinationInSource"
toConstr RecursiveFailure {} = "RecursiveFailure"
@@ -160,71 +147,77 @@ instance Exception HPathIOException
--[ Exception identifiers ]-- --[ Exception identifiers ]--
----------------------------- -----------------------------
isFileDoesNotExist, isDirDoesNotExist, isSameFile, isDestinationInSource, isFileDoesExist, isDirDoesExist, isInvalidOperation, isCan'tOpenDirectory, isCopyFailed, isRecursiveFailure :: HPathIOException -> Bool
isFileDoesNotExist ex = toConstr (ex :: HPathIOException) == toConstr FileDoesNotExist{} isSameFile, isDestinationInSource, isRecursiveFailure :: HPathIOException -> Bool
isDirDoesNotExist ex = toConstr (ex :: HPathIOException) == toConstr DirDoesNotExist{}
isSameFile ex = toConstr (ex :: HPathIOException) == toConstr SameFile{} isSameFile ex = toConstr (ex :: HPathIOException) == toConstr SameFile{}
isDestinationInSource ex = toConstr (ex :: HPathIOException) == toConstr DestinationInSource{} isDestinationInSource ex = toConstr (ex :: HPathIOException) == toConstr DestinationInSource{}
isFileDoesExist ex = toConstr (ex :: HPathIOException) == toConstr FileDoesExist{}
isDirDoesExist ex = toConstr (ex :: HPathIOException) == toConstr DirDoesExist{}
isInvalidOperation ex = toConstr (ex :: HPathIOException) == toConstr InvalidOperation{}
isCan'tOpenDirectory ex = toConstr (ex :: HPathIOException) == toConstr Can'tOpenDirectory{}
isCopyFailed ex = toConstr (ex :: HPathIOException) == toConstr CopyFailed{}
isRecursiveFailure ex = toConstr (ex :: HPathIOException) == toConstr RecursiveFailure{} isRecursiveFailure ex = toConstr (ex :: HPathIOException) == toConstr RecursiveFailure{}
isReadContentsFailed, isCreateDirFailed, isCopyFileFailed, isRecreateSymlinkFailed ::RecursiveFailureHint -> Bool
isReadContentsFailed ReadContentsFailed{} = True
isReadContentsFailed _ = False
isCreateDirFailed CreateDirFailed{} = True
isCreateDirFailed _ = False
isCopyFileFailed CopyFileFailed{} = True
isCopyFileFailed _ = False
isRecreateSymlinkFailed RecreateSymlinkFailed{} = True
isRecreateSymlinkFailed _ = False
---------------------------- ----------------------------
--[ Path based functions ]-- --[ Path based functions ]--
---------------------------- ----------------------------
throwFileDoesExist :: Path Abs -> IO () -- |Throws `AlreadyExists` `IOError` if file exists.
throwFileDoesExist fp = throwFileDoesExist :: Path b -> IO ()
whenM (doesFileExist fp) (throwIO . FileDoesExist throwFileDoesExist fp@(MkPath bs) =
. fromAbs $ fp) whenM (doesFileExist fp)
(ioError . mkIOError
alreadyExistsErrorType
"File already exists"
Nothing
$ (Just (toString $ bs))
)
throwDirDoesExist :: Path Abs -> IO () -- |Throws `AlreadyExists` `IOError` if directory exists.
throwDirDoesExist fp = throwDirDoesExist :: Path b -> IO ()
whenM (doesDirectoryExist fp) (throwIO . DirDoesExist throwDirDoesExist fp@(MkPath bs) =
. fromAbs $ fp) whenM (doesDirectoryExist fp)
(ioError . mkIOError
alreadyExistsErrorType
throwFileDoesNotExist :: Path Abs -> IO () "Directory already exists"
throwFileDoesNotExist fp = Nothing
unlessM (doesFileExist fp) (throwIO . FileDoesNotExist $ (Just (toString $ bs))
. fromAbs $ fp) )
throwDirDoesNotExist :: Path Abs -> IO ()
throwDirDoesNotExist fp =
unlessM (doesDirectoryExist fp) (throwIO . DirDoesNotExist
. fromAbs $ fp)
-- |Uses `isSameFile` and throws `SameFile` if it returns True. -- |Uses `isSameFile` and throws `SameFile` if it returns True.
throwSameFile :: Path Abs throwSameFile :: Path b1
-> Path Abs -> Path b2
-> IO () -> IO ()
throwSameFile fp1 fp2 = throwSameFile fp1@(MkPath bs1) fp2@(MkPath bs2) =
whenM (sameFile fp1 fp2) whenM (sameFile fp1 fp2)
(throwIO $ SameFile (fromAbs fp1) (fromAbs fp2)) (throwIO $ SameFile bs1 bs2)
-- |Check if the files are the same by examining device and file id. -- |Check if the files are the same by examining device and file id.
-- This follows symbolic links. -- This follows symbolic links.
sameFile :: Path Abs -> Path Abs -> IO Bool sameFile :: Path b1 -> Path b2 -> IO Bool
sameFile fp1 fp2 = sameFile (MkPath fp1) (MkPath fp2) =
withAbsPath fp1 $ \fp1' -> withAbsPath fp2 $ \fp2' -> handleIOError (\_ -> return False) $ do
handleIOError (\_ -> return False) $ do fs1 <- getFileStatus fp1
fs1 <- getFileStatus fp1' fs2 <- getFileStatus fp2
fs2 <- getFileStatus fp2'
if ((PF.deviceID fs1, PF.fileID fs1) == if ((PF.deviceID fs1, PF.fileID fs1) ==
(PF.deviceID fs2, PF.fileID fs2)) (PF.deviceID fs2, PF.fileID fs2))
then return True then return True
else return False else return False
-- TODO: make this more robust when destination does not exist -- TODO: make this more robust when destination does not exist
@@ -232,66 +225,59 @@ sameFile fp1 fp2 =
-- within the source directory by comparing the device+file ID of the -- within the source directory by comparing the device+file ID of the
-- source directory with all device+file IDs of the parent directories -- source directory with all device+file IDs of the parent directories
-- of the destination. -- of the destination.
throwDestinationInSource :: Path Abs -- ^ source dir throwDestinationInSource :: Path b1 -- ^ source dir
-> Path Abs -- ^ full destination, @dirname dest@ -> Path b2 -- ^ full destination, @dirname dest@
-- must exist -- must exist
-> IO () -> IO ()
throwDestinationInSource source dest = do throwDestinationInSource (MkPath sbs) dest@(MkPath dbs) = do
destAbs <- toAbs dest
dest' <- (\x -> maybe x (\y -> x </> y) $ basename dest) dest' <- (\x -> maybe x (\y -> x </> y) $ basename dest)
<$> (canonicalizePath $ dirname dest) <$> (canonicalizePath $ dirname destAbs)
dids <- forM (getAllParents dest') $ \p -> do dids <- forM (getAllParents dest') $ \p -> do
fs <- PF.getSymbolicLinkStatus (fromAbs p) fs <- PF.getSymbolicLinkStatus (fromAbs p)
return (PF.deviceID fs, PF.fileID fs) return (PF.deviceID fs, PF.fileID fs)
sid <- fmap (\x -> (PF.deviceID x, PF.fileID x)) sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
$ PF.getFileStatus (fromAbs source) $ PF.getFileStatus sbs
when (elem sid dids) when (elem sid dids)
(throwIO $ DestinationInSource (fromAbs dest) (throwIO $ DestinationInSource dbs sbs)
(fromAbs source))
-- |Checks if the given file exists and is not a directory. -- |Checks if the given file exists and is not a directory.
-- Does not follow symlinks. -- Does not follow symlinks.
doesFileExist :: Path Abs -> IO Bool doesFileExist :: Path b -> IO Bool
doesFileExist fp = doesFileExist (MkPath bs) =
handleIOError (\_ -> return False) $ do handleIOError (\_ -> return False) $ do
fs <- PF.getSymbolicLinkStatus (fromAbs fp) fs <- PF.getSymbolicLinkStatus bs
return $ not . PF.isDirectory $ fs return $ not . PF.isDirectory $ fs
-- |Checks if the given file exists and is a directory. -- |Checks if the given file exists and is a directory.
-- Does not follow symlinks. -- Does not follow symlinks.
doesDirectoryExist :: Path Abs -> IO Bool doesDirectoryExist :: Path b -> IO Bool
doesDirectoryExist fp = doesDirectoryExist (MkPath bs) =
handleIOError (\_ -> return False) $ do handleIOError (\_ -> return False) $ do
fs <- PF.getSymbolicLinkStatus (fromAbs fp) fs <- PF.getSymbolicLinkStatus bs
return $ PF.isDirectory fs return $ PF.isDirectory fs
-- |Checks whether a file or folder is writable. -- |Checks whether a file or folder is writable.
isWritable :: Path Abs -> IO Bool isWritable :: Path b -> IO Bool
isWritable fp = isWritable (MkPath bs) =
handleIOError (\_ -> return False) $ handleIOError (\_ -> return False) $
fileAccess (fromAbs fp) False True False fileAccess bs False True False
-- |Checks whether the directory at the given path exists and can be -- |Checks whether the directory at the given path exists and can be
-- opened. This invokes `openDirStream` which follows symlinks. -- opened. This invokes `openDirStream` which follows symlinks.
canOpenDirectory :: Path Abs -> IO Bool canOpenDirectory :: Path b -> IO Bool
canOpenDirectory fp = canOpenDirectory (MkPath bs) =
handleIOError (\_ -> return False) $ do handleIOError (\_ -> return False) $ do
bracket (PFD.openDirStream . fromAbs $ fp) bracket (PFD.openDirStream bs)
PFD.closeDirStream PFD.closeDirStream
(\_ -> return ()) (\_ -> return ())
return True return True
-- |Throws a `Can'tOpenDirectory` HPathIOException if the directory at the given
-- path cannot be opened.
throwCantOpenDirectory :: Path Abs -> IO ()
throwCantOpenDirectory fp =
unlessM (canOpenDirectory fp)
(throwIO . Can'tOpenDirectory . fromAbs $ fp)
-------------------------------- --------------------------------
@@ -371,3 +357,4 @@ reactOnError a ios fmios =
else y) else y)
(throwIO ex) (throwIO ex)
fmios fmios

View File

@@ -1,32 +0,0 @@
-- |
-- Module : HPath.IO.Utils
-- Copyright : © 2016 Julian Ospald
-- License : BSD3
--
-- Maintainer : Julian Ospald <hasufell@posteo.de>
-- Stability : experimental
-- Portability : portable
--
-- Random and general IO/monad utilities.
module HPath.IO.Utils where
import Control.Monad
(
when
, unless
)
-- |If the value of the first argument is True, then execute the action
-- provided in the second argument, otherwise do nothing.
whenM :: Monad m => m Bool -> m () -> m ()
whenM mb a = mb >>= (`when` a)
-- |If the value of the first argument is False, then execute the action
-- provided in the second argument, otherwise do nothing.
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mb a = mb >>= (`unless` a)

7
stack.yaml Normal file
View File

@@ -0,0 +1,7 @@
resolver: lts-12.1
packages:
- '.'
extra-deps:
- IfElse-0.85

View File

@@ -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)

View File

@@ -157,8 +157,10 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
CollectFailures CollectFailures
`shouldThrow` `shouldThrow`
(\(RecursiveFailure ex@[_, _]) -> (\(RecursiveFailure ex@[_, _]) ->
any (\e -> ioeGetErrorType e == InappropriateType) ex && any (\(h, e) -> ioeGetErrorType e == InappropriateType
any (\e -> ioeGetErrorType e == PermissionDenied) ex) && isCopyFileFailed h) ex &&
any (\(h, e) -> ioeGetErrorType e == PermissionDenied
&& isReadContentsFailed h) ex)
normalDirPerms "outputDir1/foo2/foo4" normalDirPerms "outputDir1/foo2/foo4"
normalDirPerms "outputDir1/foo2/foo4/inputFile4" normalDirPerms "outputDir1/foo2/foo4/inputFile4"
c <- allDirectoryContents' "outputDir1" c <- allDirectoryContents' "outputDir1"
@@ -184,7 +186,7 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
Strict Strict
CollectFailures CollectFailures
`shouldThrow` `shouldThrow`
(\(RecursiveFailure [e]) -> ioeGetErrorType e == PermissionDenied) (\(RecursiveFailure [(CreateDirFailed{}, e)]) -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursive (Strict, CollectFailures), cannot open output dir" $ it "copyDirRecursive (Strict, CollectFailures), cannot open output dir" $
copyDirRecursive' "inputDir" copyDirRecursive' "inputDir"
@@ -200,7 +202,7 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
Strict Strict
CollectFailures CollectFailures
`shouldThrow` `shouldThrow`
(\(RecursiveFailure [e]) -> ioeGetErrorType e == AlreadyExists) (\(RecursiveFailure [(CreateDirFailed{}, e)]) -> ioeGetErrorType e == AlreadyExists)
it "copyDirRecursive (Strict, CollectFailures), destination already exists and is a file" $ it "copyDirRecursive (Strict, CollectFailures), destination already exists and is a file" $
copyDirRecursive' "inputDir" copyDirRecursive' "inputDir"
@@ -216,7 +218,7 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
Strict Strict
CollectFailures CollectFailures
`shouldThrow` `shouldThrow`
(\(RecursiveFailure [e]) -> ioeGetErrorType e == InappropriateType) (\(RecursiveFailure [(ReadContentsFailed{}, e)]) -> ioeGetErrorType e == InappropriateType)
it "copyDirRecursive (Strict, CollectFailures), wrong input (symlink to directory)" $ it "copyDirRecursive (Strict, CollectFailures), wrong input (symlink to directory)" $
copyDirRecursive' "wrongInputSymL" copyDirRecursive' "wrongInputSymL"
@@ -224,7 +226,7 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
Strict Strict
CollectFailures CollectFailures
`shouldThrow` `shouldThrow`
(\(RecursiveFailure [e]) -> ioeGetErrorType e == InvalidArgument) (\(RecursiveFailure [(ReadContentsFailed{}, e)]) -> ioeGetErrorType e == InvalidArgument)
it "copyDirRecursive (Strict, CollectFailures), destination in source" $ it "copyDirRecursive (Strict, CollectFailures), destination in source" $
copyDirRecursive' "inputDir" copyDirRecursive' "inputDir"

View File

@@ -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)

View File

@@ -50,6 +50,11 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
removeDirIfExists "newDir" removeDirIfExists "newDir"
-- posix failures -- -- 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" $ it "createDir, can't write to output directory" $
createDir' "noWritePerms/newDir" createDir' "noWritePerms/newDir"
`shouldThrow` `shouldThrow`

View File

@@ -48,6 +48,11 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
removeFileIfExists "newDir" removeFileIfExists "newDir"
-- posix failures -- -- 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" $ it "createRegularFile, can't write to destination directory" $
createRegularFile' "noWritePerms/newDir" createRegularFile' "noWritePerms/newDir"
`shouldThrow` `shouldThrow`

View File

@@ -49,6 +49,11 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
removeFileIfExists "newSymL" removeFileIfExists "newSymL"
-- posix failures -- -- 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" $ it "createSymlink, can't write to destination directory" $
createSymlink' "noWritePerms/newDir" "lala" createSymlink' "noWritePerms/newDir" "lala"
`shouldThrow` `shouldThrow`

View File

@@ -116,7 +116,7 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
"alreadyExistsD" "alreadyExistsD"
Overwrite Overwrite
`shouldThrow` `shouldThrow`
isDirDoesExist (\e -> ioeGetErrorType e == AlreadyExists)
it "moveFile (Overwrite), source and dest are same file" $ it "moveFile (Overwrite), source and dest are same file" $
moveFile' "myFile" moveFile' "myFile"

View File

@@ -112,14 +112,14 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
"alreadyExists" "alreadyExists"
Strict Strict
`shouldThrow` `shouldThrow`
isFileDoesExist (\e -> ioeGetErrorType e == AlreadyExists)
it "moveFile (Strict), move from file to dir" $ it "moveFile (Strict), move from file to dir" $
moveFile' "myFile" moveFile' "myFile"
"alreadyExistsD" "alreadyExistsD"
Strict Strict
`shouldThrow` `shouldThrow`
isDirDoesExist (\e -> ioeGetErrorType e == AlreadyExists)
it "moveFile (Strict), source and dest are same file" $ it "moveFile (Strict), source and dest are same file" $
moveFile' "myFile" moveFile' "myFile"

View File

@@ -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)

View File

@@ -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)

View File

@@ -101,13 +101,13 @@ spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
renameFile' "myFile" renameFile' "myFile"
"alreadyExists" "alreadyExists"
`shouldThrow` `shouldThrow`
isFileDoesExist (\e -> ioeGetErrorType e == AlreadyExists)
it "renameFile, move from file to dir" $ it "renameFile, move from file to dir" $
renameFile' "myFile" renameFile' "myFile"
"alreadyExistsD" "alreadyExistsD"
`shouldThrow` `shouldThrow`
isDirDoesExist (\e -> ioeGetErrorType e == AlreadyExists)
it "renameFile, source and dest are same file" $ it "renameFile, source and dest are same file" $
renameFile' "myFile" renameFile' "myFile"

View File

@@ -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

View File

@@ -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)

View File

@@ -14,6 +14,10 @@ import Control.Monad
forM_ forM_
, void , void
) )
import Control.Monad.IfElse
(
whenM
)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.IORef import Data.IORef
( (
@@ -24,7 +28,7 @@ import Data.IORef
) )
import HPath.IO import HPath.IO
import HPath.IO.Errors import HPath.IO.Errors
import HPath.IO.Utils import Prelude hiding (appendFile, readFile, writeFile)
import Data.Maybe import Data.Maybe
( (
fromJust fromJust
@@ -43,6 +47,7 @@ import Data.ByteString
( (
ByteString ByteString
) )
import qualified Data.ByteString.Lazy as L
import System.Posix.Files.ByteString import System.Posix.Files.ByteString
( (
groupExecuteMode groupExecuteMode
@@ -56,9 +61,6 @@ import System.Posix.Files.ByteString
, unionFileModes , unionFileModes
) )
import qualified "unix" System.Posix.IO.ByteString as SPI
import qualified "unix-bytestring" System.Posix.IO.ByteString as SPB
baseTmpDir :: ByteString baseTmpDir :: ByteString
@@ -179,6 +181,9 @@ createDir' :: ByteString -> IO ()
{-# NOINLINE createDir' #-} {-# NOINLINE createDir' #-}
createDir' dest = withTmpDir dest (createDir newDirPerms) createDir' dest = withTmpDir dest (createDir newDirPerms)
createDirRecursive' :: ByteString -> IO ()
{-# NOINLINE createDirRecursive' #-}
createDirRecursive' dest = withTmpDir dest (createDirRecursive newDirPerms)
createRegularFile' :: ByteString -> IO () createRegularFile' :: ByteString -> IO ()
{-# NOINLINE createRegularFile' #-} {-# NOINLINE createRegularFile' #-}
@@ -237,6 +242,12 @@ normalDirPerms path =
withTmpDir path $ \p -> setFileMode (P.fromAbs p) newDirPerms 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 getFileType' :: ByteString -> IO FileType
{-# NOINLINE getFileType' #-} {-# NOINLINE getFileType' #-}
getFileType' path = withTmpDir path getFileType getFileType' path = withTmpDir path getFileType
@@ -270,11 +281,13 @@ canonicalizePath' p = withTmpDir p canonicalizePath
writeFile' :: ByteString -> ByteString -> IO () writeFile' :: ByteString -> ByteString -> IO ()
{-# NOINLINE writeFile' #-} {-# NOINLINE writeFile' #-}
writeFile' ip bs = writeFile' ip bs =
withTmpDir ip $ \p -> do withTmpDir ip $ \p -> writeFile p bs
fd <- SPI.openFd (P.fromAbs p) SPI.WriteOnly Nothing
SPI.defaultFileFlags
_ <- SPB.fdWrite fd bs appendFile' :: ByteString -> ByteString -> IO ()
SPI.closeFd fd {-# NOINLINE appendFile' #-}
appendFile' ip bs =
withTmpDir ip $ \p -> appendFile p bs
allDirectoryContents' :: ByteString -> IO [ByteString] allDirectoryContents' :: ByteString -> IO [ByteString]
@@ -282,3 +295,13 @@ allDirectoryContents' :: ByteString -> IO [ByteString]
allDirectoryContents' ip = allDirectoryContents' ip =
withTmpDir ip $ \p -> DT.allDirectoryContents' (P.fromAbs p) 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