25 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
18 changed files with 851 additions and 156 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)
@@ -32,9 +35,9 @@ library
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
, IfElse , IfElse
, bytestring >= 0.9.2.0 , 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,19 +79,23 @@ 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.CreateDirSpec
HPath.IO.CreateDirRecursiveSpec HPath.IO.CreateDirRecursiveSpec
HPath.IO.CreateDirSpec
HPath.IO.CreateRegularFileSpec HPath.IO.CreateRegularFileSpec
HPath.IO.CreateSymlinkSpec HPath.IO.CreateSymlinkSpec
HPath.IO.DeleteDirRecursiveSpec HPath.IO.DeleteDirRecursiveSpec
@@ -92,16 +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
, IfElse , IfElse
, bytestring , bytestring >= 0.10.0.0
, hpath , hpath
, hspec >= 1.3 , hspec >= 1.3
, process , process

0
mo
View File

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 "/")

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 #-}
@@ -60,6 +64,12 @@ module HPath.IO
-- * 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
@@ -69,6 +79,7 @@ module HPath.IO
, getFileType , getFileType
-- * Others -- * Others
, canonicalizePath , canonicalizePath
, toAbs
) )
where where
@@ -97,6 +108,21 @@ 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_
@@ -112,6 +138,11 @@ import Data.Maybe
( (
catMaybes catMaybes
) )
import Data.Monoid
(
(<>)
, mempty
)
import Data.Word import Data.Word
( (
Word8 Word8
@@ -145,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
@@ -163,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
@@ -305,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 -- ^ source dir --
-> Path Abs -- ^ 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 ()
@@ -323,27 +357,27 @@ copyDirRecursive fromp destdirp cm rm
(throwIO . RecursiveFailure $ collectedExceptions) (throwIO . RecursiveFailure $ collectedExceptions)
where where
go :: IORef [(RecursiveFailureHint, IOException)] go :: IORef [(RecursiveFailureHint, IOException)]
-> Path Abs -> Path Abs -> IO () -> Path b1 -> Path b2 -> IO ()
go ce fromp' destdirp' = do go ce fromp'@(MkPath fromBS) destdirp'@(MkPath destdirpBS) = do
-- NOTE: 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
-- get the contents of the source dir -- get the contents of the source dir
contents <- handleIOE (ReadContentsFailed fromp' destdirp') ce [] $ do contents <- handleIOE (ReadContentsFailed fromBS destdirpBS) ce [] $ do
contents <- getDirsFiles fromp' contents <- getDirsFiles fromp'
-- create the destination dir and -- create the destination dir and
-- only return contents if we succeed -- only return contents if we succeed
handleIOE (CreateDirFailed fromp' destdirp') ce [] $ do handleIOE (CreateDirFailed fromBS destdirpBS) ce [] $ do
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fromAbs fromp') fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus fromBS
case cm of case cm of
Strict -> createDirectory (fromAbs destdirp') fmode' Strict -> createDirectory destdirpBS fmode'
Overwrite -> catchIOError (createDirectory (fromAbs destdirp') Overwrite -> catchIOError (createDirectory destdirpBS
fmode') fmode')
$ \e -> $ \e ->
case ioeGetErrorType e of case ioeGetErrorType e of
AlreadyExists -> setFileMode (fromAbs destdirp') AlreadyExists -> setFileMode destdirpBS
fmode' fmode'
_ -> ioError e _ -> ioError e
return contents return contents
@@ -357,10 +391,10 @@ copyDirRecursive fromp destdirp cm rm
ftype <- getFileType f ftype <- getFileType f
newdest <- (destdirp' </>) <$> basename f newdest <- (destdirp' </>) <$> basename f
case ftype of case ftype of
SymbolicLink -> handleIOE (RecreateSymlinkFailed f newdest) 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 (CopyFileFailed f newdest) ce () RegularFile -> handleIOE (CopyFileFailed (toFilePath f) (toFilePath newdest)) ce ()
$ copyFile f newdest cm $ copyFile f newdest cm
_ -> return () _ -> return ()
@@ -400,24 +434,27 @@ copyDirRecursive fromp destdirp cm rm
-- --
-- - `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.
@@ -454,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
@@ -475,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
@@ -484,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)
@@ -540,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 ()
@@ -570,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.
@@ -585,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
@@ -608,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)
@@ -633,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
@@ -652,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
@@ -685,9 +723,9 @@ executeFile fp args
-- - `AlreadyExists` if destination already exists -- - `AlreadyExists` if destination already exists
-- - `NoSuchThing` if any of the parent components of the path -- - `NoSuchThing` if any of the parent components of the path
-- do not exist -- do not exist
createRegularFile :: FileMode -> Path Abs -> IO () createRegularFile :: FileMode -> Path b -> IO ()
createRegularFile fm dest = createRegularFile fm (MkPath destBS) =
bracket (SPI.openFd (fromAbs dest) SPI.WriteOnly (Just fm) bracket (SPI.openFd destBS SPI.WriteOnly (Just fm)
(SPI.defaultFileFlags { exclusive = True })) (SPI.defaultFileFlags { exclusive = True }))
SPI.closeFd SPI.closeFd
(\_ -> return ()) (\_ -> return ())
@@ -701,8 +739,8 @@ createRegularFile fm dest =
-- - `AlreadyExists` if destination already exists -- - `AlreadyExists` if destination already exists
-- - `NoSuchThing` if any of the parent components of the path -- - `NoSuchThing` if any of the parent components of the path
-- do not exist -- do not exist
createDir :: FileMode -> Path Abs -> IO () createDir :: FileMode -> Path b -> IO ()
createDir fm dest = createDirectory (fromAbs dest) fm createDir fm (MkPath destBS) = createDirectory destBS fm
-- |Create an empty directory at the given directory with the given filename. -- |Create an empty directory at the given directory with the given filename.
@@ -723,15 +761,21 @@ createDir fm dest = createDirectory (fromAbs dest) fm
-- exist and cannot be written to -- exist and cannot be written to
-- - `AlreadyExists` if destination already exists and -- - `AlreadyExists` if destination already exists and
-- is not a directory -- is not a directory
createDirRecursive :: FileMode -> Path Abs -> IO () --
createDirRecursive fm dest = -- Note: calls `getcwd` if the input path is a relative path
catchIOError (createDirectory (fromAbs dest) fm) $ \e -> do createDirRecursive :: FileMode -> Path b -> IO ()
errno <- getErrno createDirRecursive fm p =
case errno of toAbs p >>= go
en | en == eEXIST -> unlessM (doesDirectoryExist dest) (ioError e) where
| en == eNOENT -> createDirRecursive fm (dirname dest) go :: Path Abs -> IO ()
>> createDirectory (fromAbs dest) fm go dest@(MkPath destBS) = do
| otherwise -> ioError e 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.
@@ -744,11 +788,11 @@ createDirRecursive fm dest =
-- do not exist -- 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
@@ -778,12 +822,12 @@ createSymlink dest sympoint
-- (`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.
@@ -814,9 +858,12 @@ renameFile fromf tof = do
-- --
-- - `AlreadyExists` if destination already exists -- - `AlreadyExists` if destination already exists
-- --
-- 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
@@ -827,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
@@ -845,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]--
@@ -890,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
@@ -918,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
@@ -941,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

@@ -84,9 +84,14 @@ 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 System.IO.Error import System.IO.Error
( (
@@ -119,10 +124,10 @@ data HPathIOException = SameFile ByteString ByteString
-- --
-- The first argument to the data constructor is always the -- The first argument to the data constructor is always the
-- source and the second the destination. -- source and the second the destination.
data RecursiveFailureHint = ReadContentsFailed (Path Abs) (Path Abs) data RecursiveFailureHint = ReadContentsFailed ByteString ByteString
| CreateDirFailed (Path Abs) (Path Abs) | CreateDirFailed ByteString ByteString
| CopyFileFailed (Path Abs) (Path Abs) | CopyFileFailed ByteString ByteString
| RecreateSymlinkFailed (Path Abs) (Path Abs) | RecreateSymlinkFailed ByteString ByteString
deriving (Eq, Show) deriving (Eq, Show)
@@ -169,51 +174,50 @@ isRecreateSymlinkFailed _ = False
-- |Throws `AlreadyExists` `IOError` if file exists. -- |Throws `AlreadyExists` `IOError` if file exists.
throwFileDoesExist :: Path Abs -> IO () throwFileDoesExist :: Path b -> IO ()
throwFileDoesExist fp = throwFileDoesExist fp@(MkPath bs) =
whenM (doesFileExist fp) whenM (doesFileExist fp)
(ioError . mkIOError (ioError . mkIOError
alreadyExistsErrorType alreadyExistsErrorType
"File already exists" "File already exists"
Nothing Nothing
$ (Just (toString $ fromAbs fp)) $ (Just (toString $ bs))
) )
-- |Throws `AlreadyExists` `IOError` if directory exists. -- |Throws `AlreadyExists` `IOError` if directory exists.
throwDirDoesExist :: Path Abs -> IO () throwDirDoesExist :: Path b -> IO ()
throwDirDoesExist fp = throwDirDoesExist fp@(MkPath bs) =
whenM (doesDirectoryExist fp) whenM (doesDirectoryExist fp)
(ioError . mkIOError (ioError . mkIOError
alreadyExistsErrorType alreadyExistsErrorType
"Directory already exists" "Directory already exists"
Nothing Nothing
$ (Just (toString $ fromAbs fp)) $ (Just (toString $ bs))
) )
-- |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
@@ -221,54 +225,54 @@ 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

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

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

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

@@ -28,6 +28,7 @@ import Data.IORef
) )
import HPath.IO import HPath.IO
import HPath.IO.Errors import HPath.IO.Errors
import Prelude hiding (appendFile, readFile, writeFile)
import Data.Maybe import Data.Maybe
( (
fromJust fromJust
@@ -46,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
@@ -59,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
@@ -243,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
@@ -276,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]
@@ -288,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