├── .github └── workflows │ └── build.yml ├── .gitignore ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── Setup.hs ├── System ├── Directory.hs └── Directory │ ├── Internal.hs │ ├── Internal │ ├── C_utimensat.hsc │ ├── Common.hs │ ├── Config.hs │ ├── Posix.hsc │ ├── Prelude.hs │ ├── Windows.hsc │ └── windows_ext.h │ └── OsPath.hs ├── changelog.md ├── configure.ac ├── directory.cabal ├── prologue.txt ├── tests ├── CanonicalizePath.hs ├── CopyFile001.hs ├── CopyFile002.hs ├── CopyFileWithMetadata.hs ├── CreateDirectory001.hs ├── CreateDirectoryIfMissing001.hs ├── CurrentDirectory001.hs ├── Directory001.hs ├── DoesDirectoryExist001.hs ├── DoesPathExist.hs ├── FileTime.hs ├── FindFile001.hs ├── GetDirContents001.hs ├── GetDirContents002.hs ├── GetFileSize.hs ├── GetHomeDirectory001.hs ├── GetHomeDirectory002.hs ├── GetPermissions001.hs ├── LongPaths.hs ├── Main.hs ├── MakeAbsolute.hs ├── MinimizeNameConflicts.hs ├── PathIsSymbolicLink.hs ├── RemoveDirectoryRecursive001.hs ├── RemovePathForcibly.hs ├── RenameDirectory.hs ├── RenameFile001.hs ├── RenamePath.hs ├── Simplify.hs ├── T8482.hs ├── TestUtils.hs ├── Util.hs ├── WithCurrentDirectory.hs ├── Xdg.hs └── util.inl └── tools ├── retry ├── testctl ├── testscript └── vercmp /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: 3 | pull_request: 4 | push: 5 | schedule: 6 | - cron: 35 8 3 * * 7 | workflow_dispatch: 8 | defaults: 9 | run: 10 | shell: bash 11 | jobs: 12 | build: 13 | strategy: 14 | fail-fast: false 15 | matrix: 16 | include: 17 | - { os: macOS-13, stack: lts-15.3, stack-extra-deps: "bytestring-0.11.3.0, file-io-0.1.4, filepath-1.4.100.0, unix-2.8.0.0" } 18 | - { os: macos-latest, stack: lts-22.7, stack-extra-deps: "bytestring-0.11.5.3, file-io-0.1.4, filepath-1.5.2.0, os-string-2.0.2, unix-2.8.5.1", stack-package-flags: "{directory: {os-string: true}, file-io: {os-string: true}, unix: {os-string: true}}", ghc-flags: -Werror=deprecations } 19 | - { os: ubuntu-latest, ghc: 8.10.7, cabal: 3.8.1.0 } 20 | - { os: ubuntu-latest, ghc: 9.0.2, cabal: 3.8.1.0 } 21 | - { os: ubuntu-latest, ghc: 9.2.4, cabal: 3.8.1.0 } 22 | - { os: ubuntu-latest, ghc: 9.4.3, cabal: 3.8.1.0 } 23 | # TODO: Unpin cabal from 3.12.10 after https://github.com/haskell/cabal/issues/10718 is fixed. 24 | - { os: ubuntu-latest, ghc: latest, cabal: 3.12.1.0, cabal-package-flags: +os-string, ghc-flags: -Werror=deprecations } 25 | - { os: windows-latest, stack: lts-15.3, stack-extra-deps: "bytestring-0.11.3.0, file-io-0.1.4, filepath-1.4.100.0, time-1.9.3, Win32-2.14.1.0", overrides: "before_prepare() { sed -i.bak -e /CreateSymbolicLinkW/d -e /GetFinalPathNameByHandleW/d configure.ac; }" } 26 | - { os: windows-latest, stack: lts-17.5, stack-extra-deps: "bytestring-0.11.3.0, file-io-0.1.4, filepath-1.4.100.0, time-1.9.3, Win32-2.14.1.0" } 27 | - { os: windows-latest, stack: lts-22.7, stack-extra-deps: "bytestring-0.11.5.3, file-io-0.1.4, filepath-1.5.2.0, os-string-2.0.2, time-1.14, Win32-2.14.1.0", stack-package-flags: "{directory: {os-string: true}, file-io: {os-string: true}, Win32: {os-string: true}}", ghc-flags: -Werror=deprecations } 28 | runs-on: ${{ matrix.os }} 29 | env: 30 | CABAL_PACKAGE_FLAGS: ${{ matrix.cabal-package-flags }} 31 | GHC_FLAGS: ${{ matrix.ghc-flags }} 32 | TESTSCRIPT_OVERRIDES: ${{ matrix.overrides }} 33 | STACK_EXTRA_DEPS: ${{ matrix.stack-extra-deps }} 34 | STACK_PACKAGE_FLAGS: ${{ matrix.stack-package-flags }} 35 | STACK_RESOLVER: ${{ matrix.stack }} 36 | steps: 37 | - if: startsWith(matrix.os, 'macos-') 38 | run: brew install automake 39 | - if: startsWith(matrix.os, 'ubuntu-') 40 | run: | 41 | sudo apt-get update 42 | - if: startsWith(matrix.os, 'windows-') 43 | run: | 44 | echo STACK_FLAGS=--skip-msys >> $GITHUB_ENV 45 | echo 'C:\msys64\usr\bin' >> $GITHUB_PATH 46 | - if: startsWith(matrix.os, 'windows-') 47 | run: | 48 | pacman -S --needed --noconfirm autoconf automake 49 | - uses: haskell-actions/setup@v2 50 | with: 51 | ghc-version: ${{ matrix.ghc }} 52 | cabal-version: ${{ matrix.cabal }} 53 | enable-stack: ${{ matrix.stack }} 54 | stack-no-global: ${{ matrix.stack }} 55 | - uses: actions/checkout@v3 56 | - run: tools/testscript prepare 57 | - run: tools/testscript build 58 | - if: matrix.cabal 59 | uses: actions/upload-artifact@v4 60 | with: 61 | name: sdist 62 | path: dist-newstyle/sdist/*-*.tar.gz 63 | overwrite: true 64 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/ 2 | cabal.sandbox.config 3 | cabal.project.local* 4 | autom4te.cache/ 5 | config.log 6 | config.status 7 | configure 8 | dist/ 9 | dist-newstyle/ 10 | HsDirectoryConfig.h 11 | HsDirectoryConfig.h.in 12 | *~ 13 | 14 | # In GHC build tree: 15 | GNUmakefile 16 | dist-install 17 | ghc.mk 18 | 19 | # IDEs 20 | .vscode 21 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Contributions and bug reports are welcome! 2 | 3 | ## Contribution guidelines 4 | 5 | * **Size of changes:** If the change is minor, feel free to just send a pull request. Otherwise, please discuss on the issue tracker first. 6 | 7 | * **Continuous integration (CI):** Please make sure all CI checks pass on your pull request. 8 | 9 | * **New tests:** 10 | 11 | * When implementing a new feature, please include tests for it. (Use `tools/testctl` to add a new test module.) 12 | * When fixing a bug, please include regression tests if possible. 13 | 14 | * **Changelog:** Please update the `changelog.md` for any non-trivial change. 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This library (libraries/base) is derived from code from two 2 | sources: 3 | 4 | * Code from the GHC project which is largely (c) The University of 5 | Glasgow, and distributable under a BSD-style license (see below), 6 | 7 | * Code from the Haskell 98 Report which is (c) Simon Peyton Jones 8 | and freely redistributable (but see the full license for 9 | restrictions). 10 | 11 | The full text of these licenses is reproduced below. Both of the 12 | licenses are BSD-style or compatible. 13 | 14 | ----------------------------------------------------------------------------- 15 | 16 | The Glasgow Haskell Compiler License 17 | 18 | Copyright 2004, The University Court of the University of Glasgow. 19 | All rights reserved. 20 | 21 | Redistribution and use in source and binary forms, with or without 22 | modification, are permitted provided that the following conditions are met: 23 | 24 | - Redistributions of source code must retain the above copyright notice, 25 | this list of conditions and the following disclaimer. 26 | 27 | - Redistributions in binary form must reproduce the above copyright notice, 28 | this list of conditions and the following disclaimer in the documentation 29 | and/or other materials provided with the distribution. 30 | 31 | - Neither name of the University nor the names of its contributors may be 32 | used to endorse or promote products derived from this software without 33 | specific prior written permission. 34 | 35 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 36 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 37 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 38 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 39 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 40 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 41 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 42 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 43 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 44 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 45 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 46 | DAMAGE. 47 | 48 | ----------------------------------------------------------------------------- 49 | 50 | Code derived from the document "Report on the Programming Language 51 | Haskell 98", is distributed under the following license: 52 | 53 | Copyright (c) 2002 Simon Peyton Jones 54 | 55 | The authors intend this Report to belong to the entire Haskell 56 | community, and so we grant permission to copy and distribute it for 57 | any purpose, provided that it is reproduced in its entirety, 58 | including this Notice. Modified versions of this Report may also be 59 | copied and distributed for any purpose, provided that the modified 60 | version is clearly presented as such, and that it does not claim to 61 | be a definition of the Haskell 98 Language. 62 | 63 | ----------------------------------------------------------------------------- 64 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | `directory` 2 | =========== 3 | 4 | [![Hackage][hi]][hl] 5 | [![Build status][bi]][bl] 6 | [![Dependencies status][di]][dl] 7 | 8 | Documentation can be found on [Hackage][hl]. 9 | Changes between versions are recorded in the [change log](changelog.md). 10 | 11 | Building from Git repository 12 | ---------------------------- 13 | 14 | When building this package directly from the Git repository, one must run 15 | `autoreconf -fi` to generate the `configure` script needed by `cabal 16 | configure`. This requires [Autoconf][ac] to be installed. 17 | 18 | autoreconf -fi 19 | cabal install 20 | 21 | There is no need to run the `configure` script manually however, as `cabal 22 | configure` does that automatically. 23 | 24 | [hi]: https://img.shields.io/hackage/v/directory.svg 25 | [hl]: https://hackage.haskell.org/package/directory 26 | [bi]: https://github.com/haskell/directory/actions/workflows/build.yml/badge.svg 27 | [bl]: https://github.com/haskell/directory/actions 28 | [di]: https://img.shields.io/hackage-deps/v/directory.svg 29 | [dl]: http://packdeps.haskellers.com/feed?needle=exact:directory 30 | [ac]: https://gnu.org/software/autoconf 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Distribution.Simple 4 | 5 | main :: IO () 6 | main = defaultMainWithHooks autoconfUserHooks 7 | -------------------------------------------------------------------------------- /System/Directory.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.Directory 4 | -- Copyright : (c) The University of Glasgow 2001 5 | -- License : BSD-style (see the file libraries/base/LICENSE) 6 | -- 7 | -- Maintainer : libraries@haskell.org 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- System-independent interface to directory manipulation (FilePath API). 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module System.Directory 16 | ( 17 | -- $intro 18 | 19 | -- * Actions on directories 20 | createDirectory 21 | , createDirectoryIfMissing 22 | , removeDirectory 23 | , removeDirectoryRecursive 24 | , removePathForcibly 25 | , renameDirectory 26 | , listDirectory 27 | , getDirectoryContents 28 | -- ** Current working directory 29 | , getCurrentDirectory 30 | , setCurrentDirectory 31 | , withCurrentDirectory 32 | 33 | -- * Pre-defined directories 34 | , getHomeDirectory 35 | , XdgDirectory(..) 36 | , getXdgDirectory 37 | , XdgDirectoryList(..) 38 | , getXdgDirectoryList 39 | , getAppUserDataDirectory 40 | , getUserDocumentsDirectory 41 | , getTemporaryDirectory 42 | 43 | -- * PATH 44 | , getExecSearchPath 45 | 46 | -- * Actions on files 47 | , removeFile 48 | , renameFile 49 | , renamePath 50 | , copyFile 51 | , copyFileWithMetadata 52 | , getFileSize 53 | 54 | , canonicalizePath 55 | , makeAbsolute 56 | , makeRelativeToCurrentDirectory 57 | 58 | -- * Existence tests 59 | , doesPathExist 60 | , doesFileExist 61 | , doesDirectoryExist 62 | 63 | , findExecutable 64 | , findExecutables 65 | , findExecutablesInDirectories 66 | , findFile 67 | , findFiles 68 | , findFileWith 69 | , findFilesWith 70 | , exeExtension 71 | 72 | -- * Symbolic links 73 | , createFileLink 74 | , createDirectoryLink 75 | , removeDirectoryLink 76 | , pathIsSymbolicLink 77 | , getSymbolicLinkTarget 78 | 79 | -- * Permissions 80 | 81 | -- $permissions 82 | 83 | , Permissions 84 | , emptyPermissions 85 | , readable 86 | , writable 87 | , executable 88 | , searchable 89 | , setOwnerReadable 90 | , setOwnerWritable 91 | , setOwnerExecutable 92 | , setOwnerSearchable 93 | 94 | , getPermissions 95 | , setPermissions 96 | , copyPermissions 97 | 98 | -- * Timestamps 99 | 100 | , getAccessTime 101 | , getModificationTime 102 | , setAccessTime 103 | , setModificationTime 104 | 105 | -- * Deprecated 106 | , isSymbolicLink 107 | 108 | ) where 109 | import Prelude () 110 | import System.Directory.Internal 111 | import System.Directory.Internal.Prelude 112 | import Data.Time (UTCTime) 113 | import System.OsPath (decodeFS, encodeFS) 114 | import qualified System.Directory.OsPath as D 115 | 116 | {- $intro 117 | A directory contains a series of entries, each of which is a named 118 | reference to a file system object (file, directory etc.). Some 119 | entries may be hidden, inaccessible, or have some administrative 120 | function (e.g. @.@ or @..@ under 121 | ), but in 122 | this standard all such entries are considered to form part of the 123 | directory contents. Entries in sub-directories are not, however, 124 | considered to form part of the directory contents. 125 | 126 | Each file system object is referenced by a /path/. There is 127 | normally at least one absolute path to each file system object. In 128 | some operating systems, it may also be possible to have paths which 129 | are relative to the current directory. 130 | 131 | Unless otherwise documented: 132 | 133 | * 'IO' operations in this package may throw any 'IOError'. No other types of 134 | exceptions shall be thrown. 135 | 136 | * The list of possible 'IOErrorType's in the API documentation is not 137 | exhaustive. The full list may vary by platform and/or evolve over time. 138 | 139 | -} 140 | 141 | ----------------------------------------------------------------------------- 142 | -- Permissions 143 | 144 | {- $permissions 145 | 146 | directory offers a limited (and quirky) interface for reading and setting file 147 | and directory permissions; see 'getPermissions' and 'setPermissions' for a 148 | discussion of their limitations. Because permissions are very difficult to 149 | implement portably across different platforms, users who wish to do more 150 | sophisticated things with permissions are advised to use other, 151 | platform-specific libraries instead. For example, if you are only interested 152 | in permissions on POSIX-like platforms, 153 | 154 | offers much more flexibility. 155 | 156 | The 'Permissions' type is used to record whether certain operations are 157 | permissible on a file\/directory. 'getPermissions' and 'setPermissions' 158 | get and set these permissions, respectively. Permissions apply both to 159 | files and directories. For directories, the executable field will be 160 | 'False', and for files the searchable field will be 'False'. Note that 161 | directories may be searchable without being readable, if permission has 162 | been given to use them as part of a path, but not to examine the 163 | directory contents. 164 | 165 | Note that to change some, but not all permissions, a construct on the following lines must be used. 166 | 167 | > makeReadable f = do 168 | > p <- getPermissions f 169 | > setPermissions f (p {readable = True}) 170 | 171 | -} 172 | 173 | emptyPermissions :: Permissions 174 | emptyPermissions = Permissions { 175 | readable = False, 176 | writable = False, 177 | executable = False, 178 | searchable = False 179 | } 180 | 181 | setOwnerReadable :: Bool -> Permissions -> Permissions 182 | setOwnerReadable b p = p { readable = b } 183 | 184 | setOwnerWritable :: Bool -> Permissions -> Permissions 185 | setOwnerWritable b p = p { writable = b } 186 | 187 | setOwnerExecutable :: Bool -> Permissions -> Permissions 188 | setOwnerExecutable b p = p { executable = b } 189 | 190 | setOwnerSearchable :: Bool -> Permissions -> Permissions 191 | setOwnerSearchable b p = p { searchable = b } 192 | 193 | -- | Get the permissions of a file or directory. 194 | -- 195 | -- On Windows, the 'writable' permission corresponds to the "read-only" 196 | -- attribute. The 'executable' permission is set if the file extension is of 197 | -- an executable file type. The 'readable' permission is always set. 198 | -- 199 | -- On POSIX systems, this returns the result of @access@. 200 | -- 201 | -- The operation may fail with: 202 | -- 203 | -- * 'isPermissionError' if the user is not permitted to access the 204 | -- permissions, or 205 | -- 206 | -- * 'isDoesNotExistError' if the file or directory does not exist. 207 | getPermissions :: FilePath -> IO Permissions 208 | getPermissions = encodeFS >=> D.getPermissions 209 | 210 | -- | Set the permissions of a file or directory. 211 | -- 212 | -- On Windows, this is only capable of changing the 'writable' permission, 213 | -- which corresponds to the "read-only" attribute. Changing the other 214 | -- permissions has no effect. 215 | -- 216 | -- On POSIX systems, this sets the /owner/ permissions. 217 | -- 218 | -- The operation may fail with: 219 | -- 220 | -- * 'isPermissionError' if the user is not permitted to set the permissions, 221 | -- or 222 | -- 223 | -- * 'isDoesNotExistError' if the file or directory does not exist. 224 | setPermissions :: FilePath -> Permissions -> IO () 225 | setPermissions path p = encodeFS path >>= (`D.setPermissions` p) 226 | 227 | -- | Copy the permissions of one file to another. This reproduces the 228 | -- permissions more accurately than using 'getPermissions' followed by 229 | -- 'setPermissions'. 230 | -- 231 | -- On Windows, this copies only the read-only attribute. 232 | -- 233 | -- On POSIX systems, this is equivalent to @stat@ followed by @chmod@. 234 | copyPermissions :: FilePath -> FilePath -> IO () 235 | copyPermissions src dst = do 236 | src' <- encodeFS src 237 | dst' <- encodeFS dst 238 | D.copyPermissions src' dst' 239 | 240 | 241 | ----------------------------------------------------------------------------- 242 | -- Implementation 243 | 244 | {- |@'createDirectory' dir@ creates a new directory @dir@ which is 245 | initially empty, or as near to empty as the operating system 246 | allows. 247 | 248 | The operation may fail with: 249 | 250 | * 'isPermissionError' 251 | The process has insufficient privileges to perform the operation. 252 | @[EROFS, EACCES]@ 253 | 254 | * 'isAlreadyExistsError' 255 | The operand refers to a directory that already exists. 256 | @ [EEXIST]@ 257 | 258 | * @HardwareFault@ 259 | A physical I\/O error has occurred. 260 | @[EIO]@ 261 | 262 | * @InvalidArgument@ 263 | The operand is not a valid directory name. 264 | @[ENAMETOOLONG, ELOOP]@ 265 | 266 | * 'isDoesNotExistError' 267 | There is no path to the directory. 268 | @[ENOENT, ENOTDIR]@ 269 | 270 | * 'System.IO.isFullError' 271 | Insufficient resources (virtual memory, process file descriptors, 272 | physical disk space, etc.) are available to perform the operation. 273 | @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ 274 | 275 | * @InappropriateType@ 276 | The path refers to an existing non-directory object. 277 | @[EEXIST]@ 278 | 279 | -} 280 | 281 | createDirectory :: FilePath -> IO () 282 | createDirectory = encodeFS >=> D.createDirectory 283 | 284 | -- | @'createDirectoryIfMissing' parents dir@ creates a new directory 285 | -- @dir@ if it doesn\'t exist. If the first argument is 'True' 286 | -- the function will also create all parent directories if they are missing. 287 | createDirectoryIfMissing :: Bool -- ^ Create its parents too? 288 | -> FilePath -- ^ The path to the directory you want to make 289 | -> IO () 290 | createDirectoryIfMissing cp = encodeFS >=> D.createDirectoryIfMissing cp 291 | 292 | 293 | {- | @'removeDirectory' dir@ removes an existing directory /dir/. The 294 | implementation may specify additional constraints which must be 295 | satisfied before a directory can be removed (e.g. the directory has to 296 | be empty, or may not be in use by other processes). It is not legal 297 | for an implementation to partially remove a directory unless the 298 | entire directory is removed. A conformant implementation need not 299 | support directory removal in all situations (e.g. removal of the root 300 | directory). 301 | 302 | The operation may fail with: 303 | 304 | * @HardwareFault@ 305 | A physical I\/O error has occurred. 306 | @[EIO]@ 307 | 308 | * @InvalidArgument@ 309 | The operand is not a valid directory name. 310 | @[ENAMETOOLONG, ELOOP]@ 311 | 312 | * 'isDoesNotExistError' 313 | The directory does not exist. 314 | @[ENOENT, ENOTDIR]@ 315 | 316 | * 'isPermissionError' 317 | The process has insufficient privileges to perform the operation. 318 | @[EROFS, EACCES, EPERM]@ 319 | 320 | * @UnsatisfiedConstraints@ 321 | Implementation-dependent constraints are not satisfied. 322 | @[EBUSY, ENOTEMPTY, EEXIST]@ 323 | 324 | * @UnsupportedOperation@ 325 | The implementation does not support removal in this situation. 326 | @[EINVAL]@ 327 | 328 | * @InappropriateType@ 329 | The operand refers to an existing non-directory object. 330 | @[ENOTDIR]@ 331 | 332 | -} 333 | 334 | removeDirectory :: FilePath -> IO () 335 | removeDirectory = encodeFS >=> D.removeDirectory 336 | 337 | -- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ 338 | -- together with its contents and subdirectories. Within this directory, 339 | -- symbolic links are removed without affecting their targets. 340 | -- 341 | -- On Windows, the operation fails if /dir/ is a directory symbolic link. 342 | -- 343 | -- This operation is reported to be flaky on Windows so retry logic may 344 | -- be advisable. See: https://github.com/haskell/directory/pull/108 345 | removeDirectoryRecursive :: FilePath -> IO () 346 | removeDirectoryRecursive = encodeFS >=> D.removeDirectoryRecursive 347 | 348 | -- | Removes a file or directory at /path/ together with its contents and 349 | -- subdirectories. Symbolic links are removed without affecting their 350 | -- targets. If the path does not exist, nothing happens. 351 | -- 352 | -- Unlike other removal functions, this function will also attempt to delete 353 | -- files marked as read-only or otherwise made unremovable due to permissions. 354 | -- As a result, if the removal is incomplete, the permissions or attributes on 355 | -- the remaining files may be altered. If there are hard links in the 356 | -- directory, then permissions on all related hard links may be altered. 357 | -- 358 | -- If an entry within the directory vanishes while @removePathForcibly@ is 359 | -- running, it is silently ignored. 360 | -- 361 | -- If an exception occurs while removing an entry, @removePathForcibly@ will 362 | -- still try to remove as many entries as it can before failing with an 363 | -- exception. The first exception that it encountered is re-thrown. 364 | -- 365 | -- @since 1.2.7.0 366 | removePathForcibly :: FilePath -> IO () 367 | removePathForcibly = encodeFS >=> D.removePathForcibly 368 | 369 | {- |'removeFile' /file/ removes the directory entry for an existing file 370 | /file/, where /file/ is not itself a directory. The 371 | implementation may specify additional constraints which must be 372 | satisfied before a file can be removed (e.g. the file may not be in 373 | use by other processes). 374 | 375 | The operation may fail with: 376 | 377 | * @HardwareFault@ 378 | A physical I\/O error has occurred. 379 | @[EIO]@ 380 | 381 | * @InvalidArgument@ 382 | The operand is not a valid file name. 383 | @[ENAMETOOLONG, ELOOP]@ 384 | 385 | * 'isDoesNotExistError' 386 | The file does not exist. 387 | @[ENOENT, ENOTDIR]@ 388 | 389 | * 'isPermissionError' 390 | The process has insufficient privileges to perform the operation. 391 | @[EROFS, EACCES, EPERM]@ 392 | 393 | * @UnsatisfiedConstraints@ 394 | Implementation-dependent constraints are not satisfied. 395 | @[EBUSY]@ 396 | 397 | * @InappropriateType@ 398 | The operand refers to an existing directory. 399 | @[EPERM, EINVAL]@ 400 | 401 | -} 402 | 403 | removeFile :: FilePath -> IO () 404 | removeFile = encodeFS >=> D.removeFile 405 | 406 | {- |@'renameDirectory' old new@ changes the name of an existing 407 | directory from /old/ to /new/. If the /new/ directory 408 | already exists, it is atomically replaced by the /old/ directory. 409 | If the /new/ directory is neither the /old/ directory nor an 410 | alias of the /old/ directory, it is removed as if by 411 | 'removeDirectory'. A conformant implementation need not support 412 | renaming directories in all situations (e.g. renaming to an existing 413 | directory, or across different physical devices), but the constraints 414 | must be documented. 415 | 416 | On Win32 platforms, @renameDirectory@ fails if the /new/ directory already 417 | exists. 418 | 419 | The operation may fail with: 420 | 421 | * @HardwareFault@ 422 | A physical I\/O error has occurred. 423 | @[EIO]@ 424 | 425 | * @InvalidArgument@ 426 | Either operand is not a valid directory name. 427 | @[ENAMETOOLONG, ELOOP]@ 428 | 429 | * 'isDoesNotExistError' 430 | The original directory does not exist, or there is no path to the target. 431 | @[ENOENT, ENOTDIR]@ 432 | 433 | * 'isPermissionError' 434 | The process has insufficient privileges to perform the operation. 435 | @[EROFS, EACCES, EPERM]@ 436 | 437 | * 'System.IO.isFullError' 438 | Insufficient resources are available to perform the operation. 439 | @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ 440 | 441 | * @UnsatisfiedConstraints@ 442 | Implementation-dependent constraints are not satisfied. 443 | @[EBUSY, ENOTEMPTY, EEXIST]@ 444 | 445 | * @UnsupportedOperation@ 446 | The implementation does not support renaming in this situation. 447 | @[EINVAL, EXDEV]@ 448 | 449 | * @InappropriateType@ 450 | Either path refers to an existing non-directory object. 451 | @[ENOTDIR, EISDIR]@ 452 | 453 | -} 454 | 455 | renameDirectory :: FilePath -> FilePath -> IO () 456 | renameDirectory opath npath = do 457 | opath' <- encodeFS opath 458 | npath' <- encodeFS npath 459 | D.renameDirectory opath' npath' 460 | 461 | {- |@'renameFile' old new@ changes the name of an existing file system 462 | object from /old/ to /new/. If the /new/ object already exists, it is 463 | replaced by the /old/ object. Neither path may refer to an existing 464 | directory. 465 | 466 | A conformant implementation need not support renaming files in all situations 467 | (e.g. renaming across different physical devices), but the constraints must be 468 | documented. On Windows, this does not support renaming across different physical 469 | devices; if you are looking to do so, consider using 'copyFileWithMetadata' and 470 | 'removeFile'. 471 | 472 | On Windows, this calls @MoveFileEx@ with @MOVEFILE_REPLACE_EXISTING@ set, 473 | which is not guaranteed to be atomic 474 | (). 475 | 476 | On other platforms, this operation is atomic. 477 | 478 | The operation may fail with: 479 | 480 | * @HardwareFault@ 481 | A physical I\/O error has occurred. 482 | @[EIO]@ 483 | 484 | * @InvalidArgument@ 485 | Either operand is not a valid file name. 486 | @[ENAMETOOLONG, ELOOP]@ 487 | 488 | * 'isDoesNotExistError' 489 | The original file does not exist, or there is no path to the target. 490 | @[ENOENT, ENOTDIR]@ 491 | 492 | * 'isPermissionError' 493 | The process has insufficient privileges to perform the operation. 494 | @[EROFS, EACCES, EPERM]@ 495 | 496 | * 'System.IO.isFullError' 497 | Insufficient resources are available to perform the operation. 498 | @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ 499 | 500 | * @UnsatisfiedConstraints@ 501 | Implementation-dependent constraints are not satisfied. 502 | @[EBUSY]@ 503 | 504 | * @UnsupportedOperation@ 505 | The implementation does not support renaming in this situation. 506 | @[EXDEV]@ 507 | 508 | * @InappropriateType@ 509 | Either path refers to an existing directory. 510 | @[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ 511 | 512 | -} 513 | 514 | renameFile :: FilePath -> FilePath -> IO () 515 | renameFile opath npath = do 516 | opath' <- encodeFS opath 517 | npath' <- encodeFS npath 518 | D.renameFile opath' npath' 519 | 520 | -- | Rename a file or directory. If the destination path already exists, it 521 | -- is replaced atomically. The destination path must not point to an existing 522 | -- directory. A conformant implementation need not support renaming files in 523 | -- all situations (e.g. renaming across different physical devices), but the 524 | -- constraints must be documented. 525 | -- 526 | -- The operation may fail with: 527 | -- 528 | -- * @HardwareFault@ 529 | -- A physical I\/O error has occurred. 530 | -- @[EIO]@ 531 | -- 532 | -- * @InvalidArgument@ 533 | -- Either operand is not a valid file name. 534 | -- @[ENAMETOOLONG, ELOOP]@ 535 | -- 536 | -- * 'isDoesNotExistError' 537 | -- The original file does not exist, or there is no path to the target. 538 | -- @[ENOENT, ENOTDIR]@ 539 | -- 540 | -- * 'isPermissionError' 541 | -- The process has insufficient privileges to perform the operation. 542 | -- @[EROFS, EACCES, EPERM]@ 543 | -- 544 | -- * 'System.IO.isFullError' 545 | -- Insufficient resources are available to perform the operation. 546 | -- @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ 547 | -- 548 | -- * @UnsatisfiedConstraints@ 549 | -- Implementation-dependent constraints are not satisfied. 550 | -- @[EBUSY]@ 551 | -- 552 | -- * @UnsupportedOperation@ 553 | -- The implementation does not support renaming in this situation. 554 | -- @[EXDEV]@ 555 | -- 556 | -- * @InappropriateType@ 557 | -- Either the destination path refers to an existing directory, or one of the 558 | -- parent segments in the destination path is not a directory. 559 | -- @[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ 560 | -- 561 | -- @since 1.2.7.0 562 | renamePath :: FilePath -- ^ Old path 563 | -> FilePath -- ^ New path 564 | -> IO () 565 | renamePath opath npath = do 566 | opath' <- encodeFS opath 567 | npath' <- encodeFS npath 568 | D.renamePath opath' npath' 569 | 570 | -- | Copy a file with its permissions. If the destination file already exists, 571 | -- it is replaced atomically. Neither path may refer to an existing 572 | -- directory. No exceptions are thrown if the permissions could not be 573 | -- copied. 574 | copyFile :: FilePath -- ^ Source filename 575 | -> FilePath -- ^ Destination filename 576 | -> IO () 577 | copyFile fromFPath toFPath = do 578 | fromFPath' <- encodeFS fromFPath 579 | toFPath' <- encodeFS toFPath 580 | D.copyFile fromFPath' toFPath' 581 | 582 | -- | Copy a file with its associated metadata. If the destination file 583 | -- already exists, it is overwritten. There is no guarantee of atomicity in 584 | -- the replacement of the destination file. Neither path may refer to an 585 | -- existing directory. If the source and/or destination are symbolic links, 586 | -- the copy is performed on the targets of the links. 587 | -- 588 | -- On Windows, it behaves like the Win32 function 589 | -- , 590 | -- which copies various kinds of metadata including file attributes and 591 | -- security resource properties. 592 | -- 593 | -- On Unix-like systems, permissions, access time, and modification time are 594 | -- preserved. If possible, the owner and group are also preserved. Note that 595 | -- the very act of copying can change the access time of the source file, 596 | -- hence the access times of the two files may differ after the operation 597 | -- completes. 598 | -- 599 | -- @since 1.2.6.0 600 | copyFileWithMetadata :: FilePath -- ^ Source file 601 | -> FilePath -- ^ Destination file 602 | -> IO () 603 | copyFileWithMetadata src dst = do 604 | src' <- encodeFS src 605 | dst' <- encodeFS dst 606 | D.copyFileWithMetadata src' dst' 607 | 608 | 609 | -- | Make a path absolute, normalize the path, and remove as many indirections 610 | -- from it as possible. Any trailing path separators are discarded via 611 | -- 'dropTrailingPathSeparator'. Additionally, on Windows the letter case of 612 | -- the path is canonicalized. 613 | -- 614 | -- __Note__: This function is a very big hammer. If you only need an absolute 615 | -- path, 'makeAbsolute' is sufficient for removing dependence on the current 616 | -- working directory. 617 | -- 618 | -- Indirections include the two special directories @.@ and @..@, as well as 619 | -- any symbolic links (and junction points on Windows). The input path need 620 | -- not point to an existing file or directory. Canonicalization is performed 621 | -- on the longest prefix of the path that points to an existing file or 622 | -- directory. The remaining portion of the path that does not point to an 623 | -- existing file or directory will still be normalized, but case 624 | -- canonicalization and indirection removal are skipped as they are impossible 625 | -- to do on a nonexistent path. 626 | -- 627 | -- Most programs should not worry about the canonicity of a path. In 628 | -- particular, despite the name, the function does not truly guarantee 629 | -- canonicity of the returned path due to the presence of hard links, mount 630 | -- points, etc. 631 | -- 632 | -- If the path points to an existing file or directory, then the output path 633 | -- shall also point to the same file or directory, subject to the condition 634 | -- that the relevant parts of the file system do not change while the function 635 | -- is still running. In other words, the function is definitively not atomic. 636 | -- The results can be utterly wrong if the portions of the path change while 637 | -- this function is running. 638 | -- 639 | -- Since some indirections (symbolic links on all systems, @..@ on non-Windows 640 | -- systems, and junction points on Windows) are dependent on the state of the 641 | -- existing filesystem, the function can only make a conservative attempt by 642 | -- removing such indirections from the longest prefix of the path that still 643 | -- points to an existing file or directory. 644 | -- 645 | -- Note that on Windows parent directories @..@ are always fully expanded 646 | -- before the symbolic links, as consistent with the rest of the Windows API 647 | -- (such as @GetFullPathName@). In contrast, on POSIX systems parent 648 | -- directories @..@ are expanded alongside symbolic links from left to right. 649 | -- To put this more concretely: if @L@ is a symbolic link for @R/P@, then on 650 | -- Windows @L\\..@ refers to @.@, whereas on other operating systems @L/..@ 651 | -- refers to @R@. 652 | -- 653 | -- Similar to 'System.FilePath.normalise', passing an empty path is equivalent 654 | -- to passing the current directory. 655 | -- 656 | -- @canonicalizePath@ can resolve at least 64 indirections in a single path, 657 | -- more than what is supported by most operating systems. Therefore, it may 658 | -- return the fully resolved path even though the operating system itself 659 | -- would have long given up. 660 | -- 661 | -- On Windows XP or earlier systems, junction expansion is not performed due 662 | -- to their lack of @GetFinalPathNameByHandle@. 663 | -- 664 | -- /Changes since 1.2.3.0:/ The function has been altered to be more robust 665 | -- and has the same exception behavior as 'makeAbsolute'. 666 | -- 667 | -- /Changes since 1.3.0.0:/ The function no longer preserves the trailing path 668 | -- separator. File symbolic links that appear in the middle of a path are 669 | -- properly dereferenced. Case canonicalization and symbolic link expansion 670 | -- are now performed on Windows. 671 | -- 672 | canonicalizePath :: FilePath -> IO FilePath 673 | canonicalizePath = encodeFS >=> D.canonicalizePath >=> decodeFS 674 | 675 | -- | Convert a path into an absolute path. If the given path is relative, the 676 | -- current directory is prepended and then the combined result is normalized. 677 | -- If the path is already absolute, the path is simply normalized. The 678 | -- function preserves the presence or absence of the trailing path separator 679 | -- unless the path refers to the root directory @/@. 680 | -- 681 | -- If the path is already absolute, the operation never fails. Otherwise, the 682 | -- operation may fail with the same exceptions as 'getCurrentDirectory'. 683 | -- 684 | -- @since 1.2.2.0 685 | -- 686 | makeAbsolute :: FilePath -> IO FilePath 687 | makeAbsolute = encodeFS >=> D.makeAbsolute >=> decodeFS 688 | 689 | -- | Construct a path relative to the current directory, similar to 690 | -- 'makeRelative'. 691 | -- 692 | -- The operation may fail with the same exceptions as 'getCurrentDirectory'. 693 | makeRelativeToCurrentDirectory :: FilePath -> IO FilePath 694 | makeRelativeToCurrentDirectory = 695 | encodeFS >=> D.makeRelativeToCurrentDirectory >=> decodeFS 696 | 697 | -- | Given the name or path of an executable file, 'findExecutable' searches 698 | -- for such a file in a list of system-defined locations, which generally 699 | -- includes @PATH@ and possibly more. The full path to the executable is 700 | -- returned if found. For example, @(findExecutable \"ghc\")@ would normally 701 | -- give you the path to GHC. 702 | -- 703 | -- The path returned by @'findExecutable' name@ corresponds to the program 704 | -- that would be executed by 705 | -- @@ 706 | -- when passed the same string (as a @RawCommand@, not a @ShellCommand@), 707 | -- provided that @name@ is not a relative path with more than one segment. 708 | -- 709 | -- On Windows, 'findExecutable' calls the Win32 function 710 | -- @@, 711 | -- which may search other places before checking the directories in the @PATH@ 712 | -- environment variable. Where it actually searches depends on registry 713 | -- settings, but notably includes the directory containing the current 714 | -- executable. 715 | -- 716 | -- On non-Windows platforms, the behavior is equivalent to 'findFileWith' 717 | -- using the search directories from the @PATH@ environment variable and 718 | -- testing each file for executable permissions. Details can be found in the 719 | -- documentation of 'findFileWith'. 720 | findExecutable :: String -> IO (Maybe FilePath) 721 | findExecutable = encodeFS >=> D.findExecutable >=> (`for` decodeFS) 722 | 723 | -- | Search for executable files in a list of system-defined locations, which 724 | -- generally includes @PATH@ and possibly more. 725 | -- 726 | -- On Windows, this /only returns the first occurrence/, if any. Its behavior 727 | -- is therefore equivalent to 'findExecutable'. 728 | -- 729 | -- On non-Windows platforms, the behavior is equivalent to 730 | -- 'findExecutablesInDirectories' using the search directories from the @PATH@ 731 | -- environment variable. Details can be found in the documentation of 732 | -- 'findExecutablesInDirectories'. 733 | -- 734 | -- @since 1.2.2.0 735 | findExecutables :: String -> IO [FilePath] 736 | findExecutables = encodeFS >=> D.findExecutables >=> (`for` decodeFS) 737 | 738 | -- | Given a name or path, 'findExecutable' appends the 'exeExtension' to the 739 | -- query and searches for executable files in the list of given search 740 | -- directories and returns all occurrences. 741 | -- 742 | -- The behavior is equivalent to 'findFileWith' using the given search 743 | -- directories and testing each file for executable permissions. Details can 744 | -- be found in the documentation of 'findFileWith'. 745 | -- 746 | -- Unlike other similarly named functions, 'findExecutablesInDirectories' does 747 | -- not use @SearchPath@ from the Win32 API. The behavior of this function on 748 | -- Windows is therefore equivalent to those on non-Windows platforms. 749 | -- 750 | -- @since 1.2.4.0 751 | findExecutablesInDirectories :: [FilePath] -> String -> IO [FilePath] 752 | findExecutablesInDirectories path binary = do 753 | path' <- for path encodeFS 754 | binary' <- encodeFS binary 755 | D.findExecutablesInDirectories path' binary' 756 | >>= (`for` decodeFS) 757 | 758 | -- | Search through the given list of directories for the given file. 759 | -- 760 | -- The behavior is equivalent to 'findFileWith', returning only the first 761 | -- occurrence. Details can be found in the documentation of 'findFileWith'. 762 | findFile :: [FilePath] -> String -> IO (Maybe FilePath) 763 | findFile = findFileWith (\ _ -> pure True) 764 | 765 | -- | Search through the given list of directories for the given file and 766 | -- returns all paths where the given file exists. 767 | -- 768 | -- The behavior is equivalent to 'findFilesWith'. Details can be found in the 769 | -- documentation of 'findFilesWith'. 770 | -- 771 | -- @since 1.2.1.0 772 | findFiles :: [FilePath] -> String -> IO [FilePath] 773 | findFiles = findFilesWith (\ _ -> pure True) 774 | 775 | -- | Search through a given list of directories for a file that has the given 776 | -- name and satisfies the given predicate and return the path of the first 777 | -- occurrence. The directories are checked in a left-to-right order. 778 | -- 779 | -- This is essentially a more performant version of 'findFilesWith' that 780 | -- always returns the first result, if any. Details can be found in the 781 | -- documentation of 'findFilesWith'. 782 | -- 783 | -- @since 1.2.6.0 784 | findFileWith :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO (Maybe FilePath) 785 | findFileWith f ds name = do 786 | ds' <- for ds encodeFS 787 | name' <- encodeFS name 788 | D.findFileWith (decodeFS >=> f) ds' name' 789 | >>= (`for` decodeFS) 790 | 791 | -- | @findFilesWith predicate dirs name@ searches through the list of 792 | -- directories (@dirs@) for files that have the given @name@ and satisfy the 793 | -- given @predicate@ and returns the paths of those files. The directories 794 | -- are checked in a left-to-right order and the paths are returned in the same 795 | -- order. 796 | -- 797 | -- If the @name@ is a relative path, then for every search directory @dir@, 798 | -- the function checks whether @dir '' name@ exists and satisfies the 799 | -- predicate. If so, @dir '' name@ is returned as one of the results. In 800 | -- other words, the returned paths can be either relative or absolute 801 | -- depending on the search directories were used. If there are no search 802 | -- directories, no results are ever returned. 803 | -- 804 | -- If the @name@ is an absolute path, then the function will return a single 805 | -- result if the file exists and satisfies the predicate and no results 806 | -- otherwise. This is irrespective of what search directories were given. 807 | -- 808 | -- @since 1.2.1.0 809 | findFilesWith :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath] 810 | findFilesWith f ds name = do 811 | ds' <- for ds encodeFS 812 | name' <- encodeFS name 813 | res <- D.findFilesWith (decodeFS >=> f) ds' name' 814 | for res decodeFS 815 | 816 | -- | Filename extension for executable files (including the dot if any) 817 | -- (usually @\"\"@ on POSIX systems and @\".exe\"@ on Windows or OS\/2). 818 | -- 819 | -- @since 1.2.4.0 820 | exeExtension :: String 821 | exeExtension = so D.exeExtension 822 | 823 | -- | Similar to 'listDirectory', but always includes the special entries (@.@ 824 | -- and @..@). (This applies to Windows as well.) 825 | -- 826 | -- The operation may fail with the same exceptions as 'listDirectory'. 827 | getDirectoryContents :: FilePath -> IO [FilePath] 828 | getDirectoryContents = encodeFS >=> D.getDirectoryContents >=> (`for` decodeFS) 829 | 830 | -- | @'listDirectory' dir@ returns a list of /all/ entries in /dir/ without 831 | -- the special entries (@.@ and @..@). 832 | -- 833 | -- The operation may fail with: 834 | -- 835 | -- * @HardwareFault@ 836 | -- A physical I\/O error has occurred. 837 | -- @[EIO]@ 838 | -- 839 | -- * @InvalidArgument@ 840 | -- The operand is not a valid directory name. 841 | -- @[ENAMETOOLONG, ELOOP]@ 842 | -- 843 | -- * 'isDoesNotExistError' 844 | -- The directory does not exist. 845 | -- @[ENOENT, ENOTDIR]@ 846 | -- 847 | -- * 'isPermissionError' 848 | -- The process has insufficient privileges to perform the operation. 849 | -- @[EACCES]@ 850 | -- 851 | -- * 'System.IO.isFullError' 852 | -- Insufficient resources are available to perform the operation. 853 | -- @[EMFILE, ENFILE]@ 854 | -- 855 | -- * @InappropriateType@ 856 | -- The path refers to an existing non-directory object. 857 | -- @[ENOTDIR]@ 858 | -- 859 | -- @since 1.2.5.0 860 | -- 861 | listDirectory :: FilePath -> IO [FilePath] 862 | listDirectory = encodeFS >=> D.listDirectory >=> (`for` decodeFS) 863 | 864 | -- | Obtain the current working directory as an absolute path. 865 | -- 866 | -- In a multithreaded program, the current working directory is a global state 867 | -- shared among all threads of the process. Therefore, when performing 868 | -- filesystem operations from multiple threads, it is highly recommended to 869 | -- use absolute rather than relative paths (see: 'makeAbsolute'). 870 | -- 871 | -- Note that 'getCurrentDirectory' is not guaranteed to return the same path 872 | -- received by 'setCurrentDirectory'. On POSIX systems, the path returned will 873 | -- always be fully dereferenced (not contain any symbolic links). For more 874 | -- information, refer to the documentation of 875 | -- . 876 | -- 877 | -- The operation may fail with: 878 | -- 879 | -- * @HardwareFault@ 880 | -- A physical I\/O error has occurred. 881 | -- @[EIO]@ 882 | -- 883 | -- * 'isDoesNotExistError' 884 | -- There is no path referring to the working directory. 885 | -- @[EPERM, ENOENT, ESTALE...]@ 886 | -- 887 | -- * 'isPermissionError' 888 | -- The process has insufficient privileges to perform the operation. 889 | -- @[EACCES]@ 890 | -- 891 | -- * 'System.IO.isFullError' 892 | -- Insufficient resources are available to perform the operation. 893 | -- 894 | -- * @UnsupportedOperation@ 895 | -- The operating system has no notion of current working directory. 896 | -- 897 | getCurrentDirectory :: IO FilePath 898 | getCurrentDirectory = D.getCurrentDirectory >>= decodeFS 899 | 900 | -- | Change the working directory to the given path. 901 | -- 902 | -- In a multithreaded program, the current working directory is a global state 903 | -- shared among all threads of the process. Therefore, when performing 904 | -- filesystem operations from multiple threads, it is highly recommended to 905 | -- use absolute rather than relative paths (see: 'makeAbsolute'). 906 | -- 907 | -- The operation may fail with: 908 | -- 909 | -- * @HardwareFault@ 910 | -- A physical I\/O error has occurred. 911 | -- @[EIO]@ 912 | -- 913 | -- * @InvalidArgument@ 914 | -- The operand is not a valid directory name. 915 | -- @[ENAMETOOLONG, ELOOP]@ 916 | -- 917 | -- * 'isDoesNotExistError' 918 | -- The directory does not exist. 919 | -- @[ENOENT, ENOTDIR]@ 920 | -- 921 | -- * 'isPermissionError' 922 | -- The process has insufficient privileges to perform the operation. 923 | -- @[EACCES]@ 924 | -- 925 | -- * @UnsupportedOperation@ 926 | -- The operating system has no notion of current working directory, or the 927 | -- working directory cannot be dynamically changed. 928 | -- 929 | -- * @InappropriateType@ 930 | -- The path refers to an existing non-directory object. 931 | -- @[ENOTDIR]@ 932 | -- 933 | setCurrentDirectory :: FilePath -> IO () 934 | setCurrentDirectory = encodeFS >=> D.setCurrentDirectory 935 | 936 | -- | Run an 'IO' action with the given working directory and restore the 937 | -- original working directory afterwards, even if the given action fails due 938 | -- to an exception. 939 | -- 940 | -- The operation may fail with the same exceptions as 'getCurrentDirectory' 941 | -- and 'setCurrentDirectory'. 942 | -- 943 | -- @since 1.2.3.0 944 | -- 945 | withCurrentDirectory :: FilePath -- ^ Directory to execute in 946 | -> IO a -- ^ Action to be executed 947 | -> IO a 948 | withCurrentDirectory dir action = 949 | encodeFS dir >>= (`D.withCurrentDirectory` action) 950 | 951 | -- | Obtain the size of a file in bytes. 952 | -- 953 | -- @since 1.2.7.0 954 | getFileSize :: FilePath -> IO Integer 955 | getFileSize = encodeFS >=> D.getFileSize 956 | 957 | -- | Test whether the given path points to an existing filesystem object. If 958 | -- the user lacks necessary permissions to search the parent directories, this 959 | -- function may return false even if the file does actually exist. 960 | -- 961 | -- @since 1.2.7.0 962 | doesPathExist :: FilePath -> IO Bool 963 | doesPathExist = encodeFS >=> D.doesPathExist 964 | 965 | {- |The operation 'doesDirectoryExist' returns 'True' if the argument file 966 | exists and is either a directory or a symbolic link to a directory, 967 | and 'False' otherwise. 968 | -} 969 | 970 | doesDirectoryExist :: FilePath -> IO Bool 971 | doesDirectoryExist = encodeFS >=> D.doesDirectoryExist 972 | 973 | {- |The operation 'doesFileExist' returns 'True' 974 | if the argument file exists and is not a directory, and 'False' otherwise. 975 | -} 976 | 977 | doesFileExist :: FilePath -> IO Bool 978 | doesFileExist = encodeFS >=> D.doesFileExist 979 | 980 | 981 | -- | Create a /file/ symbolic link. The target path can be either absolute or 982 | -- relative and need not refer to an existing file. The order of arguments 983 | -- follows the POSIX convention. 984 | -- 985 | -- To remove an existing file symbolic link, use 'removeFile'. 986 | -- 987 | -- Although the distinction between /file/ symbolic links and /directory/ 988 | -- symbolic links does not exist on POSIX systems, on Windows this is an 989 | -- intrinsic property of every symbolic link and cannot be changed without 990 | -- recreating the link. A file symbolic link that actually points to a 991 | -- directory will fail to dereference and vice versa. Moreover, creating 992 | -- symbolic links on Windows may require privileges unavailable to users 993 | -- outside the Administrators group. Portable programs that use symbolic 994 | -- links should take both into consideration. 995 | -- 996 | -- On Windows, the function is implemented using @CreateSymbolicLink@. Since 997 | -- 1.3.3.0, the @SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE@ flag is included 998 | -- if supported by the operating system. On POSIX, the function uses @symlink@ 999 | -- and is therefore atomic. 1000 | -- 1001 | -- Windows-specific errors: This operation may fail with 'permissionErrorType' 1002 | -- if the user lacks the privileges to create symbolic links. It may also 1003 | -- fail with 'illegalOperationErrorType' if the file system does not support 1004 | -- symbolic links. 1005 | -- 1006 | -- @since 1.3.1.0 1007 | createFileLink 1008 | :: FilePath -- ^ path to the target file 1009 | -> FilePath -- ^ path of the link to be created 1010 | -> IO () 1011 | createFileLink target link = do 1012 | target' <- encodeFS target 1013 | link' <- encodeFS link 1014 | D.createFileLink target' link' 1015 | 1016 | 1017 | -- | Create a /directory/ symbolic link. The target path can be either 1018 | -- absolute or relative and need not refer to an existing directory. The 1019 | -- order of arguments follows the POSIX convention. 1020 | -- 1021 | -- To remove an existing directory symbolic link, use 'removeDirectoryLink'. 1022 | -- 1023 | -- Although the distinction between /file/ symbolic links and /directory/ 1024 | -- symbolic links does not exist on POSIX systems, on Windows this is an 1025 | -- intrinsic property of every symbolic link and cannot be changed without 1026 | -- recreating the link. A file symbolic link that actually points to a 1027 | -- directory will fail to dereference and vice versa. Moreover, creating 1028 | -- symbolic links on Windows may require privileges unavailable to users 1029 | -- outside the Administrators group. Portable programs that use symbolic 1030 | -- links should take both into consideration. 1031 | -- 1032 | -- On Windows, the function is implemented using @CreateSymbolicLink@ with 1033 | -- @SYMBOLIC_LINK_FLAG_DIRECTORY@. Since 1.3.3.0, the 1034 | -- @SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE@ flag is also included if 1035 | -- supported by the operating system. On POSIX, this is an alias for 1036 | -- 'createFileLink' and is therefore atomic. 1037 | -- 1038 | -- Windows-specific errors: This operation may fail with 'permissionErrorType' 1039 | -- if the user lacks the privileges to create symbolic links. It may also 1040 | -- fail with 'illegalOperationErrorType' if the file system does not support 1041 | -- symbolic links. 1042 | -- 1043 | -- @since 1.3.1.0 1044 | createDirectoryLink 1045 | :: FilePath -- ^ path to the target directory 1046 | -> FilePath -- ^ path of the link to be created 1047 | -> IO () 1048 | createDirectoryLink target link = do 1049 | target' <- encodeFS target 1050 | link' <- encodeFS link 1051 | D.createDirectoryLink target' link' 1052 | 1053 | -- | Remove an existing /directory/ symbolic link. 1054 | -- 1055 | -- On Windows, this is an alias for 'removeDirectory'. On POSIX systems, this 1056 | -- is an alias for 'removeFile'. 1057 | -- 1058 | -- See also: 'removeFile', which can remove an existing /file/ symbolic link. 1059 | -- 1060 | -- @since 1.3.1.0 1061 | removeDirectoryLink :: FilePath -> IO () 1062 | removeDirectoryLink = encodeFS >=> D.removeDirectoryLink 1063 | 1064 | -- | Check whether an existing @path@ is a symbolic link. If @path@ is a 1065 | -- regular file or directory, 'False' is returned. If @path@ does not exist 1066 | -- or is otherwise inaccessible, an exception is thrown (see below). 1067 | -- 1068 | -- On Windows, this checks for @FILE_ATTRIBUTE_REPARSE_POINT@. In addition to 1069 | -- symbolic links, the function also returns true on junction points. On 1070 | -- POSIX systems, this checks for @S_IFLNK@. 1071 | -- 1072 | -- The operation may fail with: 1073 | -- 1074 | -- * 'isDoesNotExistError' if the symbolic link does not exist; or 1075 | -- 1076 | -- * 'isPermissionError' if the user is not permitted to read the symbolic 1077 | -- link. 1078 | -- 1079 | -- @since 1.3.0.0 1080 | pathIsSymbolicLink :: FilePath -> IO Bool 1081 | pathIsSymbolicLink = encodeFS >=> D.pathIsSymbolicLink 1082 | 1083 | {-# DEPRECATED isSymbolicLink "Use 'pathIsSymbolicLink' instead" #-} 1084 | isSymbolicLink :: FilePath -> IO Bool 1085 | isSymbolicLink = pathIsSymbolicLink 1086 | 1087 | -- | Retrieve the target path of either a file or directory symbolic link. 1088 | -- The returned path may not be absolute, may not exist, and may not even be a 1089 | -- valid path. 1090 | -- 1091 | -- On Windows systems, this calls @DeviceIoControl@ with 1092 | -- @FSCTL_GET_REPARSE_POINT@. In addition to symbolic links, the function 1093 | -- also works on junction points. On POSIX systems, this calls @readlink@. 1094 | -- 1095 | -- Windows-specific errors: This operation may fail with 1096 | -- 'illegalOperationErrorType' if the file system does not support symbolic 1097 | -- links. 1098 | -- 1099 | -- @since 1.3.1.0 1100 | getSymbolicLinkTarget :: FilePath -> IO FilePath 1101 | getSymbolicLinkTarget = encodeFS >=> D.getSymbolicLinkTarget >=> decodeFS 1102 | 1103 | -- | Obtain the time at which the file or directory was last accessed. 1104 | -- 1105 | -- The operation may fail with: 1106 | -- 1107 | -- * 'isPermissionError' if the user is not permitted to read 1108 | -- the access time; or 1109 | -- 1110 | -- * 'isDoesNotExistError' if the file or directory does not exist. 1111 | -- 1112 | -- Caveat for POSIX systems: This function returns a timestamp with sub-second 1113 | -- resolution only if this package is compiled against @unix-2.6.0.0@ or later 1114 | -- and the underlying filesystem supports them. 1115 | -- 1116 | -- @since 1.2.3.0 1117 | -- 1118 | getAccessTime :: FilePath -> IO UTCTime 1119 | getAccessTime = encodeFS >=> D.getAccessTime 1120 | 1121 | -- | Obtain the time at which the file or directory was last modified. 1122 | -- 1123 | -- The operation may fail with: 1124 | -- 1125 | -- * 'isPermissionError' if the user is not permitted to read 1126 | -- the modification time; or 1127 | -- 1128 | -- * 'isDoesNotExistError' if the file or directory does not exist. 1129 | -- 1130 | -- Caveat for POSIX systems: This function returns a timestamp with sub-second 1131 | -- resolution only if this package is compiled against @unix-2.6.0.0@ or later 1132 | -- and the underlying filesystem supports them. 1133 | -- 1134 | getModificationTime :: FilePath -> IO UTCTime 1135 | getModificationTime = encodeFS >=> D.getModificationTime 1136 | 1137 | -- | Change the time at which the file or directory was last accessed. 1138 | -- 1139 | -- The operation may fail with: 1140 | -- 1141 | -- * 'isPermissionError' if the user is not permitted to alter the 1142 | -- access time; or 1143 | -- 1144 | -- * 'isDoesNotExistError' if the file or directory does not exist. 1145 | -- 1146 | -- Some caveats for POSIX systems: 1147 | -- 1148 | -- * Not all systems support @utimensat@, in which case the function can only 1149 | -- emulate the behavior by reading the modification time and then setting 1150 | -- both the access and modification times together. On systems where 1151 | -- @utimensat@ is supported, the access time is set atomically with 1152 | -- nanosecond precision. 1153 | -- 1154 | -- * If compiled against a version of @unix@ prior to @2.7.0.0@, the function 1155 | -- would not be able to set timestamps with sub-second resolution. In this 1156 | -- case, there would also be loss of precision in the modification time. 1157 | -- 1158 | -- @since 1.2.3.0 1159 | -- 1160 | setAccessTime :: FilePath -> UTCTime -> IO () 1161 | setAccessTime path atime = encodeFS path >>= (`D.setAccessTime` atime) 1162 | 1163 | -- | Change the time at which the file or directory was last modified. 1164 | -- 1165 | -- The operation may fail with: 1166 | -- 1167 | -- * 'isPermissionError' if the user is not permitted to alter the 1168 | -- modification time; or 1169 | -- 1170 | -- * 'isDoesNotExistError' if the file or directory does not exist. 1171 | -- 1172 | -- * 'InvalidArgument' on FAT32 file system if the time is before 1173 | -- DOS Epoch (1 January 1980). 1174 | -- 1175 | -- Some caveats for POSIX systems: 1176 | -- 1177 | -- * Not all systems support @utimensat@, in which case the function can only 1178 | -- emulate the behavior by reading the access time and then setting both the 1179 | -- access and modification times together. On systems where @utimensat@ is 1180 | -- supported, the modification time is set atomically with nanosecond 1181 | -- precision. 1182 | -- 1183 | -- * If compiled against a version of @unix@ prior to @2.7.0.0@, the function 1184 | -- would not be able to set timestamps with sub-second resolution. In this 1185 | -- case, there would also be loss of precision in the access time. 1186 | -- 1187 | -- @since 1.2.3.0 1188 | -- 1189 | setModificationTime :: FilePath -> UTCTime -> IO () 1190 | setModificationTime path mtime = 1191 | encodeFS path >>= (`D.setModificationTime` mtime) 1192 | 1193 | {- | Returns the current user's home directory. 1194 | 1195 | The directory returned is expected to be writable by the current user, 1196 | but note that it isn't generally considered good practice to store 1197 | application-specific data here; use 'getXdgDirectory' or 1198 | 'getAppUserDataDirectory' instead. 1199 | 1200 | On Unix, 'getHomeDirectory' behaves as follows: 1201 | 1202 | * Returns $HOME env variable if set (including to an empty string). 1203 | * Otherwise uses home directory returned by `getpwuid_r` using the UID of the current proccesses user. This basically reads the /etc/passwd file. An empty home directory field is considered valid. 1204 | 1205 | On Windows, the system is queried for a suitable path; a typical path might be @C:\/Users\//\/@. 1206 | 1207 | The operation may fail with: 1208 | 1209 | * @UnsupportedOperation@ 1210 | The operating system has no notion of home directory. 1211 | 1212 | * 'isDoesNotExistError' 1213 | The home directory for the current user does not exist, or 1214 | cannot be found. 1215 | -} 1216 | getHomeDirectory :: IO FilePath 1217 | getHomeDirectory = D.getHomeDirectory >>= decodeFS 1218 | 1219 | -- | Obtain the paths to special directories for storing user-specific 1220 | -- application data, configuration, and cache files, conforming to the 1221 | -- . 1222 | -- Compared with 'getAppUserDataDirectory', this function provides a more 1223 | -- fine-grained hierarchy as well as greater flexibility for the user. 1224 | -- 1225 | -- On Windows, 'XdgData' and 'XdgConfig' usually map to the same directory 1226 | -- unless overridden. 1227 | -- 1228 | -- Refer to the docs of 'XdgDirectory' for more details. 1229 | -- 1230 | -- The second argument is usually the name of the application. Since it 1231 | -- will be integrated into the path, it must consist of valid path 1232 | -- characters. Note: if the second argument is an absolute path, it will 1233 | -- just return the second argument. 1234 | -- 1235 | -- Note: The directory may not actually exist, in which case you would need 1236 | -- to create it with file mode @700@ (i.e. only accessible by the owner). 1237 | -- 1238 | -- As of 1.3.5.0, the environment variable is ignored if set to a relative 1239 | -- path, per revised XDG Base Directory Specification. See 1240 | -- . 1241 | -- 1242 | -- @since 1.2.3.0 1243 | getXdgDirectory :: XdgDirectory -- ^ which special directory 1244 | -> FilePath -- ^ a relative path that is appended 1245 | -- to the path; if empty, the base 1246 | -- path is returned 1247 | -> IO FilePath 1248 | getXdgDirectory xdgDir = encodeFS >=> D.getXdgDirectory xdgDir >=> decodeFS 1249 | 1250 | -- | Similar to 'getXdgDirectory' but retrieves the entire list of XDG 1251 | -- directories. 1252 | -- 1253 | -- On Windows, 'XdgDataDirs' and 'XdgConfigDirs' usually map to the same list 1254 | -- of directories unless overridden. 1255 | -- 1256 | -- Refer to the docs of 'XdgDirectoryList' for more details. 1257 | getXdgDirectoryList :: XdgDirectoryList -- ^ which special directory list 1258 | -> IO [FilePath] 1259 | getXdgDirectoryList = D.getXdgDirectoryList >=> (`for` decodeFS) 1260 | 1261 | -- | Obtain the path to a special directory for storing user-specific 1262 | -- application data (traditional Unix location). Newer applications may 1263 | -- prefer the the XDG-conformant location provided by 'getXdgDirectory' 1264 | -- (). 1265 | -- 1266 | -- The argument is usually the name of the application. Since it will be 1267 | -- integrated into the path, it must consist of valid path characters. 1268 | -- 1269 | -- * On Unix-like systems, the path is @~\/./\/@. 1270 | -- * On Windows, the path is @%APPDATA%\//\/@ 1271 | -- (e.g. @C:\/Users\//\/\/AppData\/Roaming\//\/@) 1272 | -- 1273 | -- Note: the directory may not actually exist, in which case you would need 1274 | -- to create it. It is expected that the parent directory exists and is 1275 | -- writable. 1276 | -- 1277 | -- The operation may fail with: 1278 | -- 1279 | -- * @UnsupportedOperation@ 1280 | -- The operating system has no notion of application-specific data 1281 | -- directory. 1282 | -- 1283 | -- * 'isDoesNotExistError' 1284 | -- The home directory for the current user does not exist, or cannot be 1285 | -- found. 1286 | -- 1287 | getAppUserDataDirectory :: FilePath -- ^ a relative path that is appended 1288 | -- to the path 1289 | -> IO FilePath 1290 | getAppUserDataDirectory = encodeFS >=> D.getAppUserDataDirectory >=>decodeFS 1291 | 1292 | {- | Returns the current user's document directory. 1293 | 1294 | The directory returned is expected to be writable by the current user, 1295 | but note that it isn't generally considered good practice to store 1296 | application-specific data here; use 'getXdgDirectory' or 1297 | 'getAppUserDataDirectory' instead. 1298 | 1299 | On Unix, 'getUserDocumentsDirectory' returns the value of the @HOME@ 1300 | environment variable. On Windows, the system is queried for a 1301 | suitable path; a typical path might be @C:\/Users\//\/\/Documents@. 1302 | 1303 | The operation may fail with: 1304 | 1305 | * @UnsupportedOperation@ 1306 | The operating system has no notion of document directory. 1307 | 1308 | * 'isDoesNotExistError' 1309 | The document directory for the current user does not exist, or 1310 | cannot be found. 1311 | -} 1312 | getUserDocumentsDirectory :: IO FilePath 1313 | getUserDocumentsDirectory = D.getUserDocumentsDirectory >>= decodeFS 1314 | 1315 | {- | Returns the current directory for temporary files. 1316 | 1317 | On Unix, 'getTemporaryDirectory' returns the value of the @TMPDIR@ 1318 | environment variable or \"\/tmp\" if the variable isn\'t defined. 1319 | On Windows, the function checks for the existence of environment variables in 1320 | the following order and uses the first path found: 1321 | 1322 | * 1323 | TMP environment variable. 1324 | 1325 | * 1326 | TEMP environment variable. 1327 | 1328 | * 1329 | USERPROFILE environment variable. 1330 | 1331 | * 1332 | The Windows directory 1333 | 1334 | The operation may fail with: 1335 | 1336 | * @UnsupportedOperation@ 1337 | The operating system has no notion of temporary directory. 1338 | 1339 | The function doesn\'t verify whether the path exists. 1340 | -} 1341 | getTemporaryDirectory :: IO FilePath 1342 | getTemporaryDirectory = D.getTemporaryDirectory >>= decodeFS 1343 | 1344 | -- | Get the contents of the @PATH@ environment variable. 1345 | getExecSearchPath :: IO [FilePath] 1346 | getExecSearchPath = D.getExecSearchPath >>= (`for` decodeFS) 1347 | -------------------------------------------------------------------------------- /System/Directory/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | -- | 4 | -- Stability: unstable 5 | -- Portability: unportable 6 | -- 7 | -- Internal modules are always subject to change from version to version. 8 | -- The contents of this module are also platform-dependent, hence what is 9 | -- shown in the Hackage documentation may differ from what is actually 10 | -- available on your system. 11 | 12 | #include 13 | 14 | module System.Directory.Internal 15 | ( module System.Directory.Internal.Common 16 | 17 | #if defined(mingw32_HOST_OS) 18 | , module System.Directory.Internal.Windows 19 | #else 20 | , module System.Directory.Internal.Posix 21 | #endif 22 | 23 | ) where 24 | 25 | import System.Directory.Internal.Common 26 | 27 | #if defined(mingw32_HOST_OS) 28 | import System.Directory.Internal.Windows 29 | #else 30 | import System.Directory.Internal.Posix 31 | #endif 32 | -------------------------------------------------------------------------------- /System/Directory/Internal/C_utimensat.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | 3 | module System.Directory.Internal.C_utimensat where 4 | #include 5 | #ifdef HAVE_UTIMENSAT 6 | #ifdef HAVE_FCNTL_H 7 | # include 8 | #endif 9 | #ifdef HAVE_TIME_H 10 | # include 11 | #endif 12 | #ifdef HAVE_SYS_STAT_H 13 | # include 14 | #endif 15 | import Prelude () 16 | import System.Directory.Internal.Prelude 17 | import Data.Time.Clock.POSIX (POSIXTime) 18 | import qualified System.Posix as Posix 19 | 20 | data CTimeSpec = CTimeSpec EpochTime CLong 21 | 22 | instance Storable CTimeSpec where 23 | sizeOf _ = #{size struct timespec} 24 | alignment _ = #{alignment struct timespec} 25 | poke p (CTimeSpec sec nsec) = do 26 | (#poke struct timespec, tv_sec) p sec 27 | (#poke struct timespec, tv_nsec) p nsec 28 | peek p = do 29 | sec <- #{peek struct timespec, tv_sec } p 30 | nsec <- #{peek struct timespec, tv_nsec} p 31 | return (CTimeSpec sec nsec) 32 | 33 | utimeOmit :: CTimeSpec 34 | utimeOmit = CTimeSpec (CTime 0) (#const UTIME_OMIT) 35 | 36 | toCTimeSpec :: POSIXTime -> CTimeSpec 37 | toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10 ^ (9 :: Int) * frac) 38 | where 39 | (sec, frac) = if frac' < 0 then (sec' - 1, frac' + 1) else (sec', frac') 40 | (sec', frac') = properFraction (toRational t) 41 | 42 | foreign import capi "sys/stat.h utimensat" c_utimensat 43 | :: Posix.Fd -> CString -> Ptr CTimeSpec -> CInt -> IO CInt 44 | 45 | #endif 46 | -------------------------------------------------------------------------------- /System/Directory/Internal/Common.hs: -------------------------------------------------------------------------------- 1 | module System.Directory.Internal.Common 2 | ( module System.Directory.Internal.Common 3 | , OsPath 4 | , OsString 5 | ) where 6 | import Prelude () 7 | import System.Directory.Internal.Prelude 8 | import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure)) 9 | import GHC.IO.Encoding.UTF16 (mkUTF16le) 10 | import GHC.IO.Encoding.UTF8 (mkUTF8) 11 | import System.File.OsPath.Internal (openFileWithCloseOnExec) 12 | import System.OsPath 13 | ( OsPath 14 | , OsString 15 | , addTrailingPathSeparator 16 | , decodeUtf 17 | , decodeWith 18 | , encodeUtf 19 | , hasTrailingPathSeparator 20 | , isPathSeparator 21 | , isRelative 22 | , joinDrive 23 | , joinPath 24 | , normalise 25 | , pack 26 | , pathSeparator 27 | , pathSeparators 28 | , splitDirectories 29 | , splitDrive 30 | , toChar 31 | , unpack 32 | , unsafeFromChar 33 | ) 34 | 35 | -- | A generator with side-effects. 36 | newtype ListT m a = ListT { unListT :: m (Maybe (a, ListT m a)) } 37 | 38 | emptyListT :: Applicative m => ListT m a 39 | emptyListT = ListT (pure Nothing) 40 | 41 | maybeToListT :: Applicative m => m (Maybe a) -> ListT m a 42 | maybeToListT m = ListT (((\ x -> (x, emptyListT)) <$>) <$> m) 43 | 44 | listToListT :: Applicative m => [a] -> ListT m a 45 | listToListT [] = emptyListT 46 | listToListT (x : xs) = ListT (pure (Just (x, listToListT xs))) 47 | 48 | liftJoinListT :: Monad m => m (ListT m a) -> ListT m a 49 | liftJoinListT m = ListT (m >>= unListT) 50 | 51 | listTHead :: Functor m => ListT m a -> m (Maybe a) 52 | listTHead (ListT m) = (fst <$>) <$> m 53 | 54 | listTToList :: Monad m => ListT m a -> m [a] 55 | listTToList (ListT m) = do 56 | mx <- m 57 | case mx of 58 | Nothing -> return [] 59 | Just (x, m') -> do 60 | xs <- listTToList m' 61 | return (x : xs) 62 | 63 | andM :: Monad m => m Bool -> m Bool -> m Bool 64 | andM mx my = do 65 | x <- mx 66 | if x 67 | then my 68 | else return x 69 | 70 | sequenceWithIOErrors_ :: [IO ()] -> IO () 71 | sequenceWithIOErrors_ actions = go (Right ()) actions 72 | where 73 | 74 | go :: Either IOError () -> [IO ()] -> IO () 75 | go (Left e) [] = ioError e 76 | go (Right ()) [] = pure () 77 | go s (m : ms) = s `seq` do 78 | r <- tryIOError m 79 | go (s *> r) ms 80 | 81 | -- | Similar to 'try' but only catches a specify kind of 'IOError' as 82 | -- specified by the predicate. 83 | tryIOErrorType :: (IOError -> Bool) -> IO a -> IO (Either IOError a) 84 | tryIOErrorType check action = do 85 | result <- tryIOError action 86 | case result of 87 | Left err -> if check err then pure (Left err) else throwIO err 88 | Right val -> pure (Right val) 89 | 90 | -- | Attempt to perform the given action, silencing any IO exception thrown by 91 | -- it. 92 | ignoreIOExceptions :: IO () -> IO () 93 | ignoreIOExceptions io = io `catchIOError` (\_ -> pure ()) 94 | 95 | specializeErrorString :: String -> (IOError -> Bool) -> IO a -> IO a 96 | specializeErrorString str errType action = do 97 | mx <- tryIOErrorType errType action 98 | case mx of 99 | Left e -> throwIO (ioeSetErrorString e str) 100 | Right x -> pure x 101 | 102 | ioeAddLocation :: IOError -> String -> IOError 103 | ioeAddLocation e loc = do 104 | ioeSetLocation e newLoc 105 | where 106 | newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc 107 | oldLoc = ioeGetLocation e 108 | 109 | rightOrError :: Exception e => Either e a -> a 110 | rightOrError (Left e) = error (displayException e) 111 | rightOrError (Right a) = a 112 | 113 | -- | Fallibly converts String to OsString. Only intended to be used on literals. 114 | os :: String -> OsString 115 | os = rightOrError . encodeUtf 116 | 117 | -- | Fallibly converts OsString to String. Only intended to be used on literals. 118 | so :: OsString -> String 119 | so = rightOrError . decodeUtf 120 | 121 | ioeSetOsPath :: IOError -> OsPath -> IOError 122 | ioeSetOsPath err = 123 | ioeSetFileName err . 124 | rightOrError . 125 | decodeWith 126 | (mkUTF8 TransliterateCodingFailure) 127 | (mkUTF16le TransliterateCodingFailure) 128 | 129 | dropSpecialDotDirs :: [OsPath] -> [OsPath] 130 | dropSpecialDotDirs = filter f 131 | where f filename = filename /= os "." && filename /= os ".." 132 | 133 | -- | Given a list of path segments, expand @.@ and @..@. The path segments 134 | -- must not contain path separators. 135 | expandDots :: [OsPath] -> [OsPath] 136 | expandDots = reverse . go [] 137 | where 138 | go ys' xs' = 139 | case xs' of 140 | [] -> ys' 141 | x : xs 142 | | x == os "." -> go ys' xs 143 | | x == os ".." -> 144 | case ys' of 145 | [] -> go (x : ys') xs 146 | y : ys 147 | | y == os ".." -> go (x : ys') xs 148 | | otherwise -> go ys xs 149 | | otherwise -> go (x : ys') xs 150 | 151 | -- | Convert to the right kind of slashes. 152 | normalisePathSeps :: OsPath -> OsPath 153 | normalisePathSeps p = pack (normaliseChar <$> unpack p) 154 | where normaliseChar c = if isPathSeparator c then pathSeparator else c 155 | 156 | -- | Remove redundant trailing slashes and pick the right kind of slash. 157 | normaliseTrailingSep :: OsPath -> OsPath 158 | normaliseTrailingSep path = do 159 | let path' = reverse (unpack path) 160 | let (sep, path'') = span isPathSeparator path' 161 | let addSep = if null sep then id else (pathSeparator :) 162 | pack (reverse (addSep path'')) 163 | 164 | -- | Convert empty paths to the current directory, otherwise leave it 165 | -- unchanged. 166 | emptyToCurDir :: OsPath -> OsPath 167 | emptyToCurDir path 168 | | path == mempty = os "." 169 | | otherwise = path 170 | 171 | -- | Similar to 'normalise' but empty paths stay empty. 172 | simplifyPosix :: OsPath -> OsPath 173 | simplifyPosix path 174 | | path == mempty = mempty 175 | | otherwise = normalise path 176 | 177 | -- | Similar to 'normalise' but: 178 | -- 179 | -- * empty paths stay empty, 180 | -- * parent dirs (@..@) are expanded, and 181 | -- * paths starting with @\\\\?\\@ are preserved. 182 | -- 183 | -- The goal is to preserve the meaning of paths better than 'normalise'. 184 | simplifyWindows :: OsPath -> OsPath 185 | simplifyWindows path 186 | | path == mempty = mempty 187 | | drive' == os "\\\\?\\" = drive' <> subpath 188 | | otherwise = simplifiedPath 189 | where 190 | simplifiedPath = joinDrive drive' subpath' 191 | (drive, subpath) = splitDrive path 192 | drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive)) 193 | subpath' = appendSep . avoidEmpty . prependSep . joinPath . 194 | stripPardirs . expandDots . skipSeps . 195 | splitDirectories $ subpath 196 | 197 | upperDrive d = case unpack d of 198 | c : k : s 199 | | isAlpha (toChar c), toChar k == ':', all isPathSeparator s -> 200 | -- unsafeFromChar is safe here since all characters are ASCII. 201 | pack (unsafeFromChar (toUpper (toChar c)) : unsafeFromChar ':' : s) 202 | _ -> d 203 | skipSeps = 204 | (pack <$>) . 205 | filter (not . (`elem` (pure <$> pathSeparators))) . 206 | (unpack <$>) 207 | stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== os "..") 208 | | otherwise = id 209 | prependSep | subpathIsAbsolute = (pack [pathSeparator] <>) 210 | | otherwise = id 211 | avoidEmpty | not pathIsAbsolute 212 | , drive == mempty || hasTrailingPathSep -- prefer "C:" over "C:." 213 | = emptyToCurDir 214 | | otherwise = id 215 | appendSep p | hasTrailingPathSep, not (pathIsAbsolute && p == mempty) 216 | = addTrailingPathSeparator p 217 | | otherwise = p 218 | pathIsAbsolute = not (isRelative path) 219 | subpathIsAbsolute = any isPathSeparator (take 1 (unpack subpath)) 220 | hasTrailingPathSep = hasTrailingPathSeparator subpath 221 | 222 | data WhetherFollow = NoFollow | FollowLinks deriving (Show) 223 | 224 | isNoFollow :: WhetherFollow -> Bool 225 | isNoFollow NoFollow = True 226 | isNoFollow FollowLinks = False 227 | 228 | data FileType = File 229 | | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link 230 | | Directory 231 | | DirectoryLink -- ^ Windows only: directory link 232 | deriving (Bounded, Enum, Eq, Ord, Read, Show) 233 | 234 | -- | Check whether the given 'FileType' is considered a directory by the 235 | -- operating system. This affects the choice of certain functions 236 | -- e.g. 'System.Directory.removeDirectory' vs 'System.Directory.removeFile'. 237 | fileTypeIsDirectory :: FileType -> Bool 238 | fileTypeIsDirectory Directory = True 239 | fileTypeIsDirectory DirectoryLink = True 240 | fileTypeIsDirectory _ = False 241 | 242 | -- | Return whether the given 'FileType' is a link. 243 | fileTypeIsLink :: FileType -> Bool 244 | fileTypeIsLink SymbolicLink = True 245 | fileTypeIsLink DirectoryLink = True 246 | fileTypeIsLink _ = False 247 | 248 | data Permissions 249 | = Permissions 250 | { readable :: Bool 251 | , writable :: Bool 252 | , executable :: Bool 253 | , searchable :: Bool 254 | } deriving (Eq, Ord, Read, Show) 255 | 256 | withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r 257 | withBinaryFile path mode = bracket (openFileWithCloseOnExec path mode) hClose 258 | 259 | -- | Copy data from one handle to another until end of file. 260 | copyHandleData :: Handle -- ^ Source handle 261 | -> Handle -- ^ Destination handle 262 | -> IO () 263 | copyHandleData hFrom hTo = 264 | (`ioeAddLocation` "copyData") `modifyIOError` do 265 | allocaBytes bufferSize go 266 | where 267 | bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h) 268 | go buffer = do 269 | count <- hGetBuf hFrom buffer bufferSize 270 | when (count > 0) $ do 271 | hPutBuf hTo buffer count 272 | go buffer 273 | 274 | -- | Special directories for storing user-specific application data, 275 | -- configuration, and cache files, as specified by the 276 | -- . 277 | -- 278 | -- Note: On Windows, 'XdgData' and 'XdgConfig' usually map to the same 279 | -- directory. 280 | -- 281 | -- @since 1.2.3.0 282 | data XdgDirectory 283 | = XdgData 284 | -- ^ For data files (e.g. images). 285 | -- It uses the @XDG_DATA_HOME@ environment variable. 286 | -- On non-Windows systems, the default is @~\/.local\/share@. 287 | -- On Windows, the default is @%APPDATA%@ 288 | -- (e.g. @C:\/Users\//\/\/AppData\/Roaming@). 289 | -- Can be considered as the user-specific equivalent of @\/usr\/share@. 290 | | XdgConfig 291 | -- ^ For configuration files. 292 | -- It uses the @XDG_CONFIG_HOME@ environment variable. 293 | -- On non-Windows systems, the default is @~\/.config@. 294 | -- On Windows, the default is @%APPDATA%@ 295 | -- (e.g. @C:\/Users\//\/\/AppData\/Roaming@). 296 | -- Can be considered as the user-specific equivalent of @\/etc@. 297 | | XdgCache 298 | -- ^ For non-essential files (e.g. cache). 299 | -- It uses the @XDG_CACHE_HOME@ environment variable. 300 | -- On non-Windows systems, the default is @~\/.cache@. 301 | -- On Windows, the default is @%LOCALAPPDATA%@ 302 | -- (e.g. @C:\/Users\//\/\/AppData\/Local@). 303 | -- Can be considered as the user-specific equivalent of @\/var\/cache@. 304 | | XdgState 305 | -- ^ For data that should persist between (application) restarts, 306 | -- but that is not important or portable enough to the user that it 307 | -- should be stored in 'XdgData'. 308 | -- It uses the @XDG_STATE_HOME@ environment variable. 309 | -- On non-Windows sytems, the default is @~\/.local\/state@. On 310 | -- Windows, the default is @%LOCALAPPDATA%@ 311 | -- (e.g. @C:\/Users\//\/\/AppData\/Local@). 312 | -- 313 | -- @since 1.3.7.0 314 | deriving (Bounded, Enum, Eq, Ord, Read, Show) 315 | 316 | -- | Search paths for various application data, as specified by the 317 | -- . 318 | -- 319 | -- The list of paths is split using 'System.FilePath.searchPathSeparator', 320 | -- which on Windows is a semicolon. 321 | -- 322 | -- Note: On Windows, 'XdgDataDirs' and 'XdgConfigDirs' usually yield the same 323 | -- result. 324 | -- 325 | -- @since 1.3.2.0 326 | data XdgDirectoryList 327 | = XdgDataDirs 328 | -- ^ For data files (e.g. images). 329 | -- It uses the @XDG_DATA_DIRS@ environment variable. 330 | -- On non-Windows systems, the default is @\/usr\/local\/share\/@ and 331 | -- @\/usr\/share\/@. 332 | -- On Windows, the default is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@ 333 | -- (e.g. @C:\/ProgramData@). 334 | | XdgConfigDirs 335 | -- ^ For configuration files. 336 | -- It uses the @XDG_CONFIG_DIRS@ environment variable. 337 | -- On non-Windows systems, the default is @\/etc\/xdg@. 338 | -- On Windows, the default is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@ 339 | -- (e.g. @C:\/ProgramData@). 340 | deriving (Bounded, Enum, Eq, Ord, Read, Show) 341 | -------------------------------------------------------------------------------- /System/Directory/Internal/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module System.Directory.Internal.Config where 3 | #include 4 | import System.Directory.Internal.Common 5 | 6 | exeExtension :: OsString 7 | exeExtension = os EXE_EXTENSION 8 | -- We avoid using #const_str from hsc because it breaks cross-compilation 9 | -- builds, so we use this ugly workaround where we simply paste the C string 10 | -- literal directly in here. This will probably break if the EXE_EXTENSION 11 | -- contains strange characters, but hopefully no sane OS would ever do that. 12 | -------------------------------------------------------------------------------- /System/Directory/Internal/Posix.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | module System.Directory.Internal.Posix where 3 | #include 4 | #if !defined(mingw32_HOST_OS) 5 | #include 6 | #ifdef HAVE_LIMITS_H 7 | # include 8 | #endif 9 | #ifdef HAVE_SYS_STAT_H 10 | # include 11 | #endif 12 | import Prelude () 13 | import System.Directory.Internal.Prelude 14 | #ifdef HAVE_UTIMENSAT 15 | import System.Directory.Internal.C_utimensat 16 | #endif 17 | import System.Directory.Internal.Common 18 | import System.Directory.Internal.Config (exeExtension) 19 | import Data.Time (UTCTime) 20 | import Data.Time.Clock.POSIX (POSIXTime) 21 | import System.OsPath ((), isRelative, splitSearchPath) 22 | import System.OsString.Internal.Types (OsString(OsString, getOsString)) 23 | import qualified Data.Time.Clock.POSIX as POSIXTime 24 | import qualified System.OsPath.Internal as OsPath 25 | import qualified System.Posix.Directory.Fd as Posix 26 | import qualified System.Posix.Directory.PosixPath as Posix 27 | import qualified System.Posix.Env.PosixString as Posix 28 | import qualified System.Posix.Files as Posix (FileStatus(..)) 29 | import qualified System.Posix.Files.PosixString as Posix 30 | import qualified System.Posix.Internals as Posix (CStat) 31 | import qualified System.Posix.IO.PosixString as Posix 32 | import qualified System.Posix.PosixPath.FilePath as Posix 33 | import qualified System.Posix.Types as Posix 34 | import qualified System.Posix.User.ByteString as Posix 35 | 36 | c_AT_FDCWD :: Posix.Fd 37 | c_AT_FDCWD = Posix.Fd (#const AT_FDCWD) 38 | 39 | c_AT_SYMLINK_NOFOLLOW :: CInt 40 | c_AT_SYMLINK_NOFOLLOW = (#const AT_SYMLINK_NOFOLLOW) 41 | 42 | atWhetherFollow :: WhetherFollow -> CInt 43 | atWhetherFollow NoFollow = c_AT_SYMLINK_NOFOLLOW 44 | atWhetherFollow FollowLinks = 0 45 | 46 | defaultOpenFlags :: Posix.OpenFileFlags 47 | defaultOpenFlags = 48 | Posix.defaultFileFlags 49 | { Posix.noctty = True 50 | , Posix.nonBlock = True 51 | , Posix.cloexec = True 52 | } 53 | 54 | type RawHandle = Posix.Fd 55 | 56 | openRaw :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO RawHandle 57 | openRaw whetherFollow dir (OsString path) = 58 | Posix.openFdAt dir path Posix.ReadOnly flags 59 | where 60 | flags = defaultOpenFlags { Posix.nofollow = isNoFollow whetherFollow } 61 | 62 | closeRaw :: RawHandle -> IO () 63 | closeRaw = Posix.closeFd 64 | 65 | createDirectoryInternal :: OsPath -> IO () 66 | createDirectoryInternal (OsString path) = Posix.createDirectory path 0o777 67 | 68 | foreign import ccall "unistd.h unlinkat" c_unlinkat 69 | :: Posix.Fd -> CString -> CInt -> IO CInt 70 | 71 | removePathAt :: FileType -> Maybe RawHandle -> OsPath -> IO () 72 | removePathAt ty dir (OsString path) = 73 | Posix.withFilePath path $ \ pPath -> do 74 | Posix.throwErrnoPathIfMinus1_ "unlinkat" path 75 | (c_unlinkat (fromMaybe c_AT_FDCWD dir) pPath flag) 76 | pure () 77 | where 78 | flag | fileTypeIsDirectory ty = (#const AT_REMOVEDIR) 79 | | otherwise = 0 80 | 81 | removePathInternal :: Bool -> OsPath -> IO () 82 | removePathInternal True = Posix.removeDirectory . getOsString 83 | removePathInternal False = Posix.removeLink . getOsString 84 | 85 | renamePathInternal :: OsPath -> OsPath -> IO () 86 | renamePathInternal (OsString p1) (OsString p2) = Posix.rename p1 p2 87 | 88 | -- On POSIX, the removability of a file is only affected by the attributes of 89 | -- the containing directory. 90 | filesAlwaysRemovable :: Bool 91 | filesAlwaysRemovable = True 92 | 93 | -- | On POSIX, equivalent to 'simplifyPosix'. 94 | simplify :: OsPath -> OsPath 95 | simplify = simplifyPosix 96 | 97 | -- we use the 'free' from the standard library here since it's not entirely 98 | -- clear whether Haskell's 'free' corresponds to the same one 99 | foreign import ccall unsafe "free" c_free :: Ptr a -> IO () 100 | 101 | c_PATH_MAX :: Maybe Int 102 | #ifdef PATH_MAX 103 | c_PATH_MAX | c_PATH_MAX' > toInteger maxValue = Nothing 104 | | otherwise = Just (fromInteger c_PATH_MAX') 105 | where c_PATH_MAX' = (#const PATH_MAX) 106 | maxValue = maxBound `asTypeInMaybe` c_PATH_MAX 107 | asTypeInMaybe :: a -> Maybe a -> a 108 | asTypeInMaybe = const 109 | #else 110 | c_PATH_MAX = Nothing 111 | #endif 112 | 113 | #if !defined(HAVE_REALPATH) 114 | 115 | c_realpath :: CString -> CString -> IO CString 116 | c_realpath _ _ = throwIO (mkIOError UnsupportedOperation "platform does not support realpath" Nothing Nothing) 117 | 118 | #else 119 | 120 | foreign import ccall "realpath" c_realpath :: CString -> CString -> IO CString 121 | 122 | #endif 123 | 124 | withRealpath :: CString -> (CString -> IO a) -> IO a 125 | withRealpath path action = case c_PATH_MAX of 126 | Nothing -> 127 | -- newer versions of POSIX support cases where the 2nd arg is NULL; 128 | -- hopefully that is the case here, as there is no safer way 129 | bracket (realpath nullPtr) c_free action 130 | Just pathMax -> 131 | -- allocate one extra just to be safe 132 | allocaBytes (pathMax + 1) (realpath >=> action) 133 | where realpath = throwErrnoIfNull "" . c_realpath path 134 | 135 | realPath :: OsPath -> IO OsPath 136 | realPath (OsString path') = 137 | Posix.withFilePath path' 138 | (`withRealpath` ((OsString <$>) . Posix.peekFilePath)) 139 | 140 | canonicalizePathSimplify :: OsPath -> IO OsPath 141 | canonicalizePathSimplify = pure 142 | 143 | findExecutablesLazyInternal :: ([OsPath] -> OsString -> ListT IO OsPath) 144 | -> OsString 145 | -> ListT IO OsPath 146 | findExecutablesLazyInternal findExecutablesInDirectoriesLazy binary = 147 | liftJoinListT $ do 148 | path <- getPath 149 | pure (findExecutablesInDirectoriesLazy path binary) 150 | 151 | getPath :: IO [OsPath] 152 | getPath = splitSearchPath <$> getEnvOs (os "PATH") 153 | 154 | exeExtensionInternal :: OsString 155 | exeExtensionInternal = exeExtension 156 | 157 | openDirFromFd :: Posix.Fd -> IO Posix.DirStream 158 | openDirFromFd fd = Posix.unsafeOpenDirStreamFd =<< Posix.dup fd 159 | 160 | readDirStreamToEnd :: Posix.DirStream -> IO [OsPath] 161 | readDirStreamToEnd stream = loop id 162 | where 163 | loop acc = do 164 | e <- Posix.readDirStream stream 165 | if e == mempty 166 | then pure (acc []) 167 | else loop (acc . (OsString e :)) 168 | 169 | readDirToEnd :: RawHandle -> IO [OsPath] 170 | readDirToEnd fd = 171 | bracket (openDirFromFd fd) Posix.closeDirStream readDirStreamToEnd 172 | 173 | getDirectoryContentsInternal :: OsPath -> IO [OsPath] 174 | getDirectoryContentsInternal (OsString path) = 175 | bracket (Posix.openDirStream path) Posix.closeDirStream readDirStreamToEnd 176 | 177 | getCurrentDirectoryInternal :: IO OsPath 178 | getCurrentDirectoryInternal = OsString <$> Posix.getWorkingDirectory 179 | 180 | -- | Convert a path into an absolute path. If the given path is relative, the 181 | -- current directory is prepended and the path may or may not be simplified. 182 | -- If the path is already absolute, the path is returned unchanged. The 183 | -- function preserves the presence or absence of the trailing path separator. 184 | -- 185 | -- If the path is already absolute, the operation never fails. Otherwise, the 186 | -- operation may throw exceptions. 187 | -- 188 | -- Empty paths are treated as the current directory. 189 | prependCurrentDirectory :: OsPath -> IO OsPath 190 | prependCurrentDirectory path 191 | | isRelative path = 192 | ((`ioeAddLocation` "prependCurrentDirectory") . 193 | (`ioeSetOsPath` path)) `modifyIOError` do 194 | ( path) <$> getCurrentDirectoryInternal 195 | | otherwise = pure path 196 | 197 | setCurrentDirectoryInternal :: OsPath -> IO () 198 | setCurrentDirectoryInternal = Posix.changeWorkingDirectory . getOsString 199 | 200 | linkToDirectoryIsDirectory :: Bool 201 | linkToDirectoryIsDirectory = False 202 | 203 | createHardLink :: OsPath -> OsPath -> IO () 204 | createHardLink (OsString p1) (OsString p2) = Posix.createLink p1 p2 205 | 206 | createSymbolicLink :: Bool -> OsPath -> OsPath -> IO () 207 | createSymbolicLink _ (OsString p1) (OsString p2) = 208 | Posix.createSymbolicLink p1 p2 209 | 210 | readSymbolicLink :: OsPath -> IO OsPath 211 | readSymbolicLink = (OsString <$>) . Posix.readSymbolicLink . getOsString 212 | 213 | type Metadata = Posix.FileStatus 214 | 215 | foreign import capi "sys/stat.h fstatat" c_fstatat 216 | :: Posix.Fd -> CString -> Ptr Posix.CStat -> CInt -> IO CInt 217 | 218 | getMetadataAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO Metadata 219 | getMetadataAt whetherFollow dir (OsString path) = 220 | Posix.withFilePath path $ \ pPath -> do 221 | stat <- mallocForeignPtrBytes (#const sizeof(struct stat)) 222 | withForeignPtr stat $ \ pStat -> do 223 | Posix.throwErrnoPathIfMinus1_ "fstatat" path $ do 224 | c_fstatat (fromMaybe c_AT_FDCWD dir) pPath pStat flags 225 | pure (Posix.FileStatus stat) 226 | where 227 | flags = atWhetherFollow whetherFollow 228 | 229 | getSymbolicLinkMetadata :: OsPath -> IO Metadata 230 | getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus . getOsString 231 | 232 | getFileMetadata :: OsPath -> IO Metadata 233 | getFileMetadata = Posix.getFileStatus . getOsString 234 | 235 | fileTypeFromMetadata :: Metadata -> FileType 236 | fileTypeFromMetadata stat 237 | | isLink = SymbolicLink 238 | | isDir = Directory 239 | | otherwise = File 240 | where 241 | isLink = Posix.isSymbolicLink stat 242 | isDir = Posix.isDirectory stat 243 | 244 | fileSizeFromMetadata :: Metadata -> Integer 245 | fileSizeFromMetadata = fromIntegral . Posix.fileSize 246 | 247 | accessTimeFromMetadata :: Metadata -> UTCTime 248 | accessTimeFromMetadata = 249 | POSIXTime.posixSecondsToUTCTime . Posix.accessTimeHiRes 250 | 251 | modificationTimeFromMetadata :: Metadata -> UTCTime 252 | modificationTimeFromMetadata = 253 | POSIXTime.posixSecondsToUTCTime . Posix.modificationTimeHiRes 254 | 255 | type Mode = Posix.FileMode 256 | 257 | modeFromMetadata :: Metadata -> Mode 258 | modeFromMetadata = Posix.fileMode 259 | 260 | allWriteMode :: Posix.FileMode 261 | allWriteMode = 262 | Posix.ownerWriteMode .|. 263 | Posix.groupWriteMode .|. 264 | Posix.otherWriteMode 265 | 266 | hasWriteMode :: Mode -> Bool 267 | hasWriteMode m = m .&. allWriteMode /= 0 268 | 269 | setWriteMode :: Bool -> Mode -> Mode 270 | setWriteMode False m = m .&. complement allWriteMode 271 | setWriteMode True m = m .|. allWriteMode 272 | 273 | setForceRemoveMode :: Mode -> Mode 274 | setForceRemoveMode m = m .|. Posix.ownerModes 275 | 276 | foreign import capi "sys/stat.h fchmodat" c_fchmodat 277 | :: Posix.Fd -> CString -> Posix.FileMode -> CInt -> IO CInt 278 | 279 | setModeAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> Mode -> IO () 280 | setModeAt whetherFollow dir (OsString path) mode = do 281 | Posix.withFilePath path $ \ pPath -> 282 | Posix.throwErrnoPathIfMinus1_ "fchmodat" path $ do 283 | c_fchmodat (fromMaybe c_AT_FDCWD dir) pPath mode flags 284 | where 285 | flags = atWhetherFollow whetherFollow 286 | 287 | setFileMode :: OsPath -> Mode -> IO () 288 | setFileMode = Posix.setFileMode . getOsString 289 | 290 | setFilePermissions :: OsPath -> Mode -> IO () 291 | setFilePermissions = setFileMode 292 | 293 | getAccessPermissions :: OsPath -> IO Permissions 294 | getAccessPermissions path = do 295 | m <- getFileMetadata path 296 | let isDir = fileTypeIsDirectory (fileTypeFromMetadata m) 297 | let OsString path' = path 298 | r <- Posix.fileAccess path' True False False 299 | w <- Posix.fileAccess path' False True False 300 | x <- Posix.fileAccess path' False False True 301 | pure Permissions 302 | { readable = r 303 | , writable = w 304 | , executable = x && not isDir 305 | , searchable = x && isDir 306 | } 307 | 308 | setAccessPermissions :: OsPath -> Permissions -> IO () 309 | setAccessPermissions path (Permissions r w e s) = do 310 | m <- getFileMetadata path 311 | setFileMode path (modifyBit (e || s) Posix.ownerExecuteMode . 312 | modifyBit w Posix.ownerWriteMode . 313 | modifyBit r Posix.ownerReadMode . 314 | modeFromMetadata $ m) 315 | where 316 | modifyBit :: Bool -> Posix.FileMode -> Posix.FileMode -> Posix.FileMode 317 | modifyBit False b m = m .&. complement b 318 | modifyBit True b m = m .|. b 319 | 320 | copyOwnerFromStatus :: Posix.FileStatus -> OsPath -> IO () 321 | copyOwnerFromStatus st (OsString dst) = do 322 | Posix.setOwnerAndGroup dst (Posix.fileOwner st) (-1) 323 | 324 | copyGroupFromStatus :: Posix.FileStatus -> OsPath -> IO () 325 | copyGroupFromStatus st (OsString dst) = do 326 | Posix.setOwnerAndGroup dst (-1) (Posix.fileGroup st) 327 | 328 | tryCopyOwnerAndGroupFromStatus :: Posix.FileStatus -> OsPath -> IO () 329 | tryCopyOwnerAndGroupFromStatus st dst = do 330 | ignoreIOExceptions (copyOwnerFromStatus st dst) 331 | ignoreIOExceptions (copyGroupFromStatus st dst) 332 | 333 | -- | Truncate the destination file and then copy the contents of the source 334 | -- file to the destination file. If the destination file already exists, its 335 | -- attributes shall remain unchanged. Otherwise, its attributes are reset to 336 | -- the defaults. 337 | copyFileContents :: OsPath -- ^ Source filename 338 | -> OsPath -- ^ Destination filename 339 | -> IO () 340 | copyFileContents fromFPath toFPath = 341 | (`ioeAddLocation` "copyFileContents") `modifyIOError` do 342 | withBinaryFile toFPath WriteMode $ \ hTo -> do 343 | withBinaryFile fromFPath ReadMode $ \ hFrom -> do 344 | copyHandleData hFrom hTo 345 | 346 | copyFileWithMetadataInternal :: (Metadata -> OsPath -> IO ()) 347 | -> (Metadata -> OsPath -> IO ()) 348 | -> OsPath 349 | -> OsPath 350 | -> IO () 351 | copyFileWithMetadataInternal copyPermissionsFromMetadata 352 | copyTimesFromMetadata 353 | src 354 | dst = do 355 | st <- Posix.getFileStatus (getOsString src) 356 | copyFileContents src dst 357 | tryCopyOwnerAndGroupFromStatus st dst 358 | copyPermissionsFromMetadata st dst 359 | copyTimesFromMetadata st dst 360 | 361 | setTimes :: OsPath -> (Maybe POSIXTime, Maybe POSIXTime) -> IO () 362 | #ifdef HAVE_UTIMENSAT 363 | setTimes (OsString path') (atime', mtime') = 364 | Posix.withFilePath path' $ \ path'' -> 365 | withArray [ maybe utimeOmit toCTimeSpec atime' 366 | , maybe utimeOmit toCTimeSpec mtime' ] $ \ times -> 367 | Posix.throwErrnoPathIfMinus1_ "" path' $ 368 | c_utimensat c_AT_FDCWD path'' times 0 369 | #else 370 | setTimes (OsString path') (Just atime', Just mtime') = 371 | Posix.setFileTimesHiRes path' atime' mtime' 372 | setTimes (OsString path') (atime', mtime') = do 373 | m <- getFileMetadata (OsString path') 374 | let atimeOld = accessTimeFromMetadata m 375 | let mtimeOld = modificationTimeFromMetadata m 376 | Posix.setFileTimesHiRes path' 377 | (fromMaybe (POSIXTime.utcTimeToPOSIXSeconds atimeOld) atime') 378 | (fromMaybe (POSIXTime.utcTimeToPOSIXSeconds mtimeOld) mtime') 379 | #endif 380 | 381 | lookupEnvOs :: OsString -> IO (Maybe OsString) 382 | lookupEnvOs (OsString name) = (OsString <$>) <$> Posix.getEnv name 383 | 384 | getEnvOs :: OsString -> IO OsString 385 | getEnvOs name = do 386 | env <- lookupEnvOs name 387 | case env of 388 | Nothing -> 389 | throwIO $ 390 | mkIOError 391 | doesNotExistErrorType 392 | ("env var " <> show name <> " not found") 393 | Nothing 394 | Nothing 395 | Just value -> pure value 396 | 397 | -- | $HOME is preferred, because the user has control over it. However, POSIX 398 | -- doesn't define it as a mandatory variable, so fall back to `getpwuid_r`. 399 | getHomeDirectoryInternal :: IO OsPath 400 | getHomeDirectoryInternal = do 401 | e <- lookupEnvOs (os "HOME") 402 | case e of 403 | Just fp -> pure fp 404 | Nothing -> 405 | OsPath.fromBytes . Posix.homeDirectory =<< 406 | Posix.getUserEntryForID =<< 407 | Posix.getEffectiveUserID 408 | 409 | getXdgDirectoryFallback :: IO OsPath -> XdgDirectory -> IO OsPath 410 | getXdgDirectoryFallback getHomeDirectory xdgDir = do 411 | (<$> getHomeDirectory) $ flip () $ case xdgDir of 412 | XdgData -> os ".local/share" 413 | XdgConfig -> os ".config" 414 | XdgCache -> os ".cache" 415 | XdgState -> os ".local/state" 416 | 417 | getXdgDirectoryListFallback :: XdgDirectoryList -> IO [OsPath] 418 | getXdgDirectoryListFallback xdgDirs = 419 | pure $ case xdgDirs of 420 | XdgDataDirs -> [os "/usr/local/share/", os "/usr/share/"] 421 | XdgConfigDirs -> [os "/etc/xdg"] 422 | 423 | getAppUserDataDirectoryInternal :: OsPath -> IO OsPath 424 | getAppUserDataDirectoryInternal appName = 425 | (\ home -> home <> (os "/" <> os "." <> appName)) <$> getHomeDirectoryInternal 426 | 427 | getUserDocumentsDirectoryInternal :: IO OsPath 428 | getUserDocumentsDirectoryInternal = getHomeDirectoryInternal 429 | 430 | getTemporaryDirectoryInternal :: IO OsPath 431 | getTemporaryDirectoryInternal = fromMaybe (os "/tmp") <$> lookupEnvOs (os "TMPDIR") 432 | 433 | #endif 434 | -------------------------------------------------------------------------------- /System/Directory/Internal/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -- | 3 | -- Stability: unstable 4 | -- Portability: portable 5 | -- 6 | -- Internal modules are always subject to change from version to version. 7 | 8 | module System.Directory.Internal.Prelude 9 | ( module Prelude 10 | , module Control.Arrow 11 | , module Control.Concurrent 12 | , module Control.Exception 13 | , module Control.Monad 14 | , module Data.Bits 15 | , module Data.Char 16 | , module Data.Foldable 17 | , module Data.Function 18 | , module Data.Maybe 19 | , module Data.Monoid 20 | , module Data.IORef 21 | , module Data.Traversable 22 | , module Foreign 23 | , module Foreign.C 24 | , module GHC.IO.Encoding 25 | , module GHC.IO.Exception 26 | , module System.Environment 27 | , module System.Exit 28 | , module System.IO 29 | , module System.IO.Error 30 | , module System.Posix.Types 31 | , module System.Timeout 32 | , Void 33 | ) where 34 | import Data.Void (Void) 35 | import Control.Arrow (second) 36 | import Control.Concurrent 37 | ( forkIO 38 | , killThread 39 | , newEmptyMVar 40 | , putMVar 41 | , readMVar 42 | , takeMVar 43 | , forkFinally 44 | ) 45 | import Control.Exception 46 | ( Exception(displayException) 47 | , SomeException 48 | , bracket 49 | , bracket_ 50 | , bracketOnError 51 | , catch 52 | , finally 53 | , mask 54 | , onException 55 | , throwIO 56 | , try 57 | ) 58 | import Control.Monad ((>=>), (<=<), unless, when, replicateM, replicateM_) 59 | import Data.Bits ((.&.), (.|.), complement) 60 | import Data.Char (isAlpha, isAscii, toLower, toUpper) 61 | import Data.Foldable (for_, sequenceA_) 62 | import Data.Function (on) 63 | import Data.Maybe (catMaybes, fromMaybe, maybeToList) 64 | import Data.Monoid ((<>), mconcat, mempty) 65 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 66 | import Data.Traversable (for) 67 | import Foreign 68 | ( Ptr 69 | , Storable 70 | ( alignment 71 | , peek 72 | , peekByteOff 73 | , peekElemOff 74 | , poke 75 | , pokeByteOff 76 | , pokeElemOff 77 | , sizeOf 78 | ) 79 | , alloca 80 | , allocaArray 81 | , allocaBytes 82 | , allocaBytesAligned 83 | , mallocForeignPtrBytes 84 | , maybeWith 85 | , nullPtr 86 | , plusPtr 87 | , with 88 | , withArray 89 | , withForeignPtr 90 | ) 91 | import Foreign.C 92 | ( CInt(..) 93 | , CLong(..) 94 | , CString 95 | , CTime(..) 96 | , CUChar(..) 97 | , CULong(..) 98 | , CUShort(..) 99 | , CWString 100 | , CWchar(..) 101 | , throwErrnoIfMinus1Retry_ 102 | , throwErrnoIfMinus1_ 103 | , throwErrnoIfNull 104 | ) 105 | import GHC.IO.Exception 106 | ( IOErrorType 107 | ( InappropriateType 108 | , InvalidArgument 109 | , OtherError 110 | , UnsupportedOperation 111 | ) 112 | ) 113 | import GHC.IO.Encoding (getFileSystemEncoding) 114 | import System.Environment (getArgs) 115 | import System.Exit (exitFailure) 116 | import System.IO 117 | ( Handle 118 | , IOMode(ReadMode, WriteMode) 119 | , hClose 120 | , hFlush 121 | , hGetBuf 122 | , hPutBuf 123 | , hPutStr 124 | , hPutStrLn 125 | , openBinaryTempFile 126 | , stderr 127 | , stdout 128 | ) 129 | import System.IO.Error 130 | ( IOError 131 | , catchIOError 132 | , doesNotExistErrorType 133 | , illegalOperationErrorType 134 | , ioeGetErrorString 135 | , ioeGetErrorType 136 | , ioeGetLocation 137 | , ioeSetErrorString 138 | , ioeSetFileName 139 | , ioeSetLocation 140 | , isAlreadyExistsError 141 | , isDoesNotExistError 142 | , isIllegalOperation 143 | , isPermissionError 144 | , mkIOError 145 | , modifyIOError 146 | , permissionErrorType 147 | , tryIOError 148 | , userError 149 | ) 150 | import System.Posix.Types (EpochTime) 151 | import System.Timeout (timeout) 152 | -------------------------------------------------------------------------------- /System/Directory/Internal/Windows.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module System.Directory.Internal.Windows where 3 | #include 4 | #if defined(mingw32_HOST_OS) 5 | ##if defined(i386_HOST_ARCH) 6 | ## define WINAPI stdcall 7 | ##elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) 8 | ## define WINAPI ccall 9 | ##else 10 | ## error unknown architecture 11 | ##endif 12 | #include 13 | #include 14 | #include 15 | #include 16 | import Prelude () 17 | import System.Directory.Internal.Prelude 18 | import System.Directory.Internal.Common 19 | import System.Directory.Internal.Config (exeExtension) 20 | import Data.Time (UTCTime) 21 | import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) 22 | #ifdef __IO_MANAGER_WINIO__ 23 | import GHC.IO.SubSystem (IoSubSystem(IoPOSIX, IoNative), ioSubSystem) 24 | #endif 25 | import System.OsPath 26 | ( () 27 | , isPathSeparator 28 | , isRelative 29 | , pack 30 | , pathSeparator 31 | , splitDirectories 32 | , splitSearchPath 33 | , takeExtension 34 | , toChar 35 | , unpack 36 | ) 37 | import System.OsPath.Types (WindowsPath, WindowsString) 38 | import System.OsString.Internal.Types (OsString(OsString, getOsString)) 39 | import qualified Data.List as List 40 | import qualified System.Win32.WindowsString.File as Win32 41 | import qualified System.Win32.WindowsString.Info as Win32 42 | import qualified System.Win32.WindowsString.Shell as Win32 43 | import qualified System.Win32.WindowsString.Time as Win32 44 | import qualified System.Win32.WindowsString.Types as Win32 45 | import qualified System.Win32.WindowsString.Console as Win32 46 | 47 | type RawHandle = OsPath 48 | 49 | pathAt :: Maybe RawHandle -> OsPath -> OsPath 50 | pathAt dir path = fromMaybe mempty dir path 51 | 52 | openRaw :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO RawHandle 53 | openRaw _ dir path = pure (pathAt dir path) 54 | 55 | closeRaw :: RawHandle -> IO () 56 | closeRaw _ = pure () 57 | 58 | lookupEnvOs :: OsString -> IO (Maybe OsString) 59 | lookupEnvOs (OsString name) = (OsString <$>) <$> Win32.getEnv name 60 | 61 | getEnvOs :: OsString -> IO OsString 62 | getEnvOs name = do 63 | env <- lookupEnvOs name 64 | case env of 65 | Nothing -> 66 | throwIO $ 67 | mkIOError 68 | doesNotExistErrorType 69 | ("env var " <> show name <> " not found") 70 | Nothing 71 | Nothing 72 | Just value -> pure value 73 | 74 | -- | Get the contents of the @PATH@ environment variable. 75 | getPath :: IO [OsPath] 76 | getPath = splitSearchPath <$> getEnvOs (os "PATH") 77 | 78 | createDirectoryInternal :: OsPath -> IO () 79 | createDirectoryInternal path = 80 | (`ioeSetOsPath` path) `modifyIOError` do 81 | path' <- furnishPath path 82 | Win32.createDirectory path' Nothing 83 | 84 | removePathAt :: FileType -> Maybe RawHandle -> OsPath -> IO () 85 | removePathAt ty dir path = removePathInternal isDir (pathAt dir path) 86 | where isDir = fileTypeIsDirectory ty 87 | 88 | removePathInternal :: Bool -> OsPath -> IO () 89 | removePathInternal isDir path = 90 | (`ioeSetOsPath` path) `modifyIOError` do 91 | furnishPath path 92 | >>= if isDir then Win32.removeDirectory else Win32.deleteFile 93 | 94 | renamePathInternal :: OsPath -> OsPath -> IO () 95 | renamePathInternal opath npath = 96 | (`ioeSetOsPath` opath) `modifyIOError` do 97 | opath' <- furnishPath opath 98 | npath' <- furnishPath npath 99 | Win32.moveFileEx opath' (Just npath') Win32.mOVEFILE_REPLACE_EXISTING 100 | 101 | -- On Windows, the removability of a file may be affected by the attributes of 102 | -- the file itself. 103 | filesAlwaysRemovable :: Bool 104 | filesAlwaysRemovable = False 105 | 106 | copyFileWithMetadataInternal :: (Metadata -> OsPath -> IO ()) 107 | -> (Metadata -> OsPath -> IO ()) 108 | -> OsPath 109 | -> OsPath 110 | -> IO () 111 | copyFileWithMetadataInternal _ _ src dst = 112 | (`ioeSetOsPath` src) `modifyIOError` do 113 | src' <- furnishPath src 114 | dst' <- furnishPath dst 115 | Win32.copyFile src' dst' False 116 | 117 | win32_cSIDL_COMMON_APPDATA :: Win32.CSIDL 118 | win32_cSIDL_COMMON_APPDATA = (#const CSIDL_COMMON_APPDATA) 119 | 120 | win32_eRROR_ENVVAR_NOT_FOUND :: Win32.ErrCode 121 | win32_eRROR_ENVVAR_NOT_FOUND = (#const ERROR_ENVVAR_NOT_FOUND) 122 | 123 | win32_eRROR_INVALID_FUNCTION :: Win32.ErrCode 124 | win32_eRROR_INVALID_FUNCTION = (#const ERROR_INVALID_FUNCTION) 125 | 126 | win32_eRROR_INVALID_PARAMETER :: Win32.ErrCode 127 | win32_eRROR_INVALID_PARAMETER = (#const ERROR_INVALID_PARAMETER) 128 | 129 | win32_eRROR_PRIVILEGE_NOT_HELD :: Win32.ErrCode 130 | win32_eRROR_PRIVILEGE_NOT_HELD = (#const ERROR_PRIVILEGE_NOT_HELD) 131 | 132 | win32_sYMBOLIC_LINK_FLAG_DIRECTORY :: Win32.DWORD 133 | win32_sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1 134 | 135 | win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE :: Win32.DWORD 136 | win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = 0x2 137 | 138 | maxShareMode :: Win32.ShareMode 139 | maxShareMode = 140 | Win32.fILE_SHARE_DELETE .|. 141 | Win32.fILE_SHARE_READ .|. 142 | Win32.fILE_SHARE_WRITE 143 | 144 | win32_getFinalPathNameByHandle :: Win32.HANDLE -> Win32.DWORD -> IO WindowsPath 145 | #ifdef HAVE_GETFINALPATHNAMEBYHANDLEW 146 | win32_getFinalPathNameByHandle h flags = do 147 | result <- peekTStringWith (#const MAX_PATH) $ \ ptr len -> do 148 | c_GetFinalPathNameByHandle h ptr len flags 149 | case result of 150 | Left errCode -> Win32.failWith "GetFinalPathNameByHandle" errCode 151 | Right path -> pure path 152 | 153 | foreign import WINAPI unsafe "windows.h GetFinalPathNameByHandleW" 154 | c_GetFinalPathNameByHandle 155 | :: Win32.HANDLE 156 | -> Ptr CWchar 157 | -> Win32.DWORD 158 | -> Win32.DWORD 159 | -> IO Win32.DWORD 160 | 161 | #else 162 | win32_getFinalPathNameByHandle _ _ = throwIO $ 163 | mkIOError 164 | UnsupportedOperation 165 | "platform does not support GetFinalPathNameByHandle" 166 | Nothing 167 | Nothing 168 | #endif 169 | 170 | getFinalPathName :: OsPath -> IO OsPath 171 | getFinalPathName = 172 | (fromExtendedLengthPath <$>) . 173 | rawGetFinalPathName . 174 | toExtendedLengthPath 175 | where 176 | #ifdef HAVE_GETFINALPATHNAMEBYHANDLEW 177 | rawGetFinalPathName path = do 178 | let open = Win32.createFile path 0 maxShareMode Nothing 179 | Win32.oPEN_EXISTING Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing 180 | bracket open Win32.closeHandle $ \ h -> do 181 | win32_getFinalPathNameByHandle h 0 182 | #else 183 | rawGetFinalPathName = Win32.getLongPathName <=< Win32.getShortPathName 184 | #endif 185 | 186 | win32_fILE_FLAG_OPEN_REPARSE_POINT :: Win32.FileAttributeOrFlag 187 | win32_fILE_FLAG_OPEN_REPARSE_POINT = 0x00200000 188 | 189 | win32_fSCTL_GET_REPARSE_POINT :: Win32.DWORD 190 | win32_fSCTL_GET_REPARSE_POINT = 0x900a8 191 | 192 | win32_iO_REPARSE_TAG_MOUNT_POINT, win32_iO_REPARSE_TAG_SYMLINK :: CULong 193 | win32_iO_REPARSE_TAG_MOUNT_POINT = (#const IO_REPARSE_TAG_MOUNT_POINT) 194 | win32_iO_REPARSE_TAG_SYMLINK = (#const IO_REPARSE_TAG_SYMLINK) 195 | 196 | win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE :: Win32.DWORD 197 | win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE = 198 | (#const MAXIMUM_REPARSE_DATA_BUFFER_SIZE) 199 | 200 | win32_sYMLINK_FLAG_RELATIVE :: CULong 201 | win32_sYMLINK_FLAG_RELATIVE = 0x00000001 202 | 203 | data Win32_REPARSE_DATA_BUFFER 204 | = Win32_MOUNT_POINT_REPARSE_DATA_BUFFER WindowsString WindowsString 205 | -- ^ substituteName printName 206 | | Win32_SYMLINK_REPARSE_DATA_BUFFER WindowsString WindowsString Bool 207 | -- ^ substituteName printName isRelative 208 | | Win32_GENERIC_REPARSE_DATA_BUFFER 209 | 210 | win32_alloca_REPARSE_DATA_BUFFER 211 | :: ((Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO a) -> IO a 212 | win32_alloca_REPARSE_DATA_BUFFER action = 213 | allocaBytesAligned size align $ \ ptr -> 214 | action (ptr, size) 215 | where size = fromIntegral win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE 216 | align = #{alignment HsDirectory_REPARSE_DATA_BUFFER} 217 | 218 | win32_peek_REPARSE_DATA_BUFFER 219 | :: Ptr Win32_REPARSE_DATA_BUFFER -> IO Win32_REPARSE_DATA_BUFFER 220 | win32_peek_REPARSE_DATA_BUFFER p = do 221 | tag <- #{peek HsDirectory_REPARSE_DATA_BUFFER, ReparseTag} p 222 | case () of 223 | _ | tag == win32_iO_REPARSE_TAG_MOUNT_POINT -> do 224 | let buf = #{ptr HsDirectory_REPARSE_DATA_BUFFER, 225 | MountPointReparseBuffer.PathBuffer} p 226 | sni <- #{peek HsDirectory_REPARSE_DATA_BUFFER, 227 | MountPointReparseBuffer.SubstituteNameOffset} p 228 | sns <- #{peek HsDirectory_REPARSE_DATA_BUFFER, 229 | MountPointReparseBuffer.SubstituteNameLength} p 230 | sn <- peekName buf sni sns 231 | pni <- #{peek HsDirectory_REPARSE_DATA_BUFFER, 232 | MountPointReparseBuffer.PrintNameOffset} p 233 | pns <- #{peek HsDirectory_REPARSE_DATA_BUFFER, 234 | MountPointReparseBuffer.PrintNameLength} p 235 | pn <- peekName buf pni pns 236 | pure (Win32_MOUNT_POINT_REPARSE_DATA_BUFFER sn pn) 237 | | tag == win32_iO_REPARSE_TAG_SYMLINK -> do 238 | let buf = #{ptr HsDirectory_REPARSE_DATA_BUFFER, 239 | SymbolicLinkReparseBuffer.PathBuffer} p 240 | sni <- #{peek HsDirectory_REPARSE_DATA_BUFFER, 241 | SymbolicLinkReparseBuffer.SubstituteNameOffset} p 242 | sns <- #{peek HsDirectory_REPARSE_DATA_BUFFER, 243 | SymbolicLinkReparseBuffer.SubstituteNameLength} p 244 | sn <- peekName buf sni sns 245 | pni <- #{peek HsDirectory_REPARSE_DATA_BUFFER, 246 | SymbolicLinkReparseBuffer.PrintNameOffset} p 247 | pns <- #{peek HsDirectory_REPARSE_DATA_BUFFER, 248 | SymbolicLinkReparseBuffer.PrintNameLength} p 249 | pn <- peekName buf pni pns 250 | flags <- #{peek HsDirectory_REPARSE_DATA_BUFFER, 251 | SymbolicLinkReparseBuffer.Flags} p 252 | pure (Win32_SYMLINK_REPARSE_DATA_BUFFER sn pn 253 | (flags .&. win32_sYMLINK_FLAG_RELATIVE /= 0)) 254 | | otherwise -> pure Win32_GENERIC_REPARSE_DATA_BUFFER 255 | where 256 | peekName :: Ptr CWchar -> CUShort -> CUShort -> IO WindowsString 257 | peekName buf offset size = 258 | Win32.peekTStringLen ( buf `plusPtr` fromIntegral offset 259 | , fromIntegral size `div` sizeOf (0 :: CWchar) ) 260 | 261 | deviceIoControl 262 | :: Win32.HANDLE 263 | -> Win32.DWORD 264 | -> (Ptr a, Int) 265 | -> (Ptr b, Int) 266 | -> Maybe Void 267 | -> IO (Either Win32.ErrCode Int) 268 | deviceIoControl h code (inPtr, inSize) (outPtr, outSize) _ = do 269 | with 0 $ \ lenPtr -> do 270 | ok <- c_DeviceIoControl h code inPtr (fromIntegral inSize) outPtr 271 | (fromIntegral outSize) lenPtr nullPtr 272 | if ok 273 | then Right . fromIntegral <$> peek lenPtr 274 | else Left <$> Win32.getLastError 275 | 276 | foreign import WINAPI unsafe "windows.h DeviceIoControl" 277 | c_DeviceIoControl 278 | :: Win32.HANDLE 279 | -> Win32.DWORD 280 | -> Ptr a 281 | -> Win32.DWORD 282 | -> Ptr b 283 | -> Win32.DWORD 284 | -> Ptr Win32.DWORD 285 | -> Ptr Void 286 | -> IO Win32.BOOL 287 | 288 | readSymbolicLink :: OsPath -> IO OsPath 289 | readSymbolicLink path = 290 | (`ioeSetOsPath` path) `modifyIOError` do 291 | path' <- furnishPath path 292 | let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING 293 | (Win32.fILE_FLAG_BACKUP_SEMANTICS .|. 294 | win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing 295 | bracket open Win32.closeHandle $ \ h -> do 296 | win32_alloca_REPARSE_DATA_BUFFER $ \ ptrAndSize@(ptr, _) -> do 297 | result <- deviceIoControl h win32_fSCTL_GET_REPARSE_POINT 298 | (nullPtr, 0) ptrAndSize Nothing 299 | case result of 300 | Left e | e == win32_eRROR_INVALID_FUNCTION -> do 301 | let msg = "Incorrect function. The file system " <> 302 | "might not support symbolic links." 303 | throwIO (mkIOError illegalOperationErrorType 304 | "DeviceIoControl" Nothing Nothing 305 | `ioeSetErrorString` msg) 306 | | otherwise -> Win32.failWith "DeviceIoControl" e 307 | Right _ -> pure () 308 | rData <- win32_peek_REPARSE_DATA_BUFFER ptr 309 | strip . OsString <$> case rData of 310 | Win32_MOUNT_POINT_REPARSE_DATA_BUFFER sn _ -> pure sn 311 | Win32_SYMLINK_REPARSE_DATA_BUFFER sn _ _ -> pure sn 312 | _ -> throwIO (mkIOError InappropriateType 313 | "readSymbolicLink" Nothing Nothing) 314 | where 315 | strip sn = 316 | fromMaybe sn 317 | (pack <$> List.stripPrefix (unpack (os "\\??\\")) (unpack sn)) 318 | 319 | -- | On Windows, equivalent to 'simplifyWindows'. 320 | simplify :: OsPath -> OsPath 321 | simplify = simplifyWindows 322 | 323 | -- | Normalise the path separators and prepend the @"\\\\?\\"@ prefix if 324 | -- necessary or possible. This is used for symbolic links targets because 325 | -- they can't handle forward slashes. 326 | normaliseSeparators :: OsPath -> WindowsPath 327 | normaliseSeparators path 328 | | isRelative path = getOsString (pack (normaliseSep <$> unpack path)) 329 | | otherwise = toExtendedLengthPath path 330 | where normaliseSep c = if isPathSeparator c then pathSeparator else c 331 | 332 | -- | 'simplify' the path and prepend the @"\\\\?\\"@ if possible. This 333 | -- function can sometimes be used to bypass the @MAX_PATH@ length restriction 334 | -- in Windows API calls. 335 | toExtendedLengthPath :: OsPath -> WindowsPath 336 | toExtendedLengthPath path = 337 | getOsString $ 338 | if isRelative path 339 | then simplifiedPath 340 | else 341 | case toChar <$> simplifiedPath' of 342 | '\\' : '?' : '?' : '\\' : _ -> simplifiedPath 343 | '\\' : '\\' : '?' : '\\' : _ -> simplifiedPath 344 | '\\' : '\\' : '.' : '\\' : _ -> simplifiedPath 345 | '\\' : '\\' : _ -> 346 | os "\\\\?\\UNC" <> pack (drop 1 simplifiedPath') 347 | _ -> os "\\\\?\\" <> simplifiedPath 348 | where simplifiedPath = simplify path 349 | simplifiedPath' = unpack simplifiedPath 350 | 351 | -- | Make a path absolute and convert to an extended length path, if possible. 352 | -- 353 | -- Empty paths are left unchanged. 354 | -- 355 | -- This function never fails. If it doesn't understand the path, it just 356 | -- returns the path unchanged. 357 | furnishPath :: OsPath -> IO WindowsPath 358 | furnishPath path = 359 | (toExtendedLengthPath <$> rawPrependCurrentDirectory path) 360 | `catchIOError` \ _ -> 361 | pure (getOsString path) 362 | 363 | -- | Strip the @"\\\\?\\"@ prefix if possible. 364 | -- The prefix is kept if the meaning of the path would otherwise change. 365 | fromExtendedLengthPath :: WindowsPath -> OsPath 366 | fromExtendedLengthPath ePath' = 367 | case unpack ePath of 368 | c1 : c2 : c3 : c4 : path 369 | | (toChar <$> [c1, c2, c3, c4]) == "\\\\?\\" -> 370 | case path of 371 | c5 : c6 : c7 : subpath@(c8 : _) 372 | | (toChar <$> [c5, c6, c7, c8]) == "UNC\\" -> 373 | pack (c8 : subpath) 374 | drive : col : subpath 375 | -- if the path is not "regular", then the prefix is necessary 376 | -- to ensure the path is interpreted literally 377 | | toChar col == ':', isDriveChar drive, isPathRegular subpath -> 378 | pack path 379 | _ -> ePath 380 | _ -> ePath 381 | where 382 | ePath = OsString ePath' 383 | isDriveChar drive = isAlpha (toChar drive) && isAscii (toChar drive) 384 | isPathRegular path = 385 | not ('/' `elem` (toChar <$> path) || 386 | os "." `elem` splitDirectories (pack path) || 387 | os ".." `elem` splitDirectories (pack path)) 388 | 389 | saturatingDouble :: Win32.DWORD -> Win32.DWORD 390 | saturatingDouble s | s > maxBound `div` 2 = maxBound 391 | | otherwise = s * 2 392 | 393 | -- Handles Windows APIs that write strings through a user-provided buffer and 394 | -- can propose a new length when it isn't big enough. This is similar to 395 | -- Win32.try, but also returns the precise error code. 396 | peekTStringWith :: Win32.DWORD 397 | -> (Win32.LPTSTR -> Win32.DWORD -> IO Win32.DWORD) 398 | -- ^ Must accept a buffer and its size in TCHARs. If the 399 | -- buffer is large enough for the function, it must write a 400 | -- string to it, which need not be null-terminated, and 401 | -- return the length of the string, not including the null 402 | -- terminator if present. If the buffer is too small, it 403 | -- must return a proposed buffer size in TCHARs, although it 404 | -- need not guarantee success with the proposed size if, 405 | -- say, the underlying data changes in the interim. If it 406 | -- fails for any other reason, it must return zero and 407 | -- communicate the error code through GetLastError. 408 | -> IO (Either Win32.ErrCode WindowsPath) 409 | peekTStringWith bufferSize cFunc = do 410 | outcome <- do 411 | allocaArray (fromIntegral bufferSize) $ \ ptr -> do 412 | size <- cFunc ptr bufferSize 413 | case size of 414 | 0 -> Right . Left <$> Win32.getLastError 415 | _ | size <= bufferSize -> 416 | Right . Right <$> Win32.peekTStringLen (ptr, fromIntegral size) 417 | | otherwise -> 418 | -- At least double the size to ensure fast termination. 419 | pure (Left (max size (saturatingDouble bufferSize))) 420 | case outcome of 421 | Left proposedSize -> peekTStringWith proposedSize cFunc 422 | Right result -> pure result 423 | 424 | realPath :: OsPath -> IO OsPath 425 | realPath = getFinalPathName 426 | 427 | canonicalizePathSimplify :: OsPath -> IO OsPath 428 | canonicalizePathSimplify path = 429 | getFullPathName path 430 | `catchIOError` \ _ -> 431 | pure path 432 | 433 | searchPathEnvForExes :: OsString -> IO (Maybe OsPath) 434 | searchPathEnvForExes (OsString binary) = search `catch` \e -> 435 | if ioeGetErrorType e == InvalidArgument 436 | then pure Nothing 437 | else throwIO e 438 | where 439 | search = (OsString <$>) <$> Win32.searchPath Nothing binary (Just (getOsString exeExtension)) 440 | 441 | findExecutablesLazyInternal :: ([OsPath] -> OsString -> ListT IO OsPath) 442 | -> OsString 443 | -> ListT IO OsPath 444 | findExecutablesLazyInternal _ = maybeToListT . searchPathEnvForExes 445 | 446 | exeExtensionInternal :: OsString 447 | exeExtensionInternal = exeExtension 448 | 449 | readDirToEnd :: RawHandle -> IO [OsPath] 450 | readDirToEnd = getDirectoryContentsInternal 451 | 452 | getDirectoryContentsInternal :: OsPath -> IO [OsPath] 453 | getDirectoryContentsInternal path = do 454 | query <- furnishPath (path os "*") 455 | bracket 456 | (Win32.findFirstFile query) 457 | (\ (h, _) -> Win32.findClose h) 458 | (\ (h, fdat) -> loop h fdat []) 459 | where 460 | -- we needn't worry about empty directories: a directory always 461 | -- has at least "." and ".." entries 462 | loop :: Win32.HANDLE -> Win32.FindData -> [OsPath] -> IO [OsPath] 463 | loop h fdat acc = do 464 | filename <- Win32.getFindDataFileName fdat 465 | more <- Win32.findNextFile h fdat 466 | if more 467 | then loop h fdat (OsString filename : acc) 468 | else pure (OsString filename : acc) 469 | -- no need to reverse, ordering is undefined 470 | 471 | getCurrentDirectoryInternal :: IO OsPath 472 | getCurrentDirectoryInternal = OsString <$> Win32.getCurrentDirectory 473 | 474 | getFullPathName :: OsPath -> IO OsPath 475 | getFullPathName path = 476 | fromExtendedLengthPath <$> Win32.getFullPathName (toExtendedLengthPath path) 477 | 478 | -- | Similar to 'prependCurrentDirectory' but fails for empty paths. 479 | rawPrependCurrentDirectory :: OsPath -> IO OsPath 480 | rawPrependCurrentDirectory path 481 | | isRelative path = 482 | ((`ioeAddLocation` "prependCurrentDirectory") . 483 | (`ioeSetOsPath` path)) `modifyIOError` do 484 | getFullPathName path 485 | | otherwise = pure path 486 | 487 | -- | Convert a path into an absolute path. If the given path is relative, the 488 | -- current directory is prepended and the path may or may not be simplified. 489 | -- If the path is already absolute, the path is returned unchanged. The 490 | -- function preserves the presence or absence of the trailing path separator. 491 | -- 492 | -- If the path is already absolute, the operation never fails. Otherwise, the 493 | -- operation may throw exceptions. 494 | -- 495 | -- Empty paths are treated as the current directory. 496 | prependCurrentDirectory :: OsPath -> IO OsPath 497 | prependCurrentDirectory = rawPrependCurrentDirectory . emptyToCurDir 498 | 499 | -- SetCurrentDirectory does not support long paths even with the \\?\ prefix 500 | -- https://ghc.haskell.org/trac/ghc/ticket/13373#comment:6 501 | setCurrentDirectoryInternal :: OsPath -> IO () 502 | setCurrentDirectoryInternal = Win32.setCurrentDirectory . getOsString 503 | 504 | createSymbolicLinkUnpriv :: WindowsPath -> WindowsPath -> Bool -> IO () 505 | createSymbolicLinkUnpriv link _target _isDir = 506 | #ifdef HAVE_CREATESYMBOLICLINKW 507 | Win32.withTString link $ \ pLink -> 508 | Win32.withTString _target $ \ pTarget -> do 509 | let flags = if _isDir then win32_sYMBOLIC_LINK_FLAG_DIRECTORY else 0 510 | call pLink pTarget flags win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE 511 | where 512 | call pLink pTarget flags unpriv = do 513 | status <- c_CreateSymbolicLink pLink pTarget (flags .|. unpriv) 514 | when (status == 0) $ do 515 | e <- Win32.getLastError 516 | case () of 517 | _ | e == win32_eRROR_INVALID_FUNCTION -> do 518 | let msg = "Incorrect function. The underlying file system " <> 519 | "might not support symbolic links." 520 | throwIO (mkIOError illegalOperationErrorType 521 | "CreateSymbolicLink" Nothing Nothing 522 | `ioeSetOsPath` OsString link 523 | `ioeSetErrorString` msg) 524 | | e == win32_eRROR_PRIVILEGE_NOT_HELD -> do 525 | let msg = "A required privilege is not held by the client. " <> 526 | "Creating symbolic links usually requires " <> 527 | "administrative rights." 528 | throwIO (mkIOError permissionErrorType "CreateSymbolicLink" 529 | Nothing Nothing 530 | `ioeSetOsPath` OsString link 531 | `ioeSetErrorString` msg) 532 | | e == win32_eRROR_INVALID_PARAMETER && 533 | unpriv /= 0 -> 534 | -- for compatibility with older versions of Windows, 535 | -- try it again without the flag 536 | call pLink pTarget flags 0 537 | | otherwise -> Win32.failWith "CreateSymbolicLink" e 538 | 539 | foreign import WINAPI unsafe "windows.h CreateSymbolicLinkW" 540 | c_CreateSymbolicLink 541 | :: Ptr CWchar -> Ptr CWchar -> Win32.DWORD -> IO Win32.BYTE 542 | 543 | #else 544 | throwIO . (`ioeSetErrorString` unsupportedErrorMsg) 545 | . (`ioeSetOsPath` OsString link) $ 546 | mkIOError UnsupportedOperation "CreateSymbolicLink" 547 | Nothing Nothing 548 | where unsupportedErrorMsg = "Not supported on Windows XP or older" 549 | #endif 550 | 551 | linkToDirectoryIsDirectory :: Bool 552 | linkToDirectoryIsDirectory = True 553 | 554 | createSymbolicLink :: Bool -> OsPath -> OsPath -> IO () 555 | createSymbolicLink isDir target link = 556 | (`ioeSetOsPath` link) `modifyIOError` do 557 | -- normaliseSeparators ensures the target gets normalised properly 558 | link' <- furnishPath link 559 | createSymbolicLinkUnpriv 560 | link' 561 | (normaliseSeparators target) 562 | isDir 563 | 564 | type Metadata = Win32.BY_HANDLE_FILE_INFORMATION 565 | 566 | getMetadataAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO Metadata 567 | getMetadataAt NoFollow dir path = getSymbolicLinkMetadata (pathAt dir path) 568 | getMetadataAt FollowLinks dir path = getFileMetadata (pathAt dir path) 569 | 570 | getSymbolicLinkMetadata :: OsPath -> IO Metadata 571 | getSymbolicLinkMetadata path = 572 | (`ioeSetOsPath` path) `modifyIOError` do 573 | path' <- furnishPath path 574 | let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING 575 | (Win32.fILE_FLAG_BACKUP_SEMANTICS .|. 576 | win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing 577 | bracket open Win32.closeHandle $ \ h -> do 578 | Win32.getFileInformationByHandle h 579 | 580 | getFileMetadata :: OsPath -> IO Metadata 581 | getFileMetadata path = 582 | (`ioeSetOsPath` path) `modifyIOError` do 583 | path' <- furnishPath path 584 | let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING 585 | Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing 586 | bracket open Win32.closeHandle $ \ h -> do 587 | Win32.getFileInformationByHandle h 588 | 589 | fileTypeFromMetadata :: Metadata -> FileType 590 | fileTypeFromMetadata info 591 | | isLink = if isDir then DirectoryLink else SymbolicLink 592 | | isDir = Directory 593 | | otherwise = File 594 | where 595 | isLink = attrs .&. Win32.fILE_ATTRIBUTE_REPARSE_POINT /= 0 596 | isDir = attrs .&. Win32.fILE_ATTRIBUTE_DIRECTORY /= 0 597 | attrs = Win32.bhfiFileAttributes info 598 | 599 | fileSizeFromMetadata :: Metadata -> Integer 600 | fileSizeFromMetadata = fromIntegral . Win32.bhfiSize 601 | 602 | accessTimeFromMetadata :: Metadata -> UTCTime 603 | accessTimeFromMetadata = 604 | posixSecondsToUTCTime . windowsToPosixTime . Win32.bhfiLastAccessTime 605 | 606 | modificationTimeFromMetadata :: Metadata -> UTCTime 607 | modificationTimeFromMetadata = 608 | posixSecondsToUTCTime . windowsToPosixTime . Win32.bhfiLastWriteTime 609 | 610 | -- | Difference between the Windows and POSIX epochs in units of 100ns. 611 | windowsPosixEpochDifference :: Num a => a 612 | windowsPosixEpochDifference = 116444736000000000 613 | 614 | -- | Convert from Windows time to POSIX time. 615 | windowsToPosixTime :: Win32.FILETIME -> POSIXTime 616 | windowsToPosixTime (Win32.FILETIME t) = 617 | (fromIntegral t - windowsPosixEpochDifference) / 10000000 618 | 619 | -- | Convert from POSIX time to Windows time. This is lossy as Windows time 620 | -- has a resolution of only 100ns. 621 | posixToWindowsTime :: POSIXTime -> Win32.FILETIME 622 | posixToWindowsTime t = Win32.FILETIME $ 623 | truncate (t * 10000000 + windowsPosixEpochDifference) 624 | 625 | setTimes :: OsPath -> (Maybe POSIXTime, Maybe POSIXTime) -> IO () 626 | setTimes path' (atime', mtime') = 627 | bracket (openFileHandle path' Win32.gENERIC_WRITE) 628 | Win32.closeHandle $ \ handle -> 629 | Win32.setFileTime handle Nothing (posixToWindowsTime <$> atime') (posixToWindowsTime <$> mtime') 630 | 631 | -- | Open the handle of an existing file or directory. 632 | openFileHandle :: OsString -> Win32.AccessMode -> IO Win32.HANDLE 633 | openFileHandle path mode = 634 | (`ioeSetOsPath` path) `modifyIOError` do 635 | path' <- furnishPath path 636 | Win32.createFile path' mode maxShareMode Nothing 637 | Win32.oPEN_EXISTING flags Nothing 638 | where flags = Win32.fILE_ATTRIBUTE_NORMAL 639 | .|. Win32.fILE_FLAG_BACKUP_SEMANTICS -- required for directories 640 | 641 | type Mode = Win32.FileAttributeOrFlag 642 | 643 | modeFromMetadata :: Metadata -> Mode 644 | modeFromMetadata = Win32.bhfiFileAttributes 645 | 646 | hasWriteMode :: Mode -> Bool 647 | hasWriteMode m = m .&. Win32.fILE_ATTRIBUTE_READONLY == 0 648 | 649 | setWriteMode :: Bool -> Mode -> Mode 650 | setWriteMode False m = m .|. Win32.fILE_ATTRIBUTE_READONLY 651 | setWriteMode True m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY 652 | 653 | setForceRemoveMode :: Mode -> Mode 654 | setForceRemoveMode m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY 655 | 656 | setModeAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> Mode -> IO () 657 | setModeAt _ dir path = setFileMode (pathAt dir path) 658 | 659 | setFileMode :: OsPath -> Mode -> IO () 660 | setFileMode path mode = 661 | (`ioeSetOsPath` path) `modifyIOError` do 662 | path' <- furnishPath path 663 | Win32.setFileAttributes path' mode 664 | 665 | -- | A restricted form of 'setFileMode' that only sets the permission bits. 666 | -- For Windows, this means only the "read-only" attribute is affected. 667 | setFilePermissions :: OsPath -> Mode -> IO () 668 | setFilePermissions path m = do 669 | m' <- modeFromMetadata <$> getFileMetadata path 670 | setFileMode path ((m' .&. complement Win32.fILE_ATTRIBUTE_READONLY) .|. 671 | (m .&. Win32.fILE_ATTRIBUTE_READONLY)) 672 | 673 | getAccessPermissions :: OsPath -> IO Permissions 674 | getAccessPermissions path = do 675 | m <- getFileMetadata path 676 | let isDir = fileTypeIsDirectory (fileTypeFromMetadata m) 677 | let w = hasWriteMode (modeFromMetadata m) 678 | let x = (toLower . toChar <$> unpack (takeExtension path)) 679 | `elem` [".bat", ".cmd", ".com", ".exe"] 680 | pure Permissions 681 | { readable = True 682 | , writable = w 683 | , executable = x && not isDir 684 | , searchable = isDir 685 | } 686 | 687 | setAccessPermissions :: OsPath -> Permissions -> IO () 688 | setAccessPermissions path Permissions{writable = w} = do 689 | setFilePermissions path (setWriteMode w 0) 690 | 691 | getFolderPath :: Win32.CSIDL -> IO OsPath 692 | getFolderPath what = OsString <$> Win32.sHGetFolderPath nullPtr what nullPtr 0 693 | 694 | getHomeDirectoryInternal :: IO OsPath 695 | getHomeDirectoryInternal = 696 | getFolderPath Win32.cSIDL_PROFILE `catchIOError` \ _ -> 697 | getFolderPath Win32.cSIDL_WINDOWS 698 | 699 | getXdgDirectoryFallback :: IO OsPath -> XdgDirectory -> IO OsPath 700 | getXdgDirectoryFallback _ xdgDir = do 701 | case xdgDir of 702 | XdgData -> getFolderPath Win32.cSIDL_APPDATA 703 | XdgConfig -> getFolderPath Win32.cSIDL_APPDATA 704 | XdgCache -> getFolderPath Win32.cSIDL_LOCAL_APPDATA 705 | XdgState -> getFolderPath Win32.cSIDL_LOCAL_APPDATA 706 | 707 | getXdgDirectoryListFallback :: XdgDirectoryList -> IO [OsPath] 708 | getXdgDirectoryListFallback _ = 709 | pure <$> getFolderPath win32_cSIDL_COMMON_APPDATA 710 | 711 | getAppUserDataDirectoryInternal :: OsPath -> IO OsPath 712 | getAppUserDataDirectoryInternal appName = 713 | (\ appData -> appData <> (os "\\" <> appName)) 714 | <$> getXdgDirectoryFallback getHomeDirectoryInternal XdgData 715 | 716 | getUserDocumentsDirectoryInternal :: IO OsPath 717 | getUserDocumentsDirectoryInternal = getFolderPath Win32.cSIDL_PERSONAL 718 | 719 | getTemporaryDirectoryInternal :: IO OsPath 720 | getTemporaryDirectoryInternal = OsString <$> Win32.getTemporaryDirectory 721 | 722 | #endif 723 | -------------------------------------------------------------------------------- /System/Directory/Internal/windows_ext.h: -------------------------------------------------------------------------------- 1 | #ifndef HS_DIRECTORY_WINDOWS_EXT_H 2 | #define HS_DIRECTORY_WINDOWS_EXT_H 3 | #include 4 | 5 | // define prototype to get size, offsets, and alignments 6 | // (can't include because that only exists in WDK) 7 | typedef struct { 8 | ULONG ReparseTag; 9 | USHORT ReparseDataLength; 10 | USHORT Reserved; 11 | union { 12 | struct { 13 | USHORT SubstituteNameOffset; 14 | USHORT SubstituteNameLength; 15 | USHORT PrintNameOffset; 16 | USHORT PrintNameLength; 17 | ULONG Flags; 18 | WCHAR PathBuffer[1]; 19 | } SymbolicLinkReparseBuffer; 20 | struct { 21 | USHORT SubstituteNameOffset; 22 | USHORT SubstituteNameLength; 23 | USHORT PrintNameOffset; 24 | USHORT PrintNameLength; 25 | WCHAR PathBuffer[1]; 26 | } MountPointReparseBuffer; 27 | struct { 28 | UCHAR DataBuffer[1]; 29 | } GenericReparseBuffer; 30 | }; 31 | } HsDirectory_REPARSE_DATA_BUFFER; 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | Changelog for the [`directory`][1] package 2 | ========================================== 3 | 4 | ## 1.3.10.0 (XXX 2025) 5 | 6 | * Add `getExecSearchPath` as replacement for 7 | `System.FilePath.getSearchPath`. 8 | ([#198](https://github.com/haskell/directory/pull/198)) 9 | 10 | ## 1.3.9.0 (Oct 2024) 11 | 12 | * Rely on `file-io` for file I/O. 13 | * Drop support for `base` older than 4.12.0. 14 | * Resolve TOCTOU issue with `removeDirectoryRecursive` and 15 | `removePathForcibly` on POSIX systems. 16 | (part of [#97](https://github.com/haskell/directory/issues/97)) 17 | * `findExecutable ""` now returns `Nothing`, matching non-Windows systems 18 | ([#180](https://github.com/haskell/directory/issues/180)) 19 | 20 | ## 1.3.8.5 (May 2024) 21 | 22 | * Fix regression that causes copying of nonexistent files to create empty 23 | files. 24 | ([#177](https://github.com/haskell/directory/issues/177)) 25 | 26 | ## 1.3.8.4 (Apr 2024) 27 | 28 | * Relax `time` version bounds to support 1.14. 29 | ([#171](https://github.com/haskell/directory/issues/171)) 30 | * Relax `base` version bounds to support 4.20. 31 | ([#173](https://github.com/haskell/directory/issues/173)) 32 | * Relax `filepath` version bounds to support 1.4.300 when `os-string` is 33 | unavailable. 34 | ([#175](https://github.com/haskell/directory/issues/175)) 35 | 36 | ## 1.3.8.3 (Jan 2024) 37 | 38 | * Relax `Win32` version bounds to support 2.14.0.0. 39 | ([#166](https://github.com/haskell/directory/issues/166)) 40 | * Fix regression in `canonicalizePath` on Windows UNC paths. 41 | ([#170](https://github.com/haskell/directory/issues/170)) 42 | 43 | ## 1.3.8.2 (Dec 2023) 44 | 45 | * Relax `base` version bounds to support 4.19. 46 | ([#157](https://github.com/haskell/directory/pull/157)) 47 | * Support filepath >= 1.5.0.0 and os-string. 48 | ([#164](https://github.com/haskell/directory/issues/164)) 49 | 50 | ## 1.3.8.1 (Feb 2023) 51 | 52 | * Use CApiFFI for utimensat. 53 | ([#145](https://github.com/haskell/directory/pull/145)) 54 | * Relax `base` version bounds to support 4.18. 55 | ([#151](https://github.com/haskell/directory/pull/151)) 56 | 57 | ## 1.3.8.0 (Sep 2022) 58 | 59 | * Drop support for `base` older than 4.11.0. 60 | * Drop support for `filepath` older than 1.4.100. 61 | * Drop support for `time` older than 1.8.0. 62 | * Drop support for `unix` older than 2.8.0. 63 | * Drop support for `Win32` older than 2.13.3. 64 | * Modules in `directory` are no longer considered 65 | [Safe](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/safe_haskell.html) 66 | because the `System.OsPath` dependency is no longer Safe. 67 | * A new module, `System.Directory.OsPath`, has been introduced to support 68 | AFPP (`OsPath` and `OsString`) with an analogous API. The old module, 69 | `System.Directory`, shall be in maintenance mode as new features will no 70 | longer be accepted there. 71 | ([#136](https://github.com/haskell/directory/pull/136)) 72 | * `removePathForcibly` no longer changes permissions of files on non-Windows 73 | systems. ([#135](https://github.com/haskell/directory/issues/135)) 74 | 75 | ## 1.3.7.1 (Jul 2022) 76 | 77 | * Relax `time` version bounds to support 1.12. 78 | * Relax `Win32` version bounds to support 2.13. 79 | * Relax `base` version bounds to support 4.17. 80 | 81 | ## 1.3.7.0 (Sep 2021) 82 | 83 | * `getXdgDirectory` now supports `XdgState` (`XDG_STATE_HOME`). 84 | ([#121](https://github.com/haskell/directory/pull/121)) 85 | 86 | ## 1.3.6.2 (May 2021) 87 | 88 | * Relax `Win32` version bounds to support 2.11. 89 | * Relax `time` version bounds to support 1.11. 90 | * Relax `base` version bounds to support 4.16. 91 | 92 | ## 1.3.6.1 (March 2020) 93 | 94 | * Relax `time` version bounds to support 1.10. 95 | 96 | ## 1.3.6.0 (January 2020) 97 | 98 | * On non-Windows platforms, `getHomeDirectory` will fall back to 99 | `getpwuid_r` if `HOME` is not set. 100 | ([#102](https://github.com/haskell/directory/issues/102)) 101 | 102 | ## 1.3.5.0 (December 2019) 103 | 104 | * Revert change introduced in the version `1.3.3.2`: Non-absolute `XDG_*` 105 | environment variables are ignored. This behavior is according to 106 | [*XDG Base Directory Specification* version 0.7](https://specifications.freedesktop.org/basedir-spec/0.7/ar01s02.html) 107 | ([#100](https://github.com/haskell/directory/issues/100)) 108 | 109 | ## 1.3.4.0 (July 2019) 110 | 111 | * `getXdgDirectory` and `getXdgDirectoryList` on Windows will now respect 112 | the XDG environment variables if present. 113 | ([#95](https://github.com/haskell/directory/issues/95)) 114 | 115 | ## 1.3.3.2 (January 2019) 116 | 117 | * `getXdgDirectory` will no longer reject environment variables containing 118 | relative paths. 119 | ([#87](https://github.com/haskell/directory/issues/87)) 120 | 121 | ## 1.3.3.1 (August 2018) 122 | 123 | * `doesDirectoryExist` and `doesPathExist` reject empty paths once again, 124 | reversing an undocumented change introduced in 1.3.1.1. 125 | ([#84](https://github.com/haskell/directory/issues/84)) 126 | 127 | ## 1.3.3.0 (June 2018) 128 | 129 | * Relax `unix` version bounds to support 2.8. 130 | 131 | * Relax `Win32` version bounds to support 2.8. 132 | 133 | * Use `SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE` when creating symbolic 134 | links on Windows, if possible. 135 | ([#83](https://github.com/haskell/directory/issues/83)) 136 | 137 | ## 1.3.2.2 (April 2018) 138 | 139 | * Relax `base` version bounds to support 4.12. 140 | 141 | ## 1.3.2.1 (March 2018) 142 | 143 | * Relax `Win32` version bounds to support 2.7. 144 | 145 | ## 1.3.2.0 (January 2018) 146 | 147 | * Relax `time` version bounds to support 1.9. 148 | 149 | * Implement `getXdgDirectoryList` and `XdgDirectoryList`. 150 | ([#78](https://github.com/haskell/directory/issues/78)) 151 | 152 | ## 1.3.1.5 (October 2017) 153 | 154 | * Rename the internal header `windows.h` to avoid GHC#14312. 155 | ([#77](https://github.com/haskell/directory/issues/77)) 156 | 157 | ## 1.3.1.4 (September 2017) 158 | 159 | * Fix `Win32` version 2.6 compatibility. 160 | ([#75](https://github.com/haskell/directory/pull/75)) 161 | 162 | ## 1.3.1.3 (September 2017) 163 | 164 | * Relax `Win32` version bounds to support 2.6. 165 | 166 | ## 1.3.1.2 (September 2017) 167 | 168 | * Relax `base` version bounds to support 4.11. 169 | ([#74](https://github.com/haskell/directory/pull/74)) 170 | 171 | ## 1.3.1.1 (March 2017) 172 | 173 | * Fix a bug where `createFileLink` and `createDirectoryLink` failed to 174 | handle `..` in absolute paths. 175 | 176 | * Improve support (partially) for paths longer than 260 characters on 177 | Windows. To achieve this, many functions will now automatically prepend 178 | `\\?\` before calling the Windows API. As a side effect, the `\\?\` 179 | prefix may show up in the error messages of the affected functions. 180 | 181 | * `makeAbsolute` can now handle drive-relative paths on Windows such as 182 | `C:foobar` 183 | 184 | ## 1.3.1.0 (March 2017) 185 | 186 | * `findFile` (and similar functions): when an absolute path is given, the 187 | list of search directories is now completely ignored. Previously, if the 188 | list was empty, `findFile` would always fail. 189 | ([#72](https://github.com/haskell/directory/issues/72)) 190 | 191 | * For symbolic links on Windows, the following functions had previously 192 | interpreted paths as referring to the links themselves rather than their 193 | targets. This was inconsistent with other platforms and has been fixed. 194 | * `getFileSize` 195 | * `doesPathExist` 196 | * `doesDirectoryExist` 197 | * `doesFileExist` 198 | 199 | * Fix incorrect location info in errors from `pathIsSymbolicLink`. 200 | 201 | * Add functions for symbolic link manipulation: 202 | * `createFileLink` 203 | * `createDirectoryLink` 204 | * `removeDirectoryLink` 205 | * `getSymbolicLinkTarget` 206 | 207 | * `canonicalizePath` can now resolve broken symbolic links too. 208 | ([#64](https://github.com/haskell/directory/issues/64)) 209 | 210 | ## 1.3.0.2 (February 2017) 211 | 212 | * [optimization] Increase internal buffer size of `copyFile` 213 | ([#69](https://github.com/haskell/directory/pull/69)) 214 | 215 | * Relax `time` version bounds to support 1.8. 216 | 217 | ## 1.3.0.1 (January 2017) 218 | 219 | * Relax `Win32` version bounds to support 2.5. 220 | ([#67](https://github.com/haskell/directory/pull/67)) 221 | 222 | ## 1.3.0.0 (December 2016) 223 | 224 | * **[breaking]** Drop trailing slashes in `canonicalizePath` 225 | ([#63](https://github.com/haskell/directory/issues/63)) 226 | 227 | * **[deprecation]** Rename `isSymbolicLink` to `pathIsSymbolicLink`. The 228 | old name will remain available but may be removed in the next major 229 | release. 230 | ([#52](https://github.com/haskell/directory/issues/52)) 231 | 232 | * Changed `canonicalizePath` to dereference symbolic links even if it points 233 | to a file and is not the last path segment 234 | 235 | * On Windows, `canonicalizePath` now canonicalizes the letter case too 236 | 237 | * On Windows, `canonicalizePath` now also dereferences symbolic links 238 | 239 | * When exceptions are thrown, the error location will now contain additional 240 | information about the internal function(s) used. 241 | 242 | ## 1.2.7.1 (November 2016) 243 | 244 | * Don't abort `removePathForcibly` if files or directories go missing. 245 | In addition, keep going even if an exception occurs. 246 | ([#60](https://github.com/haskell/directory/issues/60)) 247 | 248 | ## 1.2.7.0 (August 2016) 249 | 250 | * Remove deprecated C bits. This means `HsDirectory.h` and its functions 251 | are no longer available. 252 | ([#50](https://github.com/haskell/directory/issues/50)) 253 | 254 | * Add `doesPathExist` and `getFileSize` 255 | ([#57](https://github.com/haskell/directory/issues/57)) 256 | 257 | * Add `renamePath` 258 | ([#58](https://github.com/haskell/directory/issues/58)) 259 | 260 | * Add `removePathForcibly` 261 | ([#59](https://github.com/haskell/directory/issues/59)) 262 | 263 | ## 1.2.6.3 (May 2016) 264 | 265 | * Add missing import of `(<*>)` on Windows for `base` earlier than 4.8.0.0 266 | ([#53](https://github.com/haskell/directory/issues/53)) 267 | 268 | ## 1.2.6.2 (April 2016) 269 | 270 | * Bundled with GHC 8.0.1 271 | 272 | * Fix typo in file time functions when `utimensat` is not available and 273 | version of `unix` package is lower than 2.7.0.0 274 | 275 | ## 1.2.6.1 (April 2016) 276 | 277 | * Fix mistake in file time functions when `utimensat` is not available 278 | ([#47](https://github.com/haskell/directory/pull/47)) 279 | 280 | ## 1.2.6.0 (April 2016) 281 | 282 | * Make `findExecutable`, `findExecutables`, `findExecutablesInDirectories`, 283 | `findFile`, and `findFilesWith` lazier 284 | ([#43](https://github.com/haskell/directory/issues/43)) 285 | 286 | * Add `findFileWith` 287 | 288 | * Add `copyFileWithMetadata`, which copies additional metadata 289 | ([#40](https://github.com/haskell/directory/issues/40)) 290 | 291 | * Improve error message of `removeDirectoryRecursive` when used on a 292 | directory symbolic link on Windows. 293 | 294 | * Add `isSymbolicLink` 295 | 296 | * Drop support for Hugs. 297 | 298 | ## 1.2.5.1 (February 2016) 299 | 300 | * Improve error message of `getCurrentDirectory` when the current working 301 | directory no longer exists 302 | ([#39](https://github.com/haskell/directory/issues/39)) 303 | 304 | * Fix the behavior of trailing path separators in `canonicalizePath` as well 305 | as `makeAbsolute` when applied to the current directory; they should now 306 | match the behavior of `canonicalizePath` prior to 1.2.3.0 (when the bug 307 | was introduced) 308 | ([#42](https://github.com/haskell/directory/issues/42)) 309 | 310 | * Set the location in IO errors from `makeAbsolute`. 311 | 312 | ## 1.2.5.0 (December 2015) 313 | 314 | * Add `listDirectory`, which is similar to `getDirectoryContents` 315 | but omits `.` and `..` 316 | ([#36](https://github.com/haskell/directory/pull/36)) 317 | 318 | * Remove support for `--with-cc=` in `configure`; use the `CC=` flag instead 319 | ([ghc:D1608](https://phabricator.haskell.org/D1608)) 320 | 321 | ## 1.2.4.0 (September 2015) 322 | 323 | * Work around lack of `#const_str` when cross-compiling 324 | ([haskell-cafe](F7D)) 325 | 326 | * Add `findExecutablesInDirectories` 327 | ([#33](https://github.com/haskell/directory/pull/33)) 328 | 329 | * Add `exeExtension` 330 | 331 | [F7D]: https://mail.haskell.org/pipermail/haskell-cafe/2015-August/120892.html 332 | 333 | ## 1.2.3.1 (August 2015) 334 | 335 | * Restore support for Safe Haskell with base < 4.8 336 | ([#30](https://github.com/haskell/directory/issues/30)) 337 | 338 | ## 1.2.3.0 (July 2015) 339 | 340 | * Add support for XDG Base Directory Specification 341 | ([#6](https://github.com/haskell/directory/issues/6)) 342 | 343 | * Implement `setModificationTime` counterpart to `getModificationTime` 344 | ([#13](https://github.com/haskell/directory/issues/13)) 345 | 346 | * Implement `getAccessTime` and `setAccessTime` 347 | 348 | * Set the filename in IO errors from the file time functions 349 | 350 | * Fix `canonicalizePath` so that it always returns a reasonable result even 351 | if the path is inaccessible and will not throw exceptions unless the 352 | current directory cannot be obtained 353 | ([#23](https://github.com/haskell/directory/issues/23)) 354 | 355 | * Corrected the trailing slash behavior of `makeAbsolute` 356 | so that `makeAbsolute "" == makeAbsolute "."` 357 | 358 | * Deprecate use of `HsDirectory.h` and `HsDirectoryConfig.h` 359 | 360 | * Implement `withCurrentDirectory` 361 | 362 | ## 1.2.2.1 (Apr 2015) 363 | 364 | * Fix dependency problem on NixOS when building with tests 365 | ([#24](https://github.com/haskell/directory/issues/24)) 366 | 367 | ## 1.2.2.0 (Mar 2015) 368 | 369 | * Bundled with GHC 7.10.1 370 | 371 | * Make `getModificationTime` support sub-second resolution on Windows 372 | 373 | * Fix silent failure in `createDirectoryIfMissing` 374 | 375 | * Replace `throw` by better defined `throwIO`s 376 | 377 | * Avoid stack overflow in `getDirectoryContents` 378 | ([#17](https://github.com/haskell/directory/pull/17)) 379 | 380 | * Expose `findExecutables` 381 | ([#14](https://github.com/haskell/directory/issues/14)) 382 | 383 | * `removeDirectoryRecursive` no longer follows symlinks under any 384 | circumstances 385 | ([#15](https://github.com/haskell/directory/issues/15)) 386 | 387 | * Allow trailing path separators in `getPermissions` on Windows 388 | ([#9](https://github.com/haskell/directory/issues/9)) 389 | 390 | * `renameFile` now always throws the correct error type 391 | (`InappropriateType`) when the destination is a directory, as long as the 392 | filesystem is not being modified concurrently 393 | ([#8](https://github.com/haskell/directory/pull/8)) 394 | 395 | * Add `makeAbsolute`, which should be preferred over `canonicalizePath` 396 | unless one requires symbolic links to be resolved 397 | 398 | ## 1.2.1.0 (Mar 2014) 399 | 400 | * Bundled with GHC 7.8.1 401 | 402 | * Add support for sub-second precision in `getModificationTime` when 403 | linked against `unix>=2.6.0.0` 404 | 405 | * Fix `createDirectoryIfMissing _ "."` in `C:\` on Windows 406 | 407 | * Remove support for NHC98 compiler 408 | 409 | * Update package to `cabal-version >= 1.10` format 410 | 411 | * Enhance Haddock documentation for `doesDirectoryExist` and 412 | `canonicalizePath` 413 | 414 | * Fix `findExecutable` to check that file permissions indicate executable 415 | 416 | * New convenience functions `findFiles` and `findFilesWith` 417 | 418 | [1]: https://hackage.haskell.org/package/directory 419 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | AC_INIT([Haskell directory package], [1.0], [libraries@haskell.org], [directory]) 2 | 3 | # Safety check: Ensure that we are in the correct source directory. 4 | AC_CONFIG_SRCDIR([System/Directory.hs]) 5 | 6 | AC_CONFIG_HEADERS([HsDirectoryConfig.h]) 7 | 8 | # Autoconf chokes on spaces, but we may receive a path from Cabal containing 9 | # spaces. In that case, we just ignore Cabal's suggestion. 10 | set_with_gcc() { 11 | case $withval in 12 | *" "*) 13 | AC_MSG_WARN([--with-gcc ignored due to presence of spaces]);; 14 | *) 15 | CC=$withval 16 | esac 17 | } 18 | 19 | # Legacy support for setting the C compiler with Cabal<1.24 20 | # Newer versions use Autoconf's native `CC=...` facility 21 | AC_ARG_WITH([gcc], 22 | [C compiler], 23 | [set_with_gcc]) 24 | # avoid warnings when run via Cabal 25 | AC_ARG_WITH([compiler], 26 | [GHC compiler], 27 | []) 28 | AC_PROG_CC() 29 | 30 | # check for specific header (.h) files that we are interested in 31 | AC_CHECK_HEADERS([fcntl.h limits.h sys/types.h sys/stat.h time.h]) 32 | 33 | AC_CHECK_FUNCS([realpath]) 34 | AC_CHECK_FUNCS([utimensat]) 35 | AC_CHECK_FUNCS([CreateSymbolicLinkW]) 36 | AC_CHECK_FUNCS([GetFinalPathNameByHandleW]) 37 | 38 | # EXTEXT is defined automatically by AC_PROG_CC; 39 | # we just need to capture it in the header file 40 | AC_DEFINE_UNQUOTED([EXE_EXTENSION], ["$EXEEXT"], 41 | [Filename extension of executable files]) 42 | 43 | AC_OUTPUT 44 | -------------------------------------------------------------------------------- /directory.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: directory 3 | version: 1.3.10.0 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | maintainer: libraries@haskell.org 7 | bug-reports: https://github.com/haskell/directory/issues 8 | synopsis: Platform-agnostic library for filesystem operations 9 | description: 10 | This library provides a basic set of operations for manipulating files and 11 | directories in a portable way. 12 | category: System 13 | build-type: Configure 14 | tested-with: GHC == 8.10.7 || == 9.0.2 || == 9.2.4 || == 9.4.3 15 | 16 | extra-tmp-files: 17 | autom4te.cache 18 | config.log 19 | config.status 20 | HsDirectoryConfig.h 21 | 22 | extra-doc-files: 23 | README.md 24 | changelog.md 25 | 26 | extra-source-files: 27 | HsDirectoryConfig.h.in 28 | System/Directory/Internal/*.h 29 | configure 30 | configure.ac 31 | tests/*.hs 32 | tests/util.inl 33 | 34 | source-repository head 35 | type: git 36 | location: https://github.com/haskell/directory 37 | 38 | flag os-string 39 | description: Use the new os-string package 40 | default: False 41 | manual: False 42 | 43 | Library 44 | default-language: Haskell2010 45 | other-extensions: CApiFFI, CPP 46 | 47 | exposed-modules: 48 | System.Directory 49 | System.Directory.OsPath 50 | System.Directory.Internal 51 | System.Directory.Internal.Prelude 52 | other-modules: 53 | System.Directory.Internal.C_utimensat 54 | System.Directory.Internal.Common 55 | System.Directory.Internal.Config 56 | System.Directory.Internal.Posix 57 | System.Directory.Internal.Windows 58 | 59 | include-dirs: . 60 | 61 | build-depends: 62 | base >= 4.13.0 && < 4.22, 63 | file-io >= 0.1.4 && < 0.2, 64 | time >= 1.8.0 && < 1.15, 65 | if os(windows) 66 | build-depends: Win32 >= 2.14.1.0 && < 2.15 67 | else 68 | build-depends: unix >= 2.8.0 && < 2.9 69 | 70 | if flag(os-string) 71 | build-depends: filepath >= 1.5.0.0, os-string >= 2.0.0 72 | else 73 | build-depends: filepath >= 1.4.100.0 && < 1.5.0.0 74 | 75 | ghc-options: -Wall 76 | 77 | test-suite test 78 | default-language: Haskell2010 79 | other-extensions: BangPatterns, CPP 80 | default-extensions: OverloadedStrings 81 | ghc-options: -Wall 82 | hs-source-dirs: tests 83 | main-is: Main.hs 84 | type: exitcode-stdio-1.0 85 | build-depends: base, directory, filepath, time 86 | if os(windows) 87 | build-depends: Win32 88 | else 89 | build-depends: unix 90 | other-modules: 91 | TestUtils 92 | Util 93 | -- test-modules-begin 94 | CanonicalizePath 95 | CopyFile001 96 | CopyFile002 97 | CopyFileWithMetadata 98 | CreateDirectory001 99 | CreateDirectoryIfMissing001 100 | CurrentDirectory001 101 | Directory001 102 | DoesDirectoryExist001 103 | DoesPathExist 104 | FileTime 105 | FindFile001 106 | GetDirContents001 107 | GetDirContents002 108 | GetFileSize 109 | GetHomeDirectory001 110 | GetHomeDirectory002 111 | GetPermissions001 112 | LongPaths 113 | MakeAbsolute 114 | MinimizeNameConflicts 115 | PathIsSymbolicLink 116 | RemoveDirectoryRecursive001 117 | RemovePathForcibly 118 | RenameDirectory 119 | RenameFile001 120 | RenamePath 121 | Simplify 122 | T8482 123 | WithCurrentDirectory 124 | Xdg 125 | -- test-modules-end 126 | -------------------------------------------------------------------------------- /prologue.txt: -------------------------------------------------------------------------------- 1 | This package provides a library for handling directories. 2 | -------------------------------------------------------------------------------- /tests/CanonicalizePath.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CanonicalizePath where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | import System.OsPath ((), dropFileName, dropTrailingPathSeparator, 6 | normalise, takeFileName) 7 | import TestUtils 8 | 9 | main :: TestEnv -> IO () 10 | main _t = do 11 | dot <- canonicalizePath "" 12 | dot2 <- canonicalizePath "." 13 | dot3 <- canonicalizePath "./" 14 | dot4 <- canonicalizePath "./." 15 | T(expectEq) () dot (dropTrailingPathSeparator dot) 16 | T(expectEq) () dot dot2 17 | T(expectEq) () dot dot3 18 | T(expectEq) () dot dot4 19 | 20 | writeFile "bar" "" 21 | bar <- canonicalizePath "bar" 22 | bar2 <- canonicalizePath "bar/" 23 | bar3 <- canonicalizePath "bar/." 24 | bar4 <- canonicalizePath "bar/./" 25 | bar5 <- canonicalizePath "./bar" 26 | bar6 <- canonicalizePath "./bar/" 27 | bar7 <- canonicalizePath "./bar/." 28 | T(expectEq) () bar (normalise (dot "bar")) 29 | T(expectEq) () bar bar2 30 | T(expectEq) () bar bar3 31 | T(expectEq) () bar bar4 32 | T(expectEq) () bar bar5 33 | T(expectEq) () bar bar6 34 | T(expectEq) () bar bar7 35 | 36 | createDirectory "foo" 37 | foo <- canonicalizePath "foo" 38 | foo2 <- canonicalizePath "foo/" 39 | foo3 <- canonicalizePath "foo/." 40 | foo4 <- canonicalizePath "foo/./" 41 | foo5 <- canonicalizePath "./foo" 42 | foo6 <- canonicalizePath "./foo/" 43 | T(expectEq) () foo (normalise (dot "foo")) 44 | T(expectEq) () foo foo2 45 | T(expectEq) () foo foo3 46 | T(expectEq) () foo foo4 47 | T(expectEq) () foo foo5 48 | T(expectEq) () foo foo6 49 | 50 | -- should not fail for non-existent paths 51 | fooNon <- canonicalizePath "foo/non-existent" 52 | fooNon2 <- canonicalizePath "foo/non-existent/" 53 | fooNon3 <- canonicalizePath "foo/non-existent/." 54 | fooNon4 <- canonicalizePath "foo/non-existent/./" 55 | fooNon5 <- canonicalizePath "./foo/non-existent" 56 | fooNon6 <- canonicalizePath "./foo/non-existent/" 57 | fooNon7 <- canonicalizePath "./foo/./non-existent" 58 | fooNon8 <- canonicalizePath "./foo/./non-existent/" 59 | T(expectEq) () fooNon (normalise (foo "non-existent")) 60 | T(expectEq) () fooNon fooNon2 61 | T(expectEq) () fooNon fooNon3 62 | T(expectEq) () fooNon fooNon4 63 | T(expectEq) () fooNon fooNon5 64 | T(expectEq) () fooNon fooNon6 65 | T(expectEq) () fooNon fooNon7 66 | T(expectEq) () fooNon fooNon8 67 | 68 | -- make sure ".." gets expanded properly by 'toExtendedLengthPath' 69 | -- (turns out this test won't detect the problem because GetFullPathName 70 | -- would expand them for us if we don't, but leaving it here anyway) 71 | T(expectEq) () foo =<< canonicalizePath (foo ".." "foo") 72 | 73 | supportsSymbolicLinks <- supportsSymlinks 74 | when supportsSymbolicLinks $ do 75 | 76 | let barQux = dot "bar" "qux" 77 | 78 | -- note: this also checks that "../bar" gets normalized to "..\\bar" 79 | -- since Windows does not like "/" in symbolic links targets 80 | createFileLink "../bar" "foo/bar" 81 | T(expectEq) () bar =<< canonicalizePath "foo/bar" 82 | T(expectEq) () barQux =<< canonicalizePath "foo/bar/qux" 83 | 84 | createDirectoryLink "foo" "lfoo" 85 | T(expectEq) () foo =<< canonicalizePath "lfoo" 86 | T(expectEq) () foo =<< canonicalizePath "lfoo/" 87 | T(expectEq) () bar =<< canonicalizePath "lfoo/bar" 88 | T(expectEq) () barQux =<< canonicalizePath "lfoo/bar/qux" 89 | 90 | -- create a haphazard chain of links 91 | createDirectoryLink "./../foo/../foo/." "./foo/./somelink3" 92 | createDirectoryLink ".././foo/somelink3" "foo/somelink2" 93 | createDirectoryLink "./foo/somelink2" "somelink" 94 | T(expectEq) () foo =<< canonicalizePath "somelink" 95 | 96 | -- regression test for #64 97 | createFileLink "../foo/non-existent" "foo/qux" 98 | removeDirectoryLink "foo/somelink3" -- break the chain made earlier 99 | qux <- canonicalizePath "foo/qux" 100 | T(expectEq) () qux =<< canonicalizePath "foo/non-existent" 101 | T(expectEq) () (foo "somelink3") =<< canonicalizePath "somelink" 102 | 103 | -- make sure it can handle loops 104 | createFileLink "loop1" "loop2" 105 | createFileLink "loop2" "loop1" 106 | loop1 <- canonicalizePath "loop1" 107 | loop2 <- canonicalizePath "loop2" 108 | T(expectEq) () loop1 (normalise (dot "loop1")) 109 | T(expectEq) () loop2 (normalise (dot "loop2")) 110 | 111 | -- make sure ".." gets expanded properly by 'toExtendedLengthPath' 112 | createDirectoryLink (foo ".." "foo") "foolink" 113 | _ <- listDirectory "foolink" -- make sure directory is accessible 114 | T(expectEq) () foo =<< canonicalizePath "foolink" 115 | 116 | caseInsensitive <- 117 | (False <$ createDirectory "FOO") 118 | `catch` \ e -> 119 | if isAlreadyExistsError e 120 | then pure True 121 | else throwIO e 122 | 123 | -- if platform is case-insensitive, we expect case to be canonicalized too 124 | when caseInsensitive $ do 125 | foo7 <- canonicalizePath "FOO" 126 | foo8 <- canonicalizePath "FOO/" 127 | T(expectEq) () foo foo7 128 | T(expectEq) () foo foo8 129 | 130 | fooNon9 <- canonicalizePath "FOO/non-existent" 131 | fooNon10 <- canonicalizePath "fOo/non-existent/" 132 | fooNon11 <- canonicalizePath "foO/non-existent/." 133 | fooNon12 <- canonicalizePath "FoO/non-existent/./" 134 | fooNon13 <- canonicalizePath "./fOO/non-existent" 135 | fooNon14 <- canonicalizePath "./FOo/non-existent/" 136 | cfooNon15 <- canonicalizePath "./FOO/./NON-EXISTENT" 137 | cfooNon16 <- canonicalizePath "./FOO/./NON-EXISTENT/" 138 | T(expectEq) () fooNon fooNon9 139 | T(expectEq) () fooNon fooNon10 140 | T(expectEq) () fooNon fooNon11 141 | T(expectEq) () fooNon fooNon12 142 | T(expectEq) () fooNon fooNon13 143 | T(expectEq) () fooNon fooNon14 144 | T(expectEq) () fooNon (dropFileName cfooNon15 <> 145 | (os (toLower <$> so (takeFileName cfooNon15)))) 146 | T(expectEq) () fooNon (dropFileName cfooNon16 <> 147 | (os (toLower <$> so (takeFileName cfooNon16)))) 148 | T(expectNe) () fooNon cfooNon15 149 | T(expectNe) () fooNon cfooNon16 150 | 151 | setCurrentDirectory "foo" 152 | foo9 <- canonicalizePath "../FOO" 153 | foo10 <- canonicalizePath "../FOO/" 154 | T(expectEq) () foo foo9 155 | T(expectEq) () foo foo10 156 | 157 | let isWindows = 158 | #if defined(mingw32_HOST_OS) 159 | True 160 | #else 161 | False 162 | #endif 163 | 164 | when isWindows $ do 165 | -- https://github.com/haskell/directory/issues/170 166 | T(expectEq) () "\\\\localhost" =<< canonicalizePath "\\\\localhost" 167 | -------------------------------------------------------------------------------- /tests/CopyFile001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CopyFile001 where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | import System.OsPath (()) 6 | import qualified Data.List as List 7 | 8 | main :: TestEnv -> IO () 9 | main _t = do 10 | createDirectory dir 11 | writeFile (so (dir from)) contents 12 | T(expectEq) () [from] . List.sort =<< listDirectory dir 13 | copyFile (dir from) (dir to) 14 | T(expectEq) () [from, to] . List.sort =<< listDirectory dir 15 | T(expectEq) () contents =<< readFile (so (dir to)) 16 | 17 | -- Regression test for https://github.com/haskell/directory/issues/177 18 | createDirectory "issue177" 19 | T(expectIOErrorType) () isDoesNotExistError 20 | (copyFile "issue177/nonexistentSrc" "issue177/dst") 21 | T(expectEq) () [] =<< listDirectory "issue177" 22 | 23 | where 24 | contents = "This is the data\n" 25 | from = "source" 26 | to = "target" 27 | dir = "dir" 28 | -------------------------------------------------------------------------------- /tests/CopyFile002.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CopyFile002 where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | import qualified Data.List as List 6 | 7 | main :: TestEnv -> IO () 8 | main _t = do 9 | -- Similar to CopyFile001 but moves a file in the current directory 10 | -- (Bug #1652 on GHC Trac) 11 | writeFile (so from) contents 12 | T(expectEq) () [from] . List.sort =<< listDirectory "." 13 | copyFile from to 14 | T(expectEq) () [from, to] . List.sort =<< listDirectory "." 15 | T(expectEq) () contents =<< readFile (so to) 16 | where 17 | contents = "This is the data\n" 18 | from = "source" 19 | to = "target" 20 | -------------------------------------------------------------------------------- /tests/CopyFileWithMetadata.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CopyFileWithMetadata where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | import qualified Data.List as List 6 | 7 | main :: TestEnv -> IO () 8 | main _t = (`finally` cleanup) $ do 9 | 10 | -- prepare source file 11 | writeFile "a" contents 12 | writeFile "b" "To be replaced\n" 13 | setModificationTime "a" mtime 14 | modifyWritable False "a" 15 | perm <- getPermissions "a" 16 | 17 | -- sanity check 18 | T(expectEq) () ["a", "b"] . List.sort =<< listDirectory "." 19 | 20 | -- copy file 21 | copyFileWithMetadata "a" "b" 22 | copyFileWithMetadata "a" "c" 23 | 24 | -- make sure we got the right results 25 | T(expectEq) () ["a", "b", "c"] . List.sort =<< listDirectory "." 26 | for_ ["b", "c"] $ \ f -> do 27 | T(expectEq) f perm =<< getPermissions f 28 | T(expectEq) f mtime =<< getModificationTime f 29 | T(expectEq) f contents =<< readFile (so f) 30 | 31 | where 32 | contents = "This is the data\n" 33 | mtime = read "2000-01-01 00:00:00Z" 34 | 35 | cleanup = do 36 | -- needed to ensure the test runner can clean up our mess 37 | modifyWritable True "a" `catchIOError` \ _ -> return () 38 | modifyWritable True "b" `catchIOError` \ _ -> return () 39 | modifyWritable True "c" `catchIOError` \ _ -> return () 40 | 41 | modifyWritable b f = do 42 | perm <- getPermissions f 43 | setPermissions f (setOwnerWritable b perm) 44 | -------------------------------------------------------------------------------- /tests/CreateDirectory001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CreateDirectory001 where 3 | #include "util.inl" 4 | 5 | main :: TestEnv -> IO () 6 | main _t = do 7 | createDirectory testdir 8 | T(expectIOErrorType) () isAlreadyExistsError (createDirectory testdir) 9 | where testdir = "dir" 10 | -------------------------------------------------------------------------------- /tests/CreateDirectoryIfMissing001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CreateDirectoryIfMissing001 where 3 | #include "util.inl" 4 | import Data.Either (lefts) 5 | import System.Directory.Internal 6 | import System.OsPath ((), addTrailingPathSeparator) 7 | 8 | main :: TestEnv -> IO () 9 | main _t = do 10 | 11 | createDirectoryIfMissing False testdir 12 | cleanup 13 | 14 | T(expectIOErrorType) () isDoesNotExistError $ 15 | createDirectoryIfMissing False testdir_a 16 | 17 | createDirectoryIfMissing True testdir_a 18 | createDirectoryIfMissing False testdir_a 19 | createDirectoryIfMissing False (addTrailingPathSeparator testdir_a) 20 | cleanup 21 | 22 | createDirectoryIfMissing True (addTrailingPathSeparator testdir_a) 23 | 24 | T(inform) "testing for race conditions ..." 25 | raceCheck1 26 | T(inform) "testing for race conditions ..." 27 | raceCheck2 28 | T(inform) "done." 29 | cleanup 30 | 31 | writeFile (so testdir) (so testdir) 32 | T(expectIOErrorType) () isAlreadyExistsError $ 33 | createDirectoryIfMissing False testdir 34 | removeFile testdir 35 | cleanup 36 | 37 | writeFile (so testdir) (so testdir) 38 | T(expectIOErrorType) () isNotADirectoryError $ 39 | createDirectoryIfMissing True testdir_a 40 | removeFile testdir 41 | cleanup 42 | 43 | where 44 | 45 | testname = "CreateDirectoryIfMissing001" 46 | 47 | testdir = os (testname <> ".d") 48 | testdir_a = testdir "a" 49 | 50 | numRepeats = T.readArg _t testname "num-repeats" 10000 51 | numThreads = T.readArg _t testname "num-threads" 4 52 | 53 | forkPut mvar action = () <$ forkFinally action (putMVar mvar) 54 | 55 | -- Look for race conditions (bug #2808 on GHC Trac). This fails with 56 | -- +RTS -N2 and directory 1.0.0.2. 57 | raceCheck1 = do 58 | m <- newEmptyMVar 59 | forkPut m $ do 60 | replicateM_ numRepeats create 61 | forkPut m $ do 62 | replicateM_ numRepeats cleanup 63 | results <- replicateM 2 (takeMVar m) 64 | T(expectEq) () [] (show <$> lefts results) 65 | 66 | -- This test fails on Windows (see bug #2924 on GHC Trac): 67 | raceCheck2 = do 68 | m <- newEmptyMVar 69 | replicateM_ numThreads $ 70 | forkPut m $ do 71 | replicateM_ numRepeats $ do 72 | create 73 | cleanup 74 | results <- replicateM numThreads (takeMVar m) 75 | T(expectEq) () [] (show <$> lefts results) 76 | 77 | -- createDirectoryIfMissing is allowed to fail with isDoesNotExistError if 78 | -- another process/thread removes one of the directories during the process 79 | -- of creating the hierarchy. 80 | -- 81 | -- It is also allowed to fail with permission errors 82 | -- (see bug #2924 on GHC Trac) 83 | create = 84 | createDirectoryIfMissing True testdir_a `catch` \ e -> 85 | if isDoesNotExistError e 86 | || isPermissionError e 87 | || isInappropriateTypeError e 88 | || ioeGetErrorType e == InvalidArgument 89 | then return () 90 | else ioError e 91 | 92 | cleanup = removeDirectoryRecursive testdir `catchAny` \ _ -> return () 93 | 94 | catchAny :: IO a -> (SomeException -> IO a) -> IO a 95 | catchAny = catch 96 | 97 | #if defined(mingw32_HOST_OS) 98 | isNotADirectoryError = isAlreadyExistsError 99 | #else 100 | isNotADirectoryError = isInappropriateTypeError 101 | #endif 102 | 103 | isInappropriateTypeError = isInappropriateTypeErrorType . ioeGetErrorType 104 | 105 | isInappropriateTypeErrorType InappropriateType = True 106 | isInappropriateTypeErrorType _ = False 107 | -------------------------------------------------------------------------------- /tests/CurrentDirectory001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CurrentDirectory001 where 3 | #include "util.inl" 4 | import qualified Data.List as List 5 | 6 | main :: TestEnv -> IO () 7 | main _t = do 8 | prevDir <- getCurrentDirectory 9 | createDirectory "dir" 10 | setCurrentDirectory "dir" 11 | T(expectEq) () [".", ".."] . List.sort =<< getDirectoryContents "." 12 | setCurrentDirectory prevDir 13 | removeDirectory "dir" 14 | -------------------------------------------------------------------------------- /tests/Directory001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Directory001 where 3 | #include "util.inl" 4 | 5 | main :: TestEnv -> IO () 6 | main _t = do 7 | 8 | createDirectory "foo" 9 | writeFile "foo/bar" str 10 | renameFile "foo/bar" "foo/baz" 11 | renameDirectory "foo" "bar" 12 | str' <- readFile "bar/baz" 13 | T(expectEq) () str' str 14 | removeFile "bar/baz" 15 | removeDirectory "bar" 16 | 17 | where 18 | str = "Okay\n" 19 | -------------------------------------------------------------------------------- /tests/DoesDirectoryExist001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module DoesDirectoryExist001 where 3 | #include "util.inl" 4 | 5 | main :: TestEnv -> IO () 6 | main _t = do 7 | 8 | -- [regression test] "/" was not recognised as a directory prior to GHC 6.1 9 | T(expect) () =<< doesDirectoryExist rootDir 10 | 11 | createDirectory "somedir" 12 | 13 | T(expect) () . not =<< doesDirectoryExist "" 14 | T(expect) () . not =<< doesDirectoryExist "nonexistent" 15 | T(expect) () =<< doesDirectoryExist "." 16 | T(expect) () =<< doesDirectoryExist "somedir" 17 | #if defined(mingw32_HOST_OS) 18 | T(expect) () =<< doesDirectoryExist "SoMeDiR" 19 | #endif 20 | 21 | where 22 | #if defined(mingw32_HOST_OS) 23 | rootDir = "C:\\" 24 | #else 25 | rootDir = "/" 26 | #endif 27 | -------------------------------------------------------------------------------- /tests/DoesPathExist.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module DoesPathExist where 3 | #include "util.inl" 4 | import TestUtils (supportsSymlinks) 5 | 6 | main :: TestEnv -> IO () 7 | main _t = do 8 | 9 | T(expect) () =<< doesPathExist rootDir 10 | 11 | createDirectory "somedir" 12 | writeFile "somefile" "somedata" 13 | writeFile "\x3c0\x42f\x97f3\xe6\x221e" "somedata" 14 | 15 | T(expect) () . not =<< doesPathExist "" 16 | T(expect) () . not =<< doesPathExist "nonexistent" 17 | T(expect) () =<< doesPathExist "." 18 | T(expect) () =<< doesPathExist "somedir" 19 | T(expect) () =<< doesPathExist "somefile" 20 | T(expect) () =<< doesPathExist "./somefile" 21 | #if defined(mingw32_HOST_OS) 22 | T(expect) () =<< doesPathExist "SoMeDiR" 23 | T(expect) () =<< doesPathExist "sOmEfIlE" 24 | #endif 25 | T(expect) () =<< doesPathExist "\x3c0\x42f\x97f3\xe6\x221e" 26 | 27 | supportsSymbolicLinks <- supportsSymlinks 28 | when supportsSymbolicLinks $ do 29 | 30 | createDirectoryLink "somedir" "somedirlink" 31 | createFileLink "somefile" "somefilelink" 32 | createFileLink "nonexistent" "nonexistentlink" 33 | 34 | T(expect) () =<< doesFileExist "somefilelink" 35 | T(expect) () . not =<< doesDirectoryExist "somefilelink" 36 | T(expect) () =<< doesDirectoryExist "somedirlink" 37 | T(expect) () . not =<< doesFileExist "somedirlink" 38 | T(expect) () . not =<< doesDirectoryExist "nonexistentlink" 39 | T(expect) () . not =<< doesFileExist "nonexistentlink" 40 | 41 | where 42 | #if defined(mingw32_HOST_OS) 43 | rootDir = "C:\\" 44 | #else 45 | rootDir = "/" 46 | #endif 47 | -------------------------------------------------------------------------------- /tests/FileTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module FileTime where 3 | #include "util.inl" 4 | import Data.Time.Clock (addUTCTime, getCurrentTime) 5 | 6 | main :: TestEnv -> IO () 7 | main _t = do 8 | now <- getCurrentTime 9 | let someTimeAgo = addUTCTime (-3600) now 10 | someTimeAgo' = addUTCTime (-7200) now 11 | 12 | T(expectIOErrorType) () isDoesNotExistError $ 13 | getAccessTime "nonexistent-file" 14 | T(expectIOErrorType) () isDoesNotExistError $ 15 | setAccessTime "nonexistent-file" someTimeAgo 16 | T(expectIOErrorType) () isDoesNotExistError $ 17 | getModificationTime "nonexistent-file" 18 | T(expectIOErrorType) () isDoesNotExistError $ 19 | setModificationTime "nonexistent-file" someTimeAgo 20 | 21 | writeFile "foo" "" 22 | for_ [ "foo", ".", "" ] $ \ file -> do 23 | let mtime = someTimeAgo 24 | atime = someTimeAgo' 25 | 26 | atime1 <- getAccessTime file 27 | 28 | setModificationTime file mtime 29 | 30 | atime2 <- getAccessTime file 31 | mtime2 <- getModificationTime file 32 | 33 | -- modification time should be set with at worst 1 sec resolution 34 | T(expectNearTime) file mtime mtime2 1 35 | 36 | -- access time should not change, although it may lose some precision 37 | -- on POSIX systems without 'utimensat' 38 | T(expectNearTime) file atime1 atime2 1 39 | 40 | setAccessTime file atime 41 | 42 | atime3 <- getAccessTime file 43 | mtime3 <- getModificationTime file 44 | 45 | when setAtime $ do 46 | -- access time should be set with at worst 1 sec resolution 47 | T(expectNearTime) file atime atime3 1 48 | 49 | -- modification time should not change, although it may lose some precision 50 | -- on POSIX systems without 'utimensat' 51 | T(expectNearTime) file mtime2 mtime3 1 52 | 53 | where 54 | 55 | testname = "FileTime" 56 | 57 | setAtime = T.readArg _t testname "set-atime" True 58 | -------------------------------------------------------------------------------- /tests/FindFile001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module FindFile001 where 3 | #include "util.inl" 4 | import qualified Data.List as List 5 | import System.Directory.Internal 6 | import System.OsPath (()) 7 | 8 | main :: TestEnv -> IO () 9 | main _t = do 10 | 11 | createDirectory "bar" 12 | createDirectory "qux" 13 | writeFile "foo" "" 14 | writeFile (so ("bar" "foo")) "" 15 | writeFile (so ("qux" "foo")) ":3" 16 | 17 | -- make sure findFile is lazy enough 18 | T(expectEq) () (Just ("." "foo")) =<< findFile ("." : undefined) "foo" 19 | 20 | -- make sure relative paths work 21 | T(expectEq) () (Just ("." "bar" "foo")) =<< 22 | findFile ["."] ("bar" "foo") 23 | 24 | T(expectEq) () (Just ("." "foo")) =<< findFile [".", "bar"] ("foo") 25 | T(expectEq) () (Just ("bar" "foo")) =<< findFile ["bar", "."] ("foo") 26 | 27 | let f fn = (== ":3") <$> readFile (so fn) 28 | for_ (List.permutations ["qux", "bar", "."]) $ \ ds -> do 29 | 30 | let (match, noMatch) = List.partition (== "qux") ds 31 | match0 : _ <- pure match 32 | noMatch0 : _ <- pure noMatch 33 | 34 | T(expectEq) ds (Just (match0 "foo")) =<< 35 | findFileWith f ds "foo" 36 | 37 | T(expectEq) ds (( "foo") <$> match) =<< findFilesWith f ds "foo" 38 | 39 | T(expectEq) ds (Just (noMatch0 "foo")) =<< 40 | findFileWith ((not <$>) . f) ds "foo" 41 | 42 | T(expectEq) ds (( "foo") <$> noMatch) =<< 43 | findFilesWith ((not <$>) . f) ds "foo" 44 | 45 | T(expectEq) ds Nothing =<< findFileWith (\ _ -> return False) ds "foo" 46 | 47 | T(expectEq) ds [] =<< findFilesWith (\ _ -> return False) ds "foo" 48 | 49 | -- make sure absolute paths are handled properly irrespective of 'dirs' 50 | -- https://github.com/haskell/directory/issues/72 51 | absPath <- makeAbsolute ("bar" "foo") 52 | absPath2 <- makeAbsolute ("bar" "nonexistent") 53 | T(expectEq) () (Just absPath) =<< findFile [] absPath 54 | T(expectEq) () Nothing =<< findFile [] absPath2 55 | -------------------------------------------------------------------------------- /tests/GetDirContents001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module GetDirContents001 where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | import System.OsPath (()) 6 | import qualified Data.List as List 7 | 8 | main :: TestEnv -> IO () 9 | main _t = do 10 | createDirectory dir 11 | T(expectEq) () specials . List.sort =<< 12 | getDirectoryContents dir 13 | T(expectEq) () [] . List.sort =<< 14 | listDirectory dir 15 | names <- for [1 .. 100 :: Int] $ \ i -> do 16 | let name = "f" <> os (show i) 17 | writeFile (so (dir name)) "" 18 | return name 19 | T(expectEq) () (List.sort (specials <> names)) . List.sort =<< 20 | getDirectoryContents dir 21 | T(expectEq) () (List.sort names) . List.sort =<< 22 | listDirectory dir 23 | where dir = "dir" 24 | specials = [".", ".."] 25 | -------------------------------------------------------------------------------- /tests/GetDirContents002.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module GetDirContents002 where 3 | #include "util.inl" 4 | 5 | main :: TestEnv -> IO () 6 | main _t = do 7 | T(expectIOErrorType) () isDoesNotExistError $ 8 | getDirectoryContents "nonexistent" 9 | -------------------------------------------------------------------------------- /tests/GetFileSize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module GetFileSize where 3 | #include "util.inl" 4 | 5 | main :: TestEnv -> IO () 6 | main _t = do 7 | 8 | writeFile "emptyfile" "" 9 | writeFile "testfile" string 10 | 11 | T(expectEq) () 0 =<< getFileSize "emptyfile" 12 | T(expectEq) () (fromIntegral (length string)) =<< getFileSize "testfile" 13 | 14 | where 15 | string = "The quick brown fox jumps over the lazy dog." 16 | -------------------------------------------------------------------------------- /tests/GetHomeDirectory001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module GetHomeDirectory001 where 3 | #include "util.inl" 4 | 5 | main :: TestEnv -> IO () 6 | main _t = do 7 | homeDir <- getHomeDirectory 8 | T(expect) () (homeDir /= "") -- sanity check 9 | _ <- getAppUserDataDirectory "test" 10 | _ <- getXdgDirectory XdgCache "test" 11 | _ <- getXdgDirectory XdgConfig "test" 12 | _ <- getXdgDirectory XdgData "test" 13 | _ <- getXdgDirectory XdgState "test" 14 | _ <- getUserDocumentsDirectory 15 | _ <- getTemporaryDirectory 16 | return () 17 | -------------------------------------------------------------------------------- /tests/GetHomeDirectory002.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module GetHomeDirectory002 where 3 | 4 | #if !defined(mingw32_HOST_OS) 5 | import System.Posix.Env 6 | #endif 7 | #include "util.inl" 8 | 9 | -- Test that the getpwuid_r fallback works. 10 | -- This is only relevant on unix. 11 | main :: TestEnv -> IO () 12 | main _t = do 13 | #if !defined(mingw32_HOST_OS) 14 | unsetEnv "HOME" 15 | #endif 16 | _ <- getHomeDirectory 17 | T(expect) () True -- avoid warnings about redundant imports 18 | -------------------------------------------------------------------------------- /tests/GetPermissions001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module GetPermissions001 where 3 | #include "util.inl" 4 | import TestUtils 5 | 6 | main :: TestEnv -> IO () 7 | main _t = do 8 | 9 | checkCurrentDir 10 | checkExecutable 11 | checkOrdinary 12 | checkTrailingSlash 13 | 14 | -- 'writable' is the only permission that can be changed on Windows 15 | writeFile "foo.txt" "" 16 | foo <- makeAbsolute "foo.txt" 17 | modifyPermissions "foo.txt" (\ p -> p { writable = False }) 18 | T(expect) () =<< not . writable <$> getPermissions "foo.txt" 19 | modifyPermissions "foo.txt" (\ p -> p { writable = True }) 20 | T(expect) () =<< writable <$> getPermissions "foo.txt" 21 | modifyPermissions "foo.txt" (\ p -> p { writable = False }) 22 | T(expect) () =<< not . writable <$> getPermissions "foo.txt" 23 | modifyPermissions foo (\ p -> p { writable = True }) 24 | T(expect) () =<< writable <$> getPermissions foo 25 | modifyPermissions foo (\ p -> p { writable = False }) 26 | T(expect) () =<< not . writable <$> getPermissions foo 27 | 28 | -- test empty path 29 | modifyPermissions "" id 30 | 31 | where 32 | 33 | checkCurrentDir = do 34 | -- since the current directory is created by the test runner, 35 | -- it should be readable, writable, and searchable 36 | p <- getPermissions "." 37 | T(expect) () (readable p) 38 | T(expect) () (writable p) 39 | T(expect) () (not (executable p)) 40 | T(expect) () (searchable p) 41 | 42 | checkExecutable = do 43 | -- 'find' expected to exist on both Windows and POSIX, 44 | -- though we have no idea if it's writable 45 | Just f <- findExecutable "find" 46 | p <- getPermissions f 47 | T(expect) () (readable p) 48 | T(expect) () (executable p) 49 | T(expect) () (not (searchable p)) 50 | 51 | checkOrdinary = do 52 | writeFile "foo" "" 53 | p <- getPermissions "foo" 54 | T(expect) () (readable p) 55 | T(expect) () (writable p) 56 | T(expect) () (not (executable p)) 57 | T(expect) () (not (searchable p)) 58 | 59 | -- [regression test] (issue #9) 60 | -- Windows doesn't like trailing path separators 61 | checkTrailingSlash = do 62 | createDirectory "bar" 63 | _ <- getPermissions "bar/" 64 | return () 65 | -------------------------------------------------------------------------------- /tests/LongPaths.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module LongPaths where 3 | #include "util.inl" 4 | import TestUtils 5 | import System.OsPath (()) 6 | 7 | main :: TestEnv -> IO () 8 | main _t = do 9 | let longName = mconcat (replicate 10 "its_very_long") 10 | longDir <- makeAbsolute (longName longName) 11 | 12 | supportsLongPaths <- do 13 | -- create 2 dirs because 1 path segment by itself can't exceed MAX_PATH 14 | -- tests: [createDirectory] 15 | createDirectory =<< makeAbsolute longName 16 | createDirectory longDir 17 | return True 18 | `catchIOError` \ _ -> 19 | return False 20 | 21 | -- skip tests on file systems that do not support long paths 22 | when supportsLongPaths $ do 23 | 24 | -- test relative paths 25 | let relDir = longName mconcat (replicate 8 "yeah_its_long") 26 | createDirectory relDir 27 | T(expect) () =<< doesDirectoryExist relDir 28 | T(expectEq) () [] =<< listDirectory relDir 29 | setPermissions relDir emptyPermissions 30 | T(expectEq) () False =<< writable <$> getPermissions relDir 31 | 32 | writeFile "foobar.txt" "^.^" -- writeFile does not support long paths yet 33 | 34 | -- tests: [renamePath], [copyFileWithMetadata] 35 | renamePath "foobar.txt" (longDir "foobar_tmp.txt") 36 | renamePath (longDir "foobar_tmp.txt") (longDir "foobar.txt") 37 | copyFileWithMetadata (longDir "foobar.txt") 38 | (longDir "foobar_copy.txt") 39 | 40 | -- tests: [doesDirectoryExist], [doesFileExist], [doesPathExist] 41 | T(expect) () =<< doesDirectoryExist longDir 42 | T(expect) () =<< doesFileExist (longDir "foobar.txt") 43 | T(expect) () =<< doesPathExist longDir 44 | T(expect) () =<< doesPathExist (longDir "foobar.txt") 45 | 46 | -- tests: [getFileSize], [getModificationTime] 47 | T(expectEq) () 3 =<< getFileSize (longDir "foobar.txt") 48 | _ <- getModificationTime (longDir "foobar.txt") 49 | 50 | supportsSymbolicLinks <- supportsSymlinks 51 | when supportsSymbolicLinks $ do 52 | 53 | -- tests: [createDirectoryLink], [getSymbolicLinkTarget], [listDirectory] 54 | -- also tests expansion of "." and ".." 55 | createDirectoryLink "." (longDir "link") 56 | _ <- listDirectory (longDir ".." longName "link") 57 | T(expectEq) () "." =<< getSymbolicLinkTarget (longDir "." "link") 58 | 59 | return () 60 | 61 | -- [removeFile], [removeDirectory] are automatically tested by the cleanup 62 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | import qualified Util as T 3 | import qualified CanonicalizePath 4 | import qualified CopyFile001 5 | import qualified CopyFile002 6 | import qualified CopyFileWithMetadata 7 | import qualified CreateDirectory001 8 | import qualified CreateDirectoryIfMissing001 9 | import qualified CurrentDirectory001 10 | import qualified Directory001 11 | import qualified DoesDirectoryExist001 12 | import qualified DoesPathExist 13 | import qualified FileTime 14 | import qualified FindFile001 15 | import qualified GetDirContents001 16 | import qualified GetDirContents002 17 | import qualified GetFileSize 18 | import qualified GetHomeDirectory001 19 | import qualified GetHomeDirectory002 20 | import qualified GetPermissions001 21 | import qualified LongPaths 22 | import qualified MakeAbsolute 23 | import qualified MinimizeNameConflicts 24 | import qualified PathIsSymbolicLink 25 | import qualified RemoveDirectoryRecursive001 26 | import qualified RemovePathForcibly 27 | import qualified RenameDirectory 28 | import qualified RenameFile001 29 | import qualified RenamePath 30 | import qualified Simplify 31 | import qualified T8482 32 | import qualified WithCurrentDirectory 33 | import qualified Xdg 34 | 35 | main :: IO () 36 | main = T.testMain $ \ _t -> do 37 | T.isolatedRun _t "CanonicalizePath" CanonicalizePath.main 38 | T.isolatedRun _t "CopyFile001" CopyFile001.main 39 | T.isolatedRun _t "CopyFile002" CopyFile002.main 40 | T.isolatedRun _t "CopyFileWithMetadata" CopyFileWithMetadata.main 41 | T.isolatedRun _t "CreateDirectory001" CreateDirectory001.main 42 | T.isolatedRun _t "CreateDirectoryIfMissing001" CreateDirectoryIfMissing001.main 43 | T.isolatedRun _t "CurrentDirectory001" CurrentDirectory001.main 44 | T.isolatedRun _t "Directory001" Directory001.main 45 | T.isolatedRun _t "DoesDirectoryExist001" DoesDirectoryExist001.main 46 | T.isolatedRun _t "DoesPathExist" DoesPathExist.main 47 | T.isolatedRun _t "FileTime" FileTime.main 48 | T.isolatedRun _t "FindFile001" FindFile001.main 49 | T.isolatedRun _t "GetDirContents001" GetDirContents001.main 50 | T.isolatedRun _t "GetDirContents002" GetDirContents002.main 51 | T.isolatedRun _t "GetFileSize" GetFileSize.main 52 | T.isolatedRun _t "GetHomeDirectory001" GetHomeDirectory001.main 53 | T.isolatedRun _t "GetHomeDirectory002" GetHomeDirectory002.main 54 | T.isolatedRun _t "GetPermissions001" GetPermissions001.main 55 | T.isolatedRun _t "LongPaths" LongPaths.main 56 | T.isolatedRun _t "MakeAbsolute" MakeAbsolute.main 57 | T.isolatedRun _t "MinimizeNameConflicts" MinimizeNameConflicts.main 58 | T.isolatedRun _t "PathIsSymbolicLink" PathIsSymbolicLink.main 59 | T.isolatedRun _t "RemoveDirectoryRecursive001" RemoveDirectoryRecursive001.main 60 | T.isolatedRun _t "RemovePathForcibly" RemovePathForcibly.main 61 | T.isolatedRun _t "RenameDirectory" RenameDirectory.main 62 | T.isolatedRun _t "RenameFile001" RenameFile001.main 63 | T.isolatedRun _t "RenamePath" RenamePath.main 64 | T.isolatedRun _t "Simplify" Simplify.main 65 | T.isolatedRun _t "T8482" T8482.main 66 | T.isolatedRun _t "WithCurrentDirectory" WithCurrentDirectory.main 67 | T.isolatedRun _t "Xdg" Xdg.main 68 | -------------------------------------------------------------------------------- /tests/MakeAbsolute.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module MakeAbsolute where 3 | #include "util.inl" 4 | import System.OsPath ((), addTrailingPathSeparator, 5 | dropTrailingPathSeparator, normalise) 6 | #if defined(mingw32_HOST_OS) 7 | import System.Directory.Internal 8 | import System.OsPath (takeDrive, toChar, unpack) 9 | #endif 10 | 11 | main :: TestEnv -> IO () 12 | main _t = do 13 | dot <- makeAbsolute "" 14 | dot2 <- makeAbsolute "." 15 | dot3 <- makeAbsolute "./." 16 | T(expectEq) () dot (dropTrailingPathSeparator dot) 17 | T(expectEq) () dot dot2 18 | T(expectEq) () dot dot3 19 | 20 | sdot <- makeAbsolute "./" 21 | sdot2 <- makeAbsolute "././" 22 | T(expectEq) () sdot (addTrailingPathSeparator sdot) 23 | T(expectEq) () sdot sdot2 24 | 25 | foo <- makeAbsolute "foo" 26 | foo2 <- makeAbsolute "foo/." 27 | foo3 <- makeAbsolute "./foo" 28 | T(expectEq) () foo (normalise (dot "foo")) 29 | T(expectEq) () foo foo2 30 | T(expectEq) () foo foo3 31 | 32 | sfoo <- makeAbsolute "foo/" 33 | sfoo2 <- makeAbsolute "foo/./" 34 | sfoo3 <- makeAbsolute "./foo/" 35 | T(expectEq) () sfoo (normalise (dot "foo/")) 36 | T(expectEq) () sfoo sfoo2 37 | T(expectEq) () sfoo sfoo3 38 | 39 | #if defined(mingw32_HOST_OS) 40 | cwd <- getCurrentDirectory 41 | let driveLetter = toUpper (toChar (head (unpack (takeDrive cwd)))) 42 | let driveLetter' = if driveLetter == 'Z' then 'A' else succ driveLetter 43 | drp1 <- makeAbsolute (os (driveLetter : ":foobar")) 44 | drp2 <- makeAbsolute (os (driveLetter' : ":foobar")) 45 | T(expectEq) () drp1 =<< makeAbsolute "foobar" 46 | T(expectEq) () drp2 (os (driveLetter' : ":\\foobar")) 47 | #endif 48 | -------------------------------------------------------------------------------- /tests/MinimizeNameConflicts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module MinimizeNameConflicts 3 | ( main 4 | , module System.Directory.OsPath 5 | #if defined(mingw32_HOST_OS) 6 | , module System.Win32 7 | #else 8 | , module System.Posix 9 | #endif 10 | ) where 11 | #include "util.inl" 12 | #if defined(mingw32_HOST_OS) 13 | import System.Win32 hiding 14 | ( copyFile 15 | , createDirectory 16 | , getCurrentDirectory 17 | , getTemporaryDirectory 18 | , removeDirectory 19 | , setCurrentDirectory 20 | ) 21 | #else 22 | import System.Posix hiding 23 | ( createDirectory 24 | , isSymbolicLink 25 | , removeDirectory 26 | ) 27 | #endif 28 | 29 | -- This is just a compile-test to check for name conflicts between directory 30 | -- and other boot libraries. See for example: 31 | -- https://github.com/haskell/directory/issues/52 32 | main :: TestEnv -> IO () 33 | main _t = do 34 | T(expect) ("no-op" :: String) True 35 | -------------------------------------------------------------------------------- /tests/PathIsSymbolicLink.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module PathIsSymbolicLink where 3 | #include "util.inl" 4 | import TestUtils 5 | 6 | main :: TestEnv -> IO () 7 | main _t = do 8 | supportsSymbolicLinks <- supportsSymlinks 9 | when supportsSymbolicLinks $ do 10 | 11 | createFileLink "x" "y" 12 | createDirectoryLink "a" "b" 13 | 14 | T(expect) () =<< pathIsSymbolicLink "y" 15 | T(expect) () =<< pathIsSymbolicLink "b" 16 | T(expectEq) () "x" =<< getSymbolicLinkTarget "y" 17 | T(expectEq) () "a" =<< getSymbolicLinkTarget "b" 18 | T(expectEq) () False =<< doesFileExist "y" 19 | T(expectEq) () False =<< doesDirectoryExist "b" 20 | 21 | writeFile "x" "" 22 | createDirectory "a" 23 | 24 | T(expect) () =<< doesFileExist "y" 25 | T(expect) () =<< doesDirectoryExist "b" 26 | 27 | removeFile "y" 28 | removeDirectoryLink "b" 29 | 30 | T(expectIOErrorType) () isDoesNotExistError (pathIsSymbolicLink "y") 31 | T(expectIOErrorType) () isDoesNotExistError (pathIsSymbolicLink "b") 32 | T(expectEq) () False =<< doesFileExist "y" 33 | T(expectEq) () False =<< doesDirectoryExist "b" 34 | -------------------------------------------------------------------------------- /tests/RemoveDirectoryRecursive001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module RemoveDirectoryRecursive001 where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | import System.OsPath ((), normalise) 6 | import qualified Data.List as List 7 | import TestUtils (modifyPermissions, symlinkOrCopy) 8 | 9 | main :: TestEnv -> IO () 10 | main _t = do 11 | 12 | ------------------------------------------------------------ 13 | -- clean up junk from previous invocations 14 | 15 | modifyPermissions (tmp "c") (\ p -> p { writable = True }) 16 | `catchIOError` \ _ -> return () 17 | removeDirectoryRecursive tmpD 18 | `catchIOError` \ _ -> return () 19 | 20 | ------------------------------------------------------------ 21 | -- set up 22 | 23 | createDirectoryIfMissing True (tmp "a/x/w") 24 | createDirectoryIfMissing True (tmp "a/y") 25 | createDirectoryIfMissing True (tmp "a/z") 26 | createDirectoryIfMissing True (tmp "b") 27 | createDirectoryIfMissing True (tmp "c") 28 | writeFile (so (tmp "a/x/w/u")) "foo" 29 | writeFile (so (tmp "a/t")) "bar" 30 | symlinkOrCopy (normalise "../a") (tmp "b/g") 31 | symlinkOrCopy (normalise "../b") (tmp "c/h") 32 | symlinkOrCopy (normalise "a") (tmp "d") 33 | modifyPermissions (tmp "c") (\ p -> p { writable = False }) 34 | 35 | ------------------------------------------------------------ 36 | -- tests 37 | 38 | T(expectEq) () [".", "..", "a", "b", "c", "d"] . List.sort =<< 39 | getDirectoryContents tmpD 40 | T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< 41 | getDirectoryContents (tmp "a") 42 | T(expectEq) () [".", "..", "g"] . List.sort =<< 43 | getDirectoryContents (tmp "b") 44 | T(expectEq) () [".", "..", "h"] . List.sort =<< 45 | getDirectoryContents (tmp "c") 46 | T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< 47 | getDirectoryContents (tmp "d") 48 | 49 | removeDirectoryRecursive (tmp "d") 50 | `catchIOError` \ _ -> removeFile (tmp "d") 51 | #if defined(mingw32_HOST_OS) 52 | `catchIOError` \ _ -> removeDirectory (tmp "d") 53 | #endif 54 | 55 | T(expectEq) () [".", "..", "a", "b", "c"] . List.sort =<< 56 | getDirectoryContents tmpD 57 | T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< 58 | getDirectoryContents (tmp "a") 59 | T(expectEq) () [".", "..", "g"] . List.sort =<< 60 | getDirectoryContents (tmp "b") 61 | T(expectEq) () [".", "..", "h"] . List.sort =<< 62 | getDirectoryContents (tmp "c") 63 | 64 | removeDirectoryRecursive (tmp "c") 65 | `catchIOError` \ _ -> do 66 | modifyPermissions (tmp "c") (\ p -> p { writable = True }) 67 | removeDirectoryRecursive (tmp "c") 68 | 69 | T(expectEq) () [".", "..", "a", "b"] . List.sort =<< 70 | getDirectoryContents tmpD 71 | T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< 72 | getDirectoryContents (tmp "a") 73 | T(expectEq) () [".", "..", "g"] . List.sort =<< 74 | getDirectoryContents (tmp "b") 75 | 76 | removeDirectoryRecursive (tmp "b") 77 | 78 | T(expectEq) () [".", "..", "a"] . List.sort =<< 79 | getDirectoryContents tmpD 80 | T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< 81 | getDirectoryContents (tmp "a") 82 | 83 | removeDirectoryRecursive (tmp "a") 84 | 85 | T(expectEq) () [".", ".."] . List.sort =<< 86 | getDirectoryContents tmpD 87 | 88 | where testName = "removeDirectoryRecursive001" 89 | tmpD = testName <> ".tmp" 90 | tmp s = tmpD normalise s 91 | -------------------------------------------------------------------------------- /tests/RemovePathForcibly.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module RemovePathForcibly where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | import System.OsPath ((), normalise) 6 | import qualified Data.List as List 7 | import TestUtils (hardLinkOrCopy, modifyPermissions, symlinkOrCopy) 8 | 9 | main :: TestEnv -> IO () 10 | main _t = do 11 | 12 | ------------------------------------------------------------ 13 | -- clean up junk from previous invocations 14 | 15 | modifyPermissions (tmp "c") (\ p -> p { writable = True }) 16 | `catchIOError` \ _ -> return () 17 | removePathForcibly tmpD 18 | `catchIOError` \ _ -> return () 19 | 20 | ------------------------------------------------------------ 21 | -- set up 22 | 23 | createDirectoryIfMissing True (tmp "a/x/w") 24 | createDirectoryIfMissing True (tmp "a/y") 25 | createDirectoryIfMissing True (tmp "a/z") 26 | createDirectoryIfMissing True (tmp "b") 27 | createDirectoryIfMissing True (tmp "c") 28 | createDirectoryIfMissing True (tmp "f") 29 | writeFile (so (tmp "a/x/w/u")) "foo" 30 | writeFile (so (tmp "a/t")) "bar" 31 | writeFile (so (tmp "f/s")) "qux" 32 | symlinkOrCopy (normalise "../a") (tmp "b/g") 33 | symlinkOrCopy (normalise "../b") (tmp "c/h") 34 | symlinkOrCopy (normalise "a") (tmp "d") 35 | setPermissions (tmp "f/s") emptyPermissions 36 | setPermissions (tmp "f") emptyPermissions 37 | 38 | ------------------------------------------------------------ 39 | -- tests 40 | 41 | removePathForcibly (tmp "f") 42 | removePathForcibly (tmp "e") -- intentionally non-existent 43 | 44 | T(expectEq) () [".", "..", "a", "b", "c", "d"] . List.sort =<< 45 | getDirectoryContents tmpD 46 | T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< 47 | getDirectoryContents (tmp "a") 48 | T(expectEq) () [".", "..", "g"] . List.sort =<< 49 | getDirectoryContents (tmp "b") 50 | T(expectEq) () [".", "..", "h"] . List.sort =<< 51 | getDirectoryContents (tmp "c") 52 | T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< 53 | getDirectoryContents (tmp "d") 54 | 55 | removePathForcibly (tmp "d") 56 | 57 | T(expectEq) () [".", "..", "a", "b", "c"] . List.sort =<< 58 | getDirectoryContents tmpD 59 | T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< 60 | getDirectoryContents (tmp "a") 61 | T(expectEq) () [".", "..", "g"] . List.sort =<< 62 | getDirectoryContents (tmp "b") 63 | T(expectEq) () [".", "..", "h"] . List.sort =<< 64 | getDirectoryContents (tmp "c") 65 | 66 | removePathForcibly (tmp "c") 67 | 68 | T(expectEq) () [".", "..", "a", "b"] . List.sort =<< 69 | getDirectoryContents tmpD 70 | T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< 71 | getDirectoryContents (tmp "a") 72 | T(expectEq) () [".", "..", "g"] . List.sort =<< 73 | getDirectoryContents (tmp "b") 74 | 75 | removePathForcibly (tmp "b") 76 | 77 | T(expectEq) () [".", "..", "a"] . List.sort =<< 78 | getDirectoryContents tmpD 79 | T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< 80 | getDirectoryContents (tmp "a") 81 | 82 | removePathForcibly (tmp "a") 83 | 84 | T(expectEq) () [".", ".."] . List.sort =<< 85 | getDirectoryContents tmpD 86 | 87 | ---------------------------------------------------------------------- 88 | -- regression test for https://github.com/haskell/directory/issues/135 89 | 90 | writeFile "hl1" "hardlinked" 91 | setPermissions "hl1" emptyPermissions 92 | origPermissions <- getPermissions "hl1" 93 | hardLinkOrCopy "hl1" "hl2" 94 | removePathForcibly "hl2" 95 | T(expectEq) () origPermissions =<< getPermissions "hl1" 96 | 97 | where testName = "removePathForcibly" 98 | tmpD = testName <> ".tmp" 99 | tmp s = tmpD normalise s 100 | -------------------------------------------------------------------------------- /tests/RenameDirectory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module RenameDirectory where 3 | #include "util.inl" 4 | 5 | main :: TestEnv -> IO () 6 | main _t = do 7 | createDirectory "a" 8 | T(expectEq) () ["a"] =<< listDirectory "." 9 | renameDirectory "a" "b" 10 | T(expectEq) () ["b"] =<< listDirectory "." 11 | -------------------------------------------------------------------------------- /tests/RenameFile001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module RenameFile001 where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | 6 | main :: TestEnv -> IO () 7 | main _t = do 8 | writeFile tmp1 contents1 9 | renameFile (os tmp1) (os tmp2) 10 | T(expectEq) () contents1 =<< readFile tmp2 11 | writeFile tmp1 contents2 12 | renameFile (os tmp2) (os tmp1) 13 | T(expectEq) () contents1 =<< readFile tmp1 14 | where 15 | tmp1 = "tmp1" 16 | tmp2 = "tmp2" 17 | contents1 = "test" 18 | contents2 = "test2" 19 | -------------------------------------------------------------------------------- /tests/RenamePath.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module RenamePath where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | 6 | main :: TestEnv -> IO () 7 | main _t = do 8 | 9 | createDirectory "a" 10 | T(expectEq) () ["a"] =<< listDirectory "." 11 | renamePath "a" "b" 12 | T(expectEq) () ["b"] =<< listDirectory "." 13 | 14 | writeFile tmp1 contents1 15 | renamePath (os tmp1) (os tmp2) 16 | T(expectEq) () contents1 =<< readFile tmp2 17 | writeFile tmp1 contents2 18 | renamePath (os tmp2) (os tmp1) 19 | T(expectEq) () contents1 =<< readFile tmp1 20 | 21 | where 22 | tmp1 = "tmp1" 23 | tmp2 = "tmp2" 24 | contents1 = "test" 25 | contents2 = "test2" 26 | -------------------------------------------------------------------------------- /tests/Simplify.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Simplify where 3 | #include "util.inl" 4 | import System.Directory.Internal (simplifyWindows) 5 | import System.OsPath (normalise) 6 | 7 | main :: TestEnv -> IO () 8 | main _t = do 9 | T(expectIOErrorType) () (const True) (setCurrentDirectory "") 10 | T(expectEq) () (simplifyWindows "") "" 11 | T(expectEq) () (simplifyWindows ".") "." 12 | T(expectEq) () (simplifyWindows "a///b") (normalise "a/b") 13 | T(expectEq) () (simplifyWindows "./a//b") (normalise "a/b") 14 | T(expectEq) () (simplifyWindows "a/../../../b/.") (normalise "../../b") 15 | T(expectEq) () (simplifyWindows "a/.././b/./") (normalise "b/") 16 | T(expectEq) () (simplifyWindows "C:/a/../b") (normalise "C:/b") 17 | T(expectEq) () (simplifyWindows "\\\\?\\./a\\../b") "\\\\?\\./a\\../b" 18 | T(expectEq) () (simplifyWindows "C:/a") (normalise "C:/a") 19 | T(expectEq) () (simplifyWindows "/a") (normalise "/a") 20 | #ifdef mingw32_HOST_OS 21 | T(expectEq) () (simplifyWindows "C:") "C:" 22 | T(expectEq) () (simplifyWindows "c:\\\\") "C:\\" 23 | T(expectEq) () (simplifyWindows "C:.") "C:" 24 | T(expectEq) () (simplifyWindows "C:.\\\\") "C:.\\" 25 | T(expectEq) () (simplifyWindows "C:..") "C:.." 26 | T(expectEq) () (simplifyWindows "C:..\\") "C:..\\" 27 | T(expectEq) () (simplifyWindows "C:\\.\\") "C:\\" 28 | T(expectEq) () (simplifyWindows "C:\\a") "C:\\a" 29 | T(expectEq) () (simplifyWindows "C:\\a\\\\b\\") "C:\\a\\b\\" 30 | T(expectEq) () (simplifyWindows "\\\\a\\b") "\\\\a\\b" 31 | T(expectEq) () (simplifyWindows "//a\\b/c/./d") "\\\\a\\b\\c\\d" 32 | T(expectEq) () (simplifyWindows "/.") "\\" 33 | T(expectEq) () (simplifyWindows "/./") "\\" 34 | T(expectEq) () (simplifyWindows "/../") "\\" 35 | T(expectEq) () (simplifyWindows "\\a\\.") "\\a" 36 | T(expectEq) () (simplifyWindows "//?") "\\\\?" 37 | T(expectEq) () (simplifyWindows "//?\\") "\\\\?\\" 38 | T(expectEq) () (simplifyWindows "//?/a/b") "\\\\?\\a/b" 39 | #endif 40 | -------------------------------------------------------------------------------- /tests/T8482.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module T8482 where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | 6 | tmp1 :: OsPath 7 | tmp1 = "T8482.tmp1" 8 | 9 | testdir :: OsPath 10 | testdir = "T8482.dir" 11 | 12 | main :: TestEnv -> IO () 13 | main _t = do 14 | writeFile (so tmp1) "hello" 15 | createDirectory testdir 16 | T(expectIOErrorType) () (is InappropriateType) (renameFile testdir tmp1) 17 | T(expectIOErrorType) () (is InappropriateType) (renameFile tmp1 testdir) 18 | T(expectIOErrorType) () (is InappropriateType) (renameFile tmp1 ".") 19 | where is t = (== t) . ioeGetErrorType 20 | -------------------------------------------------------------------------------- /tests/TestUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | -- | Utility functions specific to 'directory' tests 4 | module TestUtils 5 | ( copyPathRecursive 6 | , hardLinkOrCopy 7 | , modifyPermissions 8 | , symlinkOrCopy 9 | , supportsSymlinks 10 | ) where 11 | import Prelude () 12 | import System.Directory.Internal.Prelude 13 | import System.Directory.Internal 14 | import System.Directory.OsPath 15 | import Data.String (IsString(fromString)) 16 | import System.OsPath ((), normalise, takeDirectory) 17 | #if defined(mingw32_HOST_OS) 18 | import qualified System.Win32 as Win32 19 | #endif 20 | 21 | -- | @'copyPathRecursive' path@ copies an existing file or directory at 22 | -- /path/ together with its contents and subdirectories. 23 | -- 24 | -- Warning: mostly untested and might not handle symlinks correctly. 25 | copyPathRecursive :: OsPath -> OsPath -> IO () 26 | copyPathRecursive source dest = 27 | (`ioeSetLocation` "copyPathRecursive") `modifyIOError` do 28 | dirExists <- doesDirectoryExist source 29 | if dirExists 30 | then do 31 | contents <- listDirectory source 32 | createDirectory dest 33 | mapM_ (uncurry copyPathRecursive) 34 | [(source x, dest x) | x <- contents] 35 | else copyFile source dest 36 | 37 | modifyPermissions :: OsPath -> (Permissions -> Permissions) -> IO () 38 | modifyPermissions path modify = do 39 | permissions <- getPermissions path 40 | setPermissions path (modify permissions) 41 | 42 | -- | On Windows, the handler is called if symbolic links are unsupported or 43 | -- the user lacks the necessary privileges to create them. On other 44 | -- platforms, the handler is never run. 45 | handleSymlinkUnavail 46 | :: IO a -- ^ handler 47 | -> IO a -- ^ arbitrary action 48 | -> IO a 49 | handleSymlinkUnavail _handler action = action 50 | #if defined(mingw32_HOST_OS) 51 | `catchIOError` \ e -> 52 | case ioeGetErrorType e of 53 | UnsupportedOperation -> _handler 54 | _ | isIllegalOperation e || isPermissionError e -> _handler 55 | _ -> ioError e 56 | #endif 57 | 58 | -- | Create a hard link on Posix. On Windows, it just copies. 59 | hardLinkOrCopy :: OsPath -> OsPath -> IO () 60 | #if defined(mingw32_HOST_OS) 61 | hardLinkOrCopy = copyPathRecursive 62 | #else 63 | hardLinkOrCopy = createHardLink 64 | #endif 65 | 66 | -- | Create a symbolic link. On Windows, this falls back to copying if 67 | -- forbidden by Group Policy or is not supported. On other platforms, there 68 | -- is no fallback. Also, automatically detect if the source is a file or a 69 | -- directory and create the appropriate type of link. 70 | symlinkOrCopy :: OsPath -> OsPath -> IO () 71 | symlinkOrCopy target link = do 72 | let fullTarget = takeDirectory link target 73 | handleSymlinkUnavail (copyPathRecursive fullTarget link) $ do 74 | isDir <- doesDirectoryExist fullTarget 75 | (if isDir then createDirectoryLink else createFileLink) 76 | (normalise target) 77 | link 78 | 79 | supportsSymlinks :: IO Bool 80 | supportsSymlinks = do 81 | canCreate <- supportsLinkCreation 82 | canDeref <- supportsLinkDeref 83 | return (canCreate && canDeref) 84 | 85 | -- | On Windows, test if symbolic link creation is supported and the user has 86 | -- the necessary privileges to create them. On other platforms, this always 87 | -- returns 'True'. 88 | supportsLinkCreation :: IO Bool 89 | supportsLinkCreation = do 90 | let path = os "_symlink_test.tmp" 91 | isSupported <- handleSymlinkUnavail (return False) $ do 92 | True <$ createFileLink path path 93 | when isSupported $ do 94 | removeFile path 95 | return isSupported 96 | 97 | supportsLinkDeref :: IO Bool 98 | supportsLinkDeref = do 99 | #if defined(mingw32_HOST_OS) 100 | True <$ win32_getFinalPathNameByHandle Win32.nullHANDLE 0 101 | `catchIOError` \ e -> 102 | case ioeGetErrorType e of 103 | UnsupportedOperation -> return False 104 | _ -> return True 105 | #else 106 | return True 107 | #endif 108 | 109 | instance IsString OsString where 110 | fromString = os 111 | -------------------------------------------------------------------------------- /tests/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | -- | A rudimentary testing framework 4 | module Util where 5 | import Prelude () 6 | import System.Directory.Internal.Prelude 7 | import System.Directory.Internal 8 | import System.Directory.OsPath 9 | import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime) 10 | import System.Environment (getEnvironment, setEnv, unsetEnv) 11 | import System.OsPath ((), decodeFS, encodeFS, normalise) 12 | import qualified Data.List as List 13 | 14 | modifyIORef' :: IORef a -> (a -> a) -> IO () 15 | modifyIORef' r f = do 16 | x <- readIORef r 17 | let !x' = f x in writeIORef r x' 18 | 19 | tryAny :: IO a -> IO (Either SomeException a) 20 | tryAny action = do 21 | result <- newEmptyMVar 22 | mask $ \ unmask -> do 23 | thread <- forkIO (try (unmask action) >>= putMVar result) 24 | unmask (readMVar result) `onException` killThread thread 25 | 26 | timeLimit :: Double -> IO a -> IO a 27 | timeLimit time action = do 28 | result <- timeout (round (1000000 * time)) action 29 | case result of 30 | Nothing -> throwIO (userError "timed out") 31 | Just x -> return x 32 | 33 | data TestEnv = 34 | TestEnv 35 | { testCounter :: IORef Int 36 | , testSilent :: Bool 37 | , testKeepDirs :: Bool 38 | , testArgs :: [(String, String)] 39 | } 40 | 41 | printInfo :: TestEnv -> [String] -> IO () 42 | printInfo TestEnv{testSilent = True} _ = return () 43 | printInfo TestEnv{testSilent = False} msg = do 44 | putStrLn (List.intercalate ": " msg) 45 | hFlush stdout 46 | 47 | printErr :: [String] -> IO () 48 | printErr msg = do 49 | hPutStrLn stderr ("*** " <> List.intercalate ": " msg) 50 | hFlush stderr 51 | 52 | printFailure :: TestEnv -> [String] -> IO () 53 | printFailure TestEnv{testCounter = n} msg = do 54 | modifyIORef' n (+ 1) 55 | printErr msg 56 | 57 | check :: TestEnv -> Bool -> [String] -> [String] -> [String] -> IO () 58 | check t True prefix msg _ = printInfo t (prefix <> msg) 59 | check t False prefix _ msg = printFailure t (prefix <> msg) 60 | 61 | checkEither :: TestEnv -> [String] -> Either [String] [String] -> IO () 62 | checkEither t prefix (Right msg) = printInfo t (prefix <> msg) 63 | checkEither t prefix (Left msg) = printFailure t (prefix <> msg) 64 | 65 | showContext :: Show a => String -> Integer -> a -> String 66 | showContext file line context = 67 | file <> ":" <> show line <> 68 | case show context of 69 | "()" -> "" 70 | s -> ":" <> s 71 | 72 | inform :: TestEnv -> String -> Integer -> String -> IO () 73 | inform t file line msg = 74 | printInfo t [showContext file line (), msg] 75 | 76 | expect :: Show a => TestEnv -> String -> Integer -> a -> Bool -> IO () 77 | expect t file line context x = 78 | check t x 79 | [showContext file line context] 80 | ["True"] 81 | ["False, but True was expected"] 82 | 83 | expectEq :: (Eq a, Show a, Show b) => 84 | TestEnv -> String -> Integer -> b -> a -> a -> IO () 85 | expectEq t file line context x y = 86 | check t (x == y) 87 | [showContext file line context] 88 | [show x <> " equals " <> show y] 89 | [show x <> " is not equal to " <> show y] 90 | 91 | expectNe :: (Eq a, Show a, Show b) => 92 | TestEnv -> String -> Integer -> b -> a -> a -> IO () 93 | expectNe t file line context x y = 94 | check t (x /= y) 95 | [showContext file line context] 96 | [show x <> " is not equal to " <> show y] 97 | [show x <> " equals " <> show y] 98 | 99 | expectNear :: (Num a, Ord a, Show a, Show b) => 100 | TestEnv -> String -> Integer -> b -> a -> a -> a -> IO () 101 | expectNear t file line context x y diff = 102 | check t (abs (x - y) <= diff) 103 | [showContext file line context] 104 | [show x <> " is near " <> show y] 105 | [show x <> " is not near " <> show y] 106 | 107 | expectNearTime :: Show a => 108 | TestEnv -> String -> Integer -> a -> 109 | UTCTime -> UTCTime -> NominalDiffTime -> IO () 110 | expectNearTime t file line context x y diff = 111 | check t (abs (diffUTCTime x y) <= diff) 112 | [showContext file line context] 113 | [show x <> " is near " <> show y] 114 | [show x <> " is not near " <> show y] 115 | 116 | expectIOErrorType :: Show a => 117 | TestEnv -> String -> Integer -> a 118 | -> (IOError -> Bool) -> IO b -> IO () 119 | expectIOErrorType t file line context which action = do 120 | result <- try action 121 | checkEither t [showContext file line context] $ case result of 122 | Left e | which e -> Right ["got expected exception (" <> show e <> ")"] 123 | | otherwise -> Left ["got wrong exception: ", show e] 124 | Right _ -> Left ["did not throw an exception"] 125 | 126 | -- | Traverse the directory tree in preorder. 127 | preprocessPathRecursive :: (OsPath -> IO ()) -> OsPath -> IO () 128 | preprocessPathRecursive f path = do 129 | dirExists <- doesDirectoryExist path 130 | if dirExists 131 | then do 132 | isLink <- pathIsSymbolicLink path 133 | f path 134 | when (not isLink) $ do 135 | names <- listDirectory path 136 | for_ ((path ) <$> names) (preprocessPathRecursive f) 137 | else do 138 | f path 139 | 140 | withNewDirectory :: Bool -> OsPath -> IO a -> IO a 141 | withNewDirectory keep dir action = do 142 | dir' <- makeAbsolute dir 143 | bracket_ (createDirectoryIfMissing True dir') (cleanup dir') action 144 | where cleanup dir' | keep = return () 145 | | otherwise = removePathForcibly dir' 146 | 147 | diffAsc' :: (j -> k -> Ordering) 148 | -> (u -> v -> Bool) 149 | -> [(j, u)] 150 | -> [(k, v)] 151 | -> ([(j, u)], [(k, v)]) 152 | diffAsc' cmp eq = go id id 153 | where 154 | go a b [] [] = (a [], b []) 155 | go a b jus [] = go (a . (jus <>)) b [] [] 156 | go a b [] kvs = go a (b . (kvs <>)) [] [] 157 | go a b jus@((j, u) : jus') kvs@((k, v) : kvs') = 158 | case cmp j k of 159 | LT -> go (a . ((j, u) :)) b jus' kvs 160 | GT -> go a (b . ((k, v) :)) jus kvs' 161 | EQ | eq u v -> go a b jus' kvs' 162 | | otherwise -> go (a . ((j, u) :)) (b . ((k, v) :)) jus' kvs' 163 | 164 | diffAsc :: (Ord k, Eq v) => [(k, v)] -> [(k, v)] -> ([(k, v)], [(k, v)]) 165 | diffAsc = diffAsc' compare (==) 166 | 167 | -- Environment variables may be sensitive, so don't log their values. 168 | scrubEnv :: (String, String) -> (String, String) 169 | scrubEnv (k, v) 170 | -- Allowlist for nonsensitive variables. 171 | | k `elem` ["XDG_CONFIG_HOME"] = (k, v) 172 | | otherwise = (k, "<" <> show (length v) <> " chars>") 173 | 174 | isolateEnvironment :: IO a -> IO a 175 | isolateEnvironment = bracket getEnvs setEnvs . const 176 | where 177 | -- Duplicate environment variables will cause problems for this code. 178 | -- https://github.com/haskell/cabal/issues/10718 179 | getEnvs = List.sort . filter (\(k, _) -> k /= "") <$> getEnvironment 180 | setEnvs target = do 181 | current <- getEnvs 182 | let (deletions, insertions) = diffAsc current target 183 | updateEnvs deletions insertions 184 | new <- getEnvs 185 | when (target /= new) $ do 186 | let (missing, extraneous) = diffAsc target new 187 | throwIO (userError ("isolateEnvironment.setEnvs failed:" <> 188 | " deletions=" <> show (scrubEnv <$> deletions) <> 189 | " insertions=" <> show (scrubEnv <$> insertions) <> 190 | " missing=" <> show (scrubEnv <$> missing) <> 191 | " extraneous=" <> show (scrubEnv <$> extraneous))) 192 | updateEnvs deletions insertions = do 193 | for_ deletions (unsetEnv . fst) 194 | for_ insertions (uncurry setEnv) 195 | 196 | isolateWorkingDirectory :: Bool -> OsPath -> IO a -> IO a 197 | isolateWorkingDirectory keep dir action = do 198 | normalisedDir <- decodeFS (normalise dir) 199 | when (normalisedDir `List.elem` [".", "./"]) $ 200 | throwIO (userError ("isolateWorkingDirectory cannot be used " <> 201 | "with current directory")) 202 | dir' <- makeAbsolute dir 203 | removePathForcibly dir' 204 | withNewDirectory keep dir' $ 205 | withCurrentDirectory dir' $ 206 | action 207 | 208 | run :: TestEnv -> String -> (TestEnv -> IO ()) -> IO () 209 | run t name action = do 210 | result <- tryAny (action t) 211 | case result of 212 | Left e -> check t False [name] [] ["exception", show e] 213 | Right () -> return () 214 | 215 | isolatedRun :: TestEnv -> String -> (TestEnv -> IO ()) -> IO () 216 | isolatedRun t@TestEnv{testKeepDirs = keep} name action = do 217 | workDir <- encodeFS ("dist/test-" <> name <> ".tmp") 218 | run t name (isolate workDir . action) 219 | where 220 | isolate workDir = isolateEnvironment . isolateWorkingDirectory keep workDir 221 | 222 | tryRead :: Read a => String -> Maybe a 223 | tryRead s = 224 | case reads s of 225 | [(x, "")] -> Just x 226 | _ -> Nothing 227 | 228 | getArg :: (String -> Maybe a) -> TestEnv -> String -> String -> a -> a 229 | getArg parse TestEnv{testArgs = args} testname name defaultValue = 230 | fromMaybe defaultValue (List.lookup (prefix <> name) args >>= parse) 231 | where prefix | testname == "" = "" 232 | | otherwise = testname <> "." 233 | 234 | readArg :: Read a => TestEnv -> String -> String -> a -> a 235 | readArg = getArg tryRead 236 | 237 | readBool :: String -> Maybe Bool 238 | readBool s = Just $ 239 | case toLower <$> s of 240 | 'y' : _ -> True 241 | 't' : _ -> True 242 | _ -> False 243 | 244 | parseArgs :: [String] -> [(String, String)] 245 | parseArgs = List.reverse . (second (List.drop 1) . List.span (/= '=') <$>) 246 | 247 | testMain :: (TestEnv -> IO ()) -> IO () 248 | testMain action = do 249 | args <- parseArgs <$> getArgs 250 | counter <- newIORef 0 251 | let t = TestEnv 252 | { testCounter = counter 253 | , testSilent = getArg readBool t "" "silent" False 254 | , testKeepDirs = getArg readBool t "" "keep-dirs" False 255 | , testArgs = args 256 | } 257 | action t 258 | n <- readIORef (counter) 259 | unless (n == 0) $ do 260 | putStrLn ("[" <> show n <> " failures]") 261 | hFlush stdout 262 | exitFailure 263 | -------------------------------------------------------------------------------- /tests/WithCurrentDirectory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module WithCurrentDirectory where 3 | #include "util.inl" 4 | import System.Directory.Internal 5 | import System.OsPath (()) 6 | import qualified Data.List as List 7 | 8 | main :: TestEnv -> IO () 9 | main _t = do 10 | createDirectory dir 11 | -- Make sure we're starting empty 12 | T(expectEq) () [] . List.sort =<< listDirectory dir 13 | cwd <- getCurrentDirectory 14 | withCurrentDirectory dir (writeFile (so testfile) contents) 15 | -- Are we still in original directory? 16 | T(expectEq) () cwd =<< getCurrentDirectory 17 | -- Did the test file get created? 18 | T(expectEq) () [testfile] . List.sort =<< listDirectory dir 19 | -- Does the file contain what we expected to write? 20 | T(expectEq) () contents =<< readFile (so (dir testfile)) 21 | where 22 | testfile = "testfile" 23 | contents = "some data\n" 24 | dir = "dir" 25 | -------------------------------------------------------------------------------- /tests/Xdg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Xdg where 3 | import qualified Data.List as List 4 | import System.Environment (setEnv, unsetEnv) 5 | import System.FilePath (searchPathSeparator) 6 | #if !defined(mingw32_HOST_OS) 7 | import System.OsPath (()) 8 | #endif 9 | #include "util.inl" 10 | 11 | main :: TestEnv -> IO () 12 | main _t = do 13 | 14 | -- smoke tests 15 | _ <- getXdgDirectoryList XdgDataDirs 16 | _ <- getXdgDirectoryList XdgConfigDirs 17 | 18 | T(expect) () True -- avoid warnings about redundant imports 19 | 20 | -- setEnv, unsetEnv require base 4.7.0.0+ 21 | #if !defined(mingw32_HOST_OS) 22 | unsetEnv "XDG_CONFIG_HOME" 23 | home <- getHomeDirectory 24 | T(expectEq) () (home ".config/mow") =<< getXdgDirectory XdgConfig "mow" 25 | #endif 26 | 27 | -- unset variables, so env doesn't affect test running 28 | unsetEnv "XDG_DATA_HOME" 29 | unsetEnv "XDG_CONFIG_HOME" 30 | unsetEnv "XDG_CACHE_HOME" 31 | unsetEnv "XDG_STATE_HOME" 32 | xdgData <- getXdgDirectory XdgData "ff" 33 | xdgConfig <- getXdgDirectory XdgConfig "oo" 34 | xdgCache <- getXdgDirectory XdgCache "rk" 35 | xdgState <- getXdgDirectory XdgState "aa" 36 | 37 | -- non-absolute paths are ignored, and the fallback is used 38 | setEnv "XDG_DATA_HOME" "ar" 39 | setEnv "XDG_CONFIG_HOME" "aw" 40 | setEnv "XDG_CACHE_HOME" "ba" 41 | setEnv "XDG_STATE_HOME" "uw" 42 | T(expectEq) () xdgData =<< getXdgDirectory XdgData "ff" 43 | T(expectEq) () xdgConfig =<< getXdgDirectory XdgConfig "oo" 44 | T(expectEq) () xdgCache =<< getXdgDirectory XdgCache "rk" 45 | T(expectEq) () xdgState =<< getXdgDirectory XdgState "aa" 46 | 47 | unsetEnv "XDG_CONFIG_DIRS" 48 | unsetEnv "XDG_DATA_DIRS" 49 | _xdgConfigDirs <- getXdgDirectoryList XdgConfigDirs 50 | _xdgDataDirs <- getXdgDirectoryList XdgDataDirs 51 | 52 | #if !defined(mingw32_HOST_OS) 53 | T(expectEq) () ["/etc/xdg"] _xdgConfigDirs 54 | T(expectEq) () ["/usr/local/share/", "/usr/share/"] _xdgDataDirs 55 | #endif 56 | 57 | setEnv "XDG_DATA_DIRS" (List.intercalate [searchPathSeparator] ["/a", "/b"]) 58 | setEnv "XDG_CONFIG_DIRS" (List.intercalate [searchPathSeparator] ["/c", "/d"]) 59 | T(expectEq) () ["/a", "/b"] =<< getXdgDirectoryList XdgDataDirs 60 | T(expectEq) () ["/c", "/d"] =<< getXdgDirectoryList XdgConfigDirs 61 | 62 | return () 63 | -------------------------------------------------------------------------------- /tests/util.inl: -------------------------------------------------------------------------------- 1 | #define T(f) (T.f _t __FILE__ __LINE__) 2 | 3 | import Prelude () 4 | import System.Directory.Internal.Prelude 5 | import System.Directory.OsPath 6 | import TestUtils () 7 | import Util (TestEnv) 8 | import qualified Util as T 9 | -- This comment prevents "T" above from being treated as the function-like 10 | -- macro defined earlier. 11 | -------------------------------------------------------------------------------- /tools/retry: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | usage() { 4 | cat >&2 <] [cmd...] 6 | EOF 7 | exit 1 8 | } 9 | 10 | n=3 11 | while [ $# -gt 0 ]; do 12 | case $1 in 13 | --) 14 | shift 15 | break;; 16 | -n) 17 | shift 18 | n=${1-} 19 | if [ $# -eq 0 ]; then 20 | usage 21 | fi 22 | shift;; 23 | -*) 24 | usage;; 25 | *) 26 | break;; 27 | esac 28 | done 29 | 30 | i=1 31 | while :; do 32 | if "$@"; then 33 | exit 34 | else 35 | e=$? 36 | cmd=$@ 37 | i=`expr $i + 1` || exit 38 | if [ $i -le "$n" ]; then 39 | cat >&2 < IO () 26 | main _t = do 27 | 28 | """[1:] 29 | MAIN_NAME = "Main" 30 | MAIN_TEMPLATE = """ 31 | module Main (main) where 32 | import qualified Util as T 33 | {imports} 34 | main :: IO () 35 | main = T.testMain $ \ _t -> do 36 | {runs} 37 | """[1:-1] 38 | MAIN_IMPORT_TEMPLATE = "import qualified {name}\n" 39 | MAIN_RUN_TEMPLATE = ' T.isolatedRun _t "{name}" {name}.main\n' 40 | BLACKLIST = "^(Main|.*Util.*)$" 41 | 42 | CABAL_FILE = glob.glob("*.cabal")[0] 43 | CABAL_SECTION_PATTERN = """(?s) 44 | ( *)-- test-modules-begin 45 | .*?-- test-modules-end 46 | """ 47 | CABAL_SECTION_TEMPLATE = """ 48 | {0}-- test-modules-begin 49 | {1}{0}-- test-modules-end 50 | """ 51 | 52 | program = os.path.basename(sys.argv[0]) 53 | 54 | def rename(src, dest): 55 | '''Rename a file (allows overwrites on Windows).''' 56 | import os 57 | if os.name == "nt": 58 | import ctypes, ctypes.wintypes 59 | MoveFileExW = ctypes.windll.kernel32.MoveFileExW 60 | MoveFileExW.restype = ctypes.wintypes.BOOL 61 | MOVEFILE_REPLACE_EXISTING = ctypes.wintypes.DWORD(0x1) 62 | success = MoveFileExW(ctypes.wintypes.LPCWSTR(src), 63 | ctypes.wintypes.LPCWSTR(dest), 64 | MOVEFILE_REPLACE_EXISTING) 65 | if not success: 66 | raise ctypes.WinError() 67 | else: 68 | os.rename(src, dest) 69 | 70 | def usage(): 71 | sys.stderr.write(USAGE.format(program=program)) 72 | sys.exit(2) 73 | 74 | def add(name): 75 | if not name[0].isupper(): 76 | sys.stderr.write("{0}: must start with a capital letter: {1}\n" 77 | .format(program, name)) 78 | sys.exit(1) 79 | filename = os.path.join(TEST_DIR, name + TEST_EXT) 80 | if os.path.exists(filename): 81 | sys.stderr.write("{0}: test already exists: {1}\n" 82 | .format(program, filename)) 83 | sys.exit(1) 84 | with open(filename, "wb") as file: 85 | file.write(TEST_TEMPLATE.format(name=name) 86 | .encode("utf8")) 87 | update() 88 | print("{0}: test added: {1}".format(program, filename)) 89 | 90 | def update(): 91 | tests = [] 92 | for basename in os.listdir(TEST_DIR): 93 | name, ext = os.path.splitext(basename) 94 | if (ext == TEST_EXT and 95 | len(name) > 0 and 96 | not re.search(BLACKLIST, name) and 97 | name[0].isupper()): 98 | tests.append(name) 99 | tests.sort() 100 | with open(os.path.join(TEST_DIR, MAIN_NAME + TEST_EXT), "wb") as file: 101 | file.write(MAIN_TEMPLATE.format( 102 | imports="".join(MAIN_IMPORT_TEMPLATE.format(name=name) 103 | for name in tests), 104 | runs="".join(MAIN_RUN_TEMPLATE.format(name=name) 105 | for name in tests), 106 | ).encode("utf8")) 107 | with open(CABAL_FILE, "rb") as file: 108 | cabal_file = file.read().decode("utf8") 109 | with open(CABAL_FILE + ".tmp", "wb") as file: 110 | indent, = re.search(CABAL_SECTION_PATTERN, cabal_file).groups() 111 | repl = CABAL_SECTION_TEMPLATE.format( 112 | indent, 113 | "".join("{0}{1}\n".format(indent, name) for name in tests) 114 | ) 115 | file.write(re.sub(CABAL_SECTION_PATTERN, repl, cabal_file) 116 | .encode("utf8")) 117 | rename(CABAL_FILE + ".tmp", CABAL_FILE) 118 | 119 | if len(sys.argv) < 2: 120 | usage() 121 | 122 | command = sys.argv[1] 123 | if command == "add": 124 | if len(sys.argv) > 3: 125 | usage() 126 | add(sys.argv[2]) 127 | elif command == "update": 128 | if len(sys.argv) > 2: 129 | usage() 130 | update() 131 | -------------------------------------------------------------------------------- /tools/testscript: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -eux 3 | 4 | ghcflags="-rtsopts -threaded -Werror -Wwarn=deprecations ${GHC_FLAGS-}" 5 | testflags="CreateDirectoryIfMissing001.num-repeats=100000 +RTS -N2" 6 | stack="stack --no-terminal ${STACK_FLAGS-}" 7 | 8 | # overridable hook 9 | before_prepare() { 10 | : 11 | } 12 | 13 | prepare() { 14 | before_prepare 15 | if [ -f configure.ac ]; then 16 | autoreconf -i 17 | fi 18 | if [ "${STACK_RESOLVER-}" ]; then 19 | 20 | cat >stack.yaml <cabal.project <&2 "Error: Please describe version $version in changelog.md." 65 | return 1 66 | } 67 | } 68 | 69 | eval "${TESTSCRIPT_OVERRIDES-}" 70 | "$@" 71 | -------------------------------------------------------------------------------- /tools/vercmp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | import sys 3 | 4 | def parse_version(s): 5 | return tuple(map(int, s.split("."))) 6 | 7 | def cmp(x, y): 8 | return (x > y) - (x < y) 9 | 10 | print(cmp(parse_version(sys.argv[1]), parse_version(sys.argv[2]))) 11 | --------------------------------------------------------------------------------