diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index a152483..a6d227e 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -1,9 +1,9 @@ -# packcheck-0.6.0 +# packcheck-0.7.1 # You can use any of the options supported by packcheck as environment # variables here. See https://github.com/composewell/packcheck for all # options and their explanation. -name: packcheck +name: tests #----------------------------------------------------------------------------- # Events on which the build should be triggered @@ -15,160 +15,269 @@ on: - master pull_request: - #----------------------------------------------------------------------------- # Build matrix #----------------------------------------------------------------------------- jobs: build: - name: ${{ matrix.name }} + name: >- + ${{ matrix.runner }} + ${{ matrix.command }} + ${{ matrix.ghc_version }} + ${{ matrix.name }} env: # ------------------------------------------------------------------------ # Common options # ------------------------------------------------------------------------ - # GHC_OPTIONS: "-Werror" CABAL_REINIT_CONFIG: y LC_ALL: C.UTF-8 - STACK_UPGRADE: "y" + # ------------------------------------------------------------------------ + # 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: ${{ matrix.ghc_version }} + + # ------------------------------------------------------------------------ + # 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_HACKAGE_MIRROR: hackage.haskell.org:http://hackage.fpcomplete.com - PACKCHECK_LOCAL_PATH: "./packcheck.sh" + # ------------------------------------------------------------------------ + # 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: "v0.6.0" + PACKCHECK_GITHUB_COMMIT: "3fe7607137c571fead0c77a3b2d2d333f7ef28e8" - BUILD: ${{ matrix.build }} - GHCVER: ${{ matrix.ghc_version }} - #RESOLVER: ${{ matrix.resolver }} - #CABAL_BUILD_OPTIONS: ${{ matrix.cabal_build_options }} - CABAL_PROJECT: ${{ matrix.cabal_project }} - #DISABLE_DOCS: ${{ matrix.disable_docs }} - #DISABLE_SDIST_BUILD: ${{ matrix.disable_sdist_build }} - #DISABLE_SDIST_BUILD: "y" - HLINT_OPTIONS: ${{ matrix.hlint_options }} - HLINT_TARGETS: ${{ matrix.hlint_targets }} - DOCTEST: ${{ matrix.doctest }} + # ------------------------------------------------------------------------ + # Final build variables + # ------------------------------------------------------------------------ + PACKCHECK_COMMAND: ${{ matrix.command }} ${{ matrix.pack_options }} + # ubuntu seems to have better support than debian on CI systems runs-on: ${{ matrix.runner }} + #continue-on-error: ${{ matrix.ignore_error }} strategy: fail-fast: false matrix: + + # The order of jobs is important to optimize fail-fast. + + # This section is to order the important jobs first especially for + # "fail-fast" so that these are the ones started first. + name: + - werror-fusion + + # The name of the CI is built using the name and other info from CI, + # therefore, the "name" field can be same for all tests here. + # + # The reason we have an explicit "name" field here is to force + # an additional config instead of adding to an existing config + # while adding additional configs. + # Look at + # for more info about adding matrix elements. + # Adding any element to the list will increase the number of matrix + # elements proportional to the cross product. include: - - name: 9.8.1-Werror - ghc_version: 9.8.1 - build: cabal-v2 + - name: ci runner: ubuntu-latest - cabal-version: 3.10.1.0 - cabal_project: cabal.project.d/master-Werror + command: cabal + ghc_version: head + # The URL may change, to find a working URL go to https://gitlab.haskell.org/ghc/ghc/-/jobs/ + # Find a debian10/11/12 job, click on a passed/failed status, at the + # end of the output you will find the tar.xz name, put that tar + # name after "raw/", and put the job name after "job=". + # Also see https://github.com/mpickering/ghc-artefact-nix/blob/master/gitlab-artifact.nix + # + # May also use ghcup for installing ghc head version, use the + # version "LatestNightly", and the following config: + # ghcup config add-release-channel https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml + pack_options: >- + GHCUP_GHC_OPTIONS="-u https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-deb10-int_native-validate.tar.xz?job=x86_64-linux-deb10-int_native-validate" + CABAL_PROJECT=cabal.project.ghc-head + DISABLE_SDIST_BUILD="y" - - name: 9.6.3-macos - ghc_version: 9.6.3 - build: cabal-v2 + - name: ci + runner: ubuntu-latest + command: cabal + ghc_version: 9.14.1 + #pack_options: >- + #CABAL_PROJECT=cabal.project.d/master + + - name: ci runner: macos-latest - cabal-version: 3.10.1.0 - cabal_project: cabal.project.d/master + command: cabal + ghc_version: 9.12.2 + #pack_options: >- + #CABAL_PROJECT=cabal.project.d/master - - name: 9.4.4 - ghc_version: 9.4.4 - build: cabal-v2 + - name: werror-fusion runner: ubuntu-latest - cabal-version: 3.8.1.0 - cabal_project: cabal.project.d/master + command: cabal + ghc_version: 9.10.3 + pack_options: >- + CABAL_BUILD_OPTIONS="--flag fusion-plugin" + CABAL_PROJECT=cabal.project.d/master-Werror - - name: 9.2.7+fusion-plugin - ghc_version: 9.2.7 - build: cabal-v2 + - name: ci runner: ubuntu-latest - cabal-build-options: --flag fusion-plugin - cabal-version: 3.6 - cabal_project: cabal.project.d/master + command: stack + ghc_version: 9.10.3 + pack_options: >- + STACK_UPGRADE="y" + DISABLE_SDIST_BUILD="y" + #CABAL_PROJECT=cabal.project - - name: 9.0.2+doctest - ghc_version: 9.0.2 - build: cabal-v2 + - name: ci runner: ubuntu-latest - cabal-version: 3.2 - doctest: "y" - cabal_project: cabal.project.d/master + command: cabal + ghc_version: 9.8.4 + #pack_options: >- + #CABAL_PROJECT=cabal.project.d/master - - name: 8.10.7+macOS - ghc_version: 8.10.7 - build: cabal-v2 - runner: macos-latest - cabal-version: 3.2 - cabal_project: cabal.project.d/master + - name: ci + runner: ubuntu-latest + command: cabal + ghc_version: 9.6.3 + #pack_options: >- + #CABAL_PROJECT=cabal.project.d/master - - name: 8.8.4 - ghc_version: 8.8.4 - build: cabal-v2 + - name: ci runner: ubuntu-latest - cabal-version: 3.2 - cabal_project: cabal.project.d/master + command: cabal + ghc_version: 9.4.7 + #pack_options: >- + #CABAL_PROJECT=cabal.project.d/master - - name: 8.6.5 - ghc_version: 8.6.5 - build: cabal-v2 + - name: ci runner: ubuntu-latest - cabal-version: 3.2 - cabal_project: cabal.project.d/master + command: cabal + ghc_version: 9.2.8 + #pack_options: >- + #CABAL_PROJECT=cabal.project.d/master - - name: hlint + - name: no-docs + runner: ubuntu-latest + command: cabal ghc_version: 8.10.7 - build: cabal-v2 - hlint_options: "lint" - hlint_targets: "src test Benchmark" + pack_options: >- + DISABLE_DOCS="y" + #CABAL_PROJECT=cabal.project.d/master + + - name: ci + runner: windows-latest + command: cabal + ghc_version: 9.10.3 + + - name: ci runner: ubuntu-latest - cabal-version: 3.2 - cabal_project: cabal.project.d/master + command: hlint + pack_options: >- + HLINT_VERSION=3.6.1 + HLINT_OPTIONS="lint" + HLINT_TARGETS="src test Benchmark" + #CABAL_PROJECT=cabal.project.d/master - steps: - - uses: actions/checkout@v2 + - name: docspec + runner: ubuntu-latest + command: cabal + ghc_version: 9.12.2 + pack_options: >- + ENABLE_DOCSPEC="y" + DOCSPEC_URL=https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20250606/cabal-docspec-0.0.0.20250606-x86_64-linux.xz + DOCSPEC_OPTIONS="--timeout 60" + #CABAL_PROJECT=cabal.project.d/master - - uses: haskell/actions/setup@v1 - with: - ghc-version: ${{ matrix.ghc_version }} + steps: + - uses: actions/checkout@v4 + # See the "cabal path" output in the CI logs to tweak the cache locations - uses: actions/cache@v4 - name: Restore cache ~/.cabal, ~/.stack, .stack-work, ~/.ghc, ~/.local + name: Cache common directories (non-Windows) + if: runner.os != 'Windows' with: + # ghcup: ~/.ghcup (macOS), /usr/local/.ghcup (Linux) + # cabal: ~/.local/bin, ~/.local/state/cabal, ~/.local/cache/cabal path: | + /usr/local/.ghcup ~/.cabal - ~/.stack - .stack-work - ~/.ghc + ~/.ghcup ~/.local - key: ${{ runner.os }}-${{ matrix.name }} + ~/.stack + # Bump the key version to clear the cache + # Key is same as the CI name + key: ${{ matrix.runner }}-${{ matrix.command }}-${{ matrix.ghc_version }}-${{ matrix.name }}-v1 + + - uses: actions/cache@v4 + name: Cache common directories (Windows) + if: runner.os == 'Windows' + with: + path: | + ${{ env.APPDATA }}/local + C:/ghcup + C:/cabal + key: ${{ matrix.runner }}-${{ matrix.command }}-${{ matrix.ghc_version }}-${{ matrix.name }}-v1 - name: Download packcheck + # on windows-latest GitHub Actions defaults to PowerShell + shell: bash run: | - # If a custom stack-yaml is specified, replace the default with that - if test -e "$STACK_YAML"; then rm -f stack.yaml && ln -sv $STACK_YAML stack.yaml; else true; fi - unset STACK_YAML - - # Get packcheck if needed - CURL=$(which curl) - PACKCHECK_URL=${PACKCHECK_GITHUB_URL}/${PACKCHECK_GITHUB_COMMIT}/packcheck.sh - if test ! -e "$PACKCHECK_LOCAL_PATH"; then $CURL -sL -o "$PACKCHECK_LOCAL_PATH" $PACKCHECK_URL; fi; - chmod +x $PACKCHECK_LOCAL_PATH + if test ! -e "$PACKCHECK" + then + if test -z "$PACKCHECK_GITHUB_COMMIT" + then + die "PACKCHECK_GITHUB_COMMIT env var 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 - name: Run packcheck + # on windows-latest GitHub Actions defaults to PowerShell + shell: bash run: | - if test -n "$DOCTEST" - then - mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20210111/cabal-docspec-0.0.0.20210111.xz > cabal-docspec.xz - echo '0829bd034fba901cbcfe491d98ed8b28fd54f9cb5c91fa8e1ac62dc4413c9562 cabal-docspec.xz' | sha256sum -c - - xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec - rm -f cabal-docspec.xz - chmod a+x $HOME/.cabal/bin/cabal-docspec - cabal update - cabal build all --project-file cabal.project.d/master - $HOME/.cabal/bin/cabal-docspec --version - $HOME/.cabal/bin/cabal-docspec --timeout 60 - else - bash -c "$PACKCHECK_LOCAL_PATH $BUILD" - fi + PATH_VAR=/sbin:/usr/sbin:/bin:/usr/bin + case "$(uname)" in + CYGWIN*|MINGW*|MSYS*) + PATH_VAR="$PATH_VAR:/c/Program Files/7-Zip:/mingw64/bin" + ;; + esac + # 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. + echo "DEBUG: bash -c \"$PACKCHECK $PACKCHECK_COMMAND PATH=\\\"$PATH_VAR\\\"\"" + bash -c "$PACKCHECK $PACKCHECK_COMMAND PATH=\"$PATH_VAR\"" diff --git a/.packcheck.ignore b/.packcheck.ignore index db9b969..bc7f5fc 100644 --- a/.packcheck.ignore +++ b/.packcheck.ignore @@ -2,9 +2,10 @@ stack.yaml .github/workflows/haskell.yml .gitignore -default.nix hie.yaml cabal.project.d/master cabal.project.d/master-Werror -cabal.project.d/streamly-0.9.0 -cabal.project.d/streamly-0.10.0 +flake.lock +flake.nix +test/Main.hs +benchmark/Main.hs diff --git a/README.md b/README.md index 5497b70..2d7b455 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,30 @@ -# Shell commands using streams +# Streamly Coreutils -Port useful commands from the GNU `coreutils` to Haskell functions using -streamly. +This repository provides Haskell functions that reimplement common +GNU `coreutils` commands, leveraging the `streamly` library for +efficient, streaming data processing where applicable. The goal is to +offer a functional and highly performant alternative to traditional +shell commands within Haskell applications, enabling complex data +transformations and system interactions using a pure functional +paradigm. Where applicable, these implementations are designed to be +highly concurrent, for example, the `ls` equivalent can list directory +contents concurrently for improved performance. + +## Implemented Commands + +Currently, this library provides implementations for the +following coreutils-inspired as well as some additional commands: + +Filesystem: `cp`, `rm`, `mv`, `ln`, `readlink`, `test`, `stat`, `touch` +Directories: `ls`, `dirname`, `mkdir`, `cd`, `pwd`, `home` and others +Text Processing: `cut`, `tail` +Processes: `sleep` +Shell: `which`, executing shell commands with streaming + +## Important API Notice + +**Please be aware that the API of this library is subject to heavy +change in future releases.** This project is under active development, +and function signatures, module organization, and overall design may +evolve significantly. Users should expect breaking changes and plan +accordingly. diff --git a/appveyor.yml b/appveyor.yml index d8fd49b..2972756 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -1,7 +1,8 @@ -# packcheck-0.4.2 +# packcheck-0.7.1 # You can use any of the options supported by packcheck as environment # variables here. See https://github.com/composewell/packcheck for all # options and their explanation. +# branches: only: - master @@ -18,39 +19,31 @@ environment: CABAL_REINIT_CONFIG: "y" LC_ALL: "C.UTF-8" + # ------------------------------------------------------------------------ + # How to build + # ------------------------------------------------------------------------ + # + GHCUP_VERSION: "0.1.50.2" + GHCVER: "9.10.3" + #CABALVER: "3.10.3.0" + # ------------------------------------------------------------------------ # What to build # ------------------------------------------------------------------------ # DISABLE_TEST: "y" # DISABLE_BENCH: "y" # DISABLE_DOCS: "y" - DISABLE_SDIST_BUILD: "y" DISABLE_DIST_CHECKS: "y" - ENABLE_INSTALL: "y" - - # ------------------------------------------------------------------------ - # stack options - # ------------------------------------------------------------------------ - # 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" - RESOLVER: "lts-22.33" - STACK_ROOT: "c:\\sr" - STACK_YAML: "stack.yaml" + DISABLE_SDIST_BUILD: "y" + # Note: these require the "diff" utility. + # DISABLE_SDIST_GIT_CHECK: "y" + # DISABLE_SDIST_PROJECT_CHECK: "y" # ------------------------------------------------------------------------ # cabal options # ------------------------------------------------------------------------ CABAL_CHECK_RELAX: "y" - CABAL_HACKAGE_MIRROR: "hackage.haskell.org:http://hackage.fpcomplete.com" - - # ------------------------------------------------------------------------ - # Where to find the required tools - # ------------------------------------------------------------------------ - PATH: "%PATH%;%APPDATA%\\local\\bin" - LOCAL_BIN: "%APPDATA%\\local\\bin" + #CABAL_PROJECT: "cabal.project" # ------------------------------------------------------------------------ # Location of packcheck.sh (the shell script invoked to perform CI tests ). @@ -63,31 +56,33 @@ 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: "a68b7b9c7c21eef8ed273e67030efb1d4fec027c" + PACKCHECK_GITHUB_COMMIT: "3fe7607137c571fead0c77a3b2d2d333f7ef28e8" # Override the temp directory to avoid sed escaping issues # See https://github.com/haskell/cabal/issues/5386 TMP: "c:\\tmp" +# 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" +# ghcup may use "%APPDATA%\\ghcup" or "c:\\ghcup" cache: - - "%STACK_ROOT%" - - "%LOCAL_BIN%" + - "%APPDATA%\\local\\bin -> v1" - "%APPDATA%\\cabal" - - "%APPDATA%\\ghc" -# - "%LOCALAPPDATA%\\Programs\\stack" + - "%LOCALAPPDATA%\\cabal" + - "C:\\ghcup" + - "C:\\cabal" +# Folder where the repository is cloned. clone_folder: "c:\\pkg" build: off before_test: -- if not exist %PACKCHECK_LOCAL_PATH% curl -sSkL -o%PACKCHECK_LOCAL_PATH% %PACKCHECK_GITHUB_URL%/%PACKCHECK_GITHUB_COMMIT%/packcheck.sh -- if not exist %LOCAL_BIN% mkdir %LOCAL_BIN% -- where stack.exe || curl -sSkL -ostack.zip http://www.stackage.org/stack/windows-x86_64 && 7z x stack.zip stack.exe && move stack.exe %LOCAL_BIN% -- if defined STACKVER (stack upgrade --binary-only --binary-version %STACKVER%) else (stack upgrade --binary-only || ver > nul) -- stack --version +- if not exist %PACKCHECK_LOCAL_PATH% curl --fail -sSL -o%PACKCHECK_LOCAL_PATH% %PACKCHECK_GITHUB_URL%/%PACKCHECK_GITHUB_COMMIT%/packcheck.sh test_script: -- stack setup > nul - for /f "usebackq tokens=*" %%i in (`where 7z.exe`) do set PATH7Z=%%i\.. - for /f "usebackq tokens=*" %%i in (`where git.exe`) do set PATHGIT=%%i\.. -- chcp 65001 && stack exec bash -- -c "chmod +x %PACKCHECK_LOCAL_PATH%; %PACKCHECK_LOCAL_PATH% stack PATH=/usr/bin:\"%PATH7Z%\":\"%PATHGIT%\"" +- for /f "usebackq tokens=*" %%i in (`where curl.exe`) do set PATHCURL=%%i\.. +- chcp 65001 +- bash %PACKCHECK_LOCAL_PATH% cabal PATH="/usr/bin:%PATH7Z%:%PATHGIT%:%PATHCURL%" diff --git a/cabal.project.d/master-Werror b/cabal.project.d/master-Werror index 6c5bdb2..4326d0a 100644 --- a/cabal.project.d/master-Werror +++ b/cabal.project.d/master-Werror @@ -3,13 +3,13 @@ packages: . package streamly-coreutils ghc-options: -Werror -source-repository-package - type: git - location: https://github.com/composewell/streamly.git - tag: master - -source-repository-package - type: git - location: https://github.com/composewell/streamly.git - tag: master - subdir: core +-- source-repository-package +-- type: git +-- location: https://github.com/composewell/streamly.git +-- tag: master +-- +-- source-repository-package +-- type: git +-- location: https://github.com/composewell/streamly.git +-- tag: master +-- subdir: core diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..9ac9cbe --- /dev/null +++ b/flake.lock @@ -0,0 +1,88 @@ +{ + "nodes": { + "basepkgs": { + "inputs": { + "basepkgs": "basepkgs_2", + "nixpkgs": "nixpkgs", + "nixpkgs-darwin": "nixpkgs-darwin" + }, + "locked": { + "lastModified": 1765220327, + "narHash": "sha256-8lfOJtefYuuKEilwfZ3RYUvvg3hs2gtxxnzSqkHUyp0=", + "ref": "refs/heads/master", + "rev": "6181026cd7e6313be5911915a5c924b9b6b06d61", + "revCount": 111, + "type": "git", + "url": "ssh://git@github.com/composewell/streamly-packages" + }, + "original": { + "rev": "6181026cd7e6313be5911915a5c924b9b6b06d61", + "type": "git", + "url": "ssh://git@github.com/composewell/streamly-packages" + } + }, + "basepkgs_2": { + "locked": { + "lastModified": 1765220153, + "narHash": "sha256-cxFW2hVesCxcEZnfGIKfh2529L+2XfXYWfH2mqBmH8M=", + "owner": "composewell", + "repo": "nixpack", + "rev": "dff8ebe040681a7dbbceabb2731c44f68424a6a4", + "type": "github" + }, + "original": { + "owner": "composewell", + "repo": "nixpack", + "rev": "dff8ebe040681a7dbbceabb2731c44f68424a6a4", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1761440988, + "narHash": "sha256-2qsow3cQIgZB2g8Cy8cW+L9eXDHP6a1PsvOschk5y+E=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "de69d2ba6c70e747320df9c096523b623d3a4c35", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "de69d2ba6c70e747320df9c096523b623d3a4c35", + "type": "github" + } + }, + "nixpkgs-darwin": { + "locked": { + "lastModified": 1761430225, + "narHash": "sha256-rwI/YwAAByROAXkGbQNsxgUl/UM5eG5N6XIUzBKOIOw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "08478b816182dc3cc208210b996294411690111d", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "08478b816182dc3cc208210b996294411690111d", + "type": "github" + } + }, + "root": { + "inputs": { + "basepkgs": "basepkgs", + "nixpkgs": [ + "basepkgs", + "nixpkgs" + ], + "nixpkgs-darwin": [ + "basepkgs", + "nixpkgs-darwin" + ] + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..e6218be --- /dev/null +++ b/flake.nix @@ -0,0 +1,19 @@ +{ + description = "Streamly Coreutils Development Environment"; + + inputs = { + basepkgs.url = "git+ssh://git@github.com/composewell/streamly-packages?rev=6181026cd7e6313be5911915a5c924b9b6b06d61"; + nixpkgs.follows = "basepkgs/nixpkgs"; + nixpkgs-darwin.follows = "basepkgs/nixpkgs-darwin"; + }; + + outputs = { self, nixpkgs, nixpkgs-darwin, basepkgs }: + 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; + #packages = import ./packages.nix; + }; +} diff --git a/src/Streamly/Coreutils/Common.hs b/src/Streamly/Coreutils/Common.hs index 0ad9b8d..16c8629 100644 --- a/src/Streamly/Coreutils/Common.hs +++ b/src/Streamly/Coreutils/Common.hs @@ -1,5 +1,26 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | This module is deprecated. Use 'Data.Bool' and 'Bool' instead. module Streamly.Coreutils.Common - ( Switch (..)) -where + {-# DEPRECATED "This module is deprecated. Please use 'Bool' from 'Data.Bool' instead." #-} + ( Switch + , pattern On + , pattern Off + ) where + +-- Define Switch as a Bool alias +type Switch = Bool +{-# DEPRECATED Switch "Use 'Bool' instead" #-} + +-- Alias On with True +pattern On :: Switch +pattern On = True +{-# DEPRECATED On "Use 'True' instead" #-} + +-- Alias Off with False +pattern Off :: Switch +pattern Off = False +{-# DEPRECATED Off "Use 'False' instead" #-} -data Switch = On | Off deriving (Show, Eq) +-- Ensure GHC knows these two patterns cover all Bool cases +{-# COMPLETE On, Off #-} diff --git a/src/Streamly/Coreutils/Cp.hs b/src/Streamly/Coreutils/Cp.hs index 21f210e..2ad9501 100644 --- a/src/Streamly/Coreutils/Cp.hs +++ b/src/Streamly/Coreutils/Cp.hs @@ -112,12 +112,12 @@ cpShouldOverwrite :: CpOverwrite -> FilePath -> FilePath -> IO Bool cpShouldOverwrite option src dest = case option of OverwriteAlways -> return True - OverwriteOnly -> test dest isExisting - OverwriteNever -> not <$> test dest isExisting + OverwriteOnly -> test dest doesExist + OverwriteNever -> not <$> test dest doesExist OverwriteUpdate -> do - r <- test dest isExisting + r <- test dest doesExist if r - then test src $ cmpModifyTime (>) dest + then test src $ newerThanFile dest else return True -- | @cp option-modifier source destination@. Copy a file or directory. diff --git a/src/Streamly/Coreutils/FileTest.hs b/src/Streamly/Coreutils/FileTest.hs index f82f839..92597d8 100644 --- a/src/Streamly/Coreutils/FileTest.hs +++ b/src/Streamly/Coreutils/FileTest.hs @@ -6,444 +6,351 @@ -- Stability : experimental -- Portability : GHC -- --- A predicate DSL to filter files based on their properties. This module is --- portable across Linux, macOS and Windows platforms. For Posix specific --- APIs please see "Streamly.Coreutils.FileTest.Posix". --- --- For good performance, combine multiple predicates for the same file and test --- those in one go. --- --- This module covers a subset of the functionality provided by the GNU --- coreutils @test@ utility. String testing is not provided as it can be --- trivially done using built-in Haskell functionality. That leaves only file --- test routines. The routines provided in this module have a one to one --- correspondence with the @test@ utility. - --- Design Notes: --- --- "unix" package provides accessor functions for FileStatus. Why not get the --- FileStatus and use those directly for testing properties of a file? --- Predicates are easier to understand and can wrap high level logic e.g. --- compare the file size with the size of another file. Predicates are easy to --- combine efficiently without worrying about passing around the FileStatus --- structure or accessing it multiple times. It is easier to make predicates --- OS independent. --- --- XXX This is for POSIX but some of it could be applicable to Windows as well. --- Should we create a platform independent abstraction too? --- --- XXX Need tests for Windows. Especially for file access permissions. How do --- ACLs affect it? Also file times. --- --- Files supported by windows: --- --- Regular files --- Directory files --- Symbolic links: .symlink, .lnk --- Hard links --- Named pipes: .pipe --- Device files: .sys, .dll --- Mount point files: .mount, .vhd, .vhdx, .iso, .img --- --- See FileType in Win32 package. --- --- File Permissions: --- --- See AccessMode and ShareMode in the Win32 package +-- A composable predicate DSL for testing file properties, inspired by the +-- GNU @test@ utility. This module is portable across Linux, macOS, and +-- Windows platforms. +-- +-- Predicates can be combined using boolean operators. Multiple composed +-- predicates are evaluated using a single file status query, minimizing +-- system calls and providing better performance than performing each test +-- independently. +-- +-- === GNU @test@ Utility Mapping +-- +-- This module provides Haskell equivalents for the file-related functionality +-- of the GNU coreutils @test@ utility and the standard POSIX shell +-- style tests such as: +-- +-- > [ -d path ] +-- > [ -r path ] +-- +-- It offers greater composability and improved performance by allowing +-- multiple predicates to share a single file status query. +-- +-- String comparison tests provided by GNU @test@ are intentionally omitted, +-- as they can be expressed directly using standard Haskell operators. +-- +-- The mapping below makes it straightforward to translate shell scripts +-- using @test@ or @[ ... ]@ file predicates directly into Haskell code. +-- +-- The following table shows the correspondence between common GNU @test@ +-- file predicates and the predicates provided by this module. +-- +-- > test -b file -> isBlockDevice +-- > test -c file -> isCharDevice +-- > test -d file -> isDir +-- > test -e file -> doesExist +-- > test -f file -> isFile +-- > test -g file -> hasSetGid +-- > test -G file -> isOwnedByCurrentGroup +-- > test -h file -> isSymLink +-- > test -k file -> hasStickyBit +-- > test -L file -> isSymLink +-- > test -N file -> modifiedSinceLastAccess +-- > test -O file -> isOwnedByCurrentUser +-- > test -p file -> isPipe +-- > test -r file -> isReadable +-- > test -s file -> size (> 0) +-- > test -S file -> isSocket +-- > test -t fd -> isTerminalFd +-- > test -u file -> hasSetUid +-- > test -w file -> isWritable +-- > test -x file -> isExecutable +-- +-- > test file1 -nt file2 -> newerThanFile file2 +-- > test file1 -ot file2 -> olderThanFile file2 +-- > test file1 -ef file2 -> sameFileAs file2 +-- +-- Example: +-- +-- > test path doesExist +-- > test path isReadable +-- > test path (size (> 4096)) +-- > test path (modifyTimeComparedTo (>) "reference.txt") module Streamly.Coreutils.FileTest ( -- * File Test Predicate Type FileTest - -- * Primitives - , predicate - , true - , false + -- * Running Predicates + , test + , testl - -- * Predicate Combinators + -- * Boolean Predicate Combinators , not_ , and_ , or_ + + -- * Folding Predicates + , true + , false , and , or - -- * Running Predicates - , test - -- TODO: Create Streamly.Coreutils.FileTest.Posix for Posix specific - -- functions. -#if !defined(CABAL_OS_WINDOWS) - , testFD -#endif - -- * Predicates -- ** General - , isExisting -#if !defined(CABAL_OS_WINDOWS) - , isHardLinkOf -#endif + -- , predicate -- exposes FileStatus + , doesExist -- ** File Type , isDir , isFile , isSymLink -#if !defined(CABAL_OS_WINDOWS) , isCharDevice , isBlockDevice , isPipe , isSocket - -- , isTerminalFD -#endif - - -- ** File Permissions - -- *** For current user + -- , isTerminalFd -- XXX needs to be fixed + + -- ** File Mode + -- | We can define convenience operations by combining multiple elementary + -- checks, for example: + -- + -- @ + -- hasOwnerRWX = and [hasOwnerRead, hasOwnerWrite, hasOwnerExec] + -- @ + -- + -- === Portability Notes + -- + -- On POSIX systems, this checks the standard Unix permission bits. + -- + -- On Windows, only one or two predicates make sense: + -- + -- * 'hasOwnerWrite' - returns false if the file is marked read only via attributes. + -- * 'hasOwnerExec' - returns true based on the file extension: @.bat@, @.cmd@, + -- @.com@, @.exe@. + -- * 'hasOwnerRead' - always returns true. + -- * Group, and Other predicates are same as owner predicates. + + , hasOwnerRead + , hasOwnerWrite + , hasOwnerExec + + , hasGroupRead + , hasGroupWrite + , hasGroupExec + + , hasOtherRead + , hasOtherWrite + , hasOtherExec + + , hasSetUid + , hasSetGid + , hasStickyBit + + -- ** File Access (Current User) + + -- XXX currently not working fully well, hasPermissions need to be fixed + -- for checking acess via all groups. + -- + -- These have limited use on Windows as windows uses mostly ACLs, only + -- read only bit is used in modes. + + -- *** Mode based access + -- | These APIs perform only the file permission mode checks, actual + -- readability, writability or executability may depend many other factors + -- like filesystem mount permissions, access control lists (ACLs) etc. For + -- deeper checks see: 'isReadable', 'isWritable', 'isExecutable'. + -- + , isReadableByMode + , isWritableByMode + , isExecutableByMode + + -- *** Real Access + -- | These tests determine whether the file is actually accessible at this + -- time including file permission mode, ACLs, mount permissions. , isReadable , isWritable , isExecutable -#if !defined(CABAL_OS_WINDOWS) - -- *** Mode check - -- , mkMode -- quasiquoters? - -- , hasMode - , hasSticky - , hasSetUID - , hasSetGID -#endif - - -- ** File Ownership - , isOwnedByEUID -#if !defined(CABAL_OS_WINDOWS) - , isOwnedByEGID -#endif - - --, isOwnedByUser - --, isOwnedByUid - --, isOwnedByGroup - --, isOwnedByGid + {- + -- *** Lock based + -- | These do not make much sense on posix as posix does not use mandatory + -- locks. + , isReadableNow + , isWritableNow + , isExecutableNow + -} + + -- ** File Ownership (Current User) + {- + , isOwnedByUserId + , isOwnedByGroupId + , isOwnedByUserName + , isOwnedByGroupName + -} + , isOwnedByCurrentUser + , isOwnedByCurrentGroup + + -- ** Hard Links + , sameFileAs -- ** File size -- XXX Need convenient size units and conversions (e.g. kB 1, kiB 1, mB 2) - , hasSize - , cmpSize + , size + , sizeComparedTo + , largerThanFile + , smallerThanFile + , sameSizeAs -- ** File times - -- XXX Need convenient time units and conversions (e.g. sec 5, - -- "2022-01-01") + -- | 'NominalDiffTime' is time duration specified in seconds possibly + -- fractional. It has a Num instance so you can specify literals and cast + -- common types as follows: + -- + -- >>> 0.5 :: NominalDiffTime + -- >>> fromIntegral :: Int -> NominalDiffTime + -- >>> realToFrac :: Double -> NominalDiffTime + -- >>> fromInteger :: Integer -> NominalDiffTime + -- + -- Unit helpers are convenient to specify time durations: + -- + -- >>> modifiedWithin (days 1 + hours 5 + minutes 10 + seconds 20) + + -- *** Time units + , seconds + , minutes + , hours + , days -- *** File age - , hasAccessAge - , hasModifyAge - -- , hasCreateAge + , modifyAge + , modifiedWithin + -- , modifiedOlderThan -- (not_ modifiedWithin) is better + , accessAge + , metadataAge -- *** File timestamp - , hasModifyTime + , modifyTime + , accessTime + , metadataChangeTime -- *** Compare timestamps with file - , cmpModifyTime + , modifyTimeComparedTo + , olderThanFile + , newerThanFile + , accessTimeComparedTo + + -- * Deprecated + , isExisting ) where -import Control.Exception (catch, throwIO) -import Control.Monad (when) -import Data.Bits ((.&.)) -import Data.Int (Int64) -import Data.Time.Clock.POSIX (POSIXTime) -import Foreign.C.Error (Errno(..), eNOENT) -import GHC.IO.Exception (IOException(..), IOErrorType(..)) - --- XXX Remove the dependency on unix-compat and directory -import System.PosixCompat.Files (FileStatus) -import System.Posix.Types (COff(..), FileMode) +import System.Posix.Types (Fd, FileMode) + import qualified System.PosixCompat.Files as Files #if !defined(CABAL_OS_WINDOWS) -import System.Posix.Types (Fd) -import qualified System.Posix.User as User +import qualified Streamly.Coreutils.FileTest.Posix as FileTest +#else +import qualified Streamly.Coreutils.FileTest.Windows as FileTest +import System.Win32.Types #endif +import Streamly.Coreutils.FileTest.Common import Prelude hiding (and, or) -import Streamly.Internal.Data.Time.Clock -import Streamly.Internal.Data.Time.Units -newtype Predicate m a = - Predicate (a -> m Bool) +------------------------------------------------------------------------------- +-- User and group ownerships +------------------------------------------------------------------------------- --- $setup --- >>> import Prelude hiding (or, and) +_isOwnedByUserId :: FileTest.Uid -> FileTest +_isOwnedByUserId = FileTest.isOwnedByUserId --- Naming Notes: Named FileTest rather than "Test" to be more explicit and --- specific. The command can also be named fileTest or testFile. --- --- We do not provide a Semigroup instance for the `and` operation because then --- we either do not have a similar op for `or` operation, or we need a newtype --- for that. So we just do not have it. +_isOwnedByGroupId :: FileTest.Gid -> FileTest +_isOwnedByGroupId = FileTest.isOwnedByGroupId --- | A predicate type for testing boolean statements about a file. --- -newtype FileTest = - FileTest (Predicate IO FileStatus) +-- | Unimplemented +_isOwnedByUserName :: String -> FileTest +_isOwnedByUserName = undefined --- | A boolean @and@ function for combining two 'FileTest' predicates. --- -and_ :: FileTest -> FileTest -> FileTest -and_ (FileTest (Predicate p)) (FileTest (Predicate q)) = - FileTest (Predicate $ \a -> (&&) <$> p a <*> q a) - --- | A boolean @or@ function for combining two 'FileTest' predicates. --- -or_ :: FileTest -> FileTest -> FileTest -or_ (FileTest (Predicate p)) (FileTest (Predicate q)) = - FileTest (Predicate $ \a -> (||) <$> p a <*> q a) - --- | A boolean @and@ for combining a list of 'FileTest' predicates. --- --- >>> and = foldl and_ true --- -and :: [FileTest] -> FileTest -and = foldl and_ true - --- | A boolean @and@ for combining a list of 'FileTest' predicates. --- --- >>> or = foldl or_ false --- -or :: [FileTest] -> FileTest -or = foldl or_ false - --- | A boolean @not@ function for combining two 'FileTest' predicates. --- -not_ :: FileTest -> FileTest -not_ (FileTest (Predicate p)) = FileTest (Predicate (fmap not . p)) - --- XXX Use a byte array instead of string filepath. - --- | Apply a predicate to a 'FilePath'. --- --- * Returns 'True' if the file exists and the predicate is 'True' --- * Returns 'False' if the file does not exist or the predicate is 'False' --- * Fails with an IO exception if the path to the file is not accessible due --- to lack of permissions. The exception type can be used to determine the --- reason for failure. --- -test :: FilePath -> FileTest -> IO Bool -test path (FileTest (Predicate f)) = - (Files.getFileStatus path >>= f) `catch` eatENOENT - - where - - isENOENT e = - case e of - IOError - { ioe_type = NoSuchThing - , ioe_errno = Just ioe - } -> Errno ioe == eNOENT - _ -> False - - eatENOENT e = if isENOENT e then return False else throwIO e - --- | Apply a predicate to 'FileStatus'. -apply :: FileStatus -> FileTest -> IO Bool -apply st (FileTest (Predicate f)) = f st - --- XXX Use Handle instead --- | Like 'test' but uses a file descriptor instead of file path. -#if !defined(CABAL_OS_WINDOWS) -testFD :: Fd -> FileTest -> IO Bool -testFD fd (FileTest (Predicate f)) = Files.getFdStatus fd >>= f -#endif - --- | Convert a @FileStatus -> Bool@ type of function to a 'FileTest' predicate. -predicate :: (FileStatus -> Bool) -> FileTest -predicate p = FileTest (Predicate (pure . p)) - --- | Convert a @FileStatus -> IO Bool@ type of function to a 'FileTest' --- predicate. -predicateM :: (FileStatus -> IO Bool) -> FileTest -predicateM p = FileTest (Predicate p) - --- | A predicate which is always 'True'. --- --- >>> true = predicate (const True) --- -true :: FileTest -true = predicate (const True) - --- | A predicate which is always 'False'. --- --- >>> false = predicate (const False) --- -false :: FileTest -false = predicate (const False) +-- | Unimplemented +_isOwnedByGroupName :: String -> FileTest +_isOwnedByGroupName = undefined --------------------- --- Global properties --------------------- - --- Note: these are all boolean predicates, therefore, named with "is", "has", --- "cmp" prefix. - --- | True if file exists. --- --- Note: This is do-nothing predicate. 'test' always fails if the file does not --- exist. --- --- Like coreutil @test -e file@ -isExisting :: FileTest -isExisting = true - ---------------- --- Type of file ---------------- - --- | True if file is a directory. +-- | True if the file owner matches the effective user id of the current +-- process. -- --- Like @test -d file@ -isDir :: FileTest -isDir = predicate Files.isDirectory - --- | True if file is a regular file. +-- On Windows, effective user id means effective SID. -- --- Like coreutil @test -f file@ -isFile :: FileTest -isFile = predicate Files.isRegularFile - --- | True if file is a symbolic link. --- --- Like coreutil @test -h/-L file@ -isSymLink :: FileTest -isSymLink = predicate Files.isSymbolicLink - -#if !defined(CABAL_OS_WINDOWS) --- | True if file is a block special file. --- --- Like the coreutil @test -b file@. -isBlockDevice :: FileTest -isBlockDevice = predicate Files.isBlockDevice - --- | True if is a character special file. --- --- Like @test -c file: -isCharDevice :: FileTest -isCharDevice = predicate Files.isCharacterDevice - --- | True if file is a named pipe (FIFO). --- --- Like coreutil @test -p file@ -isPipe :: FileTest -isPipe = predicate Files.isNamedPipe - --- | True if file is a socket. --- --- Like coreutil @test -S file@ -isSocket :: FileTest -isSocket = predicate Files.isSocket - -{- --- | True if the file whose file descriptor number is --- file_descriptor is open and is associated with a terminal. --- --- Like coreutil @test -t file_descriptor@ --- --- /Unimplemented/ -isTerminalFD :: FileTest -isTerminalFD = undefined --} -#endif - ---------------- --- Permissions ---------------- - --- | True if the file has specified permission mode. --- -hasMode :: FileMode -> FileTest -hasMode mode = predicate (\st -> (Files.fileMode st .&. mode) == mode) - -#if !defined(CABAL_OS_WINDOWS) --- | True if the file has set user ID flag is set. --- --- Like coreutil @test -u file@ -hasSetUID :: FileTest -hasSetUID = hasMode Files.setUserIDMode - --- | True if the file has set group ID flag is set. --- --- Like coreutil @test -g file@ -hasSetGID :: FileTest -hasSetGID = hasMode Files.setGroupIDMode +-- Like coreutil @test -O file@ +isOwnedByCurrentUser :: FileTest +isOwnedByCurrentUser = FileTest.isOwnedByCurrentUser --- | True if file has sticky bit is set. +-- Unix files have a GID and group permission bits. A process has an effective +-- GID (egid) and a list of supplementary groups stored in its credentials. +-- These supplementary groups are typically initialized at login from the +-- user's group memberships and inherited by child processes; they can be +-- changed via setgroups(2), setgid(2), newgrp, or in user namespaces. -- --- Like coreutil @test -k file@ +-- The egid and supplementary groups are used for: -- --- /Unimplemented/ -hasSticky :: FileTest -hasSticky = undefined -#endif - --- XXX This can be done for windows as well using GetSecurityInfo. Should we --- use that when getting FileStatus in unix-compat? --- See getFileSecurity in System/Win32/Security.hsc . +-- * Permission checks: if a file's GID matches the egid or any supplementary +-- group, the group permission bits apply. Certain IPC and kernel security +-- checks based on group ownership. +-- * Default group ownership of newly created files (unless overridden by +-- a setgid bit on a directory). +-- * Execution of setgid binaries, which set the process's egid to the +-- file's group. For directories, setgid changes group inheritance semantics. -- --- XXX rename this to isOwnedByCurrentUser to make it portable. - --- | True if the file owner matches the effective user id of this process. +-- Windows files have an associated "group" SID, and process tokens contain +-- a primary group plus a list of group SIDs. -- --- Like coreutil @test -O file@ +-- * file's gSID is not used in access checks; only ACLS determines access. +-- * process token’s primary gSID is used as gSID for new files. +-- * there is no setgid concept or equivalent. -- --- /Unimplemented/ -isOwnedByEUID :: FileTest -isOwnedByEUID = -#if !defined(CABAL_OS_WINDOWS) - predicateM $ \st -> (Files.fileOwner st ==) <$> User.getEffectiveUserID -#else - true -#endif +-- The group SID in Windows exists mainly for POSIX/NFS interoperability, where +-- a file must have a GID for Unix permission semantics. --- XXX rename this to isOwnedByCurrentGroup --- XXX This applies only to POSIX because windows does not have a notion of --- current group. +-- XXX On Windows we can match against the primary group SID of the process +-- token, though it won't mean much in terms of actual implications. But it can +-- still be used for Posix based semantics. But since there are no group based +-- permission bits even returning False is effectively equivalent. -- | True if file exists and its group matches the effective --- group id of this process. +-- group id of the current process. -- --- Like coreutil @test -G file@ +-- Like coreutil @test -G file@. -- --- /Unimplemented/ -isOwnedByEGID :: FileTest -isOwnedByEGID = -#if !defined(CABAL_OS_WINDOWS) - predicateM $ \st -> (Files.fileGroup st ==) <$> User.getEffectiveGroupID -#else - false -#endif - --- On Widnows we will have to use --- GetSecurityInfo/GetNamedSecurityInfo/GetEffectiveRightsFromAcl to check --- permissions properly. +-- On Windows effective group id means the primary group SID. -- --- Also, how to handle CIFS shares. On windows, check ShareMode? On Linux, are --- the file permissions enough for CIFS? +isOwnedByCurrentGroup :: FileTest +isOwnedByCurrentGroup = FileTest.isOwnedByCurrentGroup + +------------------------------------------------------------------------------- +-- Mode based access +------------------------------------------------------------------------------- hasPermissions :: (FileMode, FileMode, FileMode) -> FileTest -hasPermissions (user, group, other) = predicateM $ \st -> do - isOwner <- apply st isOwnedByEUID - let checkMode = apply st . hasMode +hasPermissions (user, group, other) = withStateM $ \fp st -> do + isOwner <- testGeneral fp st isOwnedByCurrentUser + let checkMode = testGeneral fp st . hasMode if isOwner then checkMode user +#if !defined(CABAL_OS_WINDOWS) else do - isGroup <- apply st isOwnedByEGID + -- XXX need to check access via other group memberships as well + isGroup <- testGeneral fp st isOwnedByCurrentGroup if isGroup then checkMode group else checkMode other +#else + else return False +#endif --- | True if the file is readable for the current user. +-- | True if the file mode bits allow the file to be read by the current +-- effective user id. -- --- Like coreutil @test -r file@ +-- On Windows this is always true. -- --- /Pre-release/ -isReadable :: FileTest -isReadable = +-- This does not check the ACLs and other conditions that can make the file +-- unreadable, see 'isReadable' for that. +-- +isReadableByMode :: FileTest +isReadableByMode = hasPermissions ( Files.ownerReadMode @@ -451,26 +358,14 @@ isReadable = , Files.otherReadMode ) --- XXX What does "isWritable" mean on windows? Windows has separate write and --- modify permissions. We can use two separate functions, isWritableData (or --- just isWritable), isWritableMeta. On unix both will have the same underlying --- permission. --- --- We may also need to check if the filesystem/mount is writable, or on windows --- check the drive type. Or do we need a separate stricter checking API for --- that? Or do we encode that in a separate mount/drive level API to be checked --- by the programmer separately. - --- | True if the file is writable for the current user. +-- | True if the file mode bits make it writable for the current user. -- --- Note that the file is not writable on a read-only file system even if this --- test indicates true. +-- On Windows this returns false if the read only flag is set on the file. -- --- Like coreutil @test -w file@ +-- This does not check the ACLs, see 'isWritable' for that. -- --- /Pre-release/ -isWritable :: FileTest -isWritable = +isWritableByMode :: FileTest +isWritableByMode = hasPermissions ( Files.ownerWriteMode @@ -478,24 +373,15 @@ isWritable = , Files.otherWriteMode ) --- XXX What does "isExecutable" mean on windows? For files, unix-compat --- determines executable on windows based on the file type, which does not --- sound right, why not use the execute permission? On unix, directories --- executable mean searchable. On Windows there is a separate attribute for --- that. +-- | True if the file mode bits make it executable for the current user. -- --- We should have a separate isSearchable test for directories. And make --- isExecutable not-applicable/False for directories. But utilities like chmod --- may still need to use +x for executable. But we can use "+X" or "+S" to mean --- searchable. - --- | True if the file is executable for the current user. +-- On Windows this returns true if it is a directory or if it is a file with an +-- executable extension @.bat@, @.cmd@, @.com@, or @.exe@. -- --- Like coreutil @test -x file@ +-- This does not check the ACLs, see isExecutable for that. -- --- /Pre-release/ -isExecutable :: FileTest -isExecutable = +isExecutableByMode :: FileTest +isExecutableByMode = hasPermissions ( Files.ownerExecuteMode @@ -503,101 +389,73 @@ isExecutable = , Files.otherExecuteMode ) ------------------------------- --- Comparing with other files ------------------------------- - -compareTime :: - (FileStatus -> POSIXTime) - -> (POSIXTime -> POSIXTime -> Bool) - -> POSIXTime - -> FileTest -compareTime getFileTime cmp t = predicate (\st -> getFileTime st `cmp` t) - --- | Compare the modification time of the file with a timestamp. -hasModifyTime :: - (POSIXTime -> POSIXTime -> Bool) -> POSIXTime -> FileTest -hasModifyTime = compareTime Files.modificationTimeHiRes - -compareTimeWith :: - (FileStatus -> POSIXTime) - -> (POSIXTime -> POSIXTime -> Bool) - -> FilePath - -> FileTest -compareTimeWith getFileTime cmp path = predicateM $ \st -> do - st1 <- Files.getFileStatus path - apply st $ compareTime getFileTime cmp (getFileTime st1) - --- | Compare the modification time of the file with the modification time of --- another file. -cmpModifyTime :: - (POSIXTime -> POSIXTime -> Bool) -> FilePath -> FileTest -cmpModifyTime = compareTimeWith Files.modificationTimeHiRes - --- | True if file1 and file2 exist and have the same device id and inode. +------------------------------------------------------------------------------- +-- General access, excluding locks +------------------------------------------------------------------------------- + +-- | True if the file is readable by the current process. -- --- Like coreutil @test file1 -ef file2@. +-- This is a dynamic check and determines the readability of the file at this +-- moment based on the permission checks applied by the kernel (e.g. dynamic +-- group membership based permissions, effective user id, acls). -- --- /Unimplemented/ -isHardLinkOf :: FilePath -> FileTest -isHardLinkOf = undefined - -getLocalTime :: IO TimeSpec -getLocalTime = fromAbsTime <$> getTime Realtime - -compareAge :: - (FileStatus -> POSIXTime) - -> (POSIXTime -> POSIXTime -> Bool) - -> Double - -> FileTest -compareAge getFileTime cmp ageSec = predicateM $ \st -> do - when (ageSec < 0) $ error "compareAge: age cannot be negative" - - ts <- getLocalTime - let now = timespecToPosixTime ts - age = doubleToPosixTime ageSec - apply st $ compareTime getFileTime (flip cmp) (now - age) - - where - - timespecToPosixTime (TimeSpec s ns) = - fromIntegral s + fromIntegral ns * 1E-9 - - -- XXX handle negative double value? - doubleToPosixTime :: Double -> POSIXTime - doubleToPosixTime sec = - let s = floor sec - ns = round $ (sec - fromIntegral s) * 1E9 - in timespecToPosixTime (TimeSpec s ns) - --- XXX Use a -> a -> Bool instead -hasAccessAge :: (POSIXTime -> POSIXTime -> Bool) -> Double -> FileTest -hasAccessAge = compareAge Files.accessTimeHiRes +-- Does not consider advisory or mandatory locks. +-- +-- Like coreutil @test -r file@ +-- +isReadable :: FileTest +isReadable = FileTest.isReadable -hasModifyAge :: (POSIXTime -> POSIXTime -> Bool) -> Double -> FileTest -hasModifyAge = compareAge Files.modificationTimeHiRes +-- XXX What does "isWritable" mean on windows? Windows has separate write and +-- modify permissions. We can use two separate functions, isWritableData (or +-- just isWritable), isWritableMeta. On unix both will have the same underlying +-- permission. -{- --- See https://unix.stackexchange.com/questions/91197/how-to-find-creation-date-of-file -hasCreateAge :: (POSIXTime -> POSIXTime -> Bool) -> Double -> FileTest -hasCreateAge = undefined --} +-- | True if the file is writable by the current process. +-- +-- This is a dynamic check and determines the writability of the file at this +-- moment based on the permission checks applied by the kernel (e.g. mount +-- options, dynamic group membership based permissions, effective user id, +-- acls). +-- +-- Does not consider advisory or mandatory locks. +-- +-- Like coreutil @test -w file@ +-- +isWritable :: FileTest +isWritable = FileTest.isWritable --- XXX Should use Int or Int64? +-- NOTE: On POSIX: You do NOT need directory read (r) permission to access a +-- known file. You DO need directory execute (x) permission. On Windows, the +-- (r) equivalent is "List Folder" and (x) equivalent is "Traverse Folder". By +-- default, almost all users have: SeChangeNotifyPrivilege ("Bypass traverse +-- checking"), it is a fast path to grant the access compared to giving +-- traverse folder access to everyone and checking it on each directory in the +-- path. -getSize :: FileStatus -> Int64 -getSize st = let COff size = Files.fileSize st in size +-- | True if the file is executable for the current user. +-- +-- Like coreutil @test -x file@ . +-- +isExecutable :: FileTest +isExecutable = FileTest.isExecutable --- | Compare the file size with the supplied size. +-- | True if the file being tested and the supplied file refer to the same +-- underlying file or directory. +-- +-- Like coreutil @test file1 -ef file2@. +-- +-- On POSIX systems this compares the device id and inode number. On Windows +-- it compares the volume serial number and file index. -- --- Coreutil @test -s file@ would be @hasSize (/=) 0@ +-- The supplied file path is dereferenced if it is a symlink. -- -hasSize :: (Int64 -> Int64 -> Bool) -> Int64 -> FileTest -hasSize cmp n = predicate (\st -> getSize st `cmp` n) +sameFileAs :: FilePath -> FileTest +sameFileAs = FileTest.sameFileAs --- | Compare the file size with the size of another file. +-- | True if the supplied file descriptor refers to a terminal device. -- -cmpSize :: (Int64 -> Int64 -> Bool) -> FilePath -> FileTest -cmpSize cmp path = predicateM $ \st -> do - st1 <- Files.getFileStatus path - apply st $ hasSize cmp (getSize st1) +-- Equivalent to POSIX @isatty@ and the shell command @test -t fd@. +-- On Windows this checks whether the handle refers to a console device. +isTerminalFd :: Fd -> FileTest +isTerminalFd = FileTest.isTerminalFd diff --git a/src/Streamly/Coreutils/FileTest/Common.hs b/src/Streamly/Coreutils/FileTest/Common.hs new file mode 100644 index 0000000..8637018 --- /dev/null +++ b/src/Streamly/Coreutils/FileTest/Common.hs @@ -0,0 +1,1099 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Streamly.Coreutils.FileTest.Common +-- Copyright : (c) 2021 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- See "Streamly.Coreutils.FileTest" module for general module level +-- documentation. This module provides both posix and windows implementations. +-- +-- Design Notes: +-- +-- The "unix" package exposes low-level accessors for 'FileStatus'. +-- This module builds a higher-level predicate abstraction on top of it. +-- Predicates encapsulate common file tests and allow composable logic +-- (for example, comparing file sizes or timestamps) while ensuring that +-- multiple checks share a single underlying file status query. +-- +-- 'FileTest' predicates operate on 'FileState', which carries: +-- +-- * The 'FilePath' that was supplied to the runner ('test' / 'testl'). +-- * A lazily-populated 'IORef' that caches the 'FileStatus' after the +-- first predicate that needs it fetches it. +-- * The OS stat action to use ('getFileStatus' for 'test', +-- 'getSymbolicLinkStatus' for 'testl'). Storing it in 'FileState' means +-- every predicate automatically uses the right variant without needing to +-- know how it was invoked. +-- +-- The cache guarantee: no matter how many predicates are composed with 'and_' +-- / 'or_', at most one @stat@ system call is issued per 'test' / 'testl' +-- invocation. Predicates that are short-circuited away pay no stat cost. +-- +-- FileTest is essentially a Reader. TODO: We can replace Predicate with +-- ReaderT FileState IO +-- +-- We could use a more restricted StatusTest predicates which consume only the +-- file status argument. StatusTest can then be lifted into a FileTest which +-- passes a FilePath argument as well and maybe some others. StatusTest +-- predicates can be moved into a separate module. But does it buy us anything +-- worthwhile? +-- +-- Naming: unary predicates are either isSomething or hasSomething. Binary +-- predicates are nouns. Predicates are named so that they read well on the +-- call site e.g. "test path doesExist" or "test path isReadable". +-- +-- Files supported by windows: +-- +-- Regular files +-- Directory files +-- Symbolic links: .symlink, .lnk +-- Hard links +-- Named pipes: .pipe +-- Device files: .sys, .dll +-- Mount point files: .mount, .vhd, .vhdx, .iso, .img +-- +-- See FileType in Win32 package. +-- +-- File Permissions: +-- +-- See AccessMode and ShareMode in the Win32 package + +-- Testing TODO: +-- XXX Need tests for Windows. Especially for file access permissions. How do +-- ACLs affect it? Also file times. + +module Streamly.Coreutils.FileTest.Common + ( + -- * File Test Predicate Type + Predicate (..) + , mkFileState + , FileTest (..) + + -- * Creating FileTest Predicates + , withState + , withStateM + , withStatusM + , withStatus + , withPathM + , withPath + + -- * Predicate Combinators + , not_ + , and_ + , or_ + + -- * Folds + , true + , false + , and + , or + + -- * Running Predicates + , test + , testl + , testGeneral + + -- * Predicates + + -- ** General + , doesExist + + -- ** File Type + , isDir + , isFile + , isSymLink + , isCharDevice + , isBlockDevice + , isPipe + , isSocket + + -- ** File Permissions + + , hasMode + , hasOwnerRead + , hasOwnerWrite + , hasOwnerExec + + , hasGroupRead + , hasGroupWrite + , hasGroupExec + + , hasOtherRead + , hasOtherWrite + , hasOtherExec + + -- ** File Flags + + , hasSetUid + , hasSetGid + , hasStickyBit + + -- ** File size + -- XXX Need convenient size units and conversions (e.g. kB 1, kiB 1, mB 2) + , size + , isNonEmptyFile + + -- These are not very useful, just size should be enough + , largerThan + , smallerThan + , sizeEquals + , sizeNonZero + + , sizeComparedTo + , largerThanFile + , smallerThanFile + , sameSizeAs + + -- ** File times + -- XXX Need convenient time units and conversions (e.g. sec 5, + -- "2022-01-01") + -- Time units + , seconds + , minutes + , hours + , days + + -- *** File age + , modifyAge + , modifiedWithin + , modifiedOlderThan + , modifiedSinceLastAccess + + , accessAge + , accessedWithin + , accessedOlderThan + + , metadataAge + + -- *** File timestamp + , modifyTime + , modifiedBefore + , modifiedAfter + + , accessTime + , metadataChangeTime + + -- *** Compare timestamps with file + , modifyTimeComparedTo + , olderThanFile + , newerThanFile + + , accessTimeComparedTo + , accessedBeforeFile + , accessedAfterFile + + -- * Deprecated + , isExisting + ) +where + +import Control.Exception (catch, throwIO) +import Data.Bits ((.&.)) +import Data.Int (Int64) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Time.Clock (NominalDiffTime) +import Foreign.C.Error (Errno(..), eNOENT) +import GHC.IO.Exception (IOException(..), IOErrorType(..)) + +-- XXX Remove the dependency on unix-compat and directory +import System.PosixCompat.Files (FileStatus) +import System.Posix.Types (COff(..), FileMode) +import qualified System.PosixCompat.Files as Files + +import Prelude hiding (and, or) +import Streamly.Internal.Data.Time.Clock +import Streamly.Internal.Data.Time.Units + +-- $setup +-- >>> import Prelude hiding (or, and) + +newtype Predicate m a = + Predicate (a -> m Bool) + +------------------------------------------------------------------------------ +-- FileState +------------------------------------------------------------------------------ + +-- | Carries all the information a 'FileTest' predicate needs to evaluate. +-- +-- [@filepath@] The path supplied to the runner ('test' \/ 'testl'). Available +-- to any predicate that needs the path in addition to the status (e.g. for a +-- second stat call on a related file). +-- +-- [@fileStatus@] A write-once lazy cache. Starts as 'Nothing'. The first +-- predicate that needs the 'FileStatus' calls 'requireStatus', which invokes +-- 'fetchStatus' and stores the result. Every subsequent predicate in the same +-- composed expression reuses the cached value, so at most one @stat@ system +-- call is ever issued per runner invocation. +-- +-- [@fetchStatus@] The OS stat action to use when the cache is empty. Set by +-- the runner: 'test' supplies 'Files.getFileStatus' (follows symlinks); +-- 'testl' supplies 'Files.getSymbolicLinkStatus' (examines the link itself). +-- Storing the action here keeps the choice invisible to individual predicates. +data FileState = FileState + { filepath :: FilePath + -- ^ The path supplied to 'test' \/ 'testl'. + , fileStatus :: IORef (Maybe FileStatus) + -- XXX store it in IORef using Either type. + -- ^ Lazily-populated 'FileStatus' cache. + , fetchStatus :: IO FileStatus + -- ^ OS stat action; called at most once, on cache miss. + } + +-- | Obtain the cached 'FileStatus', fetching and caching it on first call. +-- +-- This is the single point through which all leaf predicates access the +-- 'FileStatus'. It guarantees the "at most one @stat@ call" invariant. +requireStatus :: FileState -> IO FileStatus +requireStatus fs = do + cached <- readIORef (fileStatus fs) + case cached of + Just st -> pure st + Nothing -> do + st <- fetchStatus fs + writeIORef (fileStatus fs) (Just st) + pure st + +-- | Construct a fresh 'FileState' with an empty (unfetched) status cache. +-- +-- @fetchFn@ is the OS stat action predicates will use. Pass +-- 'Files.getFileStatus' for symlink-following behaviour, or +-- 'Files.getSymbolicLinkStatus' to examine the link itself. +newFileState :: FilePath -> IO FileStatus -> IO FileState +newFileState path fetchFn = do + ref <- newIORef Nothing + pure $ FileState + { filepath = path + , fileStatus = ref + , fetchStatus = fetchFn + } + +-- | Constructs a 'FileState' whose cache is pre-populated with the supplied +-- 'FileStatus', so no additional @stat@ call is ever issued. The 'filepath' +-- is left empty because no path is available at this call site; 'fetchStatus' +-- is set to an error thunk since it must never be called when the cache is +-- already populated. +mkFileState :: String -> FilePath -> FileStatus -> IO FileState +mkFileState tag fp st = do + ref <- newIORef (Just st) + return $ FileState + { filepath = fp + , fileStatus = ref + , fetchStatus = error $ tag ++ ": BUG. fetchStatus cannot be used here" + } + +------------------------------------------------------------------------------ +-- FileTest +------------------------------------------------------------------------------ + +-- Naming Notes: Named FileTest rather than "Test" to be more explicit and +-- specific. The command can also be named fileTest or testFile. +-- +-- We do not provide a Semigroup/Monoid instance, though it provides a +-- convenient <> for the `and` operation but then we need a newtype wrapper for +-- the "or" operation. Also, the generic foldMap or mconcat provided by Monoids +-- are of limited use in this case. + +-- Predicates receive a 'FileState' rather than a raw 'FileStatus'. This +-- gives them access to the file path and lets them share the lazily-cached +-- 'FileStatus' without issuing redundant @stat@ calls. + +-- | A predicate type for testing boolean statements about a file. +-- +newtype FileTest = + FileTest (Predicate IO FileState) + +-- | A boolean @and@ function for combining two 'FileTest' predicates. +-- +-- For example: +-- +-- >>> isNonEmptyFile = isFile `and_` (size (> 0)) +-- +-- Note that 'and_' uses a single @stat@ system call for both the tests, +-- even if you combine many tests using a combination of 'and_' and 'or_'. +-- +-- It short circuits i.e. if the first predicate evaluates to false it does not +-- evaluate the second. +-- +and_ :: FileTest -> FileTest -> FileTest +and_ (FileTest (Predicate p)) (FileTest (Predicate q)) = + -- The applicative does not short circuit, evaluates both the predicates. + -- FileTest (Predicate $ \a -> (&&) <$> p a <*> q a) + FileTest (Predicate f) + + where + + f a = do + r <- p a + if r + then q a + else pure False + +-- | A boolean @or@ function for combining two 'FileTest' predicates. +-- +-- For example: +-- +-- >>> isFileDir = isFile `or_` isDir +-- +-- Note that 'or_' uses a single @stat@ system call for both the tests, +-- even if you combine many tests using a combination of 'and_' and 'or_'. +-- +-- It short circuits i.e. if the first predicate evaluates to true it does not +-- evaluate the second. +-- +or_ :: FileTest -> FileTest -> FileTest +or_ (FileTest (Predicate p)) (FileTest (Predicate q)) = + -- The applicative does not short circuit, evaluates both the predicates. + -- FileTest (Predicate $ \a -> (||) <$> p a <*> q a) + FileTest (Predicate f) + + where + + f a = do + r <- p a + if r + then pure True + else q a + +-- NOTE: We can also use &&_, ||_ operators but probably not worth it. +-- For && we can provide a Semigroup instance and <> can be used, it can be +-- useful as it is auto imported by Prelude. But then we do not have a similar +-- solution for or. The operator will have to be imported explicitly from this +-- module. +infixr 3 `and_` +infixr 2 `or_` + +-- Naming note: usually we would import this module qualified. If unqualified +-- use of and/or is needed we can rename them anded/ored, andL/orL, +-- conjunction/disjunction, andB/orB (boolean). + +-- NOTE: Use foldr instead of foldl' as it allows short circuiting and infinite +-- containers. + +-- | A boolean @and@ for combining a list of 'FileTest' predicates. +-- +-- >>> and = foldr and_ true +-- +and :: [FileTest] -> FileTest +and = foldr and_ true + +-- | A boolean @or@ for combining a list of 'FileTest' predicates. +-- +-- >>> or = foldr or_ false +-- +or :: [FileTest] -> FileTest +or = foldr or_ false + +-- | A boolean @not@ function for negating a 'FileTest' predicate. +-- +not_ :: FileTest -> FileTest +not_ (FileTest (Predicate p)) = FileTest (Predicate (fmap not . p)) + +-- XXX Use Path instead of filepath. + +applyCatchENOENT :: (t -> IO Bool) -> t -> IO Bool +applyCatchENOENT f fs = + f fs `catch` eatENOENT + + where + + isENOENT e = + case e of + IOError + { ioe_type = NoSuchThing + , ioe_errno = Just ioe + } -> Errno ioe == eNOENT + _ -> False + + eatENOENT e = if isENOENT e then return False else throwIO e + +-- | Apply a predicate to a 'FilePath', if the path is a symlink uses the link +-- target and not the link itself. See 'testl' for testing the link itself. +-- +-- * 'test' returns 'True' if the file exists and the predicate is 'True' +-- * Returns 'False' if the file does not exist or the predicate is 'False' +-- * Fails with an IO exception if the path to the file is not accessible due +-- to lack of permissions. The exception type can be used to determine the +-- reason for failure. +-- * test 'isSymLink' always returns false. +-- * test 'doesExist' returns false if the path is symlink but it does not +-- point to an existing file. +-- +test :: FilePath -> FileTest -> IO Bool +test path (FileTest (Predicate f)) = do + -- 'Files.getFileStatus' dereferences symlinks. + newFileState path (Files.getFileStatus path) >>= applyCatchENOENT f + +-- | Like 'test' but uses the path and not the link target if the path is a +-- symlink. +-- +-- * 'isSymLink' returns true if path is a symlink, false otherwise. +-- * 'doesExist' returns true if the link exists irrespective of whether it +-- points to an existing file. +-- * Predicates related to file permission mode bits are meaningless, and +-- should not be used. +-- * Predicates related to file owner, group, size, time stamps are relevant. +-- +testl :: FilePath -> FileTest -> IO Bool +testl path (FileTest (Predicate f)) = + newFileState path (Files.getSymbolicLinkStatus path) >>= applyCatchENOENT f + +-- | Apply a predicate to a pre-fetched 'FileStatus'. Note you cannot use +-- predicates that require filepath when using apply. +testGeneral :: FilePath -> FileStatus -> FileTest -> IO Bool +testGeneral fp st (FileTest (Predicate f)) = + mkFileState "FileTest.apply" fp st >>= f + +-- | Like 'withState' but the supplied function may perform IO. +withStateM :: (FilePath -> FileStatus -> IO Bool) -> FileTest +withStateM p = + FileTest $ Predicate $ \fs -> requireStatus fs >>= p (filepath fs) + +-- | Convert a @FilePath -> FileStatus -> Bool@ function into a 'FileTest' +-- predicate. +withState :: (FilePath -> FileStatus -> Bool) -> FileTest +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 + +-- | Convert a @FileStatus -> Bool@ function into a 'FileTest' predicate. +withStatus :: (FileStatus -> Bool) -> FileTest +withStatus p = withStatusM (pure . p) + +-- | Like 'withPath' but the supplied function may perform IO. +withPathM :: (FilePath -> IO Bool) -> FileTest +withPathM p = FileTest $ Predicate $ \fs -> p (filepath fs) + +-- | Convert a @FilePath -> Bool@ function into a 'FileTest' predicate. +withPath :: (FilePath -> Bool) -> FileTest +withPath p = withPathM (pure . p) + +-- | A predicate which is always 'True'. Identity of 'and' style folds. +-- +true :: FileTest +true = FileTest $ Predicate $ const (pure True) + +-- | A predicate which is always 'False'. Identity of 'or' style folds. +-- +false :: FileTest +false = FileTest $ Predicate $ const (pure False) + +-------------------- +-- Global properties +-------------------- + +-- Note: these are all boolean predicates, therefore, named with "is", "has", +-- prefix. + +-- NOTE: This could be (Path -> IO Bool) type as we will never combine this +-- with anything else. But as a FileTest the same predicate can be used with +-- either "test" or "testl" to execute the predicate. + +-- >>> doesExist = true + +-- | True if the path exists. In case of symlink whether it tests the link file +-- or the file pointed to by it depends on whether you use 'test' or 'testl' to +-- execute the predicate. +-- +-- Note: 'doesExist' itself performs no check. File existence is determined +-- by 'test' or 'testl', which return False if the path does not exist. +-- +-- Like coreutil @test -e file@ +doesExist :: FileTest +doesExist = true + +{-# DEPRECATED isExisting "Use doesExist instead." #-} +isExisting :: FileTest +isExisting = doesExist + +--------------- +-- Type of file +--------------- + +-- | True if file is a directory. +-- +-- Like @test -d file@ +isDir :: FileTest +isDir = withStatus Files.isDirectory + +-- | True if file is a regular file. +-- +-- Like coreutil @test -f file@ +isFile :: FileTest +isFile = withStatus Files.isRegularFile + +-- NOTE: On Windows true if FILE_ATTRIBUTE_REPARSE_POINT is set. + +-- | True if path is a symbolic link. This is meaningful only when 'testl' is +-- used, in case of 'test' it always returns false. +-- +-- Like coreutil @test -h/-L file@ +isSymLink :: FileTest +isSymLink = withStatus Files.isSymbolicLink + +-- Note: Device files are supported in Windows/NTFS. + +-- | True if file is a block special file. +-- +-- Like the coreutil @test -b file@. +-- +-- Always false on Windows. +-- +isBlockDevice :: FileTest +isBlockDevice = withStatus Files.isBlockDevice + +-- | True if is a character special file. +-- +-- Like @test -c file@. +-- +-- Always false on Windows. +-- +isCharDevice :: FileTest +isCharDevice = withStatus Files.isCharacterDevice + +-- Note: Named pipes are supported in Windows/NTFS. + +-- | True if file is a named pipe (FIFO). +-- +-- Like coreutil @test -p file@. +-- +-- Always false on Windows. +-- +isPipe :: FileTest +isPipe = withStatus Files.isNamedPipe + +-- | True if file is a socket. +-- +-- Like coreutil @test -S file@. +-- +-- Always false on Windows. +-- +isSocket :: FileTest +isSocket = withStatus Files.isSocket + +--------------- +-- Permissions +--------------- + +-- | True if the file has specified permission mode. +-- +{-# INLINE hasMode #-} +hasMode :: FileMode -> FileTest +hasMode mode = withStatus (\st -> (Files.fileMode st .&. mode) == mode) + +-- | True if the owner (u) has read (r) permission. +-- +hasOwnerRead :: FileTest +hasOwnerRead = hasMode Files.ownerReadMode + +-- | True if the owner (u) has write (w) permission. +-- +hasOwnerWrite :: FileTest +hasOwnerWrite = hasMode Files.ownerWriteMode + +-- | True if the owner (u) has execute (x) permission. +-- +hasOwnerExec :: FileTest +hasOwnerExec = hasMode Files.ownerExecuteMode + +-- | True if the group (g) has read (r) permission. +-- +hasGroupRead :: FileTest +hasGroupRead = hasMode Files.groupReadMode + +-- | True if the group (g) has write (w) permission. +-- +hasGroupWrite :: FileTest +hasGroupWrite = hasMode Files.groupWriteMode + +-- | True if the group (g) has execute (x) permission. +-- +hasGroupExec :: FileTest +hasGroupExec = hasMode Files.groupExecuteMode + +-- | True if others (o) have read (r) permission. +-- +hasOtherRead :: FileTest +hasOtherRead = hasMode Files.otherReadMode + +-- | True if others (o) have write (w) permission. +-- +hasOtherWrite :: FileTest +hasOtherWrite = hasMode Files.otherWriteMode + +-- | True if others (o) have execute (x) permission. +-- +hasOtherExec :: FileTest +hasOtherExec = hasMode Files.otherExecuteMode + +-- | True if the file has set user ID flag is set. +-- +-- Like coreutil @test -u file@ +-- +-- Always false on Windows. +-- +hasSetUid :: FileTest +hasSetUid = hasMode Files.setUserIDMode + +-- | True if the file has set group ID flag is set. +-- +-- Like coreutil @test -g file@ +-- +-- Always false on Windows. +-- +hasSetGid :: FileTest +hasSetGid = hasMode Files.setGroupIDMode + +-- | True if file has sticky bit is set. +-- +-- Like coreutil @test -k file@ +-- +-- Always false on Windows. +-- +-- /Unimplemented/ +hasStickyBit :: FileTest +hasStickyBit = undefined + +----------------------------------- +-- Time +----------------------------------- + +-- XXX Use the streamly time module with improvements + +-- NOTES: NominalDiffTime is actually time duration in seconds possibly +-- fractional. In contrast to DiffTime it ignores the leap seconds, so it is +-- the actual elapsed time duration. A more specific and intuitive name for +-- this would be NominalDiffSeconds or Duration or simply Seconds. +-- +-- We could use (Integer -> NominalDiffTime) in the APIs below and that would +-- disallow nesting of units e.g. (seconds (minutes 5)). But that is unlikely +-- error and NominalDiffTime allows fractional seconds which is a good thing. + +-- | Time duration in seconds. +-- +-- >>> modifiedOlderThan (seconds 30) +-- +seconds :: NominalDiffTime -> NominalDiffTime +seconds = id + +-- | Time duration in minutes. +-- +-- >>> modifiedWithin (minutes 5) +-- +minutes :: NominalDiffTime -> NominalDiffTime +minutes n = n * 60 + +-- | Time duration in hours. +hours :: NominalDiffTime -> NominalDiffTime +hours n = n * 3600 + +-- | Time duration in days. +-- +-- >>> accessedOlderThan (days 1) +-- +days :: NominalDiffTime -> NominalDiffTime +days n = n * 86400 + +----------------------------------- +-- Comparing times +----------------------------------- + +timeSatisfiesWith :: + (FileStatus -> POSIXTime) -> (POSIXTime -> Bool) -> FileTest +timeSatisfiesWith getFileTime p = withStatus (p . getFileTime) + +-- | True if the modification time satisfies the supplied predicate. +-- +-- Modification time (@mtime@) records when the file contents (not the +-- metadata) were last written or file size was changed. Writing metadata (e.g. +-- via @chmod@) does not update the modification time. +-- +modifyTime :: (POSIXTime -> Bool) -> FileTest +modifyTime = timeSatisfiesWith Files.modificationTimeHiRes + +-- | True if the metadata change time satisfies the supplied predicate. +-- +-- Metadata change time (@ctime@) records when the file metadata last changed. +-- This includes operations such as permission or ownership changes, renames, +-- link count changes, or timestamp updates. Modifying the file contents or +-- changing its size also updates @ctime@. +-- +-- Typical timestamp effects: +-- +-- * reading file data (@atime@) +-- * writing or truncating file data (@mtime@, @ctime@) +-- * permission or ownership changes; @chmod@, @chown@ (@ctime@) +-- * link/unlink or rename operations; @ln@, @mv@ (@ctime@) +-- * attribute or ACL changes (@ctime@) +-- +-- Reading metadata (e.g. via @stat@) does not change any timestamps. +-- +metadataChangeTime :: (POSIXTime -> Bool) -> FileTest +metadataChangeTime = timeSatisfiesWith Files.statusChangeTimeHiRes + +-- | True if the access time satisfies the supplied predicate. +-- +-- Access time (@atime@) records when the file data was last read. +-- Reading metadata (e.g. via @stat@) does not update the access time. +-- +-- >>> accessTime (< someTime) +-- +-- Many systems avoid updating access time on every read for performance +-- reasons. +-- +-- Common strategies include: +-- +-- * @noatime@ — never update atime; default on windows. +-- * @relatime@ — update atime only if it is earlier than the modification +-- time or sufficiently old; default on Linux and macOS. +-- * @strictatime@ — update atime on every read (traditional POSIX behavior). +-- +accessTime :: (POSIXTime -> Bool) -> FileTest +accessTime = timeSatisfiesWith Files.accessTimeHiRes + +-- | True if the file was modified at or before the given timestamp. +-- +-- >>> modifiedBefore t = modifyTime (<= t) +-- +-- Equivalent to coreutil @test file1 -ot file2@. +modifiedBefore :: POSIXTime -> FileTest +modifiedBefore t = modifyTime (<= t) + +-- | True if the file was modified at or after the given timestamp. +-- +-- >>> modifiedAfter t = modifyTime (>= t) +-- +-- Equivalent to coreutil @test file1 -nt file2@. +modifiedAfter :: POSIXTime -> FileTest +modifiedAfter t = modifyTime (>= t) + +-- XXX Use Path instead of filepath. +-- +-- NOTE: The specified file path is always dereferenced. Time comparison of +-- symlinks is rare, not provided here. + +timeComparedToWith :: + (FileStatus -> POSIXTime) + -> FilePath + -> (POSIXTime -> POSIXTime -> Bool) + -> FileTest +timeComparedToWith getFileTime path cmp = + withStatusM $ \st -> do + st1 <- Files.getFileStatus path + pure $ cmp (getFileTime st) (getFileTime st1) + +-- | Compare the modification time of the file with the modification time of +-- another file. +-- +-- If specified file path is a symlink it is dereferenced. +-- +modifyTimeComparedTo :: + FilePath -> (POSIXTime -> POSIXTime -> Bool) -> FileTest +modifyTimeComparedTo = timeComparedToWith Files.modificationTimeHiRes + +-- | True if the file was modified strictly before the reference file. +-- +-- >>> olderThanFile path = modifyTimeComparedTo path (<) +-- +-- If specified file path is a symlink it is dereferenced. +-- +olderThanFile :: FilePath -> FileTest +olderThanFile path = modifyTimeComparedTo path (<) + +-- | True if the file was modified strictly after the reference file. +-- +-- >>> newerThanFile path = modifyTimeComparedTo path (>) +-- +-- If specified file path is a symlink it is dereferenced. +-- +newerThanFile :: FilePath -> FileTest +newerThanFile path = modifyTimeComparedTo path (>) + +-- | Compare the access time of the file with the access time of +-- another file. +-- +-- If specified file path is a symlink it is dereferenced. +accessTimeComparedTo :: + FilePath -> (POSIXTime -> POSIXTime -> Bool) -> FileTest +accessTimeComparedTo = timeComparedToWith Files.accessTimeHiRes + +-- | True if the file was accessed strictly before the reference file. +-- +-- >>> accessedBeforeFile path = accessTimeComparedTo path (<) +-- +-- If specified file path is a symlink it is dereferenced. +accessedBeforeFile :: FilePath -> FileTest +accessedBeforeFile path = accessTimeComparedTo path (<) + +-- | True if the file was accessed __strictly__ after the reference file. +-- +-- >>> accessedAfterFile path = accessTimeComparedTo path (>) +-- +-- If specified file path is a symlink it is dereferenced. +accessedAfterFile :: FilePath -> FileTest +accessedAfterFile path = accessTimeComparedTo path (>) + +----------------------------------- +-- Comparing age with other files +----------------------------------- + +getLocalTime :: IO TimeSpec +getLocalTime = fromAbsTime <$> getTime Realtime + +timeSpecToPOSIX :: TimeSpec -> POSIXTime +timeSpecToPOSIX (TimeSpec s ns) = + fromIntegral s + fromIntegral ns / 1_000_000_000 + +ageOfWith :: (FileStatus -> POSIXTime) -> FileStatus -> IO NominalDiffTime +ageOfWith getFileTime st = do + now <- timeSpecToPOSIX <$> getLocalTime + pure (now - getFileTime st) + +ageSatisfiesWith + :: (FileStatus -> POSIXTime) + -> (NominalDiffTime -> Bool) + -> FileTest +ageSatisfiesWith getFileTime p = + withStatusM $ \st -> p <$> ageOfWith getFileTime st + +-- | True if the access age of the file satisfies the supplied predicate. +-- +-- >>> accessAge (> minutes 10) +-- +-- Common predicates can be expressed using 'accessAge': +-- +-- >>> accessedWithin age = accessAge (<= age) +-- >>> accessedOlderThan age = accessAge (> age) +-- +accessAge :: (NominalDiffTime -> Bool) -> FileTest +accessAge = ageSatisfiesWith Files.accessTimeHiRes + +-- | True if the file was accessed within the given duration. +-- +-- >>> accessedWithin (minutes 5) +-- +-- Definition: +-- +-- >>> accessedWithin age = accessAge (<= age) +-- +-- Note: @not_ (accessedWithin age)@ is equivalent to +-- @accessedOlderThan age@. +-- +accessedWithin :: NominalDiffTime -> FileTest +accessedWithin age = accessAge (<= age) + +-- | True if the file was accessed __strictly__ older than the given duration. +-- +-- >>> accessedOlderThan (minutes 5) +-- +-- Definition: +-- +-- >>> accessedOlderThan age = accessAge (> age) +-- +-- This is equivalent to: +-- +-- >>> accessedOlderThan age = not_ (accessedWithin age) +-- +accessedOlderThan :: NominalDiffTime -> FileTest +accessedOlderThan age = accessAge (> age) + +-- | True if the modification age of the file satisfies the supplied predicate. +-- +-- >>> modifyAge (> minutes 10) +-- +-- Common predicates can be expressed using 'modifyAge': +-- +-- >>> modifiedWithin age = modifyAge (<= age) +-- >>> modifiedOlderThan age = modifyAge (> age) +-- +modifyAge :: (NominalDiffTime -> Bool) -> FileTest +modifyAge = ageSatisfiesWith Files.modificationTimeHiRes + +-- | True if the file was modified within the given duration. +-- +-- >>> modifiedWithin (minutes 5) +-- +-- Definition: +-- +-- >>> modifiedWithin age = modifyAge (<= age) +-- +-- Other predicates: +-- +-- >>> modifiedOlderThan age = not_ (modifiedWithin age) +-- +modifiedWithin :: NominalDiffTime -> FileTest +modifiedWithin age = modifyAge (<= age) + +-- | True if the file was modified __strictly__ older than the given duration. +-- +-- >>> modifiedOlderThan (minutes 5) +-- +-- Definition: +-- +-- >>> modifiedOlderThan age = modifyAge (> age) +-- +-- This is equivalent to: +-- +-- >>> modifiedOlderThan age = not_ (modifiedWithin age) +-- +modifiedOlderThan :: NominalDiffTime -> FileTest +modifiedOlderThan age = modifyAge (> age) + +-- | True if the file has been modified since it was last accessed. +-- +-- Equivalent to GNU @test -N file@. +-- +-- This checks whether the modification time is later than the access time. +-- +-- >>> test "file.txt" modifiedSinceLastAccess +modifiedSinceLastAccess :: FileTest +modifiedSinceLastAccess = + withStatus $ \st -> + Files.modificationTimeHiRes st > Files.accessTimeHiRes st + +{- +-- Posix does not have a create time. Posix ctime is metadata change time and +-- not creation time. Windows does have file creation time we can keep +-- createAge in Windows specific module. +-- +-- See https://unix.stackexchange.com/questions/91197/how-to-find-creation-date-of-file +createAge :: (NominalDiffTime -> Bool) -> FileTest +createAge = undefined +-} + +-- | True if the metadata age of the file satisfies the supplied predicate. +-- +-- >>> metadataAge (> minutes 10) +-- +-- The metadata age is the duration since the file's metadata last changed. +-- +metadataAge :: (NominalDiffTime -> Bool) -> FileTest +metadataAge = ageSatisfiesWith Files.statusChangeTimeHiRes + +----------------------------------- +-- Absolute size +-- Comparing size with other files +----------------------------------- + +-- XXX Should use Int or Int64? + +getSize :: FileStatus -> Int64 +getSize st = let COff sz = Files.fileSize st in sz + +-- | True if the file size satisfies the supplied predicate. +-- +-- >>> size (> 1024) +-- +-- Common predicates can be expressed using 'size': +-- +-- >>> largerThan n = size (> n) +-- >>> smallerThan n = size (< n) +-- >>> sizeEquals n = size (== n) +-- >>> sizeNonZero = size (> 0) +-- +-- Note: For directories, the reported size reflects filesystem metadata and +-- does not indicate the number of entries in the directory. An empty +-- 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)) + +-- | True if file size is strictly greater than the given size in bytes. +-- +-- >>> largerThan n = size (> n) +-- +largerThan :: Int64 -> FileTest +largerThan n = size (> n) + +-- | True if file size is strictly less than the given size in bytes. +-- +-- >>> smallerThan n = size (< n) +-- +smallerThan :: Int64 -> FileTest +smallerThan n = size (< n) + +-- | True if file size is exactly equal to the given size in bytes. +-- +-- >>> sizeEquals n = size (== n) +-- +sizeEquals :: Int64 -> FileTest +sizeEquals n = size (== n) + +-- | True if file is non-empty. Note that this may not be reliable for +-- directories, on Posix directories it will always be true because of \".\" +-- and \"..\" entries. +-- +-- Like coreutil @test -s file@ +-- +sizeNonZero :: FileTest +sizeNonZero = size (> 0) + +-- | True if the path refers to a regular file whose size is greater than zero. +-- +isNonEmptyFile :: FileTest +isNonEmptyFile = and_ isFile (size (> 0)) + +----------------------------------- +-- Comparing size with other files +----------------------------------- + +-- NOTE: The specified file path is always dereferenced. Size comparison of +-- symlinks is rare, not provided here. + +-- | Compare the file size with the size of another file using the supplied +-- comparison function. If specified file path is a symlink it is dereferenced. +-- +-- The first argument of the comparison function is the size of the file being +-- tested and the second argument is the size of the reference file. +-- +-- Common predicates can be defined using 'sizeComparedTo': +-- +-- >>> largerThanFile path = sizeComparedTo path (>) +-- >>> smallerThanFile path = sizeComparedTo path (<) +-- >>> sameSizeAs path = sizeComparedTo path (==) +-- +-- If the supplied file path is a symlink it is dereferenced. +sizeComparedTo :: FilePath -> (Int64 -> Int64 -> Bool) -> FileTest +sizeComparedTo path rel = + withStatusM $ \st -> do + st1 <- Files.getFileStatus path + pure $ rel (getSize st) (getSize st1) + +-- | True if the file is __strictly__ larger than the given file. If specified +-- file path is a symlink it is dereferenced. +-- +-- Definition: +-- +-- >>> largerThanFile path = sizeComparedTo path (>) +-- +largerThanFile :: FilePath -> FileTest +largerThanFile path = sizeComparedTo path (>) + +-- | True if the file is __strictly__ smaller than the given file. If specified +-- file path is a symlink it is dereferenced. +-- +-- Definition: +-- +-- >>> smallerThanFile path = sizeComparedTo path (<) +-- +smallerThanFile :: FilePath -> FileTest +smallerThanFile path = sizeComparedTo path (<) + +-- | True if the file has the same size as the given file. If specified file +-- path is a symlink it is dereferenced. +-- +-- Definition: +-- +-- >>> sameSizeAs path = sizeComparedTo path (==) +-- +sameSizeAs :: FilePath -> FileTest +sameSizeAs path = sizeComparedTo path (==) diff --git a/src/Streamly/Coreutils/FileTest/Posix.hs b/src/Streamly/Coreutils/FileTest/Posix.hs new file mode 100644 index 0000000..f5979c2 --- /dev/null +++ b/src/Streamly/Coreutils/FileTest/Posix.hs @@ -0,0 +1,125 @@ +-- | +-- Module : Streamly.Coreutils.FileTest.Posix +-- Copyright : (c) 2021 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- See "Streamly.Coreutils.FileTest" module for general module level +-- documentation. This is a posix specific version of +-- "Streamly.Coreutils.FileTest" with some additional posix specific functions. + +module Streamly.Coreutils.FileTest.Posix + ( testFd + , testHandle + , sameFileAs + , isTerminalFd + , isReadable + , isWritable + , isExecutable + , isOwnedByCurrentUser + , isOwnedByCurrentGroup + , Uid + , Gid + , isOwnedByUserId + , isOwnedByGroupId + ) +where + +import System.IO (Handle) +import System.Posix.Types (Fd, GroupID, UserID) +import qualified System.Posix.Files as Posix +import qualified System.PosixCompat.Files as Files +import qualified System.Posix.User as User +import qualified System.Posix.Terminal as Terminal + +import Streamly.Coreutils.FileTest.Common + +-- XXX 'getFdStatus' is not implemented for Windows in unix-compat. + +-- XXX The 'FileStatus' is fetched eagerly before constructing the 'FileState' +-- because the file descriptor may be closed by the time a lazy fetch would +-- occur. Instead we can wrap this in an exception handler. + +-- | Like 'test' but uses a file descriptor instead of a file path. +-- +testFd :: Fd -> FileTest -> IO Bool +testFd fd (FileTest (Predicate f)) = + -- XXX We should pass "Either Fd FilePath" in state. + let fp = error $ "FileTest.testFd: filepath cannot be used" + in Files.getFdStatus fd >>= mkFileState "FileTest.testFd" fp >>= f + +testHandle :: Handle -> FileTest -> IO Bool +testHandle = undefined + +-- | True if file1 and file2 exist and have the same device id and inode. +-- +-- Like coreutil @test file1 -ef file2@. +-- +-- The supplied file path is dereferenced if it is a symlink. +-- +sameFileAs :: FilePath -> FileTest +sameFileAs path = + withStatusM $ \st -> do + st1 <- Files.getFileStatus path + pure $ + Files.deviceID st == Files.deviceID st1 && + Files.fileID st == Files.fileID st1 + +-- XXX Need to pass the Fd in the state. + +-- | True if the supplied file descriptor refers to a terminal device. +-- +-- Equivalent to the POSIX @isatty@ check and the shell command +-- @test -t fd@. +isTerminalFd :: Fd -> FileTest +isTerminalFd fd = + withPathM $ \_ -> + Terminal.queryTerminal fd + +-- XXX large Int may get truncated to some valid id. +-- XXX Need a protable "Uid" (unix CUid or windows SID) to expose hasUid. +-- Also portable ways to get effective user id of the process. +newtype Uid = Uid UserID +newtype Gid = Gid GroupID + +isOwnedByUserId :: Uid -> FileTest +isOwnedByUserId (Uid uid) = withStatus $ \st -> Files.fileOwner st == uid + +isOwnedByGroupId :: Gid -> FileTest +isOwnedByGroupId (Gid gid) = withStatus $ \st -> Files.fileGroup st == gid + +isOwnedByCurrentUser :: FileTest +isOwnedByCurrentUser = + withStatusM $ \st -> (Files.fileOwner st ==) <$> User.getEffectiveUserID + +isOwnedByCurrentGroup :: FileTest +isOwnedByCurrentGroup = + withStatusM $ \st -> (Files.fileGroup st ==) <$> User.getEffectiveGroupID + +-- The coreutil "test" utility checks for acls as well. +-- +-- touch x +-- chmod -rwx x +-- setfacl -m u:harendra:r x +-- getfacl x +-- test -r x || echo "not readable" + +pathIsReadable :: FilePath -> IO Bool +pathIsReadable path = Posix.fileAccess path True False False + +isReadable :: FileTest +isReadable = withPathM pathIsReadable + +pathIsWritable :: FilePath -> IO Bool +pathIsWritable path = Posix.fileAccess path False True False + +isWritable :: FileTest +isWritable = withPathM pathIsWritable + +pathIsExecutable :: FilePath -> IO Bool +pathIsExecutable path = Posix.fileAccess path False False True + +isExecutable :: FileTest +isExecutable = withPathM pathIsExecutable diff --git a/src/Streamly/Coreutils/FileTest/Windows.hsc b/src/Streamly/Coreutils/FileTest/Windows.hsc new file mode 100644 index 0000000..d2ae79d --- /dev/null +++ b/src/Streamly/Coreutils/FileTest/Windows.hsc @@ -0,0 +1,577 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Streamly.Coreutils.Filetest.Windows + ( Uid + , Gid + , sameFileAs + , isTerminalFd + {- + , isOwnedByUserId + , isOwnedByGroupId + -} + , isOwnedByCurrentUser + -- , isOwnedByCurrentGroup + + , isReadableNow + , isWritableNow + , isExecutableNow + + , isReadable + , isWritable + , isExecutable + ) where + +import Control.Exception + ( AsyncException + , SomeException + , bracket + , catch + , fromException + , throwIO + ) + +import Data.Bits (shiftL, (.|.)) +import Data.Word (Word64) +import Foreign.C.Types (CInt(..)) +import Foreign.Ptr (nullPtr) +import System.IO.Error (IOException) +import System.PosixCompat.Files (FileStatus) +import System.Posix.Types (Fd(..), ownerWriteMode) +import System.Win32.Console (getConsoleMode) + +import System.Win32.File + ( .. + , getFileInformationByHandle + , bhfiVolumeSerialNumber + , bhfiFileIndexHigh + , bhfiFileIndexLow + , BY_HANDLE_FILE_INFORMATION(..) + ) +import System.Win32.File (fILE_TYPE_CHAR, getFileType) +import System.Win32.File + ( closeHandle + , createFile + , fILE_ADD_FILE + , fILE_EXECUTE + , fILE_FLAG_BACKUP_SEMANTICS + , fILE_READ_DATA + , fILE_SHARE_DELETE + , fILE_SHARE_READ + , fILE_SHARE_WRITE + , fILE_WRITE_DATA + , gENERIC_ALL + , gENERIC_EXECUTE + , gENERIC_READ + , gENERIC_WRITE + , oPEN_EXISTING + ) +import System.Win32.Security + ( PSID + , SID + , dACL_SECURITY_INFORMATION + , oWNER_SECURITY_INFORMATION + ) +import System.Win32.Types + ( BOOL + , DWORD + , HANDLE + , LPDWORD + , failIfFalse_ + , iNVALID_HANDLE_VALUE + , withFilePath + ) + +import qualified System.Win32.Types as Win32 + +import Foreign +import Streamly.Coreutils.FileTest.Common + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | Wraps a Windows SID pointer representing a user identity. +newtype Uid = Uid PSID +-- | Wraps a Windows SID pointer representing a group identity. +newtype Gid = Gid PSID + +{- +isOwnedByUserId :: Uid -> FileTest +isOwnedByUserId (Uid uid) = withPathM $ \fp -> undefined + +isOwnedByGroupId :: Gid -> FileTest +isOwnedByGroupId (Gid gid) = withPathM $ \fp -> undefined +-} + +------------------------------------------------------------------------------- +-- Raw FFI declarations +-- +-- These are all bindings not exposed by the Win32 package. +------------------------------------------------------------------------------- + +##include "windows_cconv.h" + +foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentProcess" + c_GetCurrentProcess :: IO HANDLE + +foreign import WINDOWS_CCONV unsafe "windows.h OpenProcessToken" + c_OpenProcessToken + :: HANDLE -- ProcessHandle + -> DWORD -- DesiredAccess + -> Ptr HANDLE + -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetTokenInformation" + c_GetTokenInformation + :: HANDLE -- TokenHandle + -> DWORD -- TokenInformationClass + -> Ptr () -- TokenInformation + -> DWORD -- TokenInformationLength + -> LPDWORD -- ReturnLength + -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h DuplicateToken" + c_DuplicateToken + :: HANDLE -- ExistingTokenHandle + -> DWORD -- ImpersonationLevel (SECURITY_IMPERSONATION_LEVEL) + -> Ptr HANDLE -- DuplicateTokenHandle + -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle" + c_CloseHandle :: HANDLE -> IO BOOL + +-- GetFileSecurityW is used directly so we can work with the raw +-- PSECURITY_DESCRIPTOR (Ptr ()) rather than the opaque SecurityDescriptor +-- newtype returned by getFileSecurity. +foreign import WINDOWS_CCONV unsafe "windows.h GetFileSecurityW" + c_GetFileSecurity + :: Win32.LPCWSTR -- lpFileName + -> DWORD -- RequestedInformation (SECURITY_INFORMATION) + -> Ptr () -- pSecurityDescriptor + -> DWORD -- nLength + -> LPDWORD -- lpnLengthNeeded + -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorOwner" + c_GetSecurityDescriptorOwner + :: Ptr () -- pSecurityDescriptor + -> Ptr PSID -- pOwner + -> Ptr BOOL -- lpbOwnerDefaulted + -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h EqualSid" + c_EqualSid :: PSID -> PSID -> IO BOOL + +-- In aclapi.h, linked via -ladvapi32 (same as other security calls) +foreign import WINDOWS_CCONV unsafe "aclapi.h GetNamedSecurityInfoW" + c_GetNamedSecurityInfo + :: Win32.LPWSTR -- pObjectName + -> DWORD -- ObjectType (SE_OBJECT_TYPE) + -> DWORD -- SecurityInfo + -> Ptr PSID -- ppsidOwner (out, optional) + -> Ptr PSID -- ppsidGroup (out, optional) + -> Ptr (Ptr ()) -- ppDacl (out, optional) + -> Ptr (Ptr ()) -- ppSacl (out, optional) + -> Ptr (Ptr ()) -- ppSecurityDescriptor (out) + -> IO DWORD -- ERROR_SUCCESS (0) on success + +foreign import WINDOWS_CCONV unsafe "windows.h LocalFree" + c_LocalFree :: Ptr () -> IO (Ptr ()) + +foreign import WINDOWS_CCONV unsafe "windows.h AccessCheck" + c_AccessCheck + :: Ptr () -- pSecurityDescriptor + -> HANDLE -- ClientToken (must be impersonation token) + -> DWORD -- DesiredAccess + -> Ptr GENERIC_MAPPING + -> Ptr () -- PrivilegeSet (out) + -> LPDWORD -- PrivilegeSetLength (in/out) + -> LPDWORD -- GrantedAccess (out) + -> Ptr BOOL -- AccessStatus (out) + -> IO BOOL + +------------------------------------------------------------------------------- +-- Constants not exported by Win32 +------------------------------------------------------------------------------- + +-- TOKEN_QUERY (0x0008) is not re-exported, define locally +tOKEN_QUERY :: DWORD +tOKEN_QUERY = 0x0008 + +-- TokenUser = 1 in the TOKEN_INFORMATION_CLASS enum +tOKEN_USER :: DWORD +tOKEN_USER = 1 + +-- SecurityImpersonation = 2 in SECURITY_IMPERSONATION_LEVEL +sECURITY_IMPERSONATION :: DWORD +sECURITY_IMPERSONATION = 2 + +-- SE_FILE_OBJECT = 1 in SE_OBJECT_TYPE enum +sE_FILE_OBJECT :: DWORD +sE_FILE_OBJECT = 1 + +-- FILE_GENERIC_* are composites not exported by Win32; values from WinNT.h +fILE_GENERIC_READ :: DWORD +fILE_GENERIC_READ = 0x00120089 + +fILE_GENERIC_WRITE :: DWORD +fILE_GENERIC_WRITE = 0x00120116 + +fILE_GENERIC_EXECUTE :: DWORD +fILE_GENERIC_EXECUTE = 0x001200A0 + +------------------------------------------------------------------------------- +-- GENERIC_MAPPING storable struct +------------------------------------------------------------------------------- + +-- GENERIC_MAPPING { GenericRead, GenericWrite, GenericExecute, GenericAll } +data GENERIC_MAPPING = GENERIC_MAPPING DWORD DWORD DWORD DWORD + +instance Storable GENERIC_MAPPING where + sizeOf _ = 4 * sizeOf (undefined :: DWORD) + alignment _ = alignment (undefined :: DWORD) + peek p = GENERIC_MAPPING + <$> peekByteOff p 0 + <*> peekByteOff p 4 + <*> peekByteOff p 8 + <*> peekByteOff p 12 + poke p (GENERIC_MAPPING r w e a) = do + pokeByteOff p 0 r + pokeByteOff p 4 w + pokeByteOff p 8 e + pokeByteOff p 12 a + +------------------------------------------------------------------------------- +-- Same file +------------------------------------------------------------------------------- + +-- | Open a file handle suitable for metadata queries. +-- Uses fILE_FLAG_BACKUP_SEMANTICS so that directories can be opened too. +-- Uses 0 for desired access since only metadata is needed; this succeeds +-- even when data-read access is restricted. +withFileHandle :: FilePath -> (HANDLE -> IO a) -> IO a +withFileHandle path action = + bracket + (createFile path 0 + (fILE_SHARE_READ .|. fILE_SHARE_WRITE .|. fILE_SHARE_DELETE) + Nothing + oPEN_EXISTING + fILE_FLAG_BACKUP_SEMANTICS + Nothing) + closeHandle + action + +-- | Return a (volumeSerialNumber, fileIndex) pair that uniquely identifies +-- a file on the local system, following the same-inode logic as POSIX. +fileId :: FilePath -> IO (DWORD, Word64) +fileId path = + withFileHandle path $ \h -> do + info <- getFileInformationByHandle h + let vol = bhfiVolumeSerialNumber info + high = fromIntegral (bhfiFileIndexHigh info) :: Word64 + low = fromIntegral (bhfiFileIndexLow info) :: Word64 + idx = (high `shiftL` 32) .|. low + pure (vol, idx) + +-- | True if both paths refer to the same underlying file or directory, +-- equivalent to POSIX inode comparison. +sameFileAs :: FilePath -> FileTest +sameFileAs path2 = + withPathM $ \path1 -> do + id1 <- fileId path1 + id2 <- fileId path2 + pure (id1 == id2) + +------------------------------------------------------------------------------- +-- Terminal +------------------------------------------------------------------------------- + +-- | Convert a CRT file descriptor to a Windows HANDLE. +-- Returns -1 (cast to HANDLE) on error, per CRT documentation. +foreign import ccall unsafe "_get_osfhandle" + c_get_osfhandle :: CInt -> IO HANDLE + +-- | Returns True only if GetConsoleMode succeeds on the handle, +-- which is the Windows-canonical way to test for a console. +isConsoleHandle :: HANDLE -> IO Bool +isConsoleHandle h = + (getConsoleMode h >> pure True) + `catch` \(_ :: IOError) -> pure False + +-- | True if the fd is connected to a console (terminal). +-- Mirrors the behaviour of POSIX @test -t@: +-- 1. fd must be a valid Windows HANDLE +-- 2. The handle's file type must be FILE_TYPE_CHAR +-- 3. GetConsoleMode must succeed — this distinguishes real console +-- handles from other character devices (serial ports, NUL, etc.) +isTerminalFd :: Fd -> FileTest +isTerminalFd (Fd fd) = + withPathM $ \_ -> do + h <- c_get_osfhandle (fromIntegral fd) + if h == iNVALID_HANDLE_VALUE + then pure False + else do + t <- getFileType h + if t /= fILE_TYPE_CHAR + then pure False + else isConsoleHandle h + +------------------------------------------------------------------------------- +-- withFileOwnerSID +------------------------------------------------------------------------------- + +-- We bind c_GetFileSecurity directly (as Ptr ()) rather than using +-- getFileSecurity, whose SecurityDescriptor newtype is opaque and +-- incompatible with c_GetSecurityDescriptorOwner. +withFileOwnerSID :: FilePath -> (PSID -> IO a) -> IO a +withFileOwnerSID path action = + withFilePath path $ \pPath -> + alloca $ \pLenNeeded -> do + -- First call: get required buffer size + _ <- c_GetFileSecurity + pPath oWNER_SECURITY_INFORMATION nullPtr 0 pLenNeeded + needed <- peek pLenNeeded + allocaBytes (fromIntegral needed) $ \pSd -> do + failIfFalse_ "GetFileSecurityW" $ + c_GetFileSecurity + pPath oWNER_SECURITY_INFORMATION pSd needed pLenNeeded + alloca $ \ppSid -> + alloca $ \pDefaulted -> do + failIfFalse_ "GetSecurityDescriptorOwner" $ + c_GetSecurityDescriptorOwner pSd ppSid pDefaulted + sid <- peek ppSid + action sid + +------------------------------------------------------------------------------- +-- withEffectiveUserSID +------------------------------------------------------------------------------- + +withEffectiveUserSID :: (PSID -> IO a) -> IO a +withEffectiveUserSID action = do + proc <- c_GetCurrentProcess + alloca $ \pToken -> do + failIfFalse_ "OpenProcessToken" $ + c_OpenProcessToken proc tOKEN_QUERY pToken + token <- peek pToken + bracket (return token) (\h -> c_CloseHandle h >> return ()) $ \h -> + alloca $ \pRetLen -> do + -- First call is expected to fail; returns the required size. + _ <- c_GetTokenInformation h tOKEN_USER nullPtr 0 pRetLen + retLen <- peek pRetLen + allocaBytes (fromIntegral retLen) $ \buf -> do + failIfFalse_ "GetTokenInformation" $ + c_GetTokenInformation + h tOKEN_USER buf retLen pRetLen + -- TOKEN_USER layout: + -- { SID_AND_ATTRIBUTES { PSID Sid; DWORD Attributes } } + -- First field is the PSID pointer. + sid <- peek (castPtr buf :: Ptr PSID) + action sid + +------------------------------------------------------------------------------- +-- Ownership +------------------------------------------------------------------------------- + +isPathOwnedByCurrentUser :: FilePath -> IO Bool +isPathOwnedByCurrentUser path = + withFileOwnerSID path $ \fileSid -> + withEffectiveUserSID $ \userSid -> + (/= 0) <$> c_EqualSid fileSid userSid + +isOwnedByCurrentUser :: FileTest +isOwnedByCurrentUser = withPathM isPathOwnedByCurrentUser + +{- +withFilePrimaryGroupSID = undefined +withEffectiveGroupSID = undefined + +isPathOwnedByCurrentGroup :: FilePath -> IO Bool +isPathOwnedByCurrentGroup path = + withFilePrimaryGroupSID path $ \fileSid -> + withEffectiveGroupSID $ \userSid -> + (/= 0) <$> c_EqualSid fileSid userSid + +isOwnedByCurrentGroup :: FileTest +isOwnedByCurrentGroup = withPathM isPathOwnedByCurrentGroup +-} + +------------------------------------------------------------------------------- +-- File Access including share locks +------------------------------------------------------------------------------- + +-- May return false if file is open and not readable because it is locked +-- using a share mode that denies read. This is something additional on +-- Windows; POSIX does not have a feature where read access is denied due +-- to a file being open. We implement this additional behavior to align +-- with the goal that a readability check tells us whether we can read +-- the file at this moment. + +-- | True if the file is readable by the current process. +-- +-- Returns false if the file is locked and not shared for reading. +-- +isPathReadableNow :: FilePath -> IO Bool +isPathReadableNow path = + (do h <- createFile + path fILE_READ_DATA shareMode Nothing oPEN_EXISTING + flags Nothing + closeHandle h + return True + ) `catch` \(_ :: IOException) -> return False + where + shareMode = fILE_SHARE_READ .|. fILE_SHARE_WRITE .|. fILE_SHARE_DELETE + -- Required to open directories + flags = fILE_FLAG_BACKUP_SEMANTICS + +isReadableNow :: FileTest +isReadableNow = withPathM isPathReadableNow + +-- | True if the file is writable by the current process. +-- +-- Returns false if the file is locked and not shared for writing. +-- +isFileWritableNow :: FilePath -> FileStatus -> IO Bool +isFileWritableNow path st = do + isDirectory <- testGeneral path st isDir + -- Under unix-compat on Windows, ownerWriteMode corresponds to the + -- FILE_ATTRIBUTE_READONLY flag being unset. + writable <- testGeneral path st (hasMode ownerWriteMode) + -- The READONLY attribute on directories does not prevent creating + -- files inside the directory. + if not writable && not isDirectory + then return False + else do + let desiredAccess + | isDirectory = fILE_ADD_FILE + | otherwise = fILE_WRITE_DATA + shareMode = + fILE_SHARE_READ + .|. fILE_SHARE_WRITE + .|. fILE_SHARE_DELETE + flags + | isDirectory = fILE_FLAG_BACKUP_SEMANTICS + | otherwise = 0 + bracket + (createFile + path desiredAccess shareMode Nothing oPEN_EXISTING + flags Nothing) + closeHandle + (\_ -> return True) + `catch` (\(_ :: IOException) -> return False) + +isWritableNow :: FileTest +isWritableNow = withStateM isFileWritableNow + +-- | Returns true if file is executable. +-- Returns false if the file is locked and not shared for execution. +isPathExecutableNow :: FilePath -> IO Bool +isPathExecutableNow path = + (do h <- createFile + path fILE_EXECUTE shareMode Nothing oPEN_EXISTING + flags Nothing + closeHandle h + return True + ) `catch` \(_ :: IOException) -> return False + where + shareMode = fILE_SHARE_READ .|. fILE_SHARE_WRITE .|. fILE_SHARE_DELETE + flags = fILE_FLAG_BACKUP_SEMANTICS + +isExecutableNow :: FileTest +isExecutableNow = withPathM isPathExecutableNow + +------------------------------------------------------------------------------- +-- ACL-based checks (POSIX access() equivalent) +------------------------------------------------------------------------------- + +-- | Open an impersonation token for the current process. +-- AccessCheck requires an impersonation token, not a primary token. +openCurrentProcessImpersonationToken :: IO HANDLE +openCurrentProcessImpersonationToken = do + proc <- c_GetCurrentProcess + alloca $ \pToken -> do + failIfFalse_ "OpenProcessToken" $ + c_OpenProcessToken proc tOKEN_QUERY pToken + primaryToken <- peek pToken + bracket + (return primaryToken) + (\h -> c_CloseHandle h >> return ()) + $ \pt -> alloca $ \pImpToken -> do + failIfFalse_ "DuplicateToken" $ + c_DuplicateToken pt sECURITY_IMPERSONATION pImpToken + peek pImpToken + +-- | Checks the file's DACL against the current process token for the +-- given access mask. Implements the Windows equivalent of POSIX access(). +pathAccess :: FilePath -> DWORD -> IO Bool +pathAccess path mask = + bracket + openCurrentProcessImpersonationToken + (\h -> c_CloseHandle h >> return ()) + $ \token -> + withFilePath path $ \pPath -> + alloca $ \ppSd -> do + ret <- c_GetNamedSecurityInfo + pPath + sE_FILE_OBJECT + dACL_SECURITY_INFORMATION + nullPtr nullPtr nullPtr nullPtr + ppSd + -- ret is ERROR_SUCCESS (0) on success + if ret /= 0 + then return False + else do + pSd <- peek ppSd + -- pSd allocated by GetNamedSecurityInfo; free with + -- LocalFree. + bracket (return pSd) + (\p -> c_LocalFree p >> return ()) $ \sd -> + with (GENERIC_MAPPING + gENERIC_READ + gENERIC_WRITE + gENERIC_EXECUTE + gENERIC_ALL) + $ \pMapping -> + -- PrivilegeSet: DWORD size + space for at least one + -- LUID_AND_ATTRIBUTES; 64 bytes is more than enough. + allocaBytes 64 $ \pPrivSet -> + alloca $ \pPrivSetLen -> + alloca $ \pGrantedAccess -> + alloca $ \pAccessStatus -> do + poke pPrivSetLen 64 + ok <- c_AccessCheck + sd token mask pMapping + pPrivSet pPrivSetLen + pGrantedAccess pAccessStatus + -- ok == 0 means AccessCheck itself failed + if ok == 0 + then return False + else peek pAccessStatus + `catch` handler + where + handler :: SomeException -> IO Bool + handler e + | Just (_ :: AsyncException) <- fromException e = throwIO e + | otherwise = return False + +-- | Windows equivalent of POSIX: access(path, R_OK). Matches @test -r@. +pathIsReadable :: FilePath -> IO Bool +pathIsReadable path = pathAccess path fILE_GENERIC_READ + +-- | Windows equivalent of POSIX: access(path, W_OK). Matches @test -w@. +pathIsWritable :: FilePath -> IO Bool +pathIsWritable path = pathAccess path fILE_GENERIC_WRITE + +-- | Windows equivalent of POSIX: access(path, X_OK). Matches @test -x@. +pathIsExecutable :: FilePath -> IO Bool +pathIsExecutable path = pathAccess path fILE_GENERIC_EXECUTE + +isReadable :: FileTest +isReadable = withPathM pathIsReadable + +isWritable :: FileTest +isWritable = withPathM pathIsWritable + +isExecutable :: FileTest +isExecutable = withPathM pathIsExecutable diff --git a/src/Streamly/Coreutils/Ln.hs b/src/Streamly/Coreutils/Ln.hs index 0572be7..b7855b3 100644 --- a/src/Streamly/Coreutils/Ln.hs +++ b/src/Streamly/Coreutils/Ln.hs @@ -19,34 +19,33 @@ module Streamly.Coreutils.Ln where import Control.Monad (when) -import Streamly.Coreutils.Common (Switch(..)) -import Streamly.Coreutils.FileTest (test, isExisting) +import Streamly.Coreutils.FileTest (test, doesExist) import qualified System.PosixCompat.Files as Posix data Ln = Ln - { lnForce :: Switch - , lnSymbolic :: Switch + { lnForce :: Bool + , lnSymbolic :: Bool } defaultConfig :: Ln -defaultConfig = Ln Off Off +defaultConfig = Ln False False -force :: Switch -> Ln -> Ln +force :: Bool -> Ln -> Ln force opt cfg = cfg {lnForce = opt} -symbolic :: Switch -> Ln -> Ln +symbolic :: Bool -> Ln -> Ln symbolic opt cfg = cfg {lnSymbolic = opt} ln :: (Ln -> Ln) -> FilePath -> FilePath -> IO () ln f src tgt = do let opt = f defaultConfig - when (lnForce opt == Off) $ do - found <- test tgt isExisting + when (lnForce opt == False) $ do + found <- test tgt doesExist when found $ error msg case lnSymbolic opt of - Off -> Posix.createLink src tgt - On -> Posix.createSymbolicLink src tgt + False -> Posix.createLink src tgt + True -> Posix.createSymbolicLink src tgt where diff --git a/src/Streamly/Coreutils/Ls.hs b/src/Streamly/Coreutils/Ls.hs index 7ce8ce4..6c52726 100644 --- a/src/Streamly/Coreutils/Ls.hs +++ b/src/Streamly/Coreutils/Ls.hs @@ -18,7 +18,6 @@ module Streamly.Coreutils.Ls ) where -import Streamly.Coreutils.Common (Switch(..)) import Streamly.Data.Stream.Prelude (Stream) import Streamly.FileSystem.Path (Path) @@ -29,19 +28,19 @@ import qualified Streamly.Internal.FileSystem.DirIO as Dir -- Note: We can also have options to follow symlinks and other dir traversal -- options once we decide on a good Configuration API. -newtype Ls = Ls {lsRecursive :: Switch} +newtype Ls = Ls {lsRecursive :: Bool} defaultConfig :: Ls -defaultConfig = Ls Off +defaultConfig = Ls False -recursive :: Switch -> Ls -> Ls +recursive :: Bool -> Ls -> Ls recursive opt cfg = cfg {lsRecursive = opt} ls :: (Ls -> Ls) -> Path -> Stream IO (Either Path Path) ls f dir = do case lsRecursive (f defaultConfig) of - Off -> Dir.readEitherPaths id dir - On -> + False -> Dir.readEitherPaths id dir + True -> -- Stream.unfoldIterateDfs unfoldOne -- BFS avoids opening too many file descriptors but may accumulate -- more data in memory. diff --git a/src/Streamly/Coreutils/Mkdir.hs b/src/Streamly/Coreutils/Mkdir.hs index d7b6bf6..c89e6e7 100644 --- a/src/Streamly/Coreutils/Mkdir.hs +++ b/src/Streamly/Coreutils/Mkdir.hs @@ -18,20 +18,19 @@ module Streamly.Coreutils.Mkdir ) where -import Streamly.Coreutils.Common (Switch(..)) import System.Directory (createDirectory, createDirectoryIfMissing) -newtype Mkdir = Mkdir {mdParents :: Switch} +newtype Mkdir = Mkdir {mdParents :: Bool} defaultConfig :: Mkdir -defaultConfig = Mkdir Off +defaultConfig = Mkdir False -parents :: Switch -> Mkdir -> Mkdir +parents :: Bool -> Mkdir -> Mkdir parents opt cfg = cfg {mdParents = opt} mkdir :: (Mkdir -> Mkdir) -> FilePath -> IO () mkdir f = do let opt = f defaultConfig case mdParents opt of - Off -> createDirectory - On -> createDirectoryIfMissing True + False -> createDirectory + True -> createDirectoryIfMissing True diff --git a/src/Streamly/Coreutils/Mv.hs b/src/Streamly/Coreutils/Mv.hs index 31f94e7..48ed641 100644 --- a/src/Streamly/Coreutils/Mv.hs +++ b/src/Streamly/Coreutils/Mv.hs @@ -18,23 +18,22 @@ module Streamly.Coreutils.Mv ) where -import Streamly.Coreutils.Common (Switch(..)) import System.Directory (doesPathExist, renamePath) -newtype Mv = Mv {mvForce :: Switch} +newtype Mv = Mv {mvForce :: Bool} defaultConfig :: Mv -defaultConfig = Mv Off +defaultConfig = Mv False -force :: Switch -> Mv -> Mv +force :: Bool -> Mv -> Mv force opt cfg = cfg {mvForce = opt} mv :: (Mv -> Mv) -> FilePath -> FilePath -> IO () mv f old new = do let opt = f defaultConfig case mvForce opt of - On -> renamePath old new - Off -> do + True -> renamePath old new + False -> do exists <- doesPathExist new if exists then error msg diff --git a/src/Streamly/Coreutils/Rm.hs b/src/Streamly/Coreutils/Rm.hs index fdec3a4..b9c8805 100644 --- a/src/Streamly/Coreutils/Rm.hs +++ b/src/Streamly/Coreutils/Rm.hs @@ -19,8 +19,7 @@ module Streamly.Coreutils.Rm ) where -import Streamly.Coreutils.Common (Switch(..)) -import Streamly.Coreutils.FileTest (isExisting, test, isDir, isWritable) +import Streamly.Coreutils.FileTest (doesExist, test, isDir, isWritableByMode) import System.Directory ( removeFile , removeDirectoryRecursive @@ -44,13 +43,13 @@ data RmForce = data Rm = Rm { rmForce :: RmForce - , rmRecursive :: Switch + , rmRecursive :: Bool } defaultConfig :: Rm defaultConfig = Rm { rmForce = None - , rmRecursive = Off + , rmRecursive = False } -- | Specify the force behavior. See 'RmForce'. @@ -62,16 +61,16 @@ force val cfg = cfg {rmForce = val} -- | Remove recursively when the path is a directory. -- --- Default is 'Off'. +-- Default is 'False'. -- -recursive :: Switch -> Rm -> Rm +recursive :: Bool -> Rm -> Rm recursive sw cfg = cfg {rmRecursive = sw} rmFileWith :: (FilePath -> IO ()) -> Rm -> FilePath -> IO () rmFileWith rmfile options path = do case rmForce options of None -> do - writable <- test path isWritable + writable <- test path isWritableByMode if writable then rmfile path else @@ -86,8 +85,8 @@ rmWith rmdir rmfile options path = do if dir then case rmRecursive options of - Off -> error $ "rm: cannot remove '" ++ path ++ "': is a directory" - On -> rmdir path + False -> error $ "rm: cannot remove '" ++ path ++ "': is a directory" + True -> rmdir path -- XXX Recursive case needs to do the same checks for each file, but in -- that case we rely on the recursive directory removal function which -- might provide different error messages. @@ -98,7 +97,7 @@ rm f path = do let options = f defaultConfig -- Note this test is required not just for existence check but also so that -- we fail if there is no permission to access the path. - found <- test path isExisting + found <- test path doesExist case rmForce options of Nuke -> when found diff --git a/src/Streamly/Coreutils/Stat.hs b/src/Streamly/Coreutils/Stat.hs index c425dac..83d94d6 100644 --- a/src/Streamly/Coreutils/Stat.hs +++ b/src/Streamly/Coreutils/Stat.hs @@ -21,22 +21,21 @@ module Streamly.Coreutils.Stat ) where -import Streamly.Coreutils.Common (Switch(..)) import System.PosixCompat.Files (FileStatus) import qualified System.PosixCompat.Files as Files -newtype Stat = Stat {deRef :: Switch} +newtype Stat = Stat {deRef :: Bool} defaultConfig :: Stat -defaultConfig = Stat On +defaultConfig = Stat True -followLinks :: Switch -> Stat -> Stat +followLinks :: Bool -> Stat -> Stat followLinks opt cfg = cfg {deRef = opt} stat :: (Stat -> Stat) -> FilePath -> IO FileStatus stat f = do let opt = f defaultConfig case deRef opt of - Off -> Files.getSymbolicLinkStatus - On -> Files.getFileStatus + False -> Files.getSymbolicLinkStatus + True -> Files.getFileStatus diff --git a/src/Streamly/Coreutils/Touch.hs b/src/Streamly/Coreutils/Touch.hs index 36cb96f..d089569 100644 --- a/src/Streamly/Coreutils/Touch.hs +++ b/src/Streamly/Coreutils/Touch.hs @@ -20,8 +20,7 @@ module Streamly.Coreutils.Touch where import Control.Monad (unless) -import Streamly.Coreutils.Common (Switch(..)) -import Streamly.Coreutils.FileTest (test, isExisting) +import Streamly.Coreutils.FileTest (test, doesExist) import System.IO (openFile, IOMode(WriteMode), hClose) #if !defined (CABAL_OS_WINDOWS) @@ -31,26 +30,26 @@ import qualified System.PosixCompat.Files as Posix data Touch = Touch { - createNew :: Switch - , deRef :: Switch -- touch the referenced file for symbolic link + createNew :: Bool + , deRef :: Bool -- touch the referenced file for symbolic link } defaultConfig :: Touch -defaultConfig = Touch On On +defaultConfig = Touch True True --- | Default is 'On'. -followLinks :: Switch -> Touch -> Touch +-- | Default is 'True'. +followLinks :: Bool -> Touch -> Touch followLinks opt cfg = cfg {deRef = opt} --- | Default is 'On'. -create :: Switch -> Touch -> Touch +-- | Default is 'True'. +create :: Bool -> Touch -> Touch create opt cfg = cfg {createNew = opt} -- | If the file does not exist create it only if both followLinks and create --- are set to 'On'. +-- are set to 'True'. -- -- If the file or symbolic link exists then update the access and modification --- times. If 'followLinks' is 'On' then the link target is updated otherwise +-- times. If 'followLinks' is 'True' then the link target is updated otherwise -- the symbolic link itself is updated. -- -- Fails if the parent directories in the path do not exist or if there is no @@ -58,22 +57,22 @@ create opt cfg = cfg {createNew = opt} -- -- Defaults: -- --- * create On --- * followLinks On +-- * create True +-- * followLinks True -- touch :: (Touch -> Touch) -> FilePath -> IO () touch f path = do let opt = f defaultConfig - if (createNew opt == On && deRef opt == On) + if (createNew opt == True && deRef opt == True) then do - found <- test path isExisting + found <- test path doesExist unless found $ openFile path WriteMode >>= hClose else case deRef opt of - On -> Posix.touchFile path + True -> Posix.touchFile path #if !defined (CABAL_OS_WINDOWS) - Off -> Posix.touchSymbolicLink path + False -> Posix.touchSymbolicLink path #else -- XXX Is it possible to support this on Windows? - Off -> error "touch: followLinks=Off not supported on Windows" + False -> error "touch: followLinks=False not supported on Windows" #endif diff --git a/stack.yaml b/stack.yaml index d50a9ad..f09bf05 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-22.33 +resolver: lts-24.33 packages: - '.' extra-deps: diff --git a/streamly-coreutils.cabal b/streamly-coreutils.cabal index 02c948d..501f74b 100644 --- a/streamly-coreutils.cabal +++ b/streamly-coreutils.cabal @@ -3,20 +3,10 @@ name: streamly-coreutils version: 0.1.0 synopsis: GNU Coreutils like API for Streamly description: - Port useful commands from the GNU `coreutils` to Haskell functions using - streamly. - - GNU `coreutils` are commonly used, well known interfaces to perform common - tasks on POSIX systems. It will be useful to have Haskell implementations of - these utilities in general and also to utilize the knowledge of these utilities - gained by programmers, admins, script writers for writing Haskell scripts. - - Some of these, but not all, are available in some existing Haskell libraries in - some form or other. However, there is no comprehensive collection available, - performance may not be at par and implementations may not be streaming. The - goal of this project is to have a comprehensive streaming collection using - Streamly with performance competitive with that of the C implementations - where it matters. + Streaming Haskell implementations of GNU coreutils, built on + Streamly. Provides familiar, composable, high-performance, + concurrent, streaming equivalents of common POSIX utilities, designed + for idiomatic Haskell scripting and systems programming. homepage: https://github.com/composewell/streamly-coreutils bug-reports: https://github.com/composewell/streamly-coreutils/issues @@ -113,6 +103,8 @@ library , unix-compat >= 0.5.4 && < 0.8 if !os(windows) build-depends: unix >= 2.7.0 && < 2.9 + else + build-depends: Win32 hs-source-dirs: src exposed-modules: @@ -132,11 +124,19 @@ library , Streamly.Coreutils.Sh , Streamly.Coreutils.Sleep , Streamly.Coreutils.Stat - , Streamly.Coreutils.String , Streamly.Coreutils.Tail , Streamly.Coreutils.Touch - , Streamly.Coreutils.Uniq , Streamly.Coreutils.Which + , Streamly.Coreutils.FileTest.Common + if os(windows) + exposed-modules: + Streamly.Coreutils.FileTest.Windows + else + exposed-modules: + Streamly.Coreutils.FileTest.Posix + other-modules: + Streamly.Coreutils.String + , Streamly.Coreutils.Uniq default-language: Haskell2010 @@ -144,30 +144,30 @@ library -- Benchmarks ------------------------------------------------------------------------------- -benchmark coreutils-bench - import: compile-options - type: exitcode-stdio-1.0 - hs-source-dirs: benchmark - main-is: Main.hs - build-depends: - streamly-coreutils - , streamly-core - , base >= 4.8 && < 5 - , gauge >= 0.2.4 && < 0.3 - , random >= 1.0.0 && < 2 - default-language: Haskell2010 +-- benchmark coreutils-bench +-- import: compile-options +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: benchmark +-- main-is: Main.hs +-- build-depends: +-- streamly-coreutils +-- , streamly-core +-- , base >= 4.8 && < 5 +-- , gauge >= 0.2.4 && < 0.3 +-- , random >= 1.0.0 && < 2 +-- default-language: Haskell2010 ------------------------------------------------------------------------------- -- Test suites ------------------------------------------------------------------------------- -test-suite coreutils-test - import: compile-options - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test - build-depends: - streamly-coreutils - , streamly-core - , base >= 4.8 && < 5 - default-language: Haskell2010 +-- test-suite coreutils-test +-- import: compile-options +-- type: exitcode-stdio-1.0 +-- main-is: Main.hs +-- hs-source-dirs: test +-- build-depends: +-- streamly-coreutils +-- , streamly-core +-- , base >= 4.8 && < 5 +-- default-language: Haskell2010