diff --git a/.cirrus.yml b/.cirrus.yml deleted file mode 100644 index 4188a3c4..00000000 --- a/.cirrus.yml +++ /dev/null @@ -1,103 +0,0 @@ -freebsd_instance: - image_family: freebsd-14-3 - -task: - name: FreeBSD+ghc-9.12.4+cabal - env: - PACKCHECK_COMMAND: cabal - - # ------------------------------------------------------------------------ - # Common options - # ------------------------------------------------------------------------ - CABAL_REINIT_CONFIG: y - LC_ALL: C.UTF-8 - - # ------------------------------------------------------------------------ - # What to build - # ------------------------------------------------------------------------ - # DISABLE_TEST: "y" - # DISABLE_BENCH: "y" - # DISABLE_DOCS: "y" - DISABLE_SDIST_BUILD: "y" - # DISABLE_SDIST_GIT_CHECK: "y" - DISABLE_DIST_CHECKS: "y" - - # ------------------------------------------------------------------------ - # Selecting tool versions - # ------------------------------------------------------------------------ - # For updating see: https://downloads.haskell.org/~ghcup/ - GHCUP_VERSION: 0.1.50.2 - GHCVER: 9.12.4 - - # ------------------------------------------------------------------------ - # stack options (if using stack builds) - # ------------------------------------------------------------------------ - # Note requiring a specific version of stack using STACKVER may fail due to - # github API limit while checking and upgrading/downgrading to the specific - # version. - #STACKVER: "1.6.5" - #STACK_UPGRADE: "y" - #STACK_YAML: "stack.yaml" - - # ------------------------------------------------------------------------ - # cabal options - # ------------------------------------------------------------------------ - CABAL_CHECK_RELAX: y - #CABAL_PROJECT: cabal.project - - # ------------------------------------------------------------------------ - # Location of packcheck.sh (the shell script invoked to perform CI tests ). - # ------------------------------------------------------------------------ - # You can either commit the packcheck.sh script at this path in your repo or - # you can use it by specifying the PACKCHECK_REPO_URL option below in which - # case it will be automatically copied from the packcheck repo to this path - # during CI tests. In any case it is finally invoked from this path. - PACKCHECK: "./packcheck.sh" - # If you have not committed packcheck.sh in your repo at PACKCHECK - # then it is automatically pulled from this URL. - PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck" - PACKCHECK_GITHUB_COMMIT: "4efa717bc63b4bbd0501a07df5c610849e5d6281" - - cabal_cache: - folder: ~/.cabal - fingerprint_script: echo $GHCVER - - # Cabal store is in .local/state/cabal - local_cache: - folder: ~/.local - fingerprint_script: echo $GHCVER - - ghcup_cache: - folder: ~/.ghcup - fingerprint_script: echo $GHCUP_VERSION $GHCVER - - #local_bin_cache: - # folder: ~/.local/bin - # fingerprint_script: echo $HLINT_VERSION - - deps_install_script: | - pkg install -y gmake - pkg install -y bash - - packcheck_install_script: | - if test ! -e "$PACKCHECK" - then - if test -z "$PACKCHECK_GITHUB_COMMIT" - then - die "PACKCHECK_GITHUB_COMMIT is not specified." - fi - PACKCHECK_URL=${PACKCHECK_GITHUB_URL}/${PACKCHECK_GITHUB_COMMIT}/packcheck.sh - curl --fail -sL -o "$PACKCHECK" $PACKCHECK_URL || exit 1 - chmod +x $PACKCHECK - elif test ! -x "$PACKCHECK" - then - chmod +x $PACKCHECK - fi - - packcheck_run_script: | - # Commands like mount, sysctl for info require sbin - PTH=/usr/local/bin:/usr/bin:/bin:/sbin:/usr/sbin - # Use "bash -c" instead of invoking directly to preserve quoted - # arguments in PACKCHECK_COMMAND e.g. DOCSPEC_OPTIONS="--timeout 60". - # Direct invocation would word-split on spaces inside quoted values. - bash -c "$PACKCHECK $PACKCHECK_COMMAND PATH=$PTH" diff --git a/.github/workflows/freebsd.yml b/.github/workflows/freebsd.yml new file mode 100644 index 00000000..66a116b5 --- /dev/null +++ b/.github/workflows/freebsd.yml @@ -0,0 +1,92 @@ +# FreeBSD CI +# +# FreeBSD is not a native GitHub Actions runner, so this workflow runs +# the build inside a VM via vmactions/freebsd-vm. It is kept separate +# from haskell.yml because the cache/restore step model in that +# workflow (hackage index, ghcup, deps caches) does not apply inside +# the VM. + +name: FREEBSD + +on: + workflow_dispatch: + pull_request: + push: + branches: + - master + +jobs: + build: + name: >- + freebsd-${{ matrix.release }} + ${{ matrix.command }} + ${{ matrix.ghc_version }} + runs-on: ubuntu-latest + continue-on-error: ${{ matrix.ignore_error }} + strategy: + fail-fast: false + matrix: + include: + - release: "14.5" + command: cabal + ghc_version: 9.14.1 + ignore_error: true + + steps: + - uses: actions/checkout@v4 + + - name: Build on FreeBSD + uses: vmactions/freebsd-vm@v1 + env: + PACKCHECK_COMMAND: ${{ matrix.command }} + GHCVER: ${{ matrix.ghc_version }} + # For updating see: https://downloads.haskell.org/~ghcup/ + GHCUP_VERSION: 0.1.50.2 + LC_ALL: C.UTF-8 + CABAL_REINIT_CONFIG: y + CABAL_CHECK_RELAX: y + CABAL_PROJECT: cabal.project + # With the default -j (4 CPUs) the VM (6 GB) killed cabal while it + # built fusion-plugin and other dependencies in parallel. + CABAL_BUILD_OPTIONS: "-j2" + DISABLE_BENCH: "y" + DISABLE_DOCS: "y" + DISABLE_SDIST_BUILD: "y" + DISABLE_DIST_CHECKS: "y" + PACKCHECK: "./packcheck.sh" + PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck" + PACKCHECK_GITHUB_COMMIT: "20514de6ae27035b0406b4ed46d628c806e40b49" + with: + release: ${{ matrix.release }} + usesh: true + copyback: false + envs: >- + PACKCHECK_COMMAND GHCVER GHCUP_VERSION LC_ALL + CABAL_REINIT_CONFIG CABAL_CHECK_RELAX CABAL_PROJECT CABAL_BUILD_OPTIONS + DISABLE_BENCH DISABLE_DOCS DISABLE_SDIST_BUILD DISABLE_DIST_CHECKS + PACKCHECK PACKCHECK_GITHUB_URL PACKCHECK_GITHUB_COMMIT + prepare: | + pkg update + pkg install -y gmake + pkg install -y bash + pkg install -y git + pkg install -y gmp + run: | + if test ! -e "$PACKCHECK" + then + if test -z "$PACKCHECK_GITHUB_COMMIT" + then + echo "PACKCHECK_GITHUB_COMMIT is not specified." >&2 + exit 1 + fi + PACKCHECK_URL=${PACKCHECK_GITHUB_URL}/${PACKCHECK_GITHUB_COMMIT}/packcheck.sh + curl --fail -sL -o "$PACKCHECK" $PACKCHECK_URL || exit 1 + chmod +x $PACKCHECK + elif test ! -x "$PACKCHECK" + then + chmod +x $PACKCHECK + fi + # Use "bash -c" instead of invoking directly to preserve quoted + # arguments in PACKCHECK_COMMAND e.g. DOCSPEC_OPTIONS="--timeout 60". + # Direct invocation would word-split on spaces inside quoted values. + bash -c "$PACKCHECK $PACKCHECK_COMMAND" diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 3f86aad2..7409b9f9 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -109,7 +109,7 @@ jobs: # If you have not committed packcheck.sh in your repo at PACKCHECK # then it is automatically pulled from this URL. PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck" - PACKCHECK_GITHUB_COMMIT: "74a50fd9bcb06907b822e910938dae795d0f23cc" + PACKCHECK_GITHUB_COMMIT: "20514de6ae27035b0406b4ed46d628c806e40b49" # ubuntu seems to have better support than debian on CI systems runs-on: ${{ matrix.runner }} @@ -255,11 +255,13 @@ jobs: - name: ci runner: ubuntu-latest command: hlint + # Bump to invalidate the cached hlint binary in ~/.local/bin. + ghc_salt: 1 # WARNING! cannot use # comments inside pack_options. pack_options: >- - HLINT_VERSION=3.6.1 + HLINT_VERSION=3.10 HLINT_OPTIONS="lint" - HLINT_TARGETS="src test Benchmark" + HLINT_TARGETS="src test benchmark" - name: docspec runner: ubuntu-latest @@ -300,6 +302,38 @@ jobs: - uses: actions/checkout@v4 + # The macOS image may ship Command Line Tools newer than the default + # Xcode (e.g. CLT 27.0 with Xcode 26.6). Linking against the CLT SDK then + # fails with "tapi error: malformed file ... unknown architecture + # arm64e.x1-macos". Select the default Xcode so that the compiler, linker + # and SDK come from the same toolchain. packcheck clears the environment, + # so SDKROOT or DEVELOPER_DIR cannot be used instead. + # + # The GHC bindists for macOS hardcode the CLT SDK path from their build + # machine, e.g. the rts and ghci package confs of GHC 9.14.1 have + # /Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/lib in + # library-dirs, so the linker uses the CLT SDK even when Xcode is + # selected. Point the CLT MacOSX.sdk symlink at the Xcode SDK. + # + # The GHC and dependency cache keys include the Xcode version and build, + # so a runner image with a different Xcode installs GHC afresh. + - name: Select default Xcode (macOS) + id: xcode + if: runner.os == 'macOS' + run: | + sudo xcode-select -s /Applications/Xcode.app/Contents/Developer + xcode-select -p + sdk=$(xcrun --show-sdk-path) + echo "$sdk" + clt=/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk + if test -L "$clt"; then + ls -ld "$clt" + sudo ln -sfn "$sdk" "$clt" + ls -ld "$clt" + fi + ver=$(xcodebuild -version | awk 'NR==1{v=$2} /Build version/{b=$3} END{print v "-" b}') + echo "toolchain=-xcode-$ver" >> "$GITHUB_OUTPUT" + # This should happen before cache restore. - name: Remove ~/.ghcup symlink (non-Windows) if: runner.os != 'Windows' @@ -309,7 +343,8 @@ jobs: # See the "cabal path" output in the CI logs to tweak the cache # locations. - # Shared by all tests, all platforms + # Shared by all tests, all platforms. Other workflows can restore it + # with the same key. - name: Restore hackage package index (non-Windows) id: restore-hackage uses: actions/cache/restore@v4 @@ -317,7 +352,7 @@ jobs: with: path: | ~/.cache/cabal/packages - key: cabal-hackage-index-non-windows + key: cabal-hackage-index # GHC is not test/options specific - name: Restore ghcup and ghc (non-Windows) @@ -327,7 +362,7 @@ jobs: with: path: | ~/.ghcup - key: ghc-${{ matrix.ghc_version }}-v${{ matrix.ghc_salt }}-${{ matrix.runner }} + key: ghc-${{ matrix.ghc_version }}-v${{ matrix.ghc_salt }}-${{ matrix.runner }}${{ steps.xcode.outputs.toolchain }} # GHC is not test/options specific #- name: Restore ghcup and ghc (Windows) @@ -358,7 +393,7 @@ jobs: ~/.local/bin ~/.local/state/cabal ~/.stack - key: ${{ matrix.command }}-deps-ghc-${{ matrix.ghc_version }}-v${{ matrix.ghc_salt }}-${{ matrix.runner }}-${{ matrix.name }} + key: ${{ matrix.command }}-deps-ghc-${{ matrix.ghc_version }}-v${{ matrix.ghc_salt }}-${{ matrix.runner }}-${{ matrix.name }}${{ steps.xcode.outputs.toolchain }} # Deps are test/options specific - name: Restore build dependencies, hackage index, local/bin (Windows) @@ -429,7 +464,8 @@ jobs: ARGS="$ARGS CABAL_BUILDDIR=\"/c/b\" WINVER=$WINVER" ARGS="$ARGS NUMBER_OF_PROCESSORS=$NUMBER_OF_PROCESSORS" ARGS="$ARGS PROCESSOR_IDENTIFIER=\"$PROCESSOR_IDENTIFIER\"" - PATH_VAR="$PATH_VAR:/c/ghcup:/c/Program Files/7-Zip:/mingw64/bin" + # Git for Windows 2.56 moved /mingw64 to /ucrt64 + PATH_VAR="$PATH_VAR:/c/ghcup:/c/Program Files/7-Zip:/ucrt64/bin:/mingw64/bin" ;; esac ARGS="$ARGS PATH=\"$PATH_VAR\"" @@ -457,14 +493,14 @@ jobs: if: always() && steps.deps-only.outcome == 'success' && runner.os != 'Windows' && steps.restore-hackage.outputs.cache-hit != 'true' with: path: ~/.cache/cabal/packages - key: cabal-hackage-index-non-windows + key: cabal-hackage-index - name: Save ghcup and ghc (non-Windows) uses: actions/cache/save@v4 if: always() && steps.deps-only.outcome == 'success' && runner.os != 'Windows' && steps.restore-ghcup.outputs.cache-hit != 'true' with: path: ~/.ghcup - key: ghc-${{ matrix.ghc_version }}-v${{ matrix.ghc_salt }}-${{ matrix.runner }} + key: ghc-${{ matrix.ghc_version }}-v${{ matrix.ghc_salt }}-${{ matrix.runner }}${{ steps.xcode.outputs.toolchain }} # On Windows, ghc restore step takes 2-3 minutes whereas installing # GHC takes less than 2 minutes. On top of this saving the ghc cache @@ -486,7 +522,7 @@ jobs: ~/.local/bin ~/.local/state/cabal ~/.stack - key: ${{ matrix.command }}-deps-ghc-${{ matrix.ghc_version }}-v${{ matrix.ghc_salt }}-${{ matrix.runner }}-${{ matrix.name }} + key: ${{ matrix.command }}-deps-ghc-${{ matrix.ghc_version }}-v${{ matrix.ghc_salt }}-${{ matrix.runner }}-${{ matrix.name }}${{ steps.xcode.outputs.toolchain }} # hackage package index is part of C:/cabal # Deps are test/options specific, hence, matrix.name in the key diff --git a/.packcheck.ignore b/.packcheck.ignore index 1bba77e6..844bf700 100644 --- a/.packcheck.ignore +++ b/.packcheck.ignore @@ -1,4 +1,4 @@ -.cirrus.yml +.github/workflows/freebsd.yml .packcheck.ignore .github/workflows/haskell.yml .gitignore @@ -12,3 +12,5 @@ flake.nix packages.nix stack.yaml test/Main.hs +cabal.project +sources.nix diff --git a/README.md b/README.md index f6ea6a34..9bb0fa6e 100644 --- a/README.md +++ b/README.md @@ -16,9 +16,10 @@ shell, or instead of assembling the same behaviour from `directory`, Where a function differs from GNU, for example `rm -r` on a symbolic link with a trailing slash, which here deletes only the link, the difference is documented. -* No subprocesses: no quoting of arguments, no parsing of text output. - Errors are Haskell exceptions, and the code also runs on Windows, where - the commands are not installed. +* The utilities run no subprocesses: no quoting of arguments, no parsing + of text output. Errors are Haskell exceptions, and the code also runs on + Windows, where the commands are not installed. `Streamly.Coreutils.Sh` is + the exception: it runs shell commands. * `ls`, `find` and `tail` return [streamly](https://github.com/composewell/streamly) streams. You can filter, map, take the first few entries or fold them as they are produced, in constant memory, even for a directory tree with @@ -35,7 +36,8 @@ shell, or instead of assembling the same behaviour from `directory`, * File tests compose like the operands of `test`, and a combined test makes a single `stat` call: ``test p (isFile `and_` size (> 10240))``. * When you do need a shell command, `Streamly.Coreutils.Sh` runs it and - connects its input and output to Haskell streams. + connects its input and output to Haskell streams. It uses `/bin/sh`, and + on Windows `sh` from the `PATH`, e.g. from Git for Windows. ## Example diff --git a/appveyor.yml b/appveyor.yml index 7f9d4d00..2bb5402d 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -33,7 +33,10 @@ environment: # DISABLE_BENCH: "y" # DISABLE_DOCS: "y" # DISABLE_DIST_CHECKS: "y" - # DISABLE_SDIST_BUILD: "y" + # On Windows, DISABLE_SDIST_BUILD is useful for (1) avoiding + # path length restriction, (2) avoid installing autoreconf + # for configure builds. + DISABLE_SDIST_BUILD: "y" # Note: these require the "diff" utility. # DISABLE_SDIST_GIT_CHECK: "y" DISABLE_SDIST_PROJECT_CHECK: "y" @@ -55,12 +58,16 @@ environment: # If you have not committed packcheck.sh in your repo at PACKCHECK_LOCAL_PATH # then it is automatically pulled from this URL. PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck" - PACKCHECK_GITHUB_COMMIT: "b91dd7daf50d91047ca8c1cce47e8634e34dfcbc" + PACKCHECK_GITHUB_COMMIT: "20514de6ae27035b0406b4ed46d628c806e40b49" # Override the temp directory to avoid sed escaping issues # See https://github.com/haskell/cabal/issues/5386 TMP: "c:\\tmp" +# ------------------------------------------------------------------------ +# Usually you do not need to change anything below this line +# ------------------------------------------------------------------------ + # Bump the -> version to clear the cache # packcheck uses "%APPDATA%\\local" to install tools like hlint etc. # cabal may use "%APPDATA%\\cabal" or "c:\\cabal" @@ -72,7 +79,8 @@ cache: - "C:\\ghcup" - "C:\\cabal" -# Folder where the repository is cloned. +# Folder where the repository is cloned. Kept as short as possible to avoid +# long path issues on Windows. clone_folder: "c:\\pkg" build: off diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..4132eb26 --- /dev/null +++ b/cabal.project @@ -0,0 +1,3 @@ +packages: . + +flags: +limit-build-mem diff --git a/cabal.project.d/master b/cabal.project.d/master index 65475c40..6ab0a3df 100644 --- a/cabal.project.d/master +++ b/cabal.project.d/master @@ -1,5 +1,7 @@ packages: . +flags: +limit-build-mem + source-repository-package type: git location: https://github.com/composewell/streamly.git diff --git a/cabal.project.d/master-Werror b/cabal.project.d/master-Werror index 4326d0a7..da73857b 100644 --- a/cabal.project.d/master-Werror +++ b/cabal.project.d/master-Werror @@ -1,5 +1,7 @@ packages: . +flags: +limit-build-mem + package streamly-coreutils ghc-options: -Werror diff --git a/cbits/rename_noreplace.c b/cbits/rename_noreplace.c new file mode 100644 index 00000000..72252337 --- /dev/null +++ b/cbits/rename_noreplace.c @@ -0,0 +1,59 @@ +/* + * Rename that fails instead of replacing an existing destination. + */ + +#if defined(_WIN32) + +#include + +/* + * Returns 0 on success, otherwise the GetLastError() code, read here so that + * nothing can overwrite it before the caller sees it. ERROR_FILE_EXISTS or + * ERROR_ALREADY_EXISTS mean the destination exists. + */ +DWORD streamly_coreutils_rename_noreplace_w(LPCWSTR src, LPCWSTR dst) +{ + /* Without MOVEFILE_REPLACE_EXISTING, MoveFileExW does not replace. */ + if (MoveFileExW(src, dst, 0)) { + return 0; + } + return GetLastError(); +} + +#else + +/* + * Returns 0 on success, -1 with errno set on failure. EEXIST means the + * destination exists; ENOSYS means the platform has no such call. + */ + +#define _GNU_SOURCE +#include +#include +#include +#include + +#if defined(__linux__) +#include +#ifndef RENAME_NOREPLACE +#define RENAME_NOREPLACE (1 << 0) +#endif +#endif + +int streamly_coreutils_rename_noreplace(const char *src, const char *dst) +{ +#if defined(__linux__) && defined(SYS_renameat2) + /* syscall() instead of renameat2(), which needs glibc >= 2.28. */ + return syscall(SYS_renameat2, AT_FDCWD, src, AT_FDCWD, dst, + RENAME_NOREPLACE); +#elif defined(__APPLE__) && defined(RENAME_EXCL) + return renamex_np(src, dst, RENAME_EXCL); +#else + (void)src; + (void)dst; + errno = ENOSYS; + return -1; +#endif +} + +#endif diff --git a/design/naming.md b/design/naming.md index 2234d716..6db862fc 100644 --- a/design/naming.md +++ b/design/naming.md @@ -49,5 +49,5 @@ The command runner would be called "cp" so it would be "cp :: CpOptions -> IO ## Example usage `Touch.touch (Touch.create False . Touch.followSymlinks False) path` -`Mv.mv (Mv.force True) old new` +`Mv.mv (Mv.overwrite Mv.OverwriteNever) old new` `Rm.rm (Rm.withForce Rm.Force . Rm.recursive True) path` diff --git a/flake.nix b/flake.nix index f977da94..8eba7a0b 100644 --- a/flake.nix +++ b/flake.nix @@ -11,9 +11,8 @@ basepkgs.nixpack.mkOutputs { inherit nixpkgs nixpkgs-darwin basepkgs; name = "streamly-coreutils"; - sources = basepkgs.nixpack.lib.localSource "streamly-coreutils" ./.; #packages = basepkgs.nixpack.lib.devPackage "streamly-coreutils"; - #sources = import ./sources.nix; + sources = import ./sources.nix; packages = import ./packages.nix; }; } diff --git a/sources.nix b/sources.nix new file mode 100644 index 00000000..454bc467 --- /dev/null +++ b/sources.nix @@ -0,0 +1,17 @@ +{nixpack}: +# Package sources to override the streamly-packages set. +with nixpack.mkSources; +{ +layers = [ +{ + streamly-core = hackage "0.3.2" + "1bhxdddmpg6x27kcsg9qrdsz2ggqmirlrgd7l8v6kb5xq60lf2sb"; + streamly = hackage "0.11.1" + "1dxyhq8m9fr3ghpmxkh6bc37fd4f1048xckjrlpp6ybvlg0lq7g2" + // { rev = "2"; + cabalSha256 = "022hh6aw4sa6a5z6anmngrb4lgh9xql824jn68m01pppqszd9syz"; + }; + streamly-coreutils = local ./.; +} +]; +} diff --git a/src/Streamly/Coreutils/Cp.hs b/src/Streamly/Coreutils/Cp.hs index 0e3301e6..1acc5ac1 100644 --- a/src/Streamly/Coreutils/Cp.hs +++ b/src/Streamly/Coreutils/Cp.hs @@ -13,9 +13,9 @@ module Streamly.Coreutils.Cp -- * Cp options , CpOptions - , CpOverwrite (..) + , Overwrite (..) -- , CpBackup - , cpOverwrite + , overwrite , CpMethod (..) , cpMethod ) @@ -29,6 +29,7 @@ import Streamly.FileSystem.Path (Path) import qualified Streamly.FileSystem.Path as Path import Streamly.Coreutils.FileTest +import Streamly.Coreutils.Overwrite (Overwrite(..), shouldOverwrite) -- Note: Recursive copy can be done using find. -- @@ -42,14 +43,6 @@ import Streamly.Coreutils.FileTest -- Ideally, cp should not hard link as we have ln for hard linking, but it can -- be useful when we need to hard link recursively. --- | Specify the overwrite behavior of copy. -data CpOverwrite = - OverwriteNever -- ^ Do not overwrite when destination file exists - | OverwriteAlways -- ^ Overwrite destination file if it exists - | OverwriteOnly -- ^ Copy only if the destination exists - | OverwriteUpdate -- ^ Overwrite an existing destination file only if it is - -- older than the source file. - -- | When overwriting specify backup behavior. -- newtype CpBackup = Backup (Maybe String) @@ -61,7 +54,7 @@ data CpMethod = | CopyClone -- Use the cloning method if available on the platform data CpOptions = CpOptions - { optOverwrite :: CpOverwrite + { optOverwrite :: Overwrite , optCopyMethod :: CpMethod } @@ -71,12 +64,12 @@ defaultOptions = CpOptions , optCopyMethod = CopyContents } --- | Specify the overwrite behavior. See 'Overwrite'. +-- | Specify what to do when the destination exists. See 'Overwrite'. -- --- Default is 'OverwriteAlways'. +-- Default (without this modifier): 'OverwriteAlways', like GNU @cp@. -- -cpOverwrite :: CpOverwrite -> CpOptions -> CpOptions -cpOverwrite opt options = options { optOverwrite = opt } +overwrite :: Overwrite -> CpOptions -> CpOptions +overwrite opt options = options { optOverwrite = opt } -- | Specify the copy method. -- @@ -95,23 +88,9 @@ cpCopy method src dest = SymbolicLink -> error "Unimplemented" CopyClone -> error "Unimplemented" --- | Determine whether source should be copied to destination based on the --- specified overwrite behavior option. -cpShouldOverwrite :: CpOverwrite -> Path -> Path -> IO Bool -cpShouldOverwrite option src dest = - case option of - OverwriteAlways -> return True - OverwriteOnly -> test dest doesItExist - OverwriteNever -> not <$> test dest doesItExist - OverwriteUpdate -> do - r <- test dest doesItExist - if r - then test src $ newerThanFile dest - else return True - -- | @cp option-modifier source destination@. Copy a file or directory. cp :: (CpOptions -> CpOptions) -> Path -> Path -> IO () cp f src dest = do let options = f defaultOptions - r <- cpShouldOverwrite (optOverwrite options) src dest + r <- shouldOverwrite test (optOverwrite options) src dest when r $ cpCopy (optCopyMethod options) src dest diff --git a/src/Streamly/Coreutils/FileTest/Common.hs b/src/Streamly/Coreutils/FileTest/Common.hs index c2f2811e..293cce91 100644 --- a/src/Streamly/Coreutils/FileTest/Common.hs +++ b/src/Streamly/Coreutils/FileTest/Common.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -194,6 +193,7 @@ module Streamly.Coreutils.FileTest.Common where import Control.Exception (catch, throwIO) +import Control.Monad ((>=>)) import Data.Bits ((.&.)) import Data.Int (Int64) import Data.IORef (IORef, newIORef, readIORef, writeIORef) @@ -466,7 +466,7 @@ withState p = withStateM (\fp fs -> pure $ p fp fs) -- | Like 'withStatus' but the supplied function may perform IO. withStatusM :: (FileStatus -> IO Bool) -> FileTest -withStatusM p = FileTest $ Predicate $ \fs -> requireStatus fs >>= p +withStatusM p = FileTest $ Predicate $ requireStatus >=> p -- | Convert a @FileStatus -> Bool@ function into a 'FileTest' predicate. withStatus :: (FileStatus -> Bool) -> FileTest @@ -724,7 +724,7 @@ hours n = n * 3600 -- >>> let _ = accessedOlderThan (days 1) -- days :: NominalDiffTime -> NominalDiffTime -days n = n * 86400 +days n = n * 86_400 ----------------------------------- -- Comparing times @@ -884,7 +884,7 @@ ageSatisfiesWith -> (NominalDiffTime -> Bool) -> FileTest ageSatisfiesWith getFileTime p = - withStatusM $ \st -> p <$> ageOfWith getFileTime st + withStatusM $ fmap p . ageOfWith getFileTime -- | True if the access age of the file satisfies the supplied predicate. -- @@ -1026,7 +1026,7 @@ getSize st = let COff sz = Files.fileSize st in sz -- directory may still have a non-zero size. On POSIX systems, the size -- typically accounts for the mandatory "." and ".." entries. size :: (Int64 -> Bool) -> FileTest -size cmp = withStatus (\st -> cmp (getSize st)) +size cmp = withStatus (cmp . getSize) -- | True if file size is strictly greater than the given size in bytes. -- diff --git a/src/Streamly/Coreutils/FileTest/Posix.hs b/src/Streamly/Coreutils/FileTest/Posix.hs index 03eb6d70..08004b96 100644 --- a/src/Streamly/Coreutils/FileTest/Posix.hs +++ b/src/Streamly/Coreutils/FileTest/Posix.hs @@ -49,7 +49,7 @@ import Streamly.Coreutils.FileTest.Common testFd :: Fd -> FileTest -> IO Bool testFd fd (FileTest (Predicate f)) = -- XXX We should pass "Either Fd Path" in state. - let fp = error $ "FileTest.testFd: filepath cannot be used" + let fp = error "FileTest.testFd: filepath cannot be used" in Files.getFdStatus fd >>= mkFileState "FileTest.testFd" fp >>= f testHandle :: Handle -> FileTest -> IO Bool diff --git a/src/Streamly/Coreutils/Find.hs b/src/Streamly/Coreutils/Find.hs index 55e5f04b..007f60df 100644 --- a/src/Streamly/Coreutils/Find.hs +++ b/src/Streamly/Coreutils/Find.hs @@ -329,7 +329,7 @@ findByteChunked f path = where {-# INLINE transform #-} - transform s = maybe s (\n -> takeN n s) (findMaxResults opts) + transform s = maybe s (`takeN` s) (findMaxResults opts) opts = f defaultConfig diff --git a/src/Streamly/Coreutils/Id.hs b/src/Streamly/Coreutils/Id.hs index d22c8454..69d7e15a 100644 --- a/src/Streamly/Coreutils/Id.hs +++ b/src/Streamly/Coreutils/Id.hs @@ -67,6 +67,7 @@ where import Control.Exception (try, SomeException) import Data.List (nub) +import Data.Maybe (catMaybes) import qualified System.Posix.User as Posix -- = Design notes @@ -225,7 +226,7 @@ groupNamesFromUserId i = do Nothing -> return Nothing Just gids -> do mNames <- mapM groupNameFromId gids - return $ Just [ n | Just n <- mNames ] + return $ Just (catMaybes mNames) ------------------------------------------------------------------------------ -- Current process: numeric ids @@ -299,7 +300,7 @@ groupNames :: IO [String] groupNames = do gs <- groupIds mNames <- mapM groupNameFromId gs - return [ n | Just n <- mNames ] + return (catMaybes mNames) -- | Original login name of the session the current process belongs to. -- diff --git a/src/Streamly/Coreutils/Ln.hs b/src/Streamly/Coreutils/Ln.hs index d29a462d..732b0130 100644 --- a/src/Streamly/Coreutils/Ln.hs +++ b/src/Streamly/Coreutils/Ln.hs @@ -18,8 +18,10 @@ module Streamly.Coreutils.Ln ) where -import Control.Monad (when) -import Streamly.Coreutils.FileTest (test, doesItExist) +import Control.Monad (unless, when) +import Data.Maybe (fromMaybe) +import Streamly.Coreutils.FileTest (test, testl, doesItExist, sameFileAs) +import System.Directory (removeFile) import qualified System.PosixCompat.Files as Posix import Streamly.FileSystem.Path (Path) @@ -33,6 +35,10 @@ data LnOptions = LnOptions defaultConfig :: LnOptions defaultConfig = LnOptions False False +-- | Remove an existing destination before creating the link, like @ln -f@. +-- Fails if the source and the destination are the same file. +-- +-- Default (without this modifier): 'False', fail if the destination exists. force :: Bool -> LnOptions -> LnOptions force opt cfg = cfg {lnForce = opt} @@ -42,13 +48,41 @@ symbolic opt cfg = cfg {lnSymbolic = opt} ln :: (LnOptions -> LnOptions) -> Path -> Path -> IO () ln f src tgt = do let opt = f defaultConfig - when (lnForce opt == False) $ do - found <- test tgt doesItExist - when found $ error msg + -- target can be a symlink or non-symlink + found <- testl tgt doesItExist + when found $ do + unless (lnForce opt) $ error msg + -- Do not remove the source itself. + srcFound <- test src doesItExist + same <- if srcFound then isSameEntry else pure False + when same $ error sameMsg + removeFile tgtStr case lnSymbolic opt of - False -> Posix.createLink (Path.toString src) (Path.toString tgt) - True -> Posix.createSymbolicLink (Path.toString src) (Path.toString tgt) + False -> Posix.createLink srcStr tgtStr + True -> Posix.createSymbolicLink srcStr tgtStr where + tgtStr = Path.toString tgt + srcStr = Path.toString src + + -- Same directory entry: same inode, same parent directory and same name. + -- A path without a file name part ("x/", ".", "..") is treated as the + -- same entry when the inodes match, so that the source is never removed. + isSameEntry = do + sameInode <- testl tgt (sameFileAs src) + case (Path.splitFile src, Path.splitFile tgt) of + (Just (srcDir, srcName), Just (tgtDir, tgtName)) -> do + sameDir <- test (dirOrCwd tgtDir) (sameFileAs (dirOrCwd srcDir)) + pure + $ sameInode + && sameDir + && Path.eqPath id srcName tgtName + _ -> pure sameInode + + dirOrCwd = fromMaybe (Path.fromString_ ".") + msg = "ln: Link target exists, use force to create anyway" + sameMsg = + "ln: '" ++ srcStr ++ "' and '" ++ tgtStr + ++ "' are the same file" diff --git a/src/Streamly/Coreutils/Mv.hs b/src/Streamly/Coreutils/Mv.hs index 7b3166f6..4ddcd24f 100644 --- a/src/Streamly/Coreutils/Mv.hs +++ b/src/Streamly/Coreutils/Mv.hs @@ -11,39 +11,164 @@ module Streamly.Coreutils.Mv ( mv + , mvMany -- * Options , MvOptions - , force + , Overwrite (..) + , overwrite + , intoDirectory ) where -import System.Directory (doesPathExist, renamePath) +import Control.Exception (IOException, try) +import Control.Monad (unless, void, when) +import Data.Either (lefts) +import System.Directory (doesDirectoryExist, renamePath) +import System.FilePath (dropTrailingPathSeparator, takeFileName, ()) import Streamly.FileSystem.Path (Path) import qualified Streamly.FileSystem.Path as Path -newtype MvOptions = MvOptions {mvForce :: Bool} +import Streamly.Coreutils.FileTest (testl) +import Streamly.Coreutils.Overwrite + (Overwrite(..), destinationExistsError, shouldOverwrite) +import Streamly.Coreutils.Rename (renameNoReplace) + +-- = Design notes +-- +-- * 'OverwriteNever' and 'OverwriteError' use 'renameNoReplace', which is +-- atomic on Linux, macOS and Windows, like GNU @mv@. 'OverwriteOnly' and +-- 'OverwriteUpdate' check the destination before 'renamePath' is called, +-- so the destination can change in between; GNU @mv -u@ has the same +-- race. +-- +-- * 'mv' takes one source and 'mvMany' takes a list, instead of one function +-- taking a list: with one source the destination may be a new name, with +-- several it must be an existing directory. +-- +-- * 'mvMany' raises one 'userError' listing every failure instead of +-- rethrowing the first 'IOException': with several failures there is no +-- single error type to keep. A caller that needs to handle each failure +-- can call 'mv' per source. + +-- | Options for 'mv' and 'mvMany'. +data MvOptions = MvOptions + { mvOverwrite :: Overwrite + , mvIntoDirectory :: Bool + } defaultConfig :: MvOptions -defaultConfig = MvOptions False +defaultConfig = MvOptions + { mvOverwrite = OverwriteAlways + , mvIntoDirectory = True + } -force :: Bool -> MvOptions -> MvOptions -force opt cfg = cfg {mvForce = opt} +-- | Specify what to do when the destination exists. See 'Overwrite'. +-- +-- A symlink at the destination counts as an existing destination even if +-- its target does not exist. +-- +-- 'mv' never asks the user before replacing a destination. The default, +-- 'OverwriteAlways', is equivalent to GNU @mv -f@. GNU @mv@ without @-f@ +-- asks before replacing a destination that is not writable, but only when +-- the input is a terminal; otherwise it replaces the destination, like +-- @mv -f@. +-- +-- GNU @mv -i@ asks before replacing any existing destination. 'mv' does +-- not ask; use 'OverwriteError' to keep every existing destination and +-- raise an error, 'OverwriteNever' to keep it without an error, or +-- 'OverwriteUpdate' to replace only a destination older than the source. +-- +-- With 'OverwriteNever' and 'OverwriteError' the check and the rename are one +-- atomic operation on Linux, macOS and Windows, so a destination created +-- concurrently is never replaced. On FreeBSD, and on file systems that do not +-- support it, the destination is checked first and a destination created +-- between the check and the rename is replaced. +-- +-- Default (without this modifier): 'OverwriteAlways', like GNU @mv@. +overwrite :: Overwrite -> MvOptions -> MvOptions +overwrite opt cfg = cfg {mvOverwrite = opt} -mv :: (MvOptions -> MvOptions) -> Path -> Path -> IO () -mv f old new = do +-- | The destination of 'mv' can be a file or a directory. When the +-- destination is an existing directory, or a symlink to one, 'mv' can +-- either move the source into the directory or rename the source to the +-- directory's name. 'intoDirectory' chooses between the two. +-- +-- With 'True', @mv id "a" "d"@ moves @a@ into the directory @d@, to @d/a@. +-- +-- With 'False', @mv (intoDirectory False) "a" "d"@ renames @a@ to @d@, +-- like GNU @mv -T@. On POSIX systems the rename succeeds only if @a@ is +-- also a directory and @d@ is empty; @d@ is then replaced by @a@. +-- When @d@ is a symlink to a directory and @a@ is not a directory, GNU +-- @mv -T@ replaces the symlink with @a@. 'mv' does the same on POSIX +-- systems, but on Windows the rename fails because @MoveFileEx@ cannot +-- replace a directory symlink with a file. +-- +-- When the destination does not exist or is not a directory, 'mv' renames +-- the source to the destination and ignores this option. 'mvMany' always +-- moves the sources into the directory and ignores this option. +-- +-- Default (without this modifier): 'True', like GNU @mv@. +intoDirectory :: Bool -> MvOptions -> MvOptions +intoDirectory opt cfg = cfg {mvIntoDirectory = opt} + +-- Rename src to dest, subject to the overwrite option. +moveTo :: MvOptions -> Path -> Path -> IO () +moveTo opt src dest = + case mvOverwrite opt of + OverwriteNever -> void $ renameNoReplace src dest + OverwriteError -> do + r <- renameNoReplace src dest + unless r $ ioError (destinationExistsError dest) + option -> do + r <- shouldOverwrite testl option src dest + when r $ renamePath (Path.toString src) (Path.toString dest) + +-- The last component of src, ignoring trailing separators, under dir, like +-- GNU mv. Path.takeFileName returns Nothing when there are trailing +-- separators, so FilePath is used instead. +targetInDir :: Path -> Path -> IO Path +targetInDir dir src = + let name = takeFileName $ dropTrailingPathSeparator $ Path.toString src + in Path.fromString (Path.toString dir name) + +-- | @mvMany modifier sources dir@ moves each of @sources@ into the existing +-- directory @dir@, like GNU @mv -t dir sources...@. Pass 'id' for defaults; +-- each modifier documents its own default. +-- +-- Raises an 'IOError' without moving anything if @dir@ is not a directory +-- or a symlink to one. A source that fails to move does not stop the +-- others, like GNU @mv@; after all sources are tried, an 'IOError' listing +-- each failure is raised. +mvMany :: (MvOptions -> MvOptions) -> [Path] -> Path -> IO () +mvMany f srcs dir = do let opt = f defaultConfig - oldStr = Path.toString old - newStr = Path.toString new - case mvForce opt of - True -> renamePath oldStr newStr - False -> do - exists <- doesPathExist newStr - if exists - then error msg - else renamePath oldStr newStr + dirStr = Path.toString dir + isDir <- doesDirectoryExist dirStr + unless isDir $ + ioError (userError ("mv: target is not a directory: " ++ dirStr)) + results <- mapM (moveOne opt) srcs + case lefts results of + [] -> return () + errs -> ioError (userError (unlines (map show errs))) where - msg = "mv: Move target exists, use force to move anyway" + moveOne :: MvOptions -> Path -> IO (Either IOException ()) + moveOne opt src = try (targetInDir dir src >>= moveTo opt src) + +-- | @mv modifier source dest@ renames @source@ to @dest@. If @dest@ is an +-- existing directory, or a symlink to one, @source@ is moved into it; see +-- 'intoDirectory'. Pass 'id' for defaults; each modifier documents its own +-- default. +mv :: (MvOptions -> MvOptions) -> Path -> Path -> IO () +mv f src dest = do + let opt = f defaultConfig + isDir <- + if mvIntoDirectory opt + then doesDirectoryExist (Path.toString dest) + else return False + if isDir + then targetInDir dest src >>= moveTo opt src + else moveTo opt src dest diff --git a/src/Streamly/Coreutils/Overwrite.hs b/src/Streamly/Coreutils/Overwrite.hs new file mode 100644 index 00000000..fa416251 --- /dev/null +++ b/src/Streamly/Coreutils/Overwrite.hs @@ -0,0 +1,67 @@ +-- | +-- Module : Streamly.Coreutils.Overwrite +-- Copyright : (c) 2026 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Overwrite behavior shared by commands that write to a destination path +-- (@cp@, @mv@). + +module Streamly.Coreutils.Overwrite + ( Overwrite (..) + , destinationExistsError + , shouldOverwrite + ) +where + +import System.IO.Error (alreadyExistsErrorType, mkIOError) + +import Streamly.FileSystem.Path (Path) +import qualified Streamly.FileSystem.Path as Path + +import Streamly.Coreutils.FileTest + +-- | What to do when the destination already exists. +data Overwrite = + OverwriteNever -- ^ Keep an existing destination and skip without an + -- error, like GNU @--update=none@. + | OverwriteError -- ^ Keep an existing destination and raise an + -- 'IOError', like GNU @--update=none-fail@. + | OverwriteAlways -- ^ Replace an existing destination, the GNU default + -- (@--update=all@). + | OverwriteOnly -- ^ Act only if the destination exists. No GNU + -- equivalent. + | OverwriteUpdate -- ^ Replace an existing destination only if it is + -- older than the source, like GNU @-u@ + -- (@--update=older@). + +-- | The error raised by 'OverwriteError' for an existing @dest@. +destinationExistsError :: Path -> IOError +destinationExistsError dest = + mkIOError + alreadyExistsErrorType "not replacing" Nothing + (Just (Path.toString dest)) + +-- | @shouldOverwrite runTest option src dest@ returns 'True' if the command +-- should write @src@ to @dest@, and raises 'destinationExistsError' for +-- 'OverwriteError' if @dest@ exists. @runTest@ ('test' or 'testl') decides +-- whether a symlink at @dest@ is followed when checking that @dest@ exists. +shouldOverwrite :: + (Path -> FileTest -> IO Bool) -> Overwrite -> Path -> Path -> IO Bool +shouldOverwrite runTest option src dest = + case option of + OverwriteAlways -> return True + OverwriteOnly -> runTest dest doesItExist + OverwriteNever -> not <$> runTest dest doesItExist + OverwriteError -> do + r <- runTest dest doesItExist + if r + then ioError (destinationExistsError dest) + else return True + OverwriteUpdate -> do + r <- runTest dest doesItExist + if r + then test src $ newerThanFile dest + else return True diff --git a/src/Streamly/Coreutils/Rename.hs b/src/Streamly/Coreutils/Rename.hs new file mode 100644 index 00000000..ec9164b3 --- /dev/null +++ b/src/Streamly/Coreutils/Rename.hs @@ -0,0 +1,126 @@ +-- | +-- Module : Streamly.Coreutils.Rename +-- Copyright : (c) 2026 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Rename without replacing an existing destination. + +module Streamly.Coreutils.Rename + ( renameNoReplace + ) +where + +import Streamly.FileSystem.Path (Path) +import qualified Streamly.FileSystem.Path as Path + +#if defined(CABAL_OS_WINDOWS) +import Data.List (isPrefixOf) +import Foreign.C.String (CWString, withCWString) +import System.IO.Error (catchIOError) +import System.Win32.Info (getFullPathName) +import System.Win32.Types (DWORD, failWith) +#else +import Foreign.C.Error + (Errno, eEXIST, eINVAL, eNOSYS, eNOTSUP, errnoToIOError, getErrno) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt(..)) +import System.Directory (renamePath) + +import qualified Streamly.Internal.Data.Array as Array (asCStringUnsafe) + +import Streamly.Coreutils.FileTest (doesItExist, testl) +#endif + +#if defined(CABAL_OS_WINDOWS) +-- Like furnishPath in directory, which renamePath uses: make the path +-- absolute and prepend \\?\, or \\?\UNC\ for \\server\share, so that +-- paths longer than MAX_PATH work. GetFullPathNameW also converts / to \ and +-- resolves . and .., which the Windows API does not do for \\?\ paths. +-- If GetFullPathNameW fails, the path is used unchanged. +toExtendedLengthPath :: String -> IO String +toExtendedLengthPath path + | any (`isPrefixOf` path) ["\\\\?\\", "\\??\\", "\\\\.\\"] = + return path + | otherwise = + fmap addPrefix (getFullPathName path) + `catchIOError` \_ -> return path + + where + + addPrefix full = + case full of + '\\' : '\\' : rest -> "\\\\?\\UNC\\" ++ rest + _ -> "\\\\?\\" ++ full + +foreign import ccall safe "streamly_coreutils_rename_noreplace_w" + c_renameNoReplaceW :: CWString -> CWString -> IO DWORD + +-- ERROR_FILE_EXISTS, ERROR_ALREADY_EXISTS +isExistsError :: DWORD -> Bool +isExistsError e = e == 80 || e == 183 +#else +foreign import ccall safe "streamly_coreutils_rename_noreplace" + c_renameNoReplace :: CString -> CString -> IO CInt + +-- Not atomic: a destination created between the check and the rename is +-- replaced. +renameCheckFirst :: Path -> Path -> IO Bool +renameCheckFirst src dest = do + exists <- testl dest doesItExist + if exists + then return False + else do + renamePath (Path.toString src) (Path.toString dest) + return True + +-- Errors meaning that the platform or the file system does not support an +-- atomic no-replace rename. Linux returns EINVAL when the file system does +-- not support RENAME_NOREPLACE, macOS returns ENOTSUP. +isUnsupported :: Errno -> Bool +isUnsupported e = e == eNOSYS || e == eINVAL || e == eNOTSUP +#endif + +-- | Rename @src@ to @dest@ unless @dest@ exists. Returns 'False', without +-- renaming, if @dest@ exists; a symlink at @dest@ counts as existing even if +-- its target does not. +-- +-- Atomic on Linux (@renameat2@ with @RENAME_NOREPLACE@), macOS (@renamex_np@ +-- with @RENAME_EXCL@) and Windows (@MoveFileExW@ without +-- @MOVEFILE_REPLACE_EXISTING@). On other platforms, and on file systems that +-- do not support these calls, @dest@ is checked before the rename, so a +-- @dest@ created in between is replaced. +renameNoReplace :: Path -> Path -> IO Bool +#if defined(CABAL_OS_WINDOWS) +renameNoReplace src dest = do + srcStr <- toExtendedLengthPath (Path.toString src) + destStr <- toExtendedLengthPath (Path.toString dest) + r <- withCWString srcStr $ \s -> + withCWString destStr $ \d -> + c_renameNoReplaceW s d + if r == 0 + then return True + else + if isExistsError r + then return False + else failWith "renameNoReplace" r +#else +renameNoReplace src dest = do + r <- Array.asCStringUnsafe (Path.toArray src) $ \s -> + Array.asCStringUnsafe (Path.toArray dest) $ \d -> + c_renameNoReplace s d + if r == 0 + then return True + else do + errno <- getErrno + if errno == eEXIST + then return False + else if isUnsupported errno + then renameCheckFirst src dest + else + ioError + $ errnoToIOError + "renameNoReplace" errno Nothing (Just (Path.toString src)) +#endif diff --git a/src/Streamly/Coreutils/ResolvePath.hs b/src/Streamly/Coreutils/ResolvePath.hs index d5bf594f..0f12cb88 100644 --- a/src/Streamly/Coreutils/ResolvePath.hs +++ b/src/Streamly/Coreutils/ResolvePath.hs @@ -89,7 +89,7 @@ module Streamly.Coreutils.ResolvePath ) where -import Control.Monad (when) +import Control.Monad (unless) import Data.List (isPrefixOf) import System.Directory (canonicalizePath, doesDirectoryExist, doesPathExist, makeAbsolute) @@ -422,7 +422,7 @@ lexicalCollapse p = step acc "." = acc step acc ".." = case acc of -- Relative path: preserve leading .. - [] -> if absolute then [] else [".."] + [] -> [".." | not absolute] (x:xs) | x == ".." -> "..":x:xs | otherwise -> xs @@ -439,13 +439,13 @@ checkExistence check path = case check of RequireNone -> return () RequirePath -> do exists <- doesPathExist path - when (not exists) $ + unless exists $ ioError (userError ("resolvePath: path does not exist: " ++ path)) RequireParents -> do let parent = takeDirectory path parentExists <- doesDirectoryExist parent - when (not parentExists) $ + unless parentExists $ ioError (userError ("resolvePath: parent directory does not exist: " @@ -487,7 +487,7 @@ resolvePath modifier path = do resolved <- case _resolutionMode opts of ResolveThenParent -> canonicalizePath pathStr ParentThenResolve -> - fmap lexicalCollapse (makeAbsolute pathStr) >>= canonicalizePath + makeAbsolute pathStr >>= canonicalizePath . lexicalCollapse NoSymlinkResolution -> fmap lexicalCollapse (makeAbsolute pathStr) -- Relativization and containment logic: -- * _relativeTo chooses the target to relativize against. diff --git a/src/Streamly/Coreutils/Rm.hs b/src/Streamly/Coreutils/Rm.hs index 8d663011..81434526 100644 --- a/src/Streamly/Coreutils/Rm.hs +++ b/src/Streamly/Coreutils/Rm.hs @@ -84,7 +84,7 @@ module Streamly.Coreutils.Rm ) where -import Control.Monad (forM_, when) +import Control.Monad (forM_, unless) import Streamly.Coreutils.FileTest (doesItExist, test, testl, isDir, isWritableByMode) #if defined(CABAL_OS_WINDOWS) @@ -214,7 +214,7 @@ _setWritable :: Path -> IO () _setWritable path = do let pathStr = Path.toString path perms <- getPermissions pathStr - when (not (writable perms)) $ + unless (writable perms) $ setPermissions pathStr (perms { writable = True }) rmfile :: RmOptions -> Path -> IO () diff --git a/src/Streamly/Coreutils/Sh.hs b/src/Streamly/Coreutils/Sh.hs index e1b79673..8190b417 100644 --- a/src/Streamly/Coreutils/Sh.hs +++ b/src/Streamly/Coreutils/Sh.hs @@ -8,10 +8,15 @@ -- Stability : experimental -- Portability : GHC -- --- This module allows you to run shell commands from Haskell using --- @/bin/sh@ as the command interpreter. Haskell program interacts with shell +-- This module allows you to run shell commands from Haskell using a POSIX +-- shell as the command interpreter. Haskell program interacts with shell -- processes via their standard input and output streams. -- +-- On POSIX systems the shell is @/bin/sh@. On Windows it is @sh@ found on the +-- @PATH@, e.g. the one installed by Git for Windows, MSYS2 or Cygwin; if +-- there is none, running a command fails. The commands are POSIX shell +-- commands on all platforms; @cmd.exe@ is not used. +-- -- The functions in this module are just convenience wrappers over -- "Streamly.System.Process", specialized for shell-based workflows. -- @@ -65,6 +70,10 @@ import qualified Streamly.Internal.System.Process as Process -- The APIs are named/designed such that we can replace the sh module with -- another module for bash or any other shells without requiring API name -- changes. +-- +-- On Windows we use sh from the PATH instead of cmd.exe so that the same +-- command strings work on all platforms; cmd.exe has a different syntax and +-- quoting rules. A separate module can provide cmd.exe if needed. -- $setup -- >>> :set -XFlexibleContexts @@ -76,11 +85,22 @@ import qualified Streamly.Internal.System.Process as Process -- >>> import qualified Streamly.Coreutils.Sh as Sh -- >>> import qualified Streamly.Unicode.Stream as Unicode +-- The shell used to run commands: /bin/sh on POSIX systems, sh found on the +-- PATH on Windows. +shell :: FilePath +#if defined(CABAL_OS_WINDOWS) +shell = "sh" +#else +shell = "/bin/sh" +#endif + -- | A modifier for stream generation APIs in "Streamly.System.Process" to --- generate streams from shell scripts with "\/bin/sh" as the shell --- interpreter. Defined as: +-- generate streams from shell scripts. Defined as: +-- +-- > streamWith f cmd = f sh ["-c", cmd] -- --- >>> streamWith f cmd = f "/bin/sh" ["-c", cmd] +-- where @sh@ is @/bin/sh@ on POSIX systems and @sh@ found on the @PATH@ on +-- Windows. -- -- For example: -- @@ -90,7 +110,7 @@ import qualified Streamly.Internal.System.Process as Process -- hello -- streamWith :: (FilePath -> [String] -> Stream m a) -> String -> Stream m a -streamWith f cmd = f "/bin/sh" ["-c", cmd] +streamWith f cmd = f shell ["-c", cmd] -- | A modifier for process running APIs in "Streamly.System.Process" to run -- shell commands. @@ -105,7 +125,7 @@ streamWith f cmd = f "/bin/sh" ["-c", cmd] -- /Internal/ {-# INLINE runWith #-} runWith :: (FilePath -> [String] -> m a) -> String -> m a -runWith f cmd = f "/bin/sh" ["-c", cmd] +runWith f cmd = f shell ["-c", cmd] -- | A modifier for process piping APIs in "Streamly.System.Process" to pipe -- data through shell scripts: @@ -125,7 +145,7 @@ pipeWith :: -> String -> Stream m a -> Stream m b -pipeWith f cmd = f "/bin/sh" ["-c", cmd] +pipeWith f cmd = f shell ["-c", cmd] -- | @pipeChunks command input@ runs the executable with arguments specified by -- @command@ and supplying @input@ stream as its standard input. Returns the diff --git a/src/Streamly/Coreutils/Tail.hs b/src/Streamly/Coreutils/Tail.hs index c9c74385..a710f457 100644 --- a/src/Streamly/Coreutils/Tail.hs +++ b/src/Streamly/Coreutils/Tail.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} -- | -- Module : Streamly.Coreutils.Tail -- Copyright : (c) 2025 Composewell Technologies @@ -7,7 +6,11 @@ -- Stability : experimental -- Portability : GHC -- --- Read last N lines from a file. +-- Output the end of a file, like the GNU @tail@ command. +-- +-- A regular file is read backwards from the end, so only the part of the +-- file that is output is read. A pipe or FIFO is read to the end, keeping in +-- memory only the data needed for the output. -- TODO: we can add a tail1 or last to read the last line. -- TODO: tail/head can be replaced with a single file reading utility which can @@ -26,18 +29,51 @@ module Streamly.Coreutils.Tail ) where +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Data.Functor.Identity (runIdentity) import Data.Word (Word8) import Streamly.Data.Array (Array) import Streamly.Data.Stream.Prelude (Stream) import Streamly.FileSystem.Path (Path) -import Streamly.Unicode.String (str) +import Streamly.Internal.Data.Array + (unsafeFreezeWithShrink, unsafeGetIndex, unsafeGetIndexRev) +import System.IO + ( Handle + , IOMode(ReadMode) + , SeekMode(AbsoluteSeek) + , hClose + , hFileSize + , hGetBuf + , hIsSeekable + , hSeek + , hTell + , openBinaryFile + ) +import qualified Streamly.Data.Array as Array +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Scanl as Scanl +import qualified Streamly.Data.Stream.Prelude as Stream +import qualified Streamly.FileSystem.Handle as Handle import qualified Streamly.FileSystem.Path as Path -import qualified Streamly.System.Command as Command - +import qualified Streamly.Internal.Data.MutArray as MutArray import Prelude hiding (tail, lines) +-- = Design notes +-- +-- * The output is the bytes of the file in chunks, newlines included, like +-- the output of the @tail@ command. Splitting into lines is left to the +-- caller. +-- * 'follow' polls the file size once a second, like GNU @tail -f@ when +-- inotify is not available. On Linux streamly-fsevents (inotify) could be +-- used instead of polling. +-- * The last N lines of a regular file are found by reading blocks +-- backwards from the end and counting newlines. If the file ends with a +-- newline, that newline ends the last line and does not start a new one, +-- so we look for N + 1 newlines from the end in that case. + data TailOptions = TailOptions { _follow :: Bool , _offset :: Either Int Int -- Left = lines, Right = bytes @@ -51,9 +87,12 @@ defaultConfig = TailOptions , _reverse = False -- False means default i.e. from the end } --- | Run forever following any appends to the file. +-- | After the end of the file is reached, keep running and output data as it +-- is appended to the file, like @tail -f@. The file size is checked once a +-- second. If the file is truncated, output starts again from its beginning. +-- Has no effect on a pipe or FIFO, which is read until the writer closes it. -- --- Same as @--follow@ flag in the standard tail command. +-- Default (without this modifier): 'False', stop at the end of the file. follow :: Bool -> TailOptions -> TailOptions follow opt cfg = cfg {_follow = opt} @@ -61,67 +100,324 @@ follow opt cfg = cfg {_follow = opt} -- positive from the beginning. But in that case 0 becomes ambiguous, is it -- from the end or from the beginning. --- | Read the specified number of lines at the end of the file. +-- | Output the last @n@ lines, like @tail -n n@. -- +-- Default (without this modifier or 'bytes', 'fromLine', 'fromByte'): the +-- last 10 lines. lines :: Int -> TailOptions -> TailOptions lines x cfg = cfg {_offset = Left x, _reverse = False} --- | Read the specified number of bytes at the end of the file. --- +-- | Output the last @n@ bytes, like @tail -c n@. bytes :: Int -> TailOptions -> TailOptions bytes x cfg = cfg {_offset = Right x, _reverse = False} --- | Read from the specified line number up to the end of file. +-- | Output from line @n@ to the end, like @tail -n +n@. Lines are numbered +-- from 1. fromLine :: Int -> TailOptions -> TailOptions fromLine x cfg = cfg {_offset = Left x, _reverse = True} --- | Read from the specified byte count up to the end of file. +-- | Output from byte @n@ to the end, like @tail -c +n@. Bytes are numbered +-- from 1. fromByte :: Int -> TailOptions -> TailOptions fromByte x cfg = cfg {_offset = Right x, _reverse = True} --- XXX Replace the "tail" shell command with Haskell native implementation. A --- portable implementation of "--follow" would use a sleep and poll, on linux --- we can use streamly-fsevents (inotify). --- --- XXX We can have a configurable option to return chunks of one line each. Or --- line splitting can also be done by the user, unless we are getting it for --- free here. We can also have an option to emit chunks with or without the --- newline chars. +------------------------------------------------------------------------------- +-- Array helpers +------------------------------------------------------------------------------- + +newline :: Word8 +newline = 10 + +countNewlines :: Array Word8 -> Int +countNewlines arr = + runIdentity + $ Stream.fold Fold.length + $ Stream.filter (== newline) + $ Array.read arr + +-- | Index just after the @n@-th newline counted from the end of the array, +-- or the number of newlines still to be found before the array. +afterNewlineRev :: Int -> Array Word8 -> Either Int Int +afterNewlineRev n arr = go 0 n + + where + + len = Array.length arr + + -- i is the index counted from the end. + go i k + | i >= len = Left k + | unsafeGetIndexRev i arr == newline = + if k == 1 then Right (len - i) else go (i + 1) (k - 1) + | otherwise = go (i + 1) k + +-- | Index just after the @n@-th newline counted from the start of the array, +-- or the number of newlines still to be skipped after the array. +afterNewline :: Int -> Array Word8 -> Either Int Int +afterNewline n arr = go 0 n + + where + + len = Array.length arr + + go i k + | i >= len = Left k + | unsafeGetIndex i arr == newline = + if k == 1 then Right (i + 1) else go (i + 1) (k - 1) + | otherwise = go (i + 1) k + +-- | The array from index @i@ to the end. +dropArray :: Int -> Array Word8 -> IO (Array Word8) +dropArray i arr = Stream.fold Array.create (Stream.drop i (Array.read arr)) + +endsWithNewline :: [Array Word8] -> Bool +endsWithNewline chunks = + case reverse (filter ((> 0) . Array.length) chunks) of + [] -> False + (c : _) -> Array.getIndex (Array.length c - 1) c == Just newline + +------------------------------------------------------------------------------- +-- Stream helpers +------------------------------------------------------------------------------- + +-- XXX Should go in the Array stream module +-- | Drop a prefix of a stream of chunks. @split k arr@ is @Right i@ when the +-- remaining prefix of size @k@ ends at index @i@ of @arr@, or @Left k1@ when +-- @k1@ of the prefix is still to be dropped after @arr@. +{-# INLINE dropPrefix #-} +dropPrefix :: + (Int -> Array Word8 -> Either Int Int) + -> Int + -> Stream IO (Array Word8) + -> Stream IO (Array Word8) +dropPrefix split n s + | n <= 0 = s + | otherwise = + Stream.mapMaybeM emit + $ Stream.postscanl (Scanl.mkScanl step (n, Nothing)) s + + where + + -- The state is the prefix size still to be dropped and the chunk to + -- emit with the index it starts from. + step (k, _) arr + | k <= 0 = (0, Just (0, arr)) + | otherwise = + case split k arr of + Right i -> (0, Just (i, arr)) + Left k1 -> (k1, Nothing) + + emit (_, Nothing) = pure Nothing + emit (_, Just (0, arr)) = pure (Just arr) + emit (_, Just (i, arr)) + | i >= Array.length arr = pure Nothing + | otherwise = Just <$> dropArray i arr + +-- XXX Should go in the Array stream module +-- | Drop the first @n@ lines. +{-# INLINE dropLines #-} +dropLines :: Int -> Stream IO (Array Word8) -> Stream IO (Array Word8) +dropLines = dropPrefix afterNewline + +-- XXX Should go in the Array stream module +-- | Drop the first @n@ bytes. +{-# INLINE dropBytes #-} +dropBytes :: Int -> Stream IO (Array Word8) -> Stream IO (Array Word8) +dropBytes = dropPrefix split + + where + + split k arr = + let len = Array.length arr + in if k < len then Right k else Left (k - len) + +------------------------------------------------------------------------------- +-- Non-seekable input +------------------------------------------------------------------------------- + +-- A FIFO queue of chunks, each with its measure (newlines or bytes), and the +-- total measure. Chunks are pushed at the back and dropped from the front. +data Queue = Queue [(Array Word8, Int)] [(Array Word8, Int)] !Int --- | Same as the standard @tail@ command. Returns byte arrays. +emptyQueue :: Queue +emptyQueue = Queue [] [] 0 + +-- | Add a chunk, then drop chunks from the front as long as the rest still +-- measure at least @need@. +pushQueue :: (Array Word8 -> Int) -> Int -> Queue -> Array Word8 -> Queue +pushQueue measure need (Queue front back total) arr = + trim (Queue front ((arr, m) : back) (total + m)) + + where + + m = measure arr + + trim q@(Queue [] [] _) = q + trim (Queue [] b t) = trim (Queue (reverse b) [] t) + trim q@(Queue ((_, m1) : f) b t) + | t - m1 >= need = trim (Queue f b (t - m1)) + | otherwise = q + +queueChunks :: Queue -> [Array Word8] +queueChunks (Queue front back _) = map fst (front ++ reverse back) + +queueTotal :: Queue -> Int +queueTotal (Queue _ _ t) = t + +-- XXX Should go in the Array stream module +-- | Last @n@ lines of a list of chunks. +lastLinesOf :: Int -> [Array Word8] -> IO [Array Word8] +lastLinesOf n chunks + | n <= 0 = pure [] + | otherwise = go k [] (reverse chunks) + + where + + k = if endsWithNewline chunks then n + 1 else n + + go _ acc [] = pure acc + go j acc (c : cs) = + case afterNewlineRev j c of + Right i -> do + c1 <- dropArray i c + pure (c1 : acc) + Left j1 -> go j1 (c : acc) cs + +-- XXX Should go in the Array stream module +-- | Output the last lines or bytes of a stream that cannot be seeked. +{-# INLINE tailStream #-} +tailStream :: + Either Int Int -> Stream IO (Array Word8) -> Stream IO (Array Word8) +tailStream offset s = Stream.concatEffect $ + case offset of + Left n -> do + -- n + 1 newlines cover a final newline that ends the last line. + q <- lastChunks countNewlines (n + 1) + Stream.fromList <$> lastLinesOf n (queueChunks q) + Right n -> do + q <- lastChunks Array.length n + pure + $ dropBytes (queueTotal q - max 0 n) + $ Stream.fromList (queueChunks q) + + where + + lastChunks measure need = + Stream.fold (Fold.foldl' (pushQueue measure need) emptyQueue) s + +------------------------------------------------------------------------------- +-- Seekable input +------------------------------------------------------------------------------- + +blockSize :: Integer +blockSize = 64 * 1024 + +-- XXX Use Handle.getChunkOf when it is implemented in streamly-core. +readBlock :: Handle -> Integer -> Int -> IO (Array Word8) +readBlock h off len = do + hSeek h AbsoluteSeek off + arr <- MutArray.unsafeCreateWithPtr' len $ \p -> hGetBuf h p len + pure $ unsafeFreezeWithShrink arr + +-- XXX Should go in the Array stream module +-- | Offset where the last @n@ lines of the file start. +lastLinesOffset :: Handle -> Int -> IO Integer +lastLinesOffset h n = do + size <- hFileSize h + if size == 0 || n <= 0 + then pure size + else do + lastByte <- readBlock h (size - 1) 1 + let k = if Array.getIndex 0 lastByte == Just newline then n + 1 else n + go k size + + where + + go k pos + | pos <= 0 = pure 0 + | otherwise = do + let len = min blockSize pos + off = pos - len + arr <- readBlock h off (fromIntegral len) + case afterNewlineRev k arr of + Right i -> pure (off + fromIntegral i) + Left k1 -> go k1 off + +-- | Output the requested part of a seekable file. +{-# INLINE tailSeekable #-} +tailSeekable :: TailOptions -> Handle -> IO (Stream IO (Array Word8)) +tailSeekable cfg h = + case (_reverse cfg, _offset cfg) of + (False, Left n) -> lastLinesOffset h n >>= fromOffset + (False, Right n) -> do + size <- hFileSize h + fromOffset (max 0 (size - fromIntegral (max 0 n))) + (True, Left n) -> do + hSeek h AbsoluteSeek 0 + pure $ dropLines (n - 1) (Handle.readChunks h) + (True, Right n) -> do + size <- hFileSize h + fromOffset (min size (fromIntegral (max 0 (n - 1)))) + + where + + fromOffset off = do + hSeek h AbsoluteSeek off + pure (Handle.readChunks h) + +-- | Poll for data appended to the file, forever. +{-# INLINE followHandle #-} +followHandle :: Handle -> Stream IO (Array Word8) +followHandle h = + Stream.concatMap (const (Handle.readChunks h)) (Stream.repeatM poll) + + where + + -- XXX use streamly-fsevents to watch the file, will need FreeBSD support + -- in streamly-fsevents but we can still do it on Linux/macOS/Windows. + poll = do + threadDelay 1000000 + pos <- hTell h + size <- hFileSize h + when (size < pos) $ hSeek h AbsoluteSeek 0 + +------------------------------------------------------------------------------- +-- API +------------------------------------------------------------------------------- + +-- | Output the end of a file as a stream of byte arrays, like the @tail@ +-- command. Pass 'id' for the defaults; each modifier documents its own +-- default. -- --- Note: currently this function depends on the @tail@ executable being --- installed in the PATH. +-- >> tail id path -- tail path +-- >> tail (lines 20) path -- tail -n 20 path +-- >> tail (fromLine 2) path -- tail -n +2 path +-- >> tail (bytes 100) path -- tail -c 100 path +-- >> tail (follow True) path -- tail -f path tail :: (TailOptions -> TailOptions) -> Path -> Stream IO (Array Word8) tail modifier path = - let p = Path.toString path - cfg = modifier defaultConfig - -- XXX make portable - foll = if _follow cfg then "-f" else "" - dir = if _reverse cfg then "+" else "" - loc = - case _offset cfg of - Left x -> "-n " ++ dir ++ show x - Right x -> "-c " ++ dir ++ show x - in Command.toChunks [str|tail #{foll} #{loc} #{p}|] - {- - if _follow cfg - then Command.toChunks [str|tail #{foll} #{loc} #{p}|] - -- The following is a generic implementation that works for all types - -- of files including a fifo where we cannot determine the size and - -- seek to the end. - -- - -- Note that with this implementation @yes | tail -n 10@ may never - -- terminate because we may never reach the EOF. Even @yes | tail -f -n - -- 10@ does not terminate. - -- - -- However, if the file is not a FIFO we can work on a snapshot, and we - -- can read the file in reverse from the end. In case of a seekable - -- file we can stat and determine the size of the file and then print - -- the last n lines from that point. - else Stream.concatEffect $ do - r <- FileIO.readChunks path - & Array.compactEndByLn_ -- XXX need compactEndByLn - & Stream.fold (GArray.createOfLast (_lines cfg)) - pure (GArray.read r) - -} + Stream.bracketIO + (openBinaryFile (Path.toString path) ReadMode) + hClose + run + + where + + cfg = modifier defaultConfig + + run h = Stream.concatEffect $ do + seekable <- hIsSeekable h + if seekable + then do + s <- tailSeekable cfg h + pure + $ if _follow cfg + then Stream.append s (followHandle h) + else s + else + pure + $ let s = Handle.readChunks h + in case (_reverse cfg, _offset cfg) of + (False, offset) -> tailStream offset s + (True, Left n) -> dropLines (n - 1) s + (True, Right n) -> dropBytes (n - 1) s diff --git a/src/Streamly/Coreutils/Touch.hs b/src/Streamly/Coreutils/Touch.hs index ba6d688e..a86f1e79 100644 --- a/src/Streamly/Coreutils/Touch.hs +++ b/src/Streamly/Coreutils/Touch.hs @@ -66,7 +66,7 @@ touch :: (TouchOptions -> TouchOptions) -> Path -> IO () touch f path = do let opt = f defaultConfig pathStr = Path.toString path - if (createNew opt == True && deRef opt == True) + if createNew opt && deRef opt then do found <- test path doesItExist unless found $ openFile pathStr WriteMode >>= hClose diff --git a/src/Streamly/Coreutils/Uniq.hs b/src/Streamly/Coreutils/Uniq.hs index cf608804..12672445 100644 --- a/src/Streamly/Coreutils/Uniq.hs +++ b/src/Streamly/Coreutils/Uniq.hs @@ -118,9 +118,6 @@ compareUsingOptions opt = compareXYZ (ignoreCase opt) (skipFields opt) (skipChar opt) (checkChar opt) where - compareWith :: (String -> String -> Bool) -> String -> String -> Bool - compareWith eq s1 s2 = eq s1 s2 - -- Gives the number of characters to be deleted from the beginning of the -- string to skip @n@ non-space fields\/strings indexAfterSkippingNWords :: Int -> String -> Int @@ -149,13 +146,11 @@ compareUsingOptions opt = compareFunc = if ignCase then compareIgnCase else (==) in case mz of Just z -> - compareWith - compareFunc + compareFunc (slice (ix1 + y) z str1) (slice (ix2 + y) z str2) _ -> - compareWith - compareFunc + compareFunc (drop (ix1 + y) str1) (drop (ix2 + y) str2) @@ -190,9 +185,9 @@ getRepetition comparator = {-# INLINE uniq #-} uniq :: MonadThrow m => UniqOptions -> Stream m String -> Stream m UniqResult uniq opt strm = - case (output opt) of + case output opt of Unique -> extract (eq 1) - All -> extract (\_ -> True) + All -> extract (const True) Duplicate -> extract (ge 1) Repeated -> (\(UniqResult _ x) -> UniqResult 1 x) <$> extract (ge 1) where diff --git a/stack.yaml b/stack.yaml index f09bf055..6d871075 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,8 +2,8 @@ resolver: lts-24.33 packages: - '.' extra-deps: - - streamly-core-0.3.0 - - streamly-0.11.0 + - streamly-core-0.3.2 + - streamly-0.11.1@rev:2 - streamly-process-0.4.0 #extra-deps: @@ -16,5 +16,7 @@ extra-deps: # Look at https://stackoverflow.com/questions/70045586/could-not-find-module-system-console-mintty-win32-when-compiling-test-framework flags: + streamly-coreutils: + limit-build-mem: true mintty: Win32-2-13-1: false diff --git a/streamly-coreutils.cabal b/streamly-coreutils.cabal index 2fafd433..1bf27c41 100644 --- a/streamly-coreutils.cabal +++ b/streamly-coreutils.cabal @@ -17,9 +17,10 @@ description: * Defaults and error behaviour follow GNU coreutils, including symbolic links, trailing slashes, write-protected files and missing paths. Where a function differs from GNU, the difference is documented. - * No subprocesses: no quoting of arguments, no parsing of text output. - Errors are Haskell exceptions, and the code also runs on Windows, - where the commands are not installed. + * The utilities run no subprocesses: no quoting of arguments, no + parsing of text output. Errors are Haskell exceptions, and the code + also runs on Windows, where the commands are not installed. + "Streamly.Coreutils.Sh" is the exception: it runs shell commands. * @ls@, @find@ and @tail@ return streams. You can filter, map, take the first few entries or fold them as they are produced, in constant memory, even for a directory tree with millions of files. @@ -35,7 +36,8 @@ description: * File tests compose like the operands of @test@, and a combined test makes a single @stat@ call: @test p (isFile \`and_\` size (> 10240))@. * When you do need a shell command, "Streamly.Coreutils.Sh" runs it and - connects its input and output to Haskell streams. + connects its input and output to Haskell streams. It uses @/bin/sh@, + and on Windows @sh@ from the @PATH@, e.g. from Git for Windows. . Works on Linux, macOS, FreeBSD and Windows. The API is still changing and later releases will have breaking changes. @@ -83,6 +85,11 @@ flag hfd manual: True default: False +flag limit-build-mem + description: Limits memory when building + manual: True + default: False + common compile-options default-language: Haskell2010 @@ -111,6 +118,12 @@ common compile-options if impl(ghc >= 9.8) ghc-options: -Wno-missing-role-annotations + if flag(limit-build-mem) + if impl(ghc < 9.0) + ghc-options: +RTS -M1000M -RTS + else + ghc-options: +RTS -M512M -RTS + common default-extensions default-extensions: BangPatterns @@ -192,8 +205,8 @@ library , exceptions >= 0.8 && < 0.11 , filepath >= 1.4 && < 1.6 -- We use internal modules of streamly. - , streamly >= 0.11 && < 0.12 - , streamly-core >= 0.3 && < 0.4 + , streamly >= 0.11.1 && < 0.12 + , streamly-core >= 0.3.2 && < 0.4 , streamly-process >= 0.4 && < 0.5 , time >= 1.9 && < 1.16 , unix-compat >= 0.5.4 && < 0.8 @@ -203,6 +216,7 @@ library build-depends: Win32 >= 2.6 && < 2.15 hs-source-dirs: src + c-sources: cbits/rename_noreplace.c exposed-modules: Streamly.Coreutils.Chmod , Streamly.Coreutils.Cp @@ -235,6 +249,8 @@ library Streamly.Coreutils , Streamly.Coreutils.Common , Streamly.Coreutils.FileTest.Common + , Streamly.Coreutils.Overwrite + , Streamly.Coreutils.Rename , Streamly.Coreutils.String , Streamly.Coreutils.Uniq @@ -283,3 +299,22 @@ test-suite Streamly.Coreutils.Rm , unix-compat default-language: Haskell2010 ghc-options: -main-is Streamly.Test.Coreutils.Rm.main + -rtsopts "-with-rtsopts=-M512M" + +test-suite Streamly.Coreutils.Mv + import: compile-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Coreutils/Mv.hs + hs-source-dirs: test + build-depends: + base + , directory + , filepath + , hspec + , streamly-core + , streamly-coreutils + , temporary + , time + default-language: Haskell2010 + ghc-options: -main-is Streamly.Test.Coreutils.Mv.main + -rtsopts "-with-rtsopts=-M512M" diff --git a/test/Streamly/Test/Coreutils/Mv.hs b/test/Streamly/Test/Coreutils/Mv.hs new file mode 100644 index 00000000..633a660f --- /dev/null +++ b/test/Streamly/Test/Coreutils/Mv.hs @@ -0,0 +1,553 @@ +{-# LANGUAGE CPP #-} +-- | +-- +-- Module : Streamly.Test.Coreutils.Mv +-- Copyright : (c) 2026 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Tests for 'Streamly.Coreutils.Mv'. Behavior mirrors GNU @mv@ unless noted +-- otherwise in the module documentation. + +module Streamly.Test.Coreutils.Mv (main) where + +import Control.Exception (IOException, bracket, try, SomeException) +import Control.Monad (void) +import Data.List (isInfixOf) +import Data.Time.Clock (addUTCTime, getCurrentTime) +import System.Directory + ( createDirectory + , createDirectoryIfMissing + , createDirectoryLink + , createFileLink + , doesDirectoryExist + , doesFileExist + , doesPathExist + , getTemporaryDirectory + , pathIsSymbolicLink + , removePathForcibly + , setModificationTime + , withCurrentDirectory + ) +import System.FilePath (()) +import System.IO.Error (isAlreadyExistsError) +import System.IO.Temp (createTempDirectory) +import Test.Hspec + +import Streamly.Coreutils.Mv hiding (mv, mvMany) +import qualified Streamly.Coreutils.Mv as Mv +import qualified Streamly.FileSystem.Path as Path + +------------------------------------------------------------------------------- +-- Helpers +------------------------------------------------------------------------------- + +mv :: (MvOptions -> MvOptions) -> FilePath -> FilePath -> IO () +mv f src dest = do + srcP <- Path.fromString src + destP <- Path.fromString dest + Mv.mv f srcP destP + +mvMany :: (MvOptions -> MvOptions) -> [FilePath] -> FilePath -> IO () +mvMany f srcs dir = do + srcsP <- mapM Path.fromString srcs + dirP <- Path.fromString dir + Mv.mvMany f srcsP dirP + +-- | Run a test inside a fresh temporary directory, cleaning up afterwards. +withTempDir :: (FilePath -> IO ()) -> IO () +withTempDir action = do + tmpRoot <- getTemporaryDirectory + bracket + (createTempDirectory tmpRoot "mv-test-") + removePathForcibly' + action + where + -- Best-effort cleanup; we do not want cleanup failures to mask test + -- failures. + removePathForcibly' p = + void (try (removePathForcibly p) :: IO (Either SomeException ())) + +shouldNotExist :: FilePath -> IO () +shouldNotExist path = doesPathExist path `shouldReturn` False + +shouldContain' :: FilePath -> String -> IO () +shouldContain' path content = readFile' path `shouldReturn` content + +-- Strict read, so that the file is closed before it is moved or removed. +readFile' :: FilePath -> IO String +readFile' path = do + s <- readFile path + length s `seq` return s + +shouldFail :: IO () -> IO () +shouldFail action = do + r <- try action :: IO (Either SomeException ()) + case r of + Left _ -> return () + Right _ -> + expectationFailure "Expected an exception but none was thrown" + +-- | Assert that the action raises an 'IOException' whose message contains +-- each of the given strings. +shouldFailExists :: IO () -> IO () +shouldFailExists action = do + r <- try action + case r of + Left e -> e `shouldSatisfy` isAlreadyExistsError + Right _ -> + expectationFailure "Expected an exception but none was thrown" + +shouldFailMentioning :: IO () -> [String] -> IO () +shouldFailMentioning action names = do + r <- try action :: IO (Either IOException ()) + case r of + Left e -> mapM_ (\n -> show e `shouldSatisfy` isInfixOf n) names + Right _ -> + expectationFailure "Expected an exception but none was thrown" + +-- | Set the modification time of a file to the given number of seconds from +-- now. +setAge :: FilePath -> Integer -> IO () +setAge path secs = do + now <- getCurrentTime + setModificationTime path (addUTCTime (fromInteger secs) now) + +-- | A file name that is not ASCII, to check the path encoding. +nonAscii :: FilePath +nonAscii = "f\252r-\1092\1072\1081\1083" + +-- | A relative directory path of more than 260 characters, the Windows +-- MAX_PATH limit. +longDir :: FilePath +longDir = foldr1 () (replicate 6 (replicate 50 'd')) + +------------------------------------------------------------------------------- +-- Tests +------------------------------------------------------------------------------- + +main :: IO () +main = hspec $ do + + describe "mv (no options)" $ do + + it "renames a file to a new name" $ withTempDir $ \d -> do + writeFile (d "a") "a" + mv id (d "a") (d "b") + shouldNotExist (d "a") + (d "b") `shouldContain'` "a" + + it "renames a directory to a new name" $ withTempDir $ \d -> do + createDirectory (d "x") + writeFile (d "x" "f") "f" + mv id (d "x") (d "y") + shouldNotExist (d "x") + (d "y" "f") `shouldContain'` "f" + + it "overwrites an existing file" $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "b") "b" + mv id (d "a") (d "b") + shouldNotExist (d "a") + (d "b") `shouldContain'` "a" + + it "moves a file into an existing directory" $ withTempDir $ \d -> do + writeFile (d "a") "a" + createDirectory (d "dir") + mv id (d "a") (d "dir") + shouldNotExist (d "a") + (d "dir" "a") `shouldContain'` "a" + + it "replaces a file of the same name in the directory" + $ withTempDir $ \d -> do + writeFile (d "a") "new" + createDirectory (d "dir") + writeFile (d "dir" "a") "old" + mv id (d "a") (d "dir") + (d "dir" "a") `shouldContain'` "new" + + it "moves a source with a trailing separator into a directory" + $ withTempDir $ \d -> do + createDirectory (d "x") + createDirectory (d "dir") + mv id (d "x" ++ "/") (d "dir") + shouldNotExist (d "x") + doesPathExist (d "dir" "x") `shouldReturn` True + + it "moves into the directory a symlink points to" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + createDirectory (d "dir") + createDirectoryLink "dir" (d "link") + mv id (d "a") (d "link") + (d "dir" "a") `shouldContain'` "a" + pathIsSymbolicLink (d "link") `shouldReturn` True + + it "fails on a missing source" $ withTempDir $ \d -> + shouldFail (mv id (d "missing") (d "b")) + + it "moves a directory into an existing directory" + $ withTempDir $ \d -> do + createDirectory (d "x") + writeFile (d "x" "f") "f" + createDirectory (d "dir") + mv id (d "x") (d "dir") + shouldNotExist (d "x") + (d "dir" "x" "f") `shouldContain'` "f" + + it "moves into a directory given with a trailing separator" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + createDirectory (d "dir") + mv id (d "a") (d "dir" ++ "/") + (d "dir" "a") `shouldContain'` "a" + + it "fails to replace a directory in the destination with a file" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + createDirectoryIfMissing True (d "dir" "a") + shouldFail (mv id (d "a") (d "dir")) + (d "a") `shouldContain'` "a" + doesDirectoryExist (d "dir" "a") `shouldReturn` True + + it "works with relative paths" $ withTempDir $ \d -> do + writeFile (d "a") "a" + createDirectory (d "dir") + withCurrentDirectory d $ mv id "a" "dir" + (d "dir" "a") `shouldContain'` "a" + + it "works with non-ASCII names" $ withTempDir $ \d -> do + writeFile (d nonAscii) "a" + mv id (d nonAscii) (d nonAscii ++ "-2") + shouldNotExist (d nonAscii) + (d nonAscii ++ "-2") `shouldContain'` "a" + + it "works with paths longer than 260 characters" + $ withTempDir $ \d -> do + let deep = d longDir + createDirectoryIfMissing True deep + writeFile (deep "a") "a" + mv id (deep "a") (deep "b") + (deep "b") `shouldContain'` "a" + + describe "mv (overwrite OverwriteNever)" $ do + + it "keeps an existing destination" $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "b") "b" + mv (overwrite OverwriteNever) (d "a") (d "b") + (d "a") `shouldContain'` "a" + (d "b") `shouldContain'` "b" + + it "moves to a missing destination" $ withTempDir $ \d -> do + writeFile (d "a") "a" + mv (overwrite OverwriteNever) (d "a") (d "b") + shouldNotExist (d "a") + (d "b") `shouldContain'` "a" + + it "keeps a dangling symlink at the destination" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + createFileLink "nowhere" (d "b") + mv (overwrite OverwriteNever) (d "a") (d "b") + (d "a") `shouldContain'` "a" + pathIsSymbolicLink (d "b") `shouldReturn` True + + it "keeps an existing file in the destination directory" + $ withTempDir $ \d -> do + writeFile (d "a") "new" + createDirectory (d "dir") + writeFile (d "dir" "a") "old" + mv (overwrite OverwriteNever) (d "a") (d "dir") + (d "a") `shouldContain'` "new" + (d "dir" "a") `shouldContain'` "old" + + it "keeps an existing directory" $ withTempDir $ \d -> do + createDirectory (d "x") + createDirectory (d "y") + mv (overwrite OverwriteNever . intoDirectory False) + (d "x") (d "y") + doesDirectoryExist (d "x") `shouldReturn` True + shouldNotExist (d "y" "x") + + it "fails on a missing source" $ withTempDir $ \d -> + shouldFail + (mv (overwrite OverwriteNever) (d "missing") (d "b")) + + it "works with relative paths" $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "b") "b" + writeFile (d "c") "c" + withCurrentDirectory d $ do + mv (overwrite OverwriteNever) "a" "b" + mv (overwrite OverwriteNever) "c" "e" + (d "a") `shouldContain'` "a" + (d "b") `shouldContain'` "b" + (d "e") `shouldContain'` "c" + + it "works with non-ASCII names" $ withTempDir $ \d -> do + writeFile (d nonAscii) "a" + writeFile (d "b") "b" + mv (overwrite OverwriteNever) (d nonAscii) (d "b") + (d "b") `shouldContain'` "b" + mv (overwrite OverwriteNever) + (d nonAscii) (d nonAscii ++ "-2") + shouldNotExist (d nonAscii) + (d nonAscii ++ "-2") `shouldContain'` "a" + + it "works with paths longer than 260 characters" + $ withTempDir $ \d -> do + let deep = d longDir + createDirectoryIfMissing True deep + writeFile (deep "a") "a" + writeFile (deep "b") "b" + mv (overwrite OverwriteNever) (deep "a") (deep "b") + (deep "b") `shouldContain'` "b" + mv (overwrite OverwriteNever) (deep "a") (deep "c") + shouldNotExist (deep "a") + (deep "c") `shouldContain'` "a" + + describe "mv (overwrite OverwriteError)" $ do + + it "fails and keeps an existing destination" $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "b") "b" + shouldFailExists + (mv (overwrite OverwriteError) (d "a") (d "b")) + (d "a") `shouldContain'` "a" + (d "b") `shouldContain'` "b" + + it "moves to a missing destination" $ withTempDir $ \d -> do + writeFile (d "a") "a" + mv (overwrite OverwriteError) (d "a") (d "b") + shouldNotExist (d "a") + (d "b") `shouldContain'` "a" + + it "fails on a dangling symlink at the destination" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + createFileLink "nowhere" (d "b") + shouldFailExists + (mv (overwrite OverwriteError) (d "a") (d "b")) + (d "a") `shouldContain'` "a" + pathIsSymbolicLink (d "b") `shouldReturn` True + + it "fails on an existing file in the destination directory" + $ withTempDir $ \d -> do + writeFile (d "a") "new" + createDirectory (d "dir") + writeFile (d "dir" "a") "old" + shouldFailExists + (mv (overwrite OverwriteError) (d "a") (d "dir")) + (d "a") `shouldContain'` "new" + (d "dir" "a") `shouldContain'` "old" + + describe "mv (overwrite OverwriteOnly)" $ do + + it "does nothing if the destination is missing" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + mv (overwrite OverwriteOnly) (d "a") (d "b") + (d "a") `shouldContain'` "a" + shouldNotExist (d "b") + + it "replaces an existing destination" $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "b") "b" + mv (overwrite OverwriteOnly) (d "a") (d "b") + shouldNotExist (d "a") + (d "b") `shouldContain'` "a" + + describe "mv (overwrite OverwriteUpdate)" $ do + + it "replaces an older destination" $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "b") "b" + setAge (d "b") (-100) + mv (overwrite OverwriteUpdate) (d "a") (d "b") + shouldNotExist (d "a") + (d "b") `shouldContain'` "a" + + it "keeps a newer destination" $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "b") "b" + setAge (d "a") (-100) + mv (overwrite OverwriteUpdate) (d "a") (d "b") + (d "a") `shouldContain'` "a" + (d "b") `shouldContain'` "b" + + it "moves to a missing destination" $ withTempDir $ \d -> do + writeFile (d "a") "a" + mv (overwrite OverwriteUpdate) (d "a") (d "b") + shouldNotExist (d "a") + (d "b") `shouldContain'` "a" + + it "compares with the file of the same name in the directory" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + createDirectory (d "dir") + writeFile (d "dir" "a") "old" + setAge (d "a") (-100) + mv (overwrite OverwriteUpdate) (d "a") (d "dir") + (d "a") `shouldContain'` "a" + (d "dir" "a") `shouldContain'` "old" + + describe "mv (intoDirectory False)" $ do + + it "fails to replace a directory with a file" $ withTempDir $ \d -> do + writeFile (d "a") "a" + createDirectory (d "dir") + shouldFail (mv (intoDirectory False) (d "a") (d "dir")) + (d "a") `shouldContain'` "a" + shouldNotExist (d "dir" "a") + + it "renames to a missing destination" $ withTempDir $ \d -> do + writeFile (d "a") "a" + mv (intoDirectory False) (d "a") (d "b") + (d "b") `shouldContain'` "a" + +#if !defined(CABAL_OS_WINDOWS) + -- GNU mv -T replaces the symlink. MoveFileEx cannot replace a + -- directory symlink with a file, so mv fails on Windows. + it "replaces a symlink to a directory instead of moving into it" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + createDirectory (d "dir") + createDirectoryLink "dir" (d "link") + mv (intoDirectory False) (d "a") (d "link") + pathIsSymbolicLink (d "link") `shouldReturn` False + (d "link") `shouldContain'` "a" + shouldNotExist (d "dir" "a") +#endif + +#if !defined(CABAL_OS_WINDOWS) + -- rename(2) replaces an empty directory; MoveFileEx does not. + it "replaces an empty directory with a directory" + $ withTempDir $ \d -> do + createDirectory (d "x") + writeFile (d "x" "f") "f" + createDirectory (d "y") + mv (intoDirectory False) (d "x") (d "y") + shouldNotExist (d "x") + (d "y" "f") `shouldContain'` "f" +#endif + + it "fails to replace a non-empty directory" $ withTempDir $ \d -> do + createDirectory (d "x") + createDirectory (d "y") + writeFile (d "y" "f") "f" + shouldFail (mv (intoDirectory False) (d "x") (d "y")) + doesDirectoryExist (d "x") `shouldReturn` True + (d "y" "f") `shouldContain'` "f" + + describe "mvMany" $ do + + it "moves several sources into a directory" $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "b") "b" + createDirectory (d "dir") + mvMany id [d "a", d "b"] (d "dir") + shouldNotExist (d "a") + shouldNotExist (d "b") + (d "dir" "a") `shouldContain'` "a" + (d "dir" "b") `shouldContain'` "b" + + it "fails without moving anything if the target is not a directory" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "f") "f" + shouldFail (mvMany id [d "a"] (d "f")) + (d "a") `shouldContain'` "a" + (d "f") `shouldContain'` "f" + + it "fails if the target is missing" $ withTempDir $ \d -> do + writeFile (d "a") "a" + shouldFail (mvMany id [d "a"] (d "missing")) + (d "a") `shouldContain'` "a" + + it "moves the remaining sources after a failure, then fails" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "c") "c" + createDirectory (d "dir") + shouldFail + (mvMany id + [d "a", d "missing", d "c"] (d "dir")) + (d "dir" "a") `shouldContain'` "a" + (d "dir" "c") `shouldContain'` "c" + + it "applies the overwrite option to each source" + $ withTempDir $ \d -> do + writeFile (d "a") "new" + writeFile (d "b") "b" + createDirectory (d "dir") + writeFile (d "dir" "a") "old" + mvMany (overwrite OverwriteNever) + [d "a", d "b"] (d "dir") + (d "a") `shouldContain'` "new" + (d "dir" "a") `shouldContain'` "old" + (d "dir" "b") `shouldContain'` "b" + + it "moves the other sources with OverwriteError" + $ withTempDir $ \d -> do + writeFile (d "a") "new" + writeFile (d "b") "b" + createDirectory (d "dir") + writeFile (d "dir" "a") "old" + mvMany (overwrite OverwriteError) + [d "a", d "b"] (d "dir") + `shouldFailMentioning` [d "dir" "a"] + (d "a") `shouldContain'` "new" + (d "dir" "a") `shouldContain'` "old" + (d "dir" "b") `shouldContain'` "b" + + it "names every failed source in the error" $ withTempDir $ \d -> do + createDirectory (d "dir") + mvMany id [d "missing1", d "missing2"] (d "dir") + `shouldFailMentioning` ["missing1", "missing2"] + + it "does nothing for an empty source list" $ withTempDir $ \d -> do + createDirectory (d "dir") + mvMany id [] (d "dir") + doesDirectoryExist (d "dir") `shouldReturn` True + + it "moves sources with trailing separators" $ withTempDir $ \d -> do + createDirectory (d "x") + createDirectory (d "y") + createDirectory (d "dir") + mvMany id [d "x" ++ "/", d "y" ++ "/"] (d "dir") + doesDirectoryExist (d "dir" "x") `shouldReturn` True + doesDirectoryExist (d "dir" "y") `shouldReturn` True + + it "moves into the directory a symlink points to" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + createDirectory (d "dir") + createDirectoryLink "dir" (d "link") + mvMany id [d "a"] (d "link") + (d "dir" "a") `shouldContain'` "a" + + it "fails if the target is a symlink to a file" + $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "f") "f" + createFileLink "f" (d "link") + shouldFail (mvMany id [d "a"] (d "link")) + (d "a") `shouldContain'` "a" + doesFileExist (d "f") `shouldReturn` True + + it "applies OverwriteUpdate to each source" $ withTempDir $ \d -> do + writeFile (d "a") "a" + writeFile (d "b") "b" + createDirectory (d "dir") + writeFile (d "dir" "a") "old" + writeFile (d "dir" "b") "new" + setAge (d "dir" "a") (-100) + setAge (d "b") (-100) + mvMany (overwrite OverwriteUpdate) + [d "a", d "b"] (d "dir") + (d "dir" "a") `shouldContain'` "a" + (d "b") `shouldContain'` "b" + (d "dir" "b") `shouldContain'` "new" diff --git a/test/Streamly/Test/Coreutils/Rm.hs b/test/Streamly/Test/Coreutils/Rm.hs index 7f8853b6..11968c76 100644 --- a/test/Streamly/Test/Coreutils/Rm.hs +++ b/test/Streamly/Test/Coreutils/Rm.hs @@ -29,7 +29,8 @@ -- Permission tests that require a different owning user are marked -- @needsRoot@ and skipped unless the test suite is run as root. Tests that -- merely restrict parent-directory permissions are safe to run as a normal --- user. +-- user; they are marked pending when run as root, because root bypasses +-- directory permission bits. -- -- All temporary files and directories are created under @/tmp@ and cleaned up -- after each test, even on failure, using 'bracket'. @@ -55,15 +56,12 @@ import System.PosixCompat.Files , nullFileMode , unionFileModes ) --- TODO -#if 0 -#if !defined(CABAL_OS_WINDOWS) -import System.Posix.User (getRealUserID) -#endif -#endif import System.Posix.Types (FileMode) import Test.Hspec +#if !defined(CABAL_OS_WINDOWS) +import Streamly.Coreutils.Id (idNum) +#endif import Streamly.Coreutils.Rm hiding (rm) import qualified Streamly.Coreutils.Rm as Rm import qualified Streamly.FileSystem.Path as Path @@ -120,13 +118,15 @@ shouldThrow' action = do Left _ -> return () Right _ -> expectationFailure "Expected an exception but none was thrown" --- TODO -#if 0 #if !defined(CABAL_OS_WINDOWS) --- | Check whether we are running as root. +-- | Check whether we are running as root (effective uid 0). isRoot :: IO Bool -isRoot = (== 0) <$> getRealUserID +isRoot = (== 0) <$> idNum id +#endif +-- TODO +#if 0 +#if !defined(CABAL_OS_WINDOWS) -- | Skip a test when not running as root. needsRoot :: IO () -> IO () needsRoot action = do @@ -138,6 +138,7 @@ needsRoot action = do #endif -- Convenience mode constants +{- HLINT ignore "Use camelCase" -} modeRWX, modeRW_, modeR_X, modeR__, mode___ :: FileMode modeRWX = ownerReadMode `unionFileModes` ownerWriteMode `unionFileModes` ownerExecuteMode modeRW_ = ownerReadMode `unionFileModes` ownerWriteMode @@ -147,15 +148,20 @@ mode___ = nullFileMode -- | On Unix, assert that an action fails due to directory permission -- restrictions. On Windows, directory permission bits are not enforced; --- the action is run but its result is ignored. +-- the action is run but its result is ignored. As root, permission bits are +-- not enforced and the action succeeds, as GNU rm does; the test is marked +-- pending without running the action. parentDirPermCheck :: IO () -> IO () -parentDirPermCheck = #if defined(CABAL_OS_WINDOWS) - -- On Windows, we do not check parent dir permission as they are controlled - -- by ACLs, not permission modes. - id +-- On Windows, we do not check parent dir permission as they are controlled +-- by ACLs, not permission modes. +parentDirPermCheck = id #else - shouldThrow' +parentDirPermCheck action = do + root <- isRoot + if root + then pendingWith "Root bypasses directory permission bits" + else shouldThrow' action #endif -------------------------------------------------------------------------------