From 4df911b30df00d8c2220919822fdb40b63015280 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Tue, 24 Feb 2026 12:08:12 +1100 Subject: [PATCH 1/5] cabal.project: Bump index-state --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 80a2a42..7d9dbf7 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,6 @@ index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2025-07-17T14:32:30Z + , hackage.haskell.org 2026-02-23T23:13:53Z packages: fs-api From f66ef8e9e75b5763745055c74547fe996ca6ee25 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Tue, 24 Feb 2026 12:17:33 +1100 Subject: [PATCH 2/5] Bump dependencies In the case of bumping the dependencies for `io-classes` versions `1.9` and `1.10` were both tested manually. --- fs-api/fs-api.cabal | 6 +++--- fs-sim/fs-sim.cabal | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/fs-api/fs-api.cabal b/fs-api/fs-api.cabal index 05e79c7..421f31e 100644 --- a/fs-api/fs-api.cabal +++ b/fs-api/fs-api.cabal @@ -47,14 +47,14 @@ library default-language: Haskell2010 build-depends: - , base >=4.16 && <4.22 + , base >=4.16 && <4.23 , bytestring ^>=0.10 || ^>=0.11 || ^>=0.12 - , containers ^>=0.5 || ^>=0.6 || ^>=0.7 + , containers ^>=0.5 || ^>=0.6 || ^>=0.7 || ^>=0.8 , deepseq ^>=1.4 || ^>=1.5 , digest ^>=0.0 , directory ^>=1.3 , filepath ^>=1.4 || ^>=1.5 - , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 + , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10 , primitive ^>=0.9 , safe-wild-cards ^>=1.0 , text ^>=1.2 || ^>=2.0 || ^>=2.1 diff --git a/fs-sim/fs-sim.cabal b/fs-sim/fs-sim.cabal index 8692f61..8b37cf9 100644 --- a/fs-sim/fs-sim.cabal +++ b/fs-sim/fs-sim.cabal @@ -44,16 +44,16 @@ library default-language: Haskell2010 build-depends: - , base >=4.16 && <4.22 + , base >=4.16 && <4.23 , base16-bytestring ^>=0.1 || ^>=1.0 , bytestring ^>=0.10 || ^>=0.11 || ^>=0.12 , containers ^>=0.5 || ^>=0.6 || ^>=0.7 || ^>=0.8 , fs-api ^>=0.4 - , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 + , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10 , io-classes:strict-stm , mtl ^>=2.2 || ^>=2.3 , primitive ^>=0.9 - , QuickCheck ^>=2.13 || ^>=2.14 || ^>=2.15 || ^>=2.16 + , QuickCheck ^>=2.13 || ^>=2.14 || ^>=2.15 || ^>=2.16 || ^>=2.17 , safe-wild-cards ^>=1.0 , text ^>=1.2 || ^>=2.0 || ^>=2.1 From 6c7f4db9f1c293e4f3b6abb003d1f747fc4e626c Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Tue, 24 Feb 2026 12:18:50 +1100 Subject: [PATCH 3/5] Support ghc-9.14 --- cabal.project | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/cabal.project b/cabal.project index 7d9dbf7..4ad005e 100644 --- a/cabal.project +++ b/cabal.project @@ -12,3 +12,9 @@ benchmarks: True -- comment me if you are benchmarking import: cabal.project.debug + +if impl(ghc >=9.14) + allow-newer: + , indexed-traversable:base + , safe-wild-cards:template-haskell + , unix-bytestring:base From 313740817a3e1355cefaf927c3f44b4a41481598 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Tue, 24 Feb 2026 16:05:28 +1100 Subject: [PATCH 4/5] CI: Add ghc-9.14.1 to the build matrix --- .github/workflows/haskell.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 0279c15..7baab15 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -22,8 +22,8 @@ jobs: strategy: fail-fast: false matrix: - ghc: ["9.2.8", "9.4.8", "9.6.7", "9.8.4", "9.10.2", "9.12.2"] - cabal: ["3.14.1.1"] + ghc: ["9.2.8", "9.4.8", "9.6.7", "9.8.4", "9.10.3", "9.12.2", "9.14.1"] + cabal: ["3.16.1.0"] os: [ubuntu-latest, windows-latest, macOS-latest] no-debug: [""] include: From 16c757f7e2e223c9026ce201775843d9ed608800 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 24 Feb 2026 09:52:13 +0100 Subject: [PATCH 5/5] Switch to fourmolu/cabal-gild --- .github/workflows/documentation.yml | 12 +- .github/workflows/haskell.yml | 64 +- .stylish-haskell.yaml | 271 --- fourmolu.yaml | 7 + fs-api/fs-api.cabal | 123 +- fs-api/src-unix/System/FS/IO/Unix.hs | 66 +- fs-api/src-win32/System/FS/IO/Windows.hs | 112 +- fs-api/src/System/FS/API.hs | 598 ++--- fs-api/src/System/FS/API/Lazy.hs | 203 +- fs-api/src/System/FS/API/Strict.hs | 44 +- fs-api/src/System/FS/API/Types.hs | 374 +-- fs-api/src/System/FS/CRC.hs | 106 +- fs-api/src/System/FS/CallStack.hs | 8 +- fs-api/src/System/FS/Condense.hs | 36 +- fs-api/src/System/FS/IO.hs | 170 +- fs-api/src/System/FS/IO/Handle.hs | 36 +- fs-api/test/Main.hs | 13 +- fs-api/test/Test/System/FS/API/FsPath.hs | 70 +- fs-api/test/Test/System/FS/IO.hs | 199 +- fs-sim/fs-sim.cabal | 132 +- fs-sim/src/System/FS/Sim/Error.hs | 1197 +++++---- fs-sim/src/System/FS/Sim/FsTree.hs | 430 ++-- fs-sim/src/System/FS/Sim/MockFS.hs | 1468 ++++++------ fs-sim/src/System/FS/Sim/Prim.hs | 95 +- fs-sim/src/System/FS/Sim/STM.hs | 145 +- fs-sim/src/System/FS/Sim/Stream.hs | 130 +- fs-sim/test/Main.hs | 17 +- fs-sim/test/Test/System/FS/Sim/Error.hs | 333 +-- fs-sim/test/Test/System/FS/Sim/FsTree.hs | 219 +- fs-sim/test/Test/System/FS/Sim/Stream.hs | 202 +- fs-sim/test/Test/System/FS/StateMachine.hs | 2529 ++++++++++---------- fs-sim/test/Test/Util.hs | 22 +- fs-sim/test/Test/Util/RefEnv.hs | 105 +- fs-sim/test/Test/Util/WithEntryCounter.hs | 116 +- scripts/format-cabal.sh | 24 +- scripts/format-fourmolu.sh | 35 + scripts/format-stylish.sh | 21 - 37 files changed, 5133 insertions(+), 4599 deletions(-) delete mode 100644 .stylish-haskell.yaml create mode 100644 fourmolu.yaml create mode 100755 scripts/format-fourmolu.sh delete mode 100755 scripts/format-stylish.sh diff --git a/.github/workflows/documentation.yml b/.github/workflows/documentation.yml index ea660c1..3bd3863 100644 --- a/.github/workflows/documentation.yml +++ b/.github/workflows/documentation.yml @@ -38,7 +38,7 @@ jobs: steps: - name: Checkout repository - uses: actions/checkout@v5 + uses: actions/checkout@v6 - name: Setup Haskell id: setup-haskell @@ -55,7 +55,7 @@ jobs: # The last step generates dist-newstyle/cache/plan.json for the cache key. - name: Cache cabal store - uses: actions/cache@v4 + uses: actions/cache@v5 env: cache-name: ${{ runner.os }}-${{ env.ghc }}-documentation-cabal-store with: @@ -71,7 +71,7 @@ jobs: tar vzcf haddocks.tgz ./docs/haddocks - name: Upload haddocks as an artifact - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v6 with: name: haddocks path: haddocks.tgz @@ -99,13 +99,13 @@ jobs: steps: - name: Checkout - uses: actions/checkout@v5 + uses: actions/checkout@v6 - name: Setup Pages uses: actions/configure-pages@v5 - name: Download haddocks artifact - uses: actions/download-artifact@v5 + uses: actions/download-artifact@v7 with: name: haddocks @@ -120,4 +120,4 @@ jobs: - name: Deploy to GitHub pages id: deployment - uses: actions/deploy-pages@v4 \ No newline at end of file + uses: actions/deploy-pages@v4 diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 7baab15..68b9217 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -28,7 +28,7 @@ jobs: no-debug: [""] include: - ghc: "9.6.7" - cabal: "3.12.1.0" + cabal: "3.16.1.0" os: ubuntu-latest no-debug: "no-debug" @@ -36,7 +36,7 @@ jobs: steps: - name: Checkout repository - uses: actions/checkout@v5 + uses: actions/checkout@v6 - name: Setup Haskell id: setup-haskell @@ -63,7 +63,7 @@ jobs: cabal build all --dry-run - name: "Restore cache" - uses: actions/cache/restore@v4 + uses: actions/cache/restore@v5 id: restore-cabal-cache env: cache-name: cache-cabal-build @@ -80,7 +80,7 @@ jobs: run: cabal build --only-dependencies all - name: "Save cache" - uses: actions/cache/save@v4 + uses: actions/cache/save@v5 id: save-cabal-cache # Note: cache-hit will be set to true only when cache hit occurs for the # exact key match. For a partial key match via restore-keys or a cache @@ -110,29 +110,25 @@ jobs: cabal test --test-show-details=direct all # Check formatting for Haskell files - stylish-haskell: + fourmolu: runs-on: ${{ matrix.os }} strategy: fail-fast: false matrix: - ghc: ["9.6.7"] - cabal: ["3.12.1.0"] + ghc: ["9.12.2"] + cabal: ["3.16.1.0"] os: [ubuntu-latest] - # Fix the index-state so we can get proper caching effects. Change this to a - # more recent time if you want to use a newer version of stylish-haskell, or - # if you want stylish-haskell to use updated dependencies. - # # We use this environment variable in the primary key of our caches, and as # an argument to cabal install. This ensures that we never rebuild # dependencies because of newly uploaded packages unless we want to. env: - hackage-index-state: "2025-05-26T13:28:18Z" + hackage-index-state: "2026-02-23T23:13:53Z" steps: - name: Checkout repository - uses: actions/checkout@v5 + uses: actions/checkout@v6 - name: Install system dependencies (apt-get) run: | @@ -156,45 +152,45 @@ jobs: - name: Cache cabal store uses: actions/cache@v4 env: - cache-name: cache-cabal-stylish + cache-name: cache-fourmolu with: path: ${{ steps.setup-haskell.outputs.cabal-store }} key: ${{ runner.os }}-${{ matrix.ghc }}-${{ env.cache-name }}-${{ env.hackage-index-state }} restore-keys: | ${{ runner.os }}-${{ matrix.ghc }}-${{ env.cache-name }}- - - name: Install stylish-haskell - run: cabal install --ignore-project --index-state="${{ env.hackage-index-state }}" stylish-haskell --constraint 'stylish-haskell == 0.14.6.0' + - name: Install fourmolu + run: cabal install --ignore-project --index-state="${{ env.hackage-index-state }}" fourmolu-0.19.0.1 - - name: Record stylish-haskell version + - name: Record fourmolu version run: | - which stylish-haskell - stylish-haskell --version + which fourmolu + fourmolu --version - - name: Run stylish-haskell + - name: Run fourmolu run: | - ./scripts/format-stylish.sh + ./scripts/format-fourmolu.sh git diff --exit-code # Check formatting for cabal files - cabal-fmt: + cabal-gild: runs-on: ${{ matrix.os }} strategy: fail-fast: false matrix: - ghc: ["9.6.7"] - cabal: ["3.12.1.0"] + ghc: ["9.12.2"] + cabal: ["3.16.1.0"] os: [ubuntu-latest] # See the comment on the hackage-index-state environment variable for the # stylish-haskell job. env: - hackage-index-state: "2025-05-26T13:28:18Z" + hackage-index-state: "2026-02-23T23:13:53Z" steps: - name: Checkout repository - uses: actions/checkout@v5 + uses: actions/checkout@v6 - name: Install system dependencies (apt-get) run: | @@ -226,14 +222,14 @@ jobs: ${{ runner.os }}-${{ matrix.ghc }}-${{ env.cache-name }}- - name: Install cabal-fmt - run: cabal install --ignore-project cabal-fmt --index-state="${{ env.hackage-index-state }}" --constraint 'cabal-fmt == 0.1.11' + run: cabal install --ignore-project cabal-gild-1.7.0.1 --index-state="${{ env.hackage-index-state }}" - - name: Record cabal-fmt version + - name: Record cabal-gild version run: | - which cabal-fmt - cabal-fmt --version + which cabal-gild + cabal-gild --version - - name: Run cabal-fmt + - name: Run cabal-gild run: | ./scripts/format-cabal.sh git diff --exit-code @@ -245,13 +241,13 @@ jobs: strategy: fail-fast: false matrix: - ghc: ["9.6.7"] - cabal: ["3.10.3.0"] + ghc: ["9.12.2"] + cabal: ["3.16.1.0"] os: [ubuntu-latest] steps: - name: Checkout repository - uses: actions/checkout@v5 + uses: actions/checkout@v6 - name: Setup Haskell id: setup-haskell diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml deleted file mode 100644 index 0045c67..0000000 --- a/.stylish-haskell.yaml +++ /dev/null @@ -1,271 +0,0 @@ -# Stylish-haskell configuration file used for the Consensus layer -# It's based on default config provided by `stylish-haskell --defaults` but has some changes -# ================================== - -# The stylish-haskell tool is mainly configured by specifying steps. These steps -# are a list, so they have an order, and one specific step may appear more than -# once (if needed). Each file is processed by these steps in the given order. -steps: - # Convert some ASCII sequences to their Unicode equivalents. This is disabled - # by default. - # - unicode_syntax: - # # In order to make this work, we also need to insert the UnicodeSyntax - # # language pragma. If this flag is set to true, we insert it when it's - # # not already present. You may want to disable it if you configure - # # language extensions using some other method than pragmas. Default: - # # true. - # add_language_pragma: true - - module_header: - # # How many spaces use for indentation in the module header. - indent: 2 - # - # # Should export lists be sorted? Sorting is only performed within the - # # export section, as delineated by Haddock comments. - sort: false - # - # # See `separate_lists` for the `imports` step. - separate_lists: true - # - # # When to break the "where". - # # Possible values: - # # - exports: only break when there is an explicit export list. - # # - single: only break when the export list counts more than one export. - # # - inline: only break when the export list is too long. This is - # # determined by the `columns` setting. Not applicable when the export - # # list contains comments as newlines will be required. - # # - always: always break before the "where". - break_where: single - # # Where to put open bracket - # # Possible values: - # # - same_line: put open bracket on the same line as the module name, before the - # # comment of the module - # # - next_line: put open bracket on the next line, after module comment - open_bracket: same_line - - # Align the right hand side of some elements. This is quite conservative - # and only applies to statements where each element occupies a single - # line. - - simple_align: - cases: true - top_level_patterns: true - records: true - - # Import cleanup - - imports: - # There are different ways we can align names and lists. - # - # - global: Align the import names and import list throughout the entire - # file. - # - # - file: Like global, but don't add padding when there are no qualified - # imports in the file. - # - # - group: Only align the imports per group (a group is formed by adjacent - # import lines). - # - # - none: Do not perform any alignment. - # - # Default: global. - align: global - - # The following options affect only import list alignment. - # - # List align has following options: - # - # - after_alias: Import list is aligned with end of import including - # 'as' and 'hiding' keywords. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # > init, last, length) - # - # - with_alias: Import list is aligned with start of alias or hiding. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # > init, last, length) - # - # - new_line: Import list starts always on new line. - # - # > import qualified Data.List as List - # > (concat, foldl, foldr, head, init, last, length) - # - # Default: after_alias - list_align: with_module_name - - # Right-pad the module names to align imports in a group: - # - # - true: a little more readable - # - # > import qualified Data.List as List (concat, foldl, foldr, - # > init, last, length) - # > import qualified Data.List.Extra as List (concat, foldl, foldr, - # > init, last, length) - # - # - false: diff-safe - # - # > import qualified Data.List as List (concat, foldl, foldr, init, - # > last, length) - # > import qualified Data.List.Extra as List (concat, foldl, foldr, - # > init, last, length) - # - # Default: true - - # Note: we intentionally disable it to make diffs less verbose and avoid - # merge conflicts in some cases. - pad_module_names: false - - # Long list align style takes effect when import is too long. This is - # determined by 'columns' setting. - # - # - inline: This option will put as much specs on same line as possible. - # - # - new_line: Import list will start on new line. - # - # - new_line_multiline: Import list will start on new line when it's - # short enough to fit to single line. Otherwise it'll be multiline. - # - # - multiline: One line per import list entry. - # Type with constructor list acts like single import. - # - # > import qualified Data.Map as M - # > ( empty - # > , singleton - # > , ... - # > , delete - # > ) - # - # Default: inline - long_list_align: inline - - # Align empty list (importing instances) - # - # Empty list align has following options - # - # - inherit: inherit list_align setting - # - # - right_after: () is right after the module name: - # - # > import Vector.Instances () - # - # Default: inherit - empty_list_align: inherit - - # List padding determines indentation of import list on lines after import. - # This option affects 'long_list_align'. - # - # - : constant value - # - # - module_name: align under start of module name. - # Useful for 'file' and 'group' align settings. - list_padding: 4 - - # Separate lists option affects formatting of import list for type - # or class. The only difference is single space between type and list - # of constructors, selectors and class functions. - # - # - true: There is single space between Foldable type and list of it's - # functions. - # - # > import Data.Foldable (Foldable (fold, foldl, foldMap)) - # - # - false: There is no space between Foldable type and list of it's - # functions. - # - # > import Data.Foldable (Foldable(fold, foldl, foldMap)) - # - # Default: true - separate_lists: true - - # Space surround option affects formatting of import lists on a single - # line. The only difference is single space after the initial - # parenthesis and a single space before the terminal parenthesis. - # - # - true: There is single space associated with the enclosing - # parenthesis. - # - # > import Data.Foo ( foo ) - # - # - false: There is no space associated with the enclosing parenthesis - # - # > import Data.Foo (foo) - # - # Default: false - space_surround: false - - # Language pragmas - - language_pragmas: - # We can generate different styles of language pragma lists. - # - # - vertical: Vertical-spaced language pragmas, one per line. - # - # - compact: A more compact style. - # - # - compact_line: Similar to compact, but wrap each line with - # `{-#LANGUAGE #-}'. - # - # Default: vertical. - style: vertical - - # stylish-haskell can detect redundancy of some language pragmas. If this - # is set to true, it will remove those redundant pragmas. Default: true. - remove_redundant: true - - # Replace tabs by spaces. This is disabled by default. - # - tabs: - # # Number of spaces to use for each tab. Default: 8, as specified by the - # # Haskell report. - # spaces: 8 - - # Remove trailing whitespace - - trailing_whitespace: {} - -# A common setting is the number of columns (parts of) code will be wrapped -# to. Different steps take this into account. Default: 80. -columns: 80 - -# By default, line endings are converted according to the OS. You can override -# preferred format here. -# -# - native: Native newline format. CRLF on Windows, LF on other OSes. -# -# - lf: Convert to LF ("\n"). -# -# - crlf: Convert to CRLF ("\r\n"). -# -# Default: native. -newline: native - -# These syntax-affecting language extensions are enabled so that -# stylish-haskell wouldn't fail with parsing errors when processing files -# in projects that have those extensions enabled in the .cabal file -# rather than locally. -# -# To my best knowledge, no harm should result from enabling an extension -# that isn't actually used in the file/project. —@neongreen -language_extensions: - - BangPatterns - - ConstraintKinds - - DataKinds - - DefaultSignatures - - DeriveDataTypeable - - DeriveGeneric - - ExistentialQuantification - - FlexibleContexts - - FlexibleInstances - - FunctionalDependencies - - GADTs - - GeneralizedNewtypeDeriving - - LambdaCase - - MultiParamTypeClasses - - MultiWayIf - - NoImplicitPrelude - - OverloadedStrings - - PolyKinds - - RecordWildCards - - ScopedTypeVariables - - StandaloneDeriving - - TemplateHaskell - - TupleSections - - TypeApplications - - TypeFamilies - - ViewPatterns - - ExplicitNamespaces diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..a6618df --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,7 @@ +indentation: 2 +column-limit: 100 +import-export-style: leading +haddock-style: single-line +single-constraint-parens: never +single-deriving-parens: never +import-grouping: single diff --git a/fs-api/fs-api.cabal b/fs-api/fs-api.cabal index 421f31e..8456f19 100644 --- a/fs-api/fs-api.cabal +++ b/fs-api/fs-api.cabal @@ -1,104 +1,115 @@ -cabal-version: 3.0 -name: fs-api -version: 0.4.0.0 -synopsis: Abstract interface for the file system -description: Abstract interface for the file system. -license: Apache-2.0 +cabal-version: 3.0 +name: fs-api +version: 0.4.0.0 +synopsis: Abstract interface for the file system +description: Abstract interface for the file system. +license: Apache-2.0 license-files: LICENSE NOTICE -copyright: 2019-2024 Input Output Global Inc (IOG) -author: IOG Engineering Team -maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com) -homepage: https://github.com/input-output-hk/fs-sim -bug-reports: https://github.com/input-output-hk/fs-sim/issues -category: System -build-type: Simple +copyright: 2019-2024 Input Output Global Inc (IOG) +author: IOG Engineering Team +maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com) +homepage: https://github.com/input-output-hk/fs-sim +bug-reports: https://github.com/input-output-hk/fs-sim/issues +category: System +build-type: Simple extra-doc-files: CHANGELOG.md README.md -tested-with: GHC ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 || ==9.12 +tested-with: ghc ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 || ==9.12 source-repository head - type: git + type: git location: https://github.com/input-output-hk/fs-sim - subdir: fs-api + subdir: fs-api source-repository this - type: git + type: git location: https://github.com/input-output-hk/fs-sim - subdir: fs-api - tag: fs-api-0.4.0.0 + subdir: fs-api + tag: fs-api-0.4.0.0 library - hs-source-dirs: src + hs-source-dirs: src exposed-modules: System.FS.API System.FS.API.Lazy System.FS.API.Strict System.FS.API.Types + System.FS.CRC System.FS.CallStack System.FS.Condense - System.FS.CRC System.FS.IO System.FS.IO.Handle default-language: Haskell2010 build-depends: - , base >=4.16 && <4.23 - , bytestring ^>=0.10 || ^>=0.11 || ^>=0.12 - , containers ^>=0.5 || ^>=0.6 || ^>=0.7 || ^>=0.8 - , deepseq ^>=1.4 || ^>=1.5 - , digest ^>=0.0 - , directory ^>=1.3 - , filepath ^>=1.4 || ^>=1.5 - , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10 - , primitive ^>=0.9 - , safe-wild-cards ^>=1.0 - , text ^>=1.2 || ^>=2.0 || ^>=2.1 + base >=4.16 && <4.23, + bytestring ^>=0.10 || ^>=0.11 || ^>=0.12, + containers ^>=0.5 || ^>=0.6 || ^>=0.7 || ^>=0.8, + deepseq ^>=1.4 || ^>=1.5, + digest ^>=0.0, + directory ^>=1.3, + filepath ^>=1.4 || ^>=1.5, + io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10, + primitive ^>=0.9, + safe-wild-cards ^>=1.0, + text ^>=1.2 || ^>=2.0 || ^>=2.1, if os(windows) - hs-source-dirs: src-win32 + hs-source-dirs: src-win32 exposed-modules: System.FS.IO.Windows - build-depends: Win32 ^>=2.14 - + build-depends: Win32 ^>=2.14 -- every other distribution is handled like it is Unix-based else - hs-source-dirs: src-unix + hs-source-dirs: src-unix exposed-modules: System.FS.IO.Unix build-depends: - , unix ^>=2.7 || ^>=2.8 - , unix-bytestring ^>=0.4 + unix ^>=2.7 || ^>=2.8, + unix-bytestring ^>=0.4, ghc-options: - -Wall -Wcompat -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wpartial-fields -Widentities - -Wredundant-constraints -Wmissing-export-lists -Wunused-packages + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wunused-packages test-suite fs-api-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs other-modules: Test.System.FS.API.FsPath Test.System.FS.IO default-language: Haskell2010 build-depends: - , base - , bytestring - , filepath - , fs-api - , primitive - , tasty - , tasty-quickcheck - , temporary - , text + base, + bytestring, + filepath, + fs-api, + primitive, + tasty, + tasty-quickcheck, + temporary, + text, ghc-options: - -Wall -Wcompat -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wpartial-fields -Widentities - -Wredundant-constraints -Wmissing-export-lists -Wunused-packages + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wunused-packages -fno-ignore-asserts diff --git a/fs-api/src-unix/System/FS/IO/Unix.hs b/fs-api/src-unix/System/FS/IO/Unix.hs index efbd671..29d2843 100644 --- a/fs-api/src-unix/System/FS/IO/Unix.hs +++ b/fs-api/src-unix/System/FS/IO/Unix.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} -- | This module is mainly meant to be used for the 'IO' implementation of -- 'System.FS.API.HasFS'. -module System.FS.IO.Unix ( - FHandle +module System.FS.IO.Unix + ( FHandle , close , getSize , open @@ -19,24 +19,30 @@ module System.FS.IO.Unix ( , writeBuf ) where -import Prelude hiding (read, truncate) - -import Control.Monad (void) -import Data.ByteString (ByteString) +import Control.Monad (void) +import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as Internal -import Data.Int (Int64) -import Data.Word (Word32, Word64, Word8) -import Foreign (Ptr) -import System.FS.API.Types (AllowExisting (..), OpenMode (..), - SeekMode (..)) -import System.FS.IO.Handle +import Data.Int (Int64) +import Data.Word (Word32, Word64, Word8) +import Foreign (Ptr) +import System.FS.API.Types + ( AllowExisting (..) + , OpenMode (..) + , SeekMode (..) + ) +import System.FS.IO.Handle +import System.Posix (ByteCount, Fd (..), FileOffset) import qualified System.Posix as Posix -import System.Posix (ByteCount, Fd (..), FileOffset) -import qualified System.Posix.IO.ByteString.Ext as Posix (fdPreadBuf, - fdPwriteBuf) +import qualified System.Posix.IO.ByteString.Ext as Posix + ( fdPreadBuf + , fdPwriteBuf + ) +import Prelude hiding (read, truncate) type FHandle = HandleOS Fd +{- ORMOLU_DISABLE -} + -- | Some sensible defaults for the 'OpenFileFlags'. -- -- NOTE: the 'unix' package /already/ exports a smart constructor called @@ -52,18 +58,18 @@ defaultFileFlags = Posix.OpenFileFlags { , Posix.noctty = False , Posix.nonBlock = False , Posix.trunc = False -# if MIN_VERSION_unix(2,8,0) +#if MIN_VERSION_unix(2,8,0) , Posix.nofollow = False , Posix.creat = Nothing , Posix.cloexec = False , Posix.directory = False , Posix.sync = False -# endif +#endif } -- | Opens a file from disk. open :: FilePath -> OpenMode -> IO Fd -# if MIN_VERSION_unix(2,8,0) +#if MIN_VERSION_unix(2,8,0) open fp openMode = Posix.openFd fp posixOpenMode fileFlags where (posixOpenMode, fileFlags) = case openMode of @@ -83,7 +89,7 @@ open fp openMode = Posix.openFd fp posixOpenMode fileFlags , defaultFileFlags { Posix.exclusive = isExcl ex , Posix.creat = creat ex } ) -# else +#else open fp openMode = Posix.openFd fp posixOpenMode fileMode fileFlags where (posixOpenMode, fileMode, fileFlags) = case openMode of @@ -104,7 +110,7 @@ open fp openMode = Posix.openFd fp posixOpenMode fileMode fileFlags , creat ex , defaultFileFlags { Posix.exclusive = isExcl ex } ) -# endif +#endif isExcl AllowExisting = False isExcl MustBeNew = True isExcl MustExist = False @@ -113,10 +119,12 @@ open fp openMode = Posix.openFd fp posixOpenMode fileMode fileFlags creat MustBeNew = Just Posix.stdFileMode creat MustExist = Nothing +{- ORMOLU_ENABLE -} + -- | Writes the data pointed by the input 'Ptr Word8' into the input 'FHandle'. write :: FHandle -> Ptr Word8 -> Int64 -> IO Word32 write h data' bytes = withOpenHandle "write" h $ \fd -> - fromIntegral <$> Posix.fdWriteBuf fd data' (fromIntegral bytes) + fromIntegral <$> Posix.fdWriteBuf fd data' (fromIntegral bytes) -- | Seek within the file. -- @@ -126,13 +134,13 @@ write h data' bytes = withOpenHandle "write" h $ \fd -> -- (e.g., the file pointer may not actually be moved until a subsequent write) seek :: FHandle -> SeekMode -> Int64 -> IO () seek h seekMode offset = withOpenHandle "seek" h $ \fd -> - void $ Posix.fdSeek fd seekMode (fromIntegral offset) + void $ Posix.fdSeek fd seekMode (fromIntegral offset) -- | Reads a given number of bytes from the input 'FHandle'. read :: FHandle -> Word64 -> IO ByteString read h bytes = withOpenHandle "read" h $ \fd -> - Internal.createUptoN (fromIntegral bytes) $ \ptr -> - fromIntegral <$> Posix.fdReadBuf fd ptr (fromIntegral bytes) + Internal.createUptoN (fromIntegral bytes) $ \ptr -> + fromIntegral <$> Posix.fdReadBuf fd ptr (fromIntegral bytes) readBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount readBuf f buf c = withOpenHandle "readBuf" f $ \fd -> Posix.fdReadBuf fd buf c @@ -142,8 +150,8 @@ writeBuf f buf c = withOpenHandle "writeBuf" f $ \fd -> Posix.fdWriteBuf fd buf pread :: FHandle -> Word64 -> Word64 -> IO ByteString pread h bytes offset = withOpenHandle "pread" h $ \fd -> - Internal.createUptoN (fromIntegral bytes) $ \ptr -> - fromIntegral <$> Posix.fdPreadBuf fd ptr (fromIntegral bytes) (fromIntegral offset) + Internal.createUptoN (fromIntegral bytes) $ \ptr -> + fromIntegral <$> Posix.fdPreadBuf fd ptr (fromIntegral bytes) (fromIntegral offset) -- | @'preadBuf' fh buf c off@ reads @c@ bytes into the buffer @buf@ from the file -- handle @fh@ at the file offset @off@. This does not move the position of the @@ -160,7 +168,7 @@ pwriteBuf h buf c off = withOpenHandle "pwriteBuf" h $ \fd -> Posix.fdPwriteBuf -- | Truncates the file managed by the input 'FHandle' to the input size. truncate :: FHandle -> Word64 -> IO () truncate h sz = withOpenHandle "truncate" h $ \fd -> - Posix.setFdSize fd (fromIntegral sz) + Posix.setFdSize fd (fromIntegral sz) -- | Close handle -- @@ -174,4 +182,4 @@ close h = closeHandleOS h Posix.closeFd -- may affect this thread). getSize :: FHandle -> IO Word64 getSize h = withOpenHandle "getSize" h $ \fd -> - fromIntegral . Posix.fileSize <$> Posix.getFdStatus fd + fromIntegral . Posix.fileSize <$> Posix.getFdStatus fd diff --git a/fs-api/src-win32/System/FS/IO/Windows.hs b/fs-api/src-win32/System/FS/IO/Windows.hs index b91f94b..19e83bb 100644 --- a/fs-api/src-win32/System/FS/IO/Windows.hs +++ b/fs-api/src-win32/System/FS/IO/Windows.hs @@ -2,8 +2,8 @@ -- | This module is mainly meant to be used for the 'IO' implementation of -- 'System.FS.API.HasFS'. -module System.FS.IO.Windows ( - FHandle +module System.FS.IO.Windows + ( FHandle , close , getSize , open @@ -18,49 +18,53 @@ module System.FS.IO.Windows ( , writeBuf ) where -import Prelude hiding (read, truncate) - -import Control.Monad (void) -import Data.Bits ((.|.)) -import Data.ByteString -import Data.ByteString.Internal as Internal -import Data.Word (Word32, Word64, Word8) -import Foreign (Int64, Ptr) -import System.FS.API.Types (AllowExisting (..), OpenMode (..), - SeekMode (..)) -import System.FS.IO.Handle -import System.Posix.Types -import System.Win32 +import Control.Monad (void) +import Data.Bits ((.|.)) +import Data.ByteString +import Data.ByteString.Internal as Internal +import Data.Word (Word32, Word64, Word8) +import Foreign (Int64, Ptr) +import System.FS.API.Types + ( AllowExisting (..) + , OpenMode (..) + , SeekMode (..) + ) +import System.FS.IO.Handle +import System.Posix.Types +import System.Win32 +import Prelude hiding (read, truncate) type FHandle = HandleOS HANDLE open :: FilePath -> OpenMode -> IO HANDLE open filename openMode = do - h <- createFile filename - accessMode - (fILE_SHARE_READ .|. fILE_SHARE_WRITE) - Nothing - creationDisposition - fILE_ATTRIBUTE_NORMAL - Nothing - -- There is no AppendMode in Windows, so we manually seek to the end of - -- the file. For now we don't need to carry a flag that this handle is in - -- AppendMode, but we may need to if we add more commands (read and seek - -- are disabled in AppendMode and truncate only works in AppendMode, write - -- moves the file offset in all modes). - case openMode of - AppendMode{} -> void $ setFilePointerEx h 0 fILE_END - _ -> return () - return h - where - (accessMode, creationDisposition) = case openMode of - ReadMode -> (gENERIC_READ, oPEN_EXISTING) - AppendMode ex -> ( gENERIC_WRITE, createNew ex) - WriteMode ex -> (gENERIC_READ .|. gENERIC_WRITE, createNew ex) - ReadWriteMode ex -> (gENERIC_READ .|. gENERIC_WRITE, createNew ex) - createNew AllowExisting = oPEN_ALWAYS - createNew MustBeNew = cREATE_NEW - createNew MustExist = oPEN_EXISTING + h <- + createFile + filename + accessMode + (fILE_SHARE_READ .|. fILE_SHARE_WRITE) + Nothing + creationDisposition + fILE_ATTRIBUTE_NORMAL + Nothing + -- There is no AppendMode in Windows, so we manually seek to the end of + -- the file. For now we don't need to carry a flag that this handle is in + -- AppendMode, but we may need to if we add more commands (read and seek + -- are disabled in AppendMode and truncate only works in AppendMode, write + -- moves the file offset in all modes). + case openMode of + AppendMode{} -> void $ setFilePointerEx h 0 fILE_END + _ -> return () + return h + where + (accessMode, creationDisposition) = case openMode of + ReadMode -> (gENERIC_READ, oPEN_EXISTING) + AppendMode ex -> (gENERIC_WRITE, createNew ex) + WriteMode ex -> (gENERIC_READ .|. gENERIC_WRITE, createNew ex) + ReadWriteMode ex -> (gENERIC_READ .|. gENERIC_WRITE, createNew ex) + createNew AllowExisting = oPEN_ALWAYS + createNew MustBeNew = cREATE_NEW + createNew MustExist = oPEN_EXISTING write :: FHandle -> Ptr Word8 -> Int64 -> IO Word32 write fh data' bytes = withOpenHandle "write" fh $ \h -> @@ -73,7 +77,7 @@ seek fh seekMode size = void <$> withOpenHandle "seek" fh $ \h -> fromSeekMode :: SeekMode -> FilePtrDirection fromSeekMode AbsoluteSeek = fILE_BEGIN fromSeekMode RelativeSeek = fILE_CURRENT -fromSeekMode SeekFromEnd = fILE_END +fromSeekMode SeekFromEnd = fILE_END read :: FHandle -> Word64 -> IO ByteString read fh bytes = withOpenHandle "read" fh $ \h -> @@ -85,11 +89,11 @@ getCurrentFileOffset h = setFilePointerEx h 0 fILE_CURRENT readBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount readBuf fh buf c = withOpenHandle "readBuf" fh $ \h -> - fromIntegral <$> win32_ReadFile h buf (fromIntegral c) Nothing + fromIntegral <$> win32_ReadFile h buf (fromIntegral c) Nothing writeBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount writeBuf fh buf c = withOpenHandle "writeBuf" fh $ \h -> - fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing + fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing pread :: FHandle -> Word64 -> Word64 -> IO ByteString pread fh bytes pos = withOpenHandle "pread" fh $ \h -> @@ -102,24 +106,24 @@ pread fh bytes pos = withOpenHandle "pread" fh $ \h -> preadBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount preadBuf fh buf c off = withOpenHandle "preadBuf" fh $ \h -> do - initialOffset <- getCurrentFileOffset h - _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN - n <- fromIntegral <$> win32_ReadFile h buf (fromIntegral c) Nothing - _ <- setFilePointerEx h initialOffset fILE_BEGIN - return n + initialOffset <- getCurrentFileOffset h + _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN + n <- fromIntegral <$> win32_ReadFile h buf (fromIntegral c) Nothing + _ <- setFilePointerEx h initialOffset fILE_BEGIN + return n pwriteBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount pwriteBuf fh buf c off = withOpenHandle "pwriteBuf" fh $ \h -> do - initialOffset <- getCurrentFileOffset h - _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN - n <- fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing - _ <- setFilePointerEx h initialOffset fILE_BEGIN - return n + initialOffset <- getCurrentFileOffset h + _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN + n <- fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing + _ <- setFilePointerEx h initialOffset fILE_BEGIN + return n -- We only allow truncate in AppendMode, but Windows do not support it, so we manually seek to the end. -- It is important that the logical end of the handle stays alligned to the physical end of the file. truncate :: FHandle -> Word64 -> IO () -truncate fh size = withOpenHandle "truncate" fh $ \h -> do +truncate fh size = withOpenHandle "truncate" fh $ \h -> do _ <- setFilePointerEx h (fromIntegral size) (fromSeekMode AbsoluteSeek) setEndOfFile h diff --git a/fs-api/src/System/FS/API.hs b/fs-api/src/System/FS/API.hs index 6216cfa..a3f3786 100644 --- a/fs-api/src/System/FS/API.hs +++ b/fs-api/src/System/FS/API.hs @@ -1,25 +1,29 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} -- | An abstract view over the filesystem. -module System.FS.API ( - -- * Record that abstracts over the filesystem +module System.FS.API + ( -- * Record that abstracts over the filesystem HasFS (..) + -- * Types , module Types + -- * Opening and closing files , hClose' , withFile + -- * SomeHasFS , SomeHasFS (..) + -- * File I\/O with user-supplied buffers , BufferOffset (..) , hGetBufExactly @@ -28,19 +32,18 @@ module System.FS.API ( , hPutBufExactlyAt ) where -import Control.DeepSeq (NFData (..)) -import Control.Monad.Class.MonadThrow -import Control.Monad.Primitive (PrimMonad (..)) +import Control.DeepSeq (NFData (..)) +import Control.Monad.Class.MonadThrow +import Control.Monad.Primitive (PrimMonad (..)) import qualified Data.ByteString as BS -import Data.Int (Int64) -import Data.Primitive (MutableByteArray) -import Data.Set (Set) -import Data.Word -import SafeWildCards -import System.Posix.Types (ByteCount) - -import System.FS.API.Types as Types -import System.FS.CallStack +import Data.Int (Int64) +import Data.Primitive (MutableByteArray) +import Data.Set (Set) +import Data.Word +import SafeWildCards +import System.FS.API.Types as Types +import System.FS.CallStack +import System.Posix.Types (ByteCount) {------------------------------------------------------------------------------ Record that abstracts over the filesystem @@ -53,173 +56,174 @@ import System.FS.CallStack -- responsiblity to provide buffers that are large enough. Behaviour is -- undefined if the I\/O operations access the buffer outside it's allocated -- range. -data HasFS m h = HasFS { - -- | Debugging: human-readable description of file system state - dumpState :: m String - - -- Operations of files - - -- | Open a file - , hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle h) - - -- | Close a file - , hClose :: HasCallStack => Handle h -> m () - - -- | Is the handle open? - , hIsOpen :: HasCallStack => Handle h -> m Bool - - -- | Seek handle - -- - -- The offset is an 'Int64' rather than a 'Word64' because it may be - -- negative (for use in relative positioning). - -- - -- Unlike the Posix @lseek@, 'hSeek' does not return the new seek position - -- because the value returned by Posix is rather strange and unreliable - -- and we don't want to emulate it's behaviour. - , hSeek :: HasCallStack => Handle h -> SeekMode -> Int64 -> m () - - -- | Try to read @n@ bytes from a handle - -- - -- When at the end of the file, an empty bytestring will be returned. - -- - -- The returned bytestring will typically have length @n@, but may be - -- shorter in case of a partial read, see #277. However, a partial read - -- will always return at least 1 byte, as returning 0 bytes would mean - -- that we have reached EOF. - -- - -- Postcondition: for the length of the returned bytestring @bs@ we have - -- @length bs >= 0@ and @length bs <= n@. - , hGetSome :: HasCallStack => Handle h -> Word64 -> m BS.ByteString - - -- | Same as 'hGetSome', but does not affect the file offset. An additional argument - -- is used to specify the offset. This allows it to be called concurrently for the - -- same file handle. However, the actual level of parallelism achieved depends on - -- the implementation and the operating system: generally on Unix it will be - -- \"more parallel\" than on Windows. - , hGetSomeAt :: HasCallStack - => Handle h - -> Word64 -- The number of bytes to read. - -> AbsOffset -- The offset at which to read. - -> m BS.ByteString - - -- | Write to a handle - -- - -- The return value indicates the number of bytes written and will - -- typically be equal to @l@, the length of the bytestring, but may be - -- shorter in case of a partial write, see #277. - -- - -- If nothing can be written at all, an exception will be thrown. - -- - -- Postcondition: the return value @n@ is @n > 0@ and @n <= l@, unless the - -- given bytestring is empty, in which case @n@ can be 0. - , hPutSome :: HasCallStack => Handle h -> BS.ByteString -> m Word64 - - -- | Truncate the file to the specified size - -- - -- NOTE: Only supported in append mode. - , hTruncate :: HasCallStack => Handle h -> Word64 -> m () - - -- | Return current file size - -- - -- NOTE: This is not thread safe (changes made to the file in other threads - -- may affect this thread). - , hGetSize :: HasCallStack => Handle h -> m Word64 - - -- Operations of directories - - -- | Create new directory - , createDirectory :: HasCallStack => FsPath -> m () - - -- | Create new directory if it doesn't exist. - -- - -- @createDirectoryIfMissing True@ will also try to create all parent dirs. +data HasFS m h = HasFS + { dumpState :: m String + -- ^ Debugging: human-readable description of file system state + , -- Operations of files + + hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle h) + -- ^ Open a file + , hClose :: HasCallStack => Handle h -> m () + -- ^ Close a file + , hIsOpen :: HasCallStack => Handle h -> m Bool + -- ^ Is the handle open? + , hSeek :: HasCallStack => Handle h -> SeekMode -> Int64 -> m () + -- ^ Seek handle + -- + -- The offset is an 'Int64' rather than a 'Word64' because it may be + -- negative (for use in relative positioning). + -- + -- Unlike the Posix @lseek@, 'hSeek' does not return the new seek position + -- because the value returned by Posix is rather strange and unreliable + -- and we don't want to emulate it's behaviour. + , hGetSome :: HasCallStack => Handle h -> Word64 -> m BS.ByteString + -- ^ Try to read @n@ bytes from a handle + -- + -- When at the end of the file, an empty bytestring will be returned. + -- + -- The returned bytestring will typically have length @n@, but may be + -- shorter in case of a partial read, see #277. However, a partial read + -- will always return at least 1 byte, as returning 0 bytes would mean + -- that we have reached EOF. + -- + -- Postcondition: for the length of the returned bytestring @bs@ we have + -- @length bs >= 0@ and @length bs <= n@. + , hGetSomeAt :: + HasCallStack => + Handle h -> + Word64 -> -- The number of bytes to read. + AbsOffset -> -- The offset at which to read. + m BS.ByteString + -- ^ Same as 'hGetSome', but does not affect the file offset. An additional argument + -- is used to specify the offset. This allows it to be called concurrently for the + -- same file handle. However, the actual level of parallelism achieved depends on + -- the implementation and the operating system: generally on Unix it will be + -- \"more parallel\" than on Windows. + , hPutSome :: HasCallStack => Handle h -> BS.ByteString -> m Word64 + -- ^ Write to a handle + -- + -- The return value indicates the number of bytes written and will + -- typically be equal to @l@, the length of the bytestring, but may be + -- shorter in case of a partial write, see #277. + -- + -- If nothing can be written at all, an exception will be thrown. + -- + -- Postcondition: the return value @n@ is @n > 0@ and @n <= l@, unless the + -- given bytestring is empty, in which case @n@ can be 0. + , hTruncate :: HasCallStack => Handle h -> Word64 -> m () + -- ^ Truncate the file to the specified size + -- + -- NOTE: Only supported in append mode. + , hGetSize :: HasCallStack => Handle h -> m Word64 + -- ^ Return current file size + -- + -- NOTE: This is not thread safe (changes made to the file in other threads + -- may affect this thread). + , -- Operations of directories + + createDirectory :: HasCallStack => FsPath -> m () + -- ^ Create new directory , createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> m () - - -- | List contents of a directory - , listDirectory :: HasCallStack => FsPath -> m (Set String) - - -- | Check if the path exists and is a directory - , doesDirectoryExist :: HasCallStack => FsPath -> m Bool - - -- | Check if the path exists and is a file - , doesFileExist :: HasCallStack => FsPath -> m Bool - - -- | Remove the directory (which must exist) and its contents + -- ^ Create new directory if it doesn't exist. + -- + -- @createDirectoryIfMissing True@ will also try to create all parent dirs. + , listDirectory :: HasCallStack => FsPath -> m (Set String) + -- ^ List contents of a directory + , doesDirectoryExist :: HasCallStack => FsPath -> m Bool + -- ^ Check if the path exists and is a directory + , doesFileExist :: HasCallStack => FsPath -> m Bool + -- ^ Check if the path exists and is a file , removeDirectoryRecursive :: HasCallStack => FsPath -> m () - - -- | Remove the file (which must exist) - , removeFile :: HasCallStack => FsPath -> m () - - -- | Rename the file (which must exist) from the first path to the second - -- path. If there is already a file at the latter path, it is replaced by - -- the new one. - -- - -- NOTE: only works for files within the same folder. - , renameFile :: HasCallStack => FsPath -> FsPath -> m () - - -- | Useful for better error reporting - , mkFsErrorPath :: FsPath -> FsErrorPath - - -- | Create an absolute 'FilePath' from a relative 'FsPath'. - -- - -- This is an escape hatch for creating absolute paths when @m ~'IO'@. - -- - -- Postcondition: Should throw an error for any @m@ that is not @IO@ - -- (or for which we do not have @'MonadIO' m@). - , unsafeToFilePath :: FsPath -> m FilePath - - -- === File I\/O with user-supplied buffers - - -- | Like 'hGetSome', but the bytes are read into a user-supplied buffer. - -- See [__User-supplied buffers__](#user-supplied-buffers). - , hGetBufSome :: HasCallStack - => Handle h - -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into - -> BufferOffset -- ^ Offset into buffer - -> ByteCount -- ^ The number of bytes to read - -> m ByteCount - -- | Like 'hGetSomeAt', but the bytes are read into a user-supplied buffer. - -- See [__User-supplied buffers__](#user-supplied-buffers). - , hGetBufSomeAt :: HasCallStack - => Handle h - -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into - -> BufferOffset -- ^ Offset into buffer - -> ByteCount -- ^ The number of bytes to read - -> AbsOffset -- ^ The file offset at which to read - -> m ByteCount - -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer. - -- See [__User-supplied buffers__](#user-supplied-buffers). - , hPutBufSome :: HasCallStack - => Handle h - -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from - -> BufferOffset -- ^ Offset into buffer - -> ByteCount -- ^ The number of bytes to write - -> m ByteCount - -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer - -- at a given file offset. This offset does not affect the offset stored in - -- the file handle (see also 'hGetSomeAt'). See [__User-supplied buffers__](#user-supplied-buffers). - , hPutBufSomeAt :: HasCallStack - => Handle h - -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from - -> BufferOffset -- ^ Offset into buffer - -> ByteCount -- ^ The number of bytes to write - -> AbsOffset -- ^ The file offset at which to write - -> m ByteCount + -- ^ Remove the directory (which must exist) and its contents + , removeFile :: HasCallStack => FsPath -> m () + -- ^ Remove the file (which must exist) + , renameFile :: HasCallStack => FsPath -> FsPath -> m () + -- ^ Rename the file (which must exist) from the first path to the second + -- path. If there is already a file at the latter path, it is replaced by + -- the new one. + -- + -- NOTE: only works for files within the same folder. + , mkFsErrorPath :: FsPath -> FsErrorPath + -- ^ Useful for better error reporting + , unsafeToFilePath :: FsPath -> m FilePath + -- ^ Create an absolute 'FilePath' from a relative 'FsPath'. + -- + -- This is an escape hatch for creating absolute paths when @m ~'IO'@. + -- + -- Postcondition: Should throw an error for any @m@ that is not @IO@ + -- (or for which we do not have @'MonadIO' m@). + , -- === File I\/O with user-supplied buffers + + hGetBufSome :: + HasCallStack => + Handle h -> + MutableByteArray (PrimState m) -> + -- \^ Buffer to read bytes into + BufferOffset -> + -- \^ Offset into buffer + ByteCount -> + -- \^ The number of bytes to read + m ByteCount + -- ^ Like 'hGetSome', but the bytes are read into a user-supplied buffer. + -- See [__User-supplied buffers__](#user-supplied-buffers). + , hGetBufSomeAt :: + HasCallStack => + Handle h -> + MutableByteArray (PrimState m) -> + -- \^ Buffer to read bytes into + BufferOffset -> + -- \^ Offset into buffer + ByteCount -> + -- \^ The number of bytes to read + AbsOffset -> + -- \^ The file offset at which to read + m ByteCount + -- ^ Like 'hGetSomeAt', but the bytes are read into a user-supplied buffer. + -- See [__User-supplied buffers__](#user-supplied-buffers). + , hPutBufSome :: + HasCallStack => + Handle h -> + MutableByteArray (PrimState m) -> + -- \^ Buffer to write bytes from + BufferOffset -> + -- \^ Offset into buffer + ByteCount -> + -- \^ The number of bytes to write + m ByteCount + -- ^ Like 'hPutSome', but the bytes are written from a user-supplied buffer. + -- See [__User-supplied buffers__](#user-supplied-buffers). + , hPutBufSomeAt :: + HasCallStack => + Handle h -> + MutableByteArray (PrimState m) -> + -- \^ Buffer to write bytes from + BufferOffset -> + -- \^ Offset into buffer + ByteCount -> + -- \^ The number of bytes to write + AbsOffset -> + -- \^ The file offset at which to write + m ByteCount + -- ^ Like 'hPutSome', but the bytes are written from a user-supplied buffer + -- at a given file offset. This offset does not affect the offset stored in + -- the file handle (see also 'hGetSomeAt'). See [__User-supplied buffers__](#user-supplied-buffers). } {------------------------------------------------------------------------------- Opening and closing files -------------------------------------------------------------------------------} -withFile :: (HasCallStack, MonadThrow m) - => HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a +withFile :: + (HasCallStack, MonadThrow m) => + HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a withFile HasFS{..} fp openMode = bracket (hOpen fp openMode) hClose -- | Returns 'True' when the handle was still open. hClose' :: (HasCallStack, Monad m) => HasFS m h -> Handle h -> m Bool -hClose' HasFS { hClose, hIsOpen } h = do - isOpen <- hIsOpen h - if isOpen then do +hClose' HasFS{hClose, hIsOpen} h = do + isOpen <- hIsOpen h + if isOpen + then do hClose h return True else @@ -244,112 +248,146 @@ data SomeHasFS m where -- offset positions. This is similar to 'plusPtr' for 'Ptr' types. However, note -- that reading or writing from a buffer at a negative offset leads to undefined -- behaviour. -newtype BufferOffset = BufferOffset { unBufferOffset :: Int } +newtype BufferOffset = BufferOffset {unBufferOffset :: Int} deriving (Eq, Ord, Enum, Bounded, Num, Show) -- | Wrapper for 'hGetBufSome' that ensures that we read exactly as many -- bytes as requested. If EOF is found before the requested number of bytes is -- read, an 'FsError' exception is thrown. -hGetBufExactly :: forall m h. (HasCallStack, MonadThrow m) - => HasFS m h - -> Handle h - -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into - -> BufferOffset -- ^ Offset into buffer - -> ByteCount -- ^ The number of bytes to read - -> m ByteCount +hGetBufExactly :: + forall m h. + (HasCallStack, MonadThrow m) => + HasFS m h -> + Handle h -> + -- | Buffer to read bytes into + MutableByteArray (PrimState m) -> + -- | Offset into buffer + BufferOffset -> + -- | The number of bytes to read + ByteCount -> + m ByteCount hGetBufExactly hfs h buf bufOff c = go c bufOff - where - go :: ByteCount -> BufferOffset -> m ByteCount - go !remainingCount !currentBufOff - | remainingCount == 0 = pure c - | otherwise = do - readBytes <- hGetBufSome hfs h buf currentBufOff remainingCount - if readBytes == 0 then - throwIO FsError { - fsErrorType = FsReachedEOF - , fsErrorPath = mkFsErrorPath hfs $ handlePath h - , fsErrorString = "hGetBufExactly found eof before reading " ++ show c ++ " bytes" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } + where + go :: ByteCount -> BufferOffset -> m ByteCount + go !remainingCount !currentBufOff + | remainingCount == 0 = pure c + | otherwise = do + readBytes <- hGetBufSome hfs h buf currentBufOff remainingCount + if readBytes == 0 + then + throwIO + FsError + { fsErrorType = FsReachedEOF + , fsErrorPath = mkFsErrorPath hfs $ handlePath h + , fsErrorString = "hGetBufExactly found eof before reading " ++ show c ++ " bytes" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } -- We know the length <= remainingBytes, so this can't underflow. - else go (remainingCount - readBytes) - (currentBufOff + fromIntegral readBytes) + else + go + (remainingCount - readBytes) + (currentBufOff + fromIntegral readBytes) -- | Wrapper for 'hGetBufSomeAt' that ensures that we read exactly as many bytes -- as requested. If EOF is found before the requested number of bytes is read, -- an 'FsError' exception is thrown. -hGetBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m) - => HasFS m h - -> Handle h - -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into - -> BufferOffset -- ^ Offset into buffer - -> ByteCount -- ^ The number of bytes to read - -> AbsOffset -- ^ The file offset at which to read - -> m ByteCount +hGetBufExactlyAt :: + forall m h. + (HasCallStack, MonadThrow m) => + HasFS m h -> + Handle h -> + -- | Buffer to read bytes into + MutableByteArray (PrimState m) -> + -- | Offset into buffer + BufferOffset -> + -- | The number of bytes to read + ByteCount -> + -- | The file offset at which to read + AbsOffset -> + m ByteCount hGetBufExactlyAt hfs h buf bufOff c off = go c off bufOff - where - go :: ByteCount -> AbsOffset -> BufferOffset -> m ByteCount - go !remainingCount !currentOffset !currentBufOff - | remainingCount == 0 = pure c - | otherwise = do - readBytes <- hGetBufSomeAt hfs h buf currentBufOff remainingCount currentOffset - if readBytes == 0 then - throwIO FsError { - fsErrorType = FsReachedEOF - , fsErrorPath = mkFsErrorPath hfs $ handlePath h - , fsErrorString = "hGetBufExactlyAt found eof before reading " ++ show c ++ " bytes" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } + where + go :: ByteCount -> AbsOffset -> BufferOffset -> m ByteCount + go !remainingCount !currentOffset !currentBufOff + | remainingCount == 0 = pure c + | otherwise = do + readBytes <- hGetBufSomeAt hfs h buf currentBufOff remainingCount currentOffset + if readBytes == 0 + then + throwIO + FsError + { fsErrorType = FsReachedEOF + , fsErrorPath = mkFsErrorPath hfs $ handlePath h + , fsErrorString = "hGetBufExactlyAt found eof before reading " ++ show c ++ " bytes" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } -- We know the length <= remainingBytes, so this can't underflow. - else go (remainingCount - readBytes) - (currentOffset + fromIntegral readBytes) - (currentBufOff + fromIntegral readBytes) + else + go + (remainingCount - readBytes) + (currentOffset + fromIntegral readBytes) + (currentBufOff + fromIntegral readBytes) -- | Wrapper for 'hPutBufSome' that ensures we write exactly as many bytes as -- requested. -hPutBufExactly :: forall m h. (HasCallStack, MonadThrow m) - => HasFS m h - -> Handle h - -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from - -> BufferOffset -- ^ Offset into buffer - -> ByteCount -- ^ The number of bytes to write - -> m ByteCount +hPutBufExactly :: + forall m h. + (HasCallStack, MonadThrow m) => + HasFS m h -> + Handle h -> + -- | Buffer to write bytes from + MutableByteArray (PrimState m) -> + -- | Offset into buffer + BufferOffset -> + -- | The number of bytes to write + ByteCount -> + m ByteCount hPutBufExactly hbfs h buf bufOff c = go c bufOff - where - go :: ByteCount -> BufferOffset -> m ByteCount - go !remainingCount !currentBufOff = do - writtenBytes <- hPutBufSome hbfs h buf currentBufOff remainingCount - let remainingCount' = remainingCount - writtenBytes - if remainingCount' == 0 - then pure c - else go remainingCount' - (currentBufOff + fromIntegral writtenBytes) + where + go :: ByteCount -> BufferOffset -> m ByteCount + go !remainingCount !currentBufOff = do + writtenBytes <- hPutBufSome hbfs h buf currentBufOff remainingCount + let remainingCount' = remainingCount - writtenBytes + if remainingCount' == 0 + then pure c + else + go + remainingCount' + (currentBufOff + fromIntegral writtenBytes) -- | Wrapper for 'hPutBufSomeAt' that ensures we write exactly as many bytes as -- requested. -hPutBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m) - => HasFS m h - -> Handle h - -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from - -> BufferOffset -- ^ Offset into buffer - -> ByteCount -- ^ The number of bytes to write - -> AbsOffset -- ^ The file offset at which to write - -> m ByteCount +hPutBufExactlyAt :: + forall m h. + (HasCallStack, MonadThrow m) => + HasFS m h -> + Handle h -> + -- | Buffer to write bytes from + MutableByteArray (PrimState m) -> + -- | Offset into buffer + BufferOffset -> + -- | The number of bytes to write + ByteCount -> + -- | The file offset at which to write + AbsOffset -> + m ByteCount hPutBufExactlyAt hbfs h buf bufOff c off = go c off bufOff - where - go :: ByteCount -> AbsOffset -> BufferOffset -> m ByteCount - go !remainingCount !currentOffset !currentBufOff = do - writtenBytes <- hPutBufSomeAt hbfs h buf currentBufOff remainingCount currentOffset - let remainingCount' = remainingCount - writtenBytes - if remainingCount' == 0 - then pure c - else go remainingCount' - (currentOffset + fromIntegral writtenBytes) - (currentBufOff + fromIntegral writtenBytes) + where + go :: ByteCount -> AbsOffset -> BufferOffset -> m ByteCount + go !remainingCount !currentOffset !currentBufOff = do + writtenBytes <- hPutBufSomeAt hbfs h buf currentBufOff remainingCount currentOffset + let remainingCount' = remainingCount - writtenBytes + if remainingCount' == 0 + then pure c + else + go + remainingCount' + (currentOffset + fromIntegral writtenBytes) + (currentBufOff + fromIntegral writtenBytes) {------------------------------------------------------------------------------- Other @@ -358,14 +396,32 @@ hPutBufExactlyAt hbfs h buf bufOff c off = go c off bufOff -- Without this, the module won't compile because the instance below is in the -- same declaration group as the datatype definition. For more info, see -- https://blog.monadfix.com/th-groups. -$(pure[]) +$(pure []) instance NFData (HasFS m h) where rnf $(fields 'HasFS) = - dumpState `seq` hOpen `seq` hClose `seq` hIsOpen `seq` hSeek `seq` - hGetSome `seq`hGetSomeAt `seq` hPutSome `seq` hTruncate `seq` - hGetSize `seq` createDirectory `seq` createDirectoryIfMissing `seq` - listDirectory `seq` doesDirectoryExist `seq` doesFileExist `seq` - removeDirectoryRecursive `seq` removeFile `seq` renameFile `seq` - mkFsErrorPath `seq` unsafeToFilePath `seq` hGetBufSome `seq` - hGetBufSomeAt `seq` hPutBufSome `seq` hPutBufSomeAt `seq` () + dumpState `seq` + hOpen `seq` + hClose `seq` + hIsOpen `seq` + hSeek `seq` + hGetSome `seq` + hGetSomeAt `seq` + hPutSome `seq` + hTruncate `seq` + hGetSize `seq` + createDirectory `seq` + createDirectoryIfMissing `seq` + listDirectory `seq` + doesDirectoryExist `seq` + doesFileExist `seq` + removeDirectoryRecursive `seq` + removeFile `seq` + renameFile `seq` + mkFsErrorPath `seq` + unsafeToFilePath `seq` + hGetBufSome `seq` + hGetBufSomeAt `seq` + hPutBufSome `seq` + hPutBufSomeAt `seq` + () diff --git a/fs-api/src/System/FS/API/Lazy.hs b/fs-api/src/System/FS/API/Lazy.hs index 9d6a7ab..bed081e 100644 --- a/fs-api/src/System/FS/API/Lazy.hs +++ b/fs-api/src/System/FS/API/Lazy.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module System.FS.API.Lazy ( - -- * API +module System.FS.API.Lazy + ( -- * API module API + -- * Lazy functions , hGetAll , hGetAllAt @@ -13,126 +14,142 @@ module System.FS.API.Lazy ( , hPutAll ) where -import Control.Monad (foldM) -import Control.Monad.Class.MonadThrow (MonadThrow (throwIO)) +import Control.Monad (foldM) +import Control.Monad.Class.MonadThrow (MonadThrow (throwIO)) import qualified Data.ByteString as BS -import Data.ByteString.Builder (Builder) +import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Lazy as BL -import Data.Word (Word64) -import System.FS.API as API -import System.FS.API.Strict -import System.FS.CallStack (HasCallStack, prettyCallStack) +import Data.Word (Word64) +import System.FS.API as API +import System.FS.API.Strict +import System.FS.CallStack (HasCallStack, prettyCallStack) -- | Makes sure it reads all requested bytes. -- If eof is found before all bytes are read, it throws an exception. -hGetExactly :: forall m h. (HasCallStack, MonadThrow m) - => HasFS m h - -> Handle h - -> Word64 - -> m BL.ByteString +hGetExactly :: + forall m h. + (HasCallStack, MonadThrow m) => + HasFS m h -> + Handle h -> + Word64 -> + m BL.ByteString hGetExactly hasFS h n = go n [] - where - go :: Word64 -> [BS.ByteString] -> m BL.ByteString - go remainingBytes acc - | remainingBytes == 0 = return $ BL.fromChunks $ reverse acc - | otherwise = do + where + go :: Word64 -> [BS.ByteString] -> m BL.ByteString + go remainingBytes acc + | remainingBytes == 0 = return $ BL.fromChunks $ reverse acc + | otherwise = do bs <- hGetSome hasFS h remainingBytes - if BS.null bs then - throwIO FsError { - fsErrorType = FsReachedEOF - , fsErrorPath = mkFsErrorPath hasFS $ handlePath h - , fsErrorString = "hGetExactly found eof before reading " ++ show n ++ " bytes" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - -- We know the length <= remainingBytes, so this can't underflow - else go (remainingBytes - fromIntegral (BS.length bs)) (bs : acc) + if BS.null bs + then + throwIO + FsError + { fsErrorType = FsReachedEOF + , fsErrorPath = mkFsErrorPath hasFS $ handlePath h + , fsErrorString = "hGetExactly found eof before reading " ++ show n ++ " bytes" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + -- We know the length <= remainingBytes, so this can't underflow + else go (remainingBytes - fromIntegral (BS.length bs)) (bs : acc) -- | Like 'hGetExactly', but is thread safe since it does not change or depend -- on the file offset. @pread@ syscall is used internally. -hGetExactlyAt :: forall m h. (HasCallStack, MonadThrow m) - => HasFS m h - -> Handle h - -> Word64 -- ^ The number of bytes to read. - -> AbsOffset -- ^ The offset at which to read. - -> m BL.ByteString +hGetExactlyAt :: + forall m h. + (HasCallStack, MonadThrow m) => + HasFS m h -> + Handle h -> + -- | The number of bytes to read. + Word64 -> + -- | The offset at which to read. + AbsOffset -> + m BL.ByteString hGetExactlyAt hasFS h n offset = go n offset [] - where - go :: Word64 -> AbsOffset -> [BS.ByteString] -> m BL.ByteString - go remainingBytes currentOffset acc - | remainingBytes == 0 = return $ BL.fromChunks $ reverse acc - | otherwise = do + where + go :: Word64 -> AbsOffset -> [BS.ByteString] -> m BL.ByteString + go remainingBytes currentOffset acc + | remainingBytes == 0 = return $ BL.fromChunks $ reverse acc + | otherwise = do bs <- hGetSomeAt hasFS h remainingBytes currentOffset let readBytes = BS.length bs - if BS.null bs then - throwIO FsError { - fsErrorType = FsReachedEOF - , fsErrorPath = mkFsErrorPath hasFS $ handlePath h - , fsErrorString = "hGetExactlyAt found eof before reading " ++ show n ++ " bytes" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - -- We know the length <= remainingBytes, so this can't underflow. - else go (remainingBytes - fromIntegral readBytes) - (currentOffset + fromIntegral readBytes) - (bs : acc) + if BS.null bs + then + throwIO + FsError + { fsErrorType = FsReachedEOF + , fsErrorPath = mkFsErrorPath hasFS $ handlePath h + , fsErrorString = "hGetExactlyAt found eof before reading " ++ show n ++ " bytes" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + -- We know the length <= remainingBytes, so this can't underflow. + else + go + (remainingBytes - fromIntegral readBytes) + (currentOffset + fromIntegral readBytes) + (bs : acc) -- | Read all the data from the given file handle 64kB at a time. -- -- Stops when EOF is reached. hGetAll :: Monad m => HasFS m h -> Handle h -> m BL.ByteString hGetAll HasFS{..} hnd = go mempty - where - bufferSize = 64 * 1024 - go acc = do - chunk <- hGetSome hnd bufferSize - let acc' = chunk : acc - if BS.null chunk - then return $ BL.fromChunks $ reverse acc' - else go acc' + where + bufferSize = 64 * 1024 + go acc = do + chunk <- hGetSome hnd bufferSize + let acc' = chunk : acc + if BS.null chunk + then return $ BL.fromChunks $ reverse acc' + else go acc' -- | Like 'hGetAll', but is thread safe since it does not change or depend -- on the file offset. @pread@ syscall is used internally. -hGetAllAt :: Monad m - => HasFS m h - -> Handle h - -> AbsOffset -- ^ The offset at which to read. - -> m BL.ByteString +hGetAllAt :: + Monad m => + HasFS m h -> + Handle h -> + -- | The offset at which to read. + AbsOffset -> + m BL.ByteString hGetAllAt HasFS{..} hnd = go mempty - where - bufferSize = 64 * 1024 - go acc offset = do - chunk <- hGetSomeAt hnd bufferSize offset - let acc' = chunk : acc - if BS.null chunk - then return $ BL.fromChunks $ reverse acc' - else go acc' (offset + fromIntegral (BS.length chunk)) + where + bufferSize = 64 * 1024 + go acc offset = do + chunk <- hGetSomeAt hnd bufferSize offset + let acc' = chunk : acc + if BS.null chunk + then return $ BL.fromChunks $ reverse acc' + else go acc' (offset + fromIntegral (BS.length chunk)) -- | This function makes sure that the whole 'BL.ByteString' is written. -hPutAll :: forall m h - . (HasCallStack, Monad m) - => HasFS m h - -> Handle h - -> BL.ByteString - -> m Word64 +hPutAll :: + forall m h. + (HasCallStack, Monad m) => + HasFS m h -> + Handle h -> + BL.ByteString -> + m Word64 hPutAll hasFS h = foldM putChunk 0 . BL.toChunks - where - putChunk :: Word64 -> BS.ByteString -> m Word64 - putChunk written chunk = do - written' <- hPutAllStrict hasFS h chunk - return $! written + written' + where + putChunk :: Word64 -> BS.ByteString -> m Word64 + putChunk written chunk = do + written' <- hPutAllStrict hasFS h chunk + return $! written + written' -- | This function makes sure that the whole 'Builder' is written. -- -- The chunk size of the resulting 'BL.ByteString' determines how much memory -- will be used while writing to the handle. -hPut :: forall m h - . (HasCallStack, Monad m) - => HasFS m h - -> Handle h - -> Builder - -> m Word64 +hPut :: + forall m h. + (HasCallStack, Monad m) => + HasFS m h -> + Handle h -> + Builder -> + m Word64 hPut hasFS g = hPutAll hasFS g . BS.toLazyByteString diff --git a/fs-api/src/System/FS/API/Strict.hs b/fs-api/src/System/FS/API/Strict.hs index 94dbe92..cb9feff 100644 --- a/fs-api/src/System/FS/API/Strict.hs +++ b/fs-api/src/System/FS/API/Strict.hs @@ -1,32 +1,34 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} -module System.FS.API.Strict ( - -- * API +module System.FS.API.Strict + ( -- * API module API + -- * Strict functions , hPutAllStrict ) where import qualified Data.ByteString as BS -import Data.Word -import System.FS.API as API -import System.FS.CallStack +import Data.Word +import System.FS.API as API +import System.FS.CallStack -- | This function makes sure that the whole 'BS.ByteString' is written. -hPutAllStrict :: forall m h - . (HasCallStack, Monad m) - => HasFS m h - -> Handle h - -> BS.ByteString - -> m Word64 +hPutAllStrict :: + forall m h. + (HasCallStack, Monad m) => + HasFS m h -> + Handle h -> + BS.ByteString -> + m Word64 hPutAllStrict hasFS h = go 0 - where - go :: Word64 -> BS.ByteString -> m Word64 - go !written bs = do - n <- hPutSome hasFS h bs - let bs' = BS.drop (fromIntegral n) bs - written' = written + n - if BS.null bs' - then return written' - else go written' bs' + where + go :: Word64 -> BS.ByteString -> m Word64 + go !written bs = do + n <- hPutSome hasFS h bs + let bs' = BS.drop (fromIntegral n) bs + written' = written + n + if BS.null bs' + then return written' + else go written' bs' diff --git a/fs-api/src/System/FS/API/Types.hs b/fs-api/src/System/FS/API/Types.hs index ccc44f7..122e498 100644 --- a/fs-api/src/System/FS/API/Types.hs +++ b/fs-api/src/System/FS/API/Types.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -module System.FS.API.Types ( - -- * Modes +module System.FS.API.Types + ( -- * Modes AllowExisting (..) , OpenMode (..) , SeekMode (..) , allowExisting + -- * Paths , MountPoint (..) , fsFromFilePath @@ -24,12 +25,16 @@ module System.FS.API.Types ( , addExtension , () , combine + -- ** opaque , FsPath + -- * Handles , Handle (..) + -- * Offset , AbsOffset (..) + -- * Errors , FsError (..) , FsErrorPath (..) @@ -40,31 +45,31 @@ module System.FS.API.Types ( , isFsErrorType , prettyFsError , sameFsError + -- * From 'IOError' to 'FsError' , ioToFsError , ioToFsErrorType ) where -import Control.DeepSeq (NFData (..), force) -import Control.Exception -import Data.Function (on) -import Data.List (intercalate, stripPrefix) -import Data.Maybe (isJust) +import Control.DeepSeq (NFData (..), force) +import Control.Exception +import Data.Function (on) +import Data.List (intercalate, stripPrefix) +import Data.Maybe (isJust) import qualified Data.Text as Strict import qualified Data.Text as Text -import Data.Word -import Foreign.C.Error (Errno (..)) +import Data.Word +import Foreign.C.Error (Errno (..)) import qualified Foreign.C.Error as C -import GHC.Generics (Generic) +import GHC.Generics (Generic) import qualified GHC.IO.Exception as GHC -import GHC.Show (showCommaSpace) +import GHC.Show (showCommaSpace) +import System.FS.CallStack +import System.FS.Condense import qualified System.FilePath as FilePath -import System.IO (SeekMode (..)) +import System.IO (SeekMode (..)) import qualified System.IO.Error as IO -import System.FS.CallStack -import System.FS.Condense - {------------------------------------------------------------------------------- Modes -------------------------------------------------------------------------------} @@ -81,32 +86,32 @@ import System.FS.Condense -- 0 bytes of data and is hence a useless operation. data OpenMode = ReadMode - | WriteMode AllowExisting - | AppendMode AllowExisting + | WriteMode AllowExisting + | AppendMode AllowExisting | ReadWriteMode AllowExisting deriving (Eq, Show) -- | When opening a file: data AllowExisting - = AllowExisting - -- ^ The file may already exist. If it does, it is reopened. If it + = -- | The file may already exist. If it does, it is reopened. If it -- doesn't, it is created. - | MustBeNew - -- ^ The file must not yet exist. If it does, an error + AllowExisting + | -- | The file must not yet exist. If it does, an error -- ('FsResourceAlreadyExist') is thrown. - | MustExist - -- ^ The file must already exist. If it does not, an error + MustBeNew + | -- | The file must already exist. If it does not, an error -- ('FsResourceDoesNotExist') is thrown. -- -- /Note:/ If opening a file in 'ReadMode', then the file must exist -- or an exception is thrown. + MustExist deriving (Eq, Show) allowExisting :: OpenMode -> AllowExisting allowExisting openMode = case openMode of - ReadMode -> MustExist - WriteMode ex -> ex - AppendMode ex -> ex + ReadMode -> MustExist + WriteMode ex -> ex + AppendMode ex -> ex ReadWriteMode ex -> ex {------------------------------------------------------------------------------- @@ -134,7 +139,7 @@ allowExisting openMode = case openMode of -- \"@..@\" should not be used because @fs-sim@ will not be able to follow these -- types of back-links. @fs-sim@ will interpret \"@..@\" as a directory name -- instead. -newtype FsPath = UnsafeFsPath { fsPathToList :: [Strict.Text] } +newtype FsPath = UnsafeFsPath {fsPathToList :: [Strict.Text]} deriving (Eq, Ord, Generic) deriving newtype NFData @@ -158,41 +163,43 @@ mkFsPath = fsPathFromList . map Strict.pack -- Like @init@ and @last@, 'Nothing' if empty. fsPathSplit :: FsPath -> Maybe (FsPath, Strict.Text) fsPathSplit fp = - case reverse (fsPathToList fp) of - [] -> Nothing - p:ps -> Just (fsPathFromList (reverse ps), p) + case reverse (fsPathToList fp) of + [] -> Nothing + p : ps -> Just (fsPathFromList (reverse ps), p) -- | Drop the final component of the path -- -- Undefined if the path is empty. fsPathInit :: HasCallStack => FsPath -> FsPath fsPathInit fp = case fsPathSplit fp of - Nothing -> error $ "fsPathInit: empty path" - Just (fp', _) -> fp' + Nothing -> error $ "fsPathInit: empty path" + Just (fp', _) -> fp' -- | An alias for '<.>'. addExtension :: FsPath -> String -> FsPath addExtension = (<.>) infixr 7 <.> + -- | Add an extension, even if there is already one there. -- -- This works similarly to 'Filepath.<.>'. (<.>) :: FsPath -> String -> FsPath path <.> [] = path path <.> ext = case fsPathSplit path of - Nothing -> mkFsPath [ext'] - Just (dir, file) -> dir UnsafeFsPath [file `Text.append` Text.pack ext'] - where - ext' = case ext of - '.':_ -> ext - _ -> '.':ext + Nothing -> mkFsPath [ext'] + Just (dir, file) -> dir UnsafeFsPath [file `Text.append` Text.pack ext'] + where + ext' = case ext of + '.' : _ -> ext + _ -> '.' : ext -- | An alias for ''. combine :: FsPath -> FsPath -> FsPath combine = () infixr 5 + -- | Combine two paths with a path separator. -- -- This works similarly to 'Filepath.', but since the arguments are @@ -204,9 +211,9 @@ infixr 5 -- combining two empty paths is the empty path () :: FsPath -> FsPath -> FsPath UnsafeFsPath x UnsafeFsPath y = case (x, y) of - ([], _) -> UnsafeFsPath y - (_, []) -> UnsafeFsPath x - _ -> fsPathFromList (x ++ y) + ([], _) -> UnsafeFsPath y + (_, []) -> UnsafeFsPath x + _ -> fsPathFromList (x ++ y) -- | Mount point -- @@ -216,11 +223,12 @@ newtype MountPoint = MountPoint FilePath fsToFilePath :: MountPoint -> FsPath -> FilePath fsToFilePath (MountPoint mp) fp = - mp FilePath. foldr (FilePath.) "" (map Strict.unpack $ fsPathToList fp) + mp FilePath. foldr (FilePath.) "" (map Strict.unpack $ fsPathToList fp) fsFromFilePath :: MountPoint -> FilePath -> Maybe FsPath -fsFromFilePath (MountPoint mp) path = mkFsPath <$> - stripPrefix (FilePath.splitDirectories mp) (FilePath.splitDirectories path) +fsFromFilePath (MountPoint mp) path = + mkFsPath + <$> stripPrefix (FilePath.splitDirectories mp) (FilePath.splitDirectories path) -- | For better error reporting to the end user, we want to include the -- mount point of the file. But the mountpoint may not always be available, @@ -236,7 +244,7 @@ fsToFsErrorPathUnmounted = FsErrorPath Nothing instance Show FsErrorPath where show (FsErrorPath (Just mp) fp) = fsToFilePath mp fp - show (FsErrorPath Nothing fp) = show fp + show (FsErrorPath Nothing fp) = show fp instance Condense FsErrorPath where condense = show @@ -250,19 +258,18 @@ instance Eq FsErrorPath where Handles -------------------------------------------------------------------------------} -data Handle h = Handle { - -- | The raw underlying handle - handleRaw :: !h - - -- | The path corresponding to this handle - -- - -- This is primarily useful for error reporting. - , handlePath :: !FsPath - } - deriving (Generic) +data Handle h = Handle + { handleRaw :: !h + -- ^ The raw underlying handle + , handlePath :: !FsPath + -- ^ The path corresponding to this handle + -- + -- This is primarily useful for error reporting. + } + deriving Generic instance NFData h => NFData (Handle h) where - rnf (Handle handleRaw handlePath) = rnf handleRaw `seq` rnf handlePath + rnf (Handle handleRaw handlePath) = rnf handleRaw `seq` rnf handlePath instance Eq h => Eq (Handle h) where (==) = (==) `on` handleRaw @@ -270,80 +277,92 @@ instance Eq h => Eq (Handle h) where instance Show (Handle h) where show (Handle _ fp) = "") fp ++ ">" - {------------------------------------------------------------------------------- Offset wrappers -------------------------------------------------------------------------------} -newtype AbsOffset = AbsOffset { unAbsOffset :: Word64 } +newtype AbsOffset = AbsOffset {unAbsOffset :: Word64} deriving (Eq, Ord, Enum, Bounded, Num, Show) {------------------------------------------------------------------------------- Errors -------------------------------------------------------------------------------} -data FsError = FsError { - -- | Error type - fsErrorType :: FsErrorType - - -- | Path to the file - , fsErrorPath :: FsErrorPath - - -- | Human-readable string giving additional information about the error - , fsErrorString :: String - - -- | The 'Errno', if available. This is more precise than the - -- 'FsErrorType'. - , fsErrorNo :: Maybe Errno - - -- | Call stack - , fsErrorStack :: PrettyCallStack - - -- | Is this error due to a limitation of the mock file system? - -- - -- The mock file system does not all of Posix's features and quirks. - -- This flag will be set for such unsupported IO calls. Real I/O calls - -- would not have thrown an error for these calls. - , fsLimitation :: Bool - } +data FsError = FsError + { fsErrorType :: FsErrorType + -- ^ Error type + , fsErrorPath :: FsErrorPath + -- ^ Path to the file + , fsErrorString :: String + -- ^ Human-readable string giving additional information about the error + , fsErrorNo :: Maybe Errno + -- ^ The 'Errno', if available. This is more precise than the + -- 'FsErrorType'. + , fsErrorStack :: PrettyCallStack + -- ^ Call stack + , fsLimitation :: Bool + -- ^ Is this error due to a limitation of the mock file system? + -- + -- The mock file system does not all of Posix's features and quirks. + -- This flag will be set for such unsupported IO calls. Real I/O calls + -- would not have thrown an error for these calls. + } -- This is a custom instance and not an auto-derive one, since 'Errno' does not -- have a 'Show' instance, and we don't want to provide an orphan instance for -- this @base@ type. instance Show FsError where - showsPrec n fserr = showParen (n >= 11) $ - showString "FsError {" - . showString "fsErrorType = " . shows fsErrorType . showCommaSpace - . showString "fsErrorPath = " . shows fsErrorPath . showCommaSpace - . showString "fsErrorString = " . shows fsErrorString . showCommaSpace - . showString "fsErrorNo = " . showsFsErrNo fsErrorNo . showCommaSpace - . showString "fsErrorStack = " . shows fsErrorStack . showCommaSpace - . showString "fsLimitation = " . shows fsLimitation - . showString "}" - where - -- Quite a bit of boilerplate, but it should ensure that we won't silently - -- change/forget to change the Show instance when fields are - -- changed/re-ordered/added. - FsError { - fsErrorType = fsErrorType :: FsErrorType - , fsErrorPath = fsErrorPath :: FsErrorPath - , fsErrorString = fsErrorString :: String - , fsErrorNo = fsErrorNo :: Maybe Errno - , fsErrorStack = fsErrorStack :: PrettyCallStack - , fsLimitation = fsLimitation :: Bool - } = fserr - _coveredAllCases = case fserr of - FsError (_ :: FsErrorType) (_ :: FsErrorPath) (_ :: String) - (_ :: Maybe Errno) (_ :: PrettyCallStack) (_ :: Bool) -> () - - showsFsErrNo Nothing = showString "Nothing" - showsFsErrNo (Just (Errno e)) = showString "Just " - . showParen True (showString "Errno " . shows e) + showsPrec n fserr = + showParen (n >= 11) $ + showString "FsError {" + . showString "fsErrorType = " + . shows fsErrorType + . showCommaSpace + . showString "fsErrorPath = " + . shows fsErrorPath + . showCommaSpace + . showString "fsErrorString = " + . shows fsErrorString + . showCommaSpace + . showString "fsErrorNo = " + . showsFsErrNo fsErrorNo + . showCommaSpace + . showString "fsErrorStack = " + . shows fsErrorStack + . showCommaSpace + . showString "fsLimitation = " + . shows fsLimitation + . showString "}" + where + -- Quite a bit of boilerplate, but it should ensure that we won't silently + -- change/forget to change the Show instance when fields are + -- changed/re-ordered/added. + FsError + { fsErrorType = fsErrorType :: FsErrorType + , fsErrorPath = fsErrorPath :: FsErrorPath + , fsErrorString = fsErrorString :: String + , fsErrorNo = fsErrorNo :: Maybe Errno + , fsErrorStack = fsErrorStack :: PrettyCallStack + , fsLimitation = fsLimitation :: Bool + } = fserr + _coveredAllCases = case fserr of + FsError + (_ :: FsErrorType) + (_ :: FsErrorPath) + (_ :: String) + (_ :: Maybe Errno) + (_ :: PrettyCallStack) + (_ :: Bool) -> () + + showsFsErrNo Nothing = showString "Nothing" + showsFsErrNo (Just (Errno e)) = + showString "Just " + . showParen True (showString "Errno " . shows e) data FsErrorType = FsIllegalOperation - | FsResourceInappropriateType - -- ^ e.g the user tried to open a directory with hOpen rather than a file. + | -- | e.g the user tried to open a directory with hOpen rather than a file. + FsResourceInappropriateType | FsResourceAlreadyInUse | FsResourceDoesNotExist | FsResourceAlreadyExist @@ -352,26 +371,28 @@ data FsErrorType | FsTooManyOpenFiles | FsInsufficientPermissions | FsInvalidArgument - | FsOther - -- ^ Used for all other error types + | -- | Used for all other error types + FsOther deriving (Show, Eq) instance Exception FsError where - displayException = prettyFsError + displayException = prettyFsError -- | Check if two errors are semantically the same error -- -- This ignores the error string, the errno, and the callstack. sameFsError :: FsError -> FsError -> Bool -sameFsError e e' = fsErrorType e == fsErrorType e' - && fsErrorPath e == fsErrorPath e' +sameFsError e e' = + fsErrorType e == fsErrorType e' + && fsErrorPath e == fsErrorPath e' isFsErrorType :: FsErrorType -> FsError -> Bool isFsErrorType ty e = fsErrorType e == ty prettyFsError :: FsError -> String -prettyFsError FsError{..} = concat [ - show fsErrorType +prettyFsError FsError{..} = + concat + [ show fsErrorType , " for " , show fsErrorPath , ": " @@ -392,19 +413,21 @@ hasMountPoint FsError{fsErrorPath = FsErrorPath mp _} = isJust mp -- We take the 'FsPath' as an argument. We could try to translate back from a -- 'FilePath' to an 'FsPath' (given a 'MountPoint'), but we know the 'FsPath' -- at all times anyway and not all IO exceptions actually include a filepath. -ioToFsError :: HasCallStack - => FsErrorPath -> IOError -> FsError -ioToFsError fep ioErr = FsError - { fsErrorType = ioToFsErrorType ioErr - , fsErrorPath = fep - -- We don't use 'ioeGetErrorString', because that only returns the +ioToFsError :: + HasCallStack => + FsErrorPath -> IOError -> FsError +ioToFsError fep ioErr = + FsError + { fsErrorType = ioToFsErrorType ioErr + , fsErrorPath = fep + , -- We don't use 'ioeGetErrorString', because that only returns the -- description in case 'isUserErrorType' is true, otherwise it will -- return 'ioToFsErrorType', which we already include in 'fsErrorType'. -- So we use the underlying field directly. - , fsErrorString = GHC.ioe_description ioErr - , fsErrorNo = Errno <$> GHC.ioe_errno ioErr - , fsErrorStack = prettyCallStack - , fsLimitation = False + fsErrorString = GHC.ioe_description ioErr + , fsErrorNo = Errno <$> GHC.ioe_errno ioErr + , fsErrorStack = prettyCallStack + , fsLimitation = False } -- | Assign an 'FsErrorType' to the given 'IOError'. @@ -420,46 +443,37 @@ ioToFsError fep ioErr = FsError -- See the ERRNO(3) man page for the meaning of the different errnos. ioToFsErrorType :: IOError -> FsErrorType ioToFsErrorType ioErr = case Errno <$> GHC.ioe_errno ioErr of - Just errno - | errno == C.eACCES - || errno == C.eROFS - || errno == C.ePERM - -> FsInsufficientPermissions - - | errno == C.eNOSPC - -> FsDeviceFull - - | errno == C.eMFILE - || errno == C.eNFILE - -> FsTooManyOpenFiles - - | errno == C.eNOENT - || errno == C.eNXIO - -> FsResourceDoesNotExist - - _ | IO.isAlreadyInUseErrorType eType - -> FsResourceAlreadyInUse - - | IO.isAlreadyExistsErrorType eType - -> FsResourceAlreadyExist - - | IO.isEOFErrorType eType - -> FsReachedEOF - - | IO.isIllegalOperationErrorType eType - -> FsIllegalOperation - - | eType == GHC.InappropriateType - -> FsResourceInappropriateType - - | eType == GHC.InvalidArgument - -> FsInvalidArgument - - | otherwise - -> FsOther - where - eType :: IO.IOErrorType - eType = IO.ioeGetErrorType ioErr + Just errno + | errno == C.eACCES + || errno == C.eROFS + || errno == C.ePERM -> + FsInsufficientPermissions + | errno == C.eNOSPC -> + FsDeviceFull + | errno == C.eMFILE + || errno == C.eNFILE -> + FsTooManyOpenFiles + | errno == C.eNOENT + || errno == C.eNXIO -> + FsResourceDoesNotExist + _ + | IO.isAlreadyInUseErrorType eType -> + FsResourceAlreadyInUse + | IO.isAlreadyExistsErrorType eType -> + FsResourceAlreadyExist + | IO.isEOFErrorType eType -> + FsReachedEOF + | IO.isIllegalOperationErrorType eType -> + FsIllegalOperation + | eType == GHC.InappropriateType -> + FsResourceInappropriateType + | eType == GHC.InvalidArgument -> + FsInvalidArgument + | otherwise -> + FsOther + where + eType :: IO.IOErrorType + eType = IO.ioeGetErrorType ioErr {------------------------------------------------------------------------------- Condense instances @@ -467,14 +481,14 @@ ioToFsErrorType ioErr = case Errno <$> GHC.ioe_errno ioErr of instance Condense AllowExisting where condense AllowExisting = "" - condense MustBeNew = "!" - condense MustExist = "+" + condense MustBeNew = "!" + condense MustExist = "+" instance Condense OpenMode where - condense ReadMode = "r" - condense (WriteMode ex) = "w" ++ condense ex - condense (ReadWriteMode ex) = "rw" ++ condense ex - condense (AppendMode ex) = "a" ++ condense ex + condense ReadMode = "r" + condense (WriteMode ex) = "w" ++ condense ex + condense (ReadWriteMode ex) = "rw" ++ condense ex + condense (AppendMode ex) = "a" ++ condense ex instance Condense (Handle h) where condense = show diff --git a/fs-api/src/System/FS/CRC.hs b/fs-api/src/System/FS/CRC.hs index 1a8b69d..ca566db 100644 --- a/fs-api/src/System/FS/CRC.hs +++ b/fs-api/src/System/FS/CRC.hs @@ -1,39 +1,40 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Support for CRC -module System.FS.CRC ( - -- * Wrap digest functionality +module System.FS.CRC + ( -- * Wrap digest functionality CRC (..) , computeCRC , initCRC , updateCRC + -- * File system functions with CRC functionality , hGetAllAtCRC , hGetExactlyAtCRC , hPutAllCRC ) where -import Control.Monad (foldM) -import Control.Monad.Class.MonadThrow +import Control.Monad (foldM) +import Control.Monad.Class.MonadThrow import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL -import Data.Coerce +import Data.Coerce import qualified Data.Digest.CRC32 as Digest -import Data.Word -import Foreign.Storable (Storable) -import GHC.Generics (Generic) -import GHC.Stack -import System.FS.API.Lazy -import System.FS.API.Strict +import Data.Word +import Foreign.Storable (Storable) +import GHC.Generics (Generic) +import GHC.Stack +import System.FS.API.Lazy +import System.FS.API.Strict {------------------------------------------------------------------------------- Wrap functionality from digest -------------------------------------------------------------------------------} -newtype CRC = CRC { getCRC :: Word32 } +newtype CRC = CRC {getCRC :: Word32} deriving (Eq, Show, Generic, Storable) initCRC :: CRC @@ -50,43 +51,52 @@ computeCRC = coerce (Digest.crc32 :: a -> Word32) -------------------------------------------------------------------------------} -- | Variation on 'hPutAll' that also computes a CRC -hPutAllCRC :: forall m h. (HasCallStack, Monad m) - => HasFS m h - -> Handle h - -> BL.ByteString - -> m (Word64, CRC) +hPutAllCRC :: + forall m h. + (HasCallStack, Monad m) => + HasFS m h -> + Handle h -> + BL.ByteString -> + m (Word64, CRC) hPutAllCRC hasFS h = foldM putChunk (0, initCRC) . BL.toChunks - where - putChunk :: (Word64, CRC) -> BS.ByteString -> m (Word64, CRC) - putChunk (written, crc) chunk = do - chunkSize <- hPutAllStrict hasFS h chunk - let !written' = written + chunkSize - !crc' = updateCRC chunk crc - return (written', crc') + where + putChunk :: (Word64, CRC) -> BS.ByteString -> m (Word64, CRC) + putChunk (written, crc) chunk = do + chunkSize <- hPutAllStrict hasFS h chunk + let !written' = written + chunkSize + !crc' = updateCRC chunk crc + return (written', crc') -- | Variation on 'hGetExactlyAt' that also computes a CRC -hGetExactlyAtCRC :: forall m h. (HasCallStack, MonadThrow m) - => HasFS m h - -> Handle h - -> Word64 -- ^ The number of bytes to read. - -> AbsOffset -- ^ The offset at which to read. - -> m (BL.ByteString, CRC) +hGetExactlyAtCRC :: + forall m h. + (HasCallStack, MonadThrow m) => + HasFS m h -> + Handle h -> + -- | The number of bytes to read. + Word64 -> + -- | The offset at which to read. + AbsOffset -> + m (BL.ByteString, CRC) hGetExactlyAtCRC hasFS h n offset = do - -- TODO Interleave reading with computing the CRC. Better cache locality - -- and fits better with incremental parsing, when we add support for that. - bs <- hGetExactlyAt hasFS h n offset - let !crc = computeCRC bs - return (bs, crc) + -- TODO Interleave reading with computing the CRC. Better cache locality + -- and fits better with incremental parsing, when we add support for that. + bs <- hGetExactlyAt hasFS h n offset + let !crc = computeCRC bs + return (bs, crc) -- | Variation on 'hGetAllAt' that also computes a CRC -hGetAllAtCRC :: forall m h. Monad m - => HasFS m h - -> Handle h - -> AbsOffset -- ^ The offset at which to read. - -> m (BL.ByteString, CRC) +hGetAllAtCRC :: + forall m h. + Monad m => + HasFS m h -> + Handle h -> + -- | The offset at which to read. + AbsOffset -> + m (BL.ByteString, CRC) hGetAllAtCRC hasFS h offset = do - -- TODO Interleave reading with computing the CRC. Better cache locality - -- and fits better with incremental parsing, when we add support for that. - bs <- hGetAllAt hasFS h offset - let !crc = computeCRC bs - return (bs, crc) + -- TODO Interleave reading with computing the CRC. Better cache locality + -- and fits better with incremental parsing, when we add support for that. + bs <- hGetAllAt hasFS h offset + let !crc = computeCRC bs + return (bs, crc) diff --git a/fs-api/src/System/FS/CallStack.hs b/fs-api/src/System/FS/CallStack.hs index 076ecf5..56e6be0 100644 --- a/fs-api/src/System/FS/CallStack.hs +++ b/fs-api/src/System/FS/CallStack.hs @@ -3,15 +3,17 @@ -- | CallStack with a nicer 'Show' instance -- -- Use of this module is intended to /replace/ import of @GHC.Stack@ -module System.FS.CallStack ( - prettyCallStack +module System.FS.CallStack + ( prettyCallStack + -- * opaque , PrettyCallStack + -- * Re-exports , HasCallStack ) where -import GHC.Stack (CallStack, HasCallStack) +import GHC.Stack (CallStack, HasCallStack) import qualified GHC.Stack as GHC {------------------------------------------------------------------------------- diff --git a/fs-api/src/System/FS/Condense.hs b/fs-api/src/System/FS/Condense.hs index af76cd7..64e07bb 100644 --- a/fs-api/src/System/FS/Condense.hs +++ b/fs-api/src/System/FS/Condense.hs @@ -1,30 +1,30 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- | Condensed but human-readable output (like 'Show'). -module System.FS.Condense ( - Condense (..) +module System.FS.Condense + ( Condense (..) , Condense1 (..) , condense1 ) where import qualified Data.ByteString as BS.Strict import qualified Data.ByteString.Lazy as BS.Lazy -import Data.Int -import Data.List (intercalate) -import Data.Map.Strict (Map) +import Data.Int +import Data.List (intercalate) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Set (Set) +import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text, unpack) -import Data.Void -import Data.Word -import Numeric.Natural -import System.IO (SeekMode (..)) -import Text.Printf (printf) +import Data.Text (Text, unpack) +import Data.Void +import Data.Word +import Numeric.Natural +import System.IO (SeekMode (..)) +import Text.Printf (printf) {------------------------------------------------------------------------------- Main class @@ -87,7 +87,7 @@ instance Condense a => Condense [a] where instance Condense a => Condense (Maybe a) where condense (Just a) = "Just " ++ condense a - condense Nothing = "Nothing" + condense Nothing = "Nothing" instance Condense a => Condense (Set a) where condense = condense1 @@ -116,4 +116,4 @@ instance Condense BS.Lazy.ByteString where instance Condense SeekMode where condense RelativeSeek = "r" condense AbsoluteSeek = "a" - condense SeekFromEnd = "e" + condense SeekFromEnd = "e" diff --git a/fs-api/src/System/FS/IO.hs b/fs-api/src/System/FS/IO.hs index 90d37ba..99b4f38 100644 --- a/fs-api/src/System/FS/IO.hs +++ b/fs-api/src/System/FS/IO.hs @@ -1,24 +1,24 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | 'IO' implementation of the 'HasFS' interface. -module System.FS.IO ( - HandleIO +module System.FS.IO + ( HandleIO , ioHasFS ) where -import Control.Concurrent.MVar +import Control.Concurrent.MVar import qualified Control.Exception as E -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Primitive (PrimMonad (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Primitive (PrimMonad (..)) import qualified Data.ByteString.Unsafe as BS -import Data.Primitive (withMutableByteArrayContents) +import Data.Primitive (withMutableByteArrayContents) import qualified Data.Set as Set import qualified Foreign -import GHC.Stack +import GHC.Stack import qualified System.Directory as Dir -import System.FS.API +import System.FS.API #if defined(mingw32_HOST_OS) import qualified System.FS.IO.Windows as F #else @@ -41,76 +41,110 @@ type HandleIO = F.FHandle -- The concrete implementation depends on the OS distribution, but behaviour -- should be similar across distributions. ioHasFS :: (MonadIO m, PrimState IO ~ PrimState m) => MountPoint -> HasFS m HandleIO -ioHasFS mount = HasFS { - -- TODO(adn) Might be useful to implement this properly by reading all +ioHasFS mount = + HasFS + { -- TODO(adn) Might be useful to implement this properly by reading all -- the stuff available at the 'MountPoint'. dumpState = return "" , hOpen = \fp openMode -> liftIO $ do let path = root fp - osHandle <- rethrowFsError fp $ + osHandle <- + rethrowFsError fp $ F.open path openMode hVar <- newMVar $ Just osHandle return $ Handle (H.HandleOS path hVar) fp - , hClose = \(Handle h fp) -> liftIO $ rethrowFsError fp $ - F.close h + , hClose = \(Handle h fp) -> + liftIO $ + rethrowFsError fp $ + F.close h , hIsOpen = liftIO . H.isOpenHandleOS . handleRaw - , hSeek = \(Handle h fp) mode o -> liftIO $ rethrowFsError fp $ - F.seek h mode o - , hGetSome = \(Handle h fp) n -> liftIO $ rethrowFsError fp $ - F.read h n - , hGetSomeAt = \(Handle h fp) n o -> liftIO $ rethrowFsError fp $ - F.pread h n (unAbsOffset o) - , hTruncate = \(Handle h fp) sz -> liftIO $ rethrowFsError fp $ - F.truncate h sz - , hGetSize = \(Handle h fp) -> liftIO $ rethrowFsError fp $ - F.getSize h + , hSeek = \(Handle h fp) mode o -> + liftIO $ + rethrowFsError fp $ + F.seek h mode o + , hGetSome = \(Handle h fp) n -> + liftIO $ + rethrowFsError fp $ + F.read h n + , hGetSomeAt = \(Handle h fp) n o -> + liftIO $ + rethrowFsError fp $ + F.pread h n (unAbsOffset o) + , hTruncate = \(Handle h fp) sz -> + liftIO $ + rethrowFsError fp $ + F.truncate h sz + , hGetSize = \(Handle h fp) -> + liftIO $ + rethrowFsError fp $ + F.getSize h , hPutSome = \(Handle h fp) bs -> liftIO $ rethrowFsError fp $ do BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - fromIntegral <$> F.write h (Foreign.castPtr ptr) (fromIntegral len) - , createDirectory = \fp -> liftIO $ rethrowFsError fp $ - Dir.createDirectory (root fp) - , listDirectory = \fp -> liftIO $ rethrowFsError fp $ - Set.fromList <$> Dir.listDirectory (root fp) - , doesDirectoryExist= \fp -> liftIO $ rethrowFsError fp $ - Dir.doesDirectoryExist (root fp) - , doesFileExist = \fp -> liftIO $ rethrowFsError fp $ - Dir.doesFileExist (root fp) - , createDirectoryIfMissing = \createParent fp -> liftIO $ rethrowFsError fp $ - Dir.createDirectoryIfMissing createParent (root fp) - , removeDirectoryRecursive = \fp -> liftIO $ rethrowFsError fp $ - Dir.removeDirectoryRecursive (root fp) - , removeFile = \fp -> liftIO $ rethrowFsError fp $ - Dir.removeFile (root fp) - , renameFile = \fp1 fp2 -> liftIO $ rethrowFsError fp1 $ - Dir.renameFile (root fp1) (root fp2) + fromIntegral <$> F.write h (Foreign.castPtr ptr) (fromIntegral len) + , createDirectory = \fp -> + liftIO $ + rethrowFsError fp $ + Dir.createDirectory (root fp) + , listDirectory = \fp -> + liftIO $ + rethrowFsError fp $ + Set.fromList <$> Dir.listDirectory (root fp) + , doesDirectoryExist = \fp -> + liftIO $ + rethrowFsError fp $ + Dir.doesDirectoryExist (root fp) + , doesFileExist = \fp -> + liftIO $ + rethrowFsError fp $ + Dir.doesFileExist (root fp) + , createDirectoryIfMissing = \createParent fp -> + liftIO $ + rethrowFsError fp $ + Dir.createDirectoryIfMissing createParent (root fp) + , removeDirectoryRecursive = \fp -> + liftIO $ + rethrowFsError fp $ + Dir.removeDirectoryRecursive (root fp) + , removeFile = \fp -> + liftIO $ + rethrowFsError fp $ + Dir.removeFile (root fp) + , renameFile = \fp1 fp2 -> + liftIO $ + rethrowFsError fp1 $ + Dir.renameFile (root fp1) (root fp2) , mkFsErrorPath = fsToFsErrorPath mount , unsafeToFilePath = pure . root - , hGetBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $ - withMutableByteArrayContents buf $ \ptr -> - F.readBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c - , hGetBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $ - withMutableByteArrayContents buf $ \ptr -> - F.preadBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off) - , hPutBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $ - withMutableByteArrayContents buf $ \ptr -> - F.writeBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c - , hPutBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $ - withMutableByteArrayContents buf $ \ptr -> - F.pwriteBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off) + , hGetBufSome = \(Handle h fp) buf bufOff c -> liftIO $ + rethrowFsError fp $ + withMutableByteArrayContents buf $ \ptr -> + F.readBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c + , hGetBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ + rethrowFsError fp $ + withMutableByteArrayContents buf $ \ptr -> + F.preadBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off) + , hPutBufSome = \(Handle h fp) buf bufOff c -> liftIO $ + rethrowFsError fp $ + withMutableByteArrayContents buf $ \ptr -> + F.writeBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c + , hPutBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ + rethrowFsError fp $ + withMutableByteArrayContents buf $ \ptr -> + F.pwriteBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off) } - where - root :: FsPath -> FilePath - root = fsToFilePath mount + where + root :: FsPath -> FilePath + root = fsToFilePath mount - rethrowFsError :: HasCallStack => FsPath -> IO a -> IO a - rethrowFsError fp action = do - res <- E.try action - case res of - Left err -> handleError err - Right a -> return a - where - handleError :: HasCallStack => IOError -> IO a - handleError ioErr = E.throwIO $ ioToFsError errorPath ioErr + rethrowFsError :: HasCallStack => FsPath -> IO a -> IO a + rethrowFsError fp action = do + res <- E.try action + case res of + Left err -> handleError err + Right a -> return a + where + handleError :: HasCallStack => IOError -> IO a + handleError ioErr = E.throwIO $ ioToFsError errorPath ioErr - errorPath :: FsErrorPath - errorPath = fsToFsErrorPath mount fp + errorPath :: FsErrorPath + errorPath = fsToFsErrorPath mount fp diff --git a/fs-api/src/System/FS/IO/Handle.hs b/fs-api/src/System/FS/IO/Handle.hs index ab21659..8a4b4c4 100644 --- a/fs-api/src/System/FS/IO/Handle.hs +++ b/fs-api/src/System/FS/IO/Handle.hs @@ -2,18 +2,18 @@ -- | This module is mainly meant to be used for the 'IO' implementation of -- 'System.FS.API.HasFS'. -module System.FS.IO.Handle ( - HandleOS (..) +module System.FS.IO.Handle + ( HandleOS (..) , closeHandleOS , isHandleClosedException , isOpenHandleOS , withOpenHandle ) where -import Control.Concurrent.MVar -import Control.Exception hiding (handle) -import Data.Maybe (isJust) -import System.IO.Error as IO +import Control.Concurrent.MVar +import Control.Exception hiding (handle) +import Data.Maybe (isJust) +import System.IO.Error as IO -- | File handlers for the IO instance for HasFS. -- This is parametric on the os. @@ -21,10 +21,10 @@ import System.IO.Error as IO -- The 'FilePath' is used to improve error messages. -- The 'MVar' is used to implement 'close'. -- osHandle is Fd for unix and HANDLE for Windows. -data HandleOS osHandle = HandleOS { - filePath :: FilePath - , handle :: MVar (Maybe osHandle) - } +data HandleOS osHandle = HandleOS + { filePath :: FilePath + , handle :: MVar (Maybe osHandle) + } instance Eq (HandleOS a) where h1 == h2 = handle h1 == handle h2 @@ -40,7 +40,7 @@ closeHandleOS :: HandleOS osHandle -> (osHandle -> IO ()) -> IO () closeHandleOS (HandleOS _ hVar) close = modifyMVar hVar $ \case Nothing -> return (Nothing, ()) - Just h -> close h >> return (Nothing, ()) + Just h -> close h >> return (Nothing, ()) {------------------------------------------------------------------------------- Exceptions @@ -51,15 +51,15 @@ closeHandleOS (HandleOS _ hVar) close = -- handle is closed. withOpenHandle :: String -> HandleOS osHandle -> (osHandle -> IO a) -> IO a withOpenHandle label (HandleOS fp hVar) k = - withMVar hVar $ \case - Nothing -> throwIO (handleClosedException fp label) - Just fd -> k fd + withMVar hVar $ \case + Nothing -> throwIO (handleClosedException fp label) + Just fd -> k fd handleClosedException :: FilePath -> String -> IOException handleClosedException fp label = - flip IO.ioeSetErrorType IO.illegalOperationErrorType - $ flip IO.ioeSetFileName fp - $ userError (label ++ ": FHandle closed") + flip IO.ioeSetErrorType IO.illegalOperationErrorType $ + flip IO.ioeSetFileName fp $ + userError (label ++ ": FHandle closed") {------------------------------------------------------------------------------- Internal auxiliary @@ -67,4 +67,4 @@ handleClosedException fp label = isHandleClosedException :: IOException -> Bool isHandleClosedException ioErr = - IO.isUserErrorType (IO.ioeGetErrorType ioErr) + IO.isUserErrorType (IO.ioeGetErrorType ioErr) diff --git a/fs-api/test/Main.hs b/fs-api/test/Main.hs index 402f738..41ba681 100644 --- a/fs-api/test/Main.hs +++ b/fs-api/test/Main.hs @@ -2,10 +2,13 @@ module Main (main) where import qualified Test.System.FS.API.FsPath import qualified Test.System.FS.IO -import Test.Tasty +import Test.Tasty main :: IO () -main = defaultMain $ testGroup "fs-api-test" [ - Test.System.FS.API.FsPath.tests - , Test.System.FS.IO.tests - ] +main = + defaultMain $ + testGroup + "fs-api-test" + [ Test.System.FS.API.FsPath.tests + , Test.System.FS.IO.tests + ] diff --git a/fs-api/test/Test/System/FS/API/FsPath.hs b/fs-api/test/Test/System/FS/API/FsPath.hs index b1e3eb3..73a0a1f 100644 --- a/fs-api/test/Test/System/FS/API/FsPath.hs +++ b/fs-api/test/Test/System/FS/API/FsPath.hs @@ -2,33 +2,38 @@ module Test.System.FS.API.FsPath (tests) where -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as Text -import Prelude hiding (read) -import qualified System.FilePath as FilePath import qualified System.FS.API as FS -import Test.Tasty +import qualified System.FilePath as FilePath +import Test.Tasty +import Test.Tasty.QuickCheck import qualified Test.Tasty.QuickCheck as QC -import Test.Tasty.QuickCheck +import Prelude hiding (read) tests :: TestTree -tests = testGroup "Test.System.FS.API.FsPath" [ - testProperty "prop_combineCommutes" prop_combineCommutes +tests = + testGroup + "Test.System.FS.API.FsPath" + [ testProperty "prop_combineCommutes" prop_combineCommutes , testProperty "prop_addExtensionCommutes" prop_addExtensionCommutes ] -- | Orphan instance that generates a __non-empty__ text! instance Arbitrary Text where arbitrary = Text.pack <$> QC.listOf (QC.elements validChars) `suchThat` (not . null) - shrink x = [ x''' | let x' = Text.unpack x - , x'' <- shrink x' - , not (null x'') - , let x''' = Text.pack x'' ] + shrink x = + [ x''' + | let x' = Text.unpack x + , x'' <- shrink x' + , not (null x'') + , let x''' = Text.pack x'' + ] -- | We pick a small subset of characters to use in directory/file names, so -- that we don't break the invariant of 'FsPath'. validChars :: [Char] -validChars = concat [['a'..'z'], ['A'..'Z'], ['0'..'9']] +validChars = concat [['a' .. 'z'], ['A' .. 'Z'], ['0' .. '9']] -- | Commutativity property for 'FS.' and 'FilePath.'. -- @@ -43,15 +48,15 @@ validChars = concat [['a'..'z'], ['A'..'Z'], ['0'..'9']] -- work, we need at least the empty mountpoint. prop_combineCommutes :: [Text] -> [Text] -> [Text] -> Property prop_combineCommutes mnt path1 path2 = - QC.classify (FilePath.isValid rhs) "Valid file path" - $ lhs === rhs - .&&. FilePath.makeValid lhs === FilePath.makeValid rhs - where - mnt' = filePathFromList mnt - mnt'' = FS.MountPoint mnt' - fsp = FS.fsPathFromList path1 FS. FS.fsPathFromList path2 - lhs = FS.fsToFilePath mnt'' fsp - rhs = mnt' FilePath. filePathFromList path1 FilePath. filePathFromList path2 + QC.classify (FilePath.isValid rhs) "Valid file path" $ + lhs === rhs + .&&. FilePath.makeValid lhs === FilePath.makeValid rhs + where + mnt' = filePathFromList mnt + mnt'' = FS.MountPoint mnt' + fsp = FS.fsPathFromList path1 FS. FS.fsPathFromList path2 + lhs = FS.fsToFilePath mnt'' fsp + rhs = mnt' FilePath. filePathFromList path1 FilePath. filePathFromList path2 -- | Commutativity property for 'FS.<.>' and 'FilePath.<.>'. -- @@ -66,17 +71,18 @@ prop_combineCommutes mnt path1 path2 = -- work, we need at least the empty mountpoint. prop_addExtensionCommutes :: [Text] -> [Text] -> String -> Property prop_addExtensionCommutes mnt path ext = - QC.classify (FilePath.isValid rhs) "Valid file path" - $ QC.classify (case ext of '.':_ -> True; _ -> False) - "Extension to add starts with an extension separator (.)" - $ lhs === rhs - .&&. FilePath.makeValid lhs === FilePath.makeValid rhs - where - mnt' = filePathFromList mnt - mnt'' = FS.MountPoint mnt' - fsp = FS.fsPathFromList path FS.<.> ext - lhs = FS.fsToFilePath mnt'' fsp - rhs = mnt' FilePath. filePathFromList path FilePath.<.> ext + QC.classify (FilePath.isValid rhs) "Valid file path" + $ QC.classify + (case ext of '.' : _ -> True; _ -> False) + "Extension to add starts with an extension separator (.)" + $ lhs === rhs + .&&. FilePath.makeValid lhs === FilePath.makeValid rhs + where + mnt' = filePathFromList mnt + mnt'' = FS.MountPoint mnt' + fsp = FS.fsPathFromList path FS.<.> ext + lhs = FS.fsToFilePath mnt'' fsp + rhs = mnt' FilePath. filePathFromList path FilePath.<.> ext -- | Build a 'FilePath' by 'FilePath.combine'ing the directory/file names. filePathFromList :: [Text] -> FilePath diff --git a/fs-api/test/Test/System/FS/IO.hs b/fs-api/test/Test/System/FS/IO.hs index c75a086..886331e 100644 --- a/fs-api/test/Test/System/FS/IO.hs +++ b/fs-api/test/Test/System/FS/IO.hs @@ -3,28 +3,34 @@ module Test.System.FS.IO (tests) where -import Control.Monad.Primitive -import Data.ByteString (ByteString) +import Control.Monad.Primitive +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Short.Internal as SBS -import Data.Primitive.ByteArray -import Prelude hiding (read) +import Data.Primitive.ByteArray import qualified System.FS.API as FS import qualified System.FS.IO as IO -import System.IO.Temp -import System.Posix.Types (ByteCount) -import Test.Tasty -import Test.Tasty.QuickCheck +import System.IO.Temp +import System.Posix.Types (ByteCount) +import Test.Tasty +import Test.Tasty.QuickCheck +import Prelude hiding (read) tests :: TestTree -tests = testGroup "Test.System.FS.IO" [ - testProperty "prop_roundtrip_hPutGetBufSome" +tests = + testGroup + "Test.System.FS.IO" + [ testProperty + "prop_roundtrip_hPutGetBufSome" prop_roundtrip_hPutGetBufSome - , testProperty "prop_roundtrip_hPutGetBufSomeAt" + , testProperty + "prop_roundtrip_hPutGetBufSomeAt" prop_roundtrip_hPutGetBufSomeAt - , testProperty "prop_roundtrip_hPutGetBufExactly" + , testProperty + "prop_roundtrip_hPutGetBufExactly" prop_roundtrip_hPutGetBufExactly - , testProperty "prop_roundtrip_hPutGetBufExactlyAt" + , testProperty + "prop_roundtrip_hPutGetBufExactlyAt" prop_roundtrip_hPutGetBufExactlyAt ] @@ -38,7 +44,8 @@ instance Arbitrary FS.AbsOffset where fromByteString :: PrimMonad m => ByteString -> m (MutableByteArray (PrimState m)) fromByteString bs = thawByteArray (ByteArray ba) 0 (SBS.length sbs) - where !sbs@(SBS.SBS ba) = SBS.toShort bs + where + !sbs@(SBS.SBS ba) = SBS.toShort bs toByteString :: PrimMonad m => Int -> MutableByteArray (PrimState m) -> m ByteString toByteString n mba = freezeByteArray mba 0 n >>= \(ByteArray ba) -> pure (SBS.fromShort $ SBS.SBS ba) @@ -48,103 +55,115 @@ toByteString n mba = freezeByteArray mba 0 n >>= \(ByteArray ba) -> pure (SBS.fr -- This does not test what happens if we try to write/read more bytes than fits -- in the buffer, because the behaviour is then undefined. prop_roundtrip_hPutGetBufSome :: - ByteString - -> Small ByteCount -- ^ Prefix length - -> Property + ByteString -> + -- | Prefix length + Small ByteCount -> + Property prop_roundtrip_hPutGetBufSome bs (Small c) = BS.length bs >= fromIntegral c ==> - ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufSome" $ \dirPath -> do - let hfs = IO.ioHasFS (FS.MountPoint dirPath) - - FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do - putBuf <- fromByteString bs - m <- FS.hPutBufSome hfs h putBuf 0 c - let writeTest = counterexample "wrote too many bytes" ((if c > 0 then 1 .<= m else property True) .&&. m .<= c) - FS.hSeek hfs h FS.AbsoluteSeek 0 - getBuf <- newPinnedByteArray (fromIntegral m) - o <- FS.hGetBufSome hfs h getBuf 0 m - let readTest = counterexample "read too many bytes" ((if c > 0 then 1 .<= o else property True) .&&. o .<= m) - bs' <- toByteString (fromIntegral o) getBuf - let cmpTest = counterexample "(prefix of) input and output bytestring do not match" - $ BS.take (fromIntegral o) bs === bs' - pure (writeTest .&&. readTest .&&. cmpTest) + ioProperty $ + withSystemTempDirectory "prop_roundtrip_hPutGetBufSome" $ \dirPath -> do + let hfs = IO.ioHasFS (FS.MountPoint dirPath) + + FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do + putBuf <- fromByteString bs + m <- FS.hPutBufSome hfs h putBuf 0 c + let writeTest = counterexample "wrote too many bytes" ((if c > 0 then 1 .<= m else property True) .&&. m .<= c) + FS.hSeek hfs h FS.AbsoluteSeek 0 + getBuf <- newPinnedByteArray (fromIntegral m) + o <- FS.hGetBufSome hfs h getBuf 0 m + let readTest = counterexample "read too many bytes" ((if c > 0 then 1 .<= o else property True) .&&. o .<= m) + bs' <- toByteString (fromIntegral o) getBuf + let cmpTest = + counterexample "(prefix of) input and output bytestring do not match" $ + BS.take (fromIntegral o) bs === bs' + pure (writeTest .&&. readTest .&&. cmpTest) -- | Like 'prop_roundtrip_hPutGetBufSome', but reading and writing at a specified offset. prop_roundtrip_hPutGetBufSomeAt :: - ByteString - -> Small ByteCount -- ^ Prefix length - -> FS.AbsOffset - -> Property + ByteString -> + -- | Prefix length + Small ByteCount -> + FS.AbsOffset -> + Property prop_roundtrip_hPutGetBufSomeAt bs (Small c) off = BS.length bs >= fromIntegral c ==> - ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufSomeAt" $ \dirPath -> do - let hfs = IO.ioHasFS (FS.MountPoint dirPath) - - FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do - putBuf <- fromByteString bs - m <- FS.hPutBufSomeAt hfs h putBuf 0 c off - let writeTest = counterexample "wrote too many bytes" ((if c > 0 then 1 .<= m else property True) .&&. m .<= c) - getBuf <- newPinnedByteArray (fromIntegral m) - o <- FS.hGetBufSomeAt hfs h getBuf 0 m off - let readTest = counterexample "read too many bytes" ((if c > 0 then 1 .<= o else property True) .&&. o .<= m) - bs' <- toByteString (fromIntegral o) getBuf - let cmpTest = counterexample "(prefix of) input and output bytestring do not match" - $ BS.take (fromIntegral o) bs === bs' - pure (writeTest .&&. readTest .&&. cmpTest) + ioProperty $ + withSystemTempDirectory "prop_roundtrip_hPutGetBufSomeAt" $ \dirPath -> do + let hfs = IO.ioHasFS (FS.MountPoint dirPath) + + FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do + putBuf <- fromByteString bs + m <- FS.hPutBufSomeAt hfs h putBuf 0 c off + let writeTest = counterexample "wrote too many bytes" ((if c > 0 then 1 .<= m else property True) .&&. m .<= c) + getBuf <- newPinnedByteArray (fromIntegral m) + o <- FS.hGetBufSomeAt hfs h getBuf 0 m off + let readTest = counterexample "read too many bytes" ((if c > 0 then 1 .<= o else property True) .&&. o .<= m) + bs' <- toByteString (fromIntegral o) getBuf + let cmpTest = + counterexample "(prefix of) input and output bytestring do not match" $ + BS.take (fromIntegral o) bs === bs' + pure (writeTest .&&. readTest .&&. cmpTest) -- | Like 'prop_roundtrip_hPutGetBufSome', but ensuring that all bytes are -- written/read. prop_roundtrip_hPutGetBufExactly :: - ByteString - -> Small ByteCount -- ^ Prefix length - -> Property + ByteString -> + -- | Prefix length + Small ByteCount -> + Property prop_roundtrip_hPutGetBufExactly bs (Small c) = BS.length bs >= fromIntegral c ==> - ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufExactly" $ \dirPath -> do - let hfs = IO.ioHasFS (FS.MountPoint dirPath) - - FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do - putBuf <- fromByteString bs - m <- FS.hPutBufExactly hfs h putBuf 0 c - let writeTest = counterexample "wrote too few bytes" (m === c) - FS.hSeek hfs h FS.AbsoluteSeek 0 - getBuf <- newPinnedByteArray (fromIntegral c) - o <- FS.hGetBufExactly hfs h getBuf 0 c - let readTest = counterexample "read too few byes" (o === c) - bs' <- toByteString (fromIntegral c) getBuf - let cmpTest = counterexample "input and output bytestring do not match" - $ BS.take (fromIntegral c) bs === BS.take (fromIntegral c) bs' - pure (writeTest .&&. readTest .&&. cmpTest) + ioProperty $ + withSystemTempDirectory "prop_roundtrip_hPutGetBufExactly" $ \dirPath -> do + let hfs = IO.ioHasFS (FS.MountPoint dirPath) + + FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do + putBuf <- fromByteString bs + m <- FS.hPutBufExactly hfs h putBuf 0 c + let writeTest = counterexample "wrote too few bytes" (m === c) + FS.hSeek hfs h FS.AbsoluteSeek 0 + getBuf <- newPinnedByteArray (fromIntegral c) + o <- FS.hGetBufExactly hfs h getBuf 0 c + let readTest = counterexample "read too few byes" (o === c) + bs' <- toByteString (fromIntegral c) getBuf + let cmpTest = + counterexample "input and output bytestring do not match" $ + BS.take (fromIntegral c) bs === BS.take (fromIntegral c) bs' + pure (writeTest .&&. readTest .&&. cmpTest) -- | Like 'prop_roundtrip_hPutGetBufSome', but reading and writing at a -- specified offset, and ensuring that all bytes are written/read. prop_roundtrip_hPutGetBufExactlyAt :: - ByteString - -> Small ByteCount -- ^ Prefix length - -> FS.AbsOffset - -> Property + ByteString -> + -- | Prefix length + Small ByteCount -> + FS.AbsOffset -> + Property prop_roundtrip_hPutGetBufExactlyAt bs (Small c) off = BS.length bs >= fromIntegral c ==> - ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufExactlyAt" $ \dirPath -> do - let hfs = IO.ioHasFS (FS.MountPoint dirPath) - - FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do - putBuf <- fromByteString bs - m <- FS.hPutBufExactlyAt hfs h putBuf 0 c off - let writeTest = counterexample "wrote too few bytes" (m === c) - getBuf <- newPinnedByteArray (fromIntegral c) - o <- FS.hGetBufExactlyAt hfs h getBuf 0 c off - let readTest = counterexample "read too few byes" (o === c) - bs' <- toByteString (fromIntegral c) getBuf - let cmpTest = counterexample "input and output bytestring do not match" - $ BS.take (fromIntegral c) bs === BS.take (fromIntegral c) bs' - pure (writeTest .&&. readTest .&&. cmpTest) + ioProperty $ + withSystemTempDirectory "prop_roundtrip_hPutGetBufExactlyAt" $ \dirPath -> do + let hfs = IO.ioHasFS (FS.MountPoint dirPath) + + FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do + putBuf <- fromByteString bs + m <- FS.hPutBufExactlyAt hfs h putBuf 0 c off + let writeTest = counterexample "wrote too few bytes" (m === c) + getBuf <- newPinnedByteArray (fromIntegral c) + o <- FS.hGetBufExactlyAt hfs h getBuf 0 c off + let readTest = counterexample "read too few byes" (o === c) + bs' <- toByteString (fromIntegral c) getBuf + let cmpTest = + counterexample "input and output bytestring do not match" $ + BS.take (fromIntegral c) bs === BS.take (fromIntegral c) bs' + pure (writeTest .&&. readTest .&&. cmpTest) infix 4 .<= (.<=) :: (Ord a, Show a) => a -> a -> Property x .<= y = counterexample (show x ++ interpret res ++ show y) res - where - res = x <= y - interpret True = " <= " - interpret False = " > " + where + res = x <= y + interpret True = " <= " + interpret False = " > " diff --git a/fs-sim/fs-sim.cabal b/fs-sim/fs-sim.cabal index 8b37cf9..6ad73db 100644 --- a/fs-sim/fs-sim.cabal +++ b/fs-sim/fs-sim.cabal @@ -1,39 +1,39 @@ -cabal-version: 3.0 -name: fs-sim -version: 0.4.1.0 -synopsis: Simulated file systems -description: Simulated file systems. -license: Apache-2.0 +cabal-version: 3.0 +name: fs-sim +version: 0.4.1.0 +synopsis: Simulated file systems +description: Simulated file systems. +license: Apache-2.0 license-files: LICENSE NOTICE -copyright: 2019-2024 Input Output Global Inc (IOG) -author: IOG Engineering Team -maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com) -homepage: https://github.com/input-output-hk/fs-sim -bug-reports: https://github.com/input-output-hk/fs-sim/issues -category: Testing -build-type: Simple +copyright: 2019-2024 Input Output Global Inc (IOG) +author: IOG Engineering Team +maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com) +homepage: https://github.com/input-output-hk/fs-sim +bug-reports: https://github.com/input-output-hk/fs-sim/issues +category: Testing +build-type: Simple extra-doc-files: CHANGELOG.md README.md -tested-with: GHC ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 || ==9.12 +tested-with: ghc ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 || ==9.12 source-repository head - type: git + type: git location: https://github.com/input-output-hk/fs-sim - subdir: fs-sim + subdir: fs-sim source-repository this - type: git + type: git location: https://github.com/input-output-hk/fs-sim - subdir: fs-sim - tag: fs-sim-0.4.1.0 + subdir: fs-sim + tag: fs-sim-0.4.1.0 library - hs-source-dirs: src + hs-source-dirs: src exposed-modules: System.FS.Sim.Error System.FS.Sim.FsTree @@ -44,28 +44,34 @@ library default-language: Haskell2010 build-depends: - , base >=4.16 && <4.23 - , base16-bytestring ^>=0.1 || ^>=1.0 - , bytestring ^>=0.10 || ^>=0.11 || ^>=0.12 - , containers ^>=0.5 || ^>=0.6 || ^>=0.7 || ^>=0.8 - , fs-api ^>=0.4 - , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10 - , io-classes:strict-stm - , mtl ^>=2.2 || ^>=2.3 - , primitive ^>=0.9 - , QuickCheck ^>=2.13 || ^>=2.14 || ^>=2.15 || ^>=2.16 || ^>=2.17 - , safe-wild-cards ^>=1.0 - , text ^>=1.2 || ^>=2.0 || ^>=2.1 + QuickCheck ^>=2.13 || ^>=2.14 || ^>=2.15 || ^>=2.16 || ^>=2.17, + base >=4.16 && <4.23, + base16-bytestring ^>=0.1 || ^>=1.0, + bytestring ^>=0.10 || ^>=0.11 || ^>=0.12, + containers ^>=0.5 || ^>=0.6 || ^>=0.7 || ^>=0.8, + fs-api ^>=0.4, + io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10, + io-classes:strict-stm, + mtl ^>=2.2 || ^>=2.3, + primitive ^>=0.9, + safe-wild-cards ^>=1.0, + text ^>=1.2 || ^>=2.0 || ^>=2.1, ghc-options: - -Wall -Wcompat -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wpartial-fields -Widentities - -Wredundant-constraints -Wmissing-export-lists -Wunused-packages + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wunused-packages test-suite fs-sim-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs other-modules: Test.System.FS.Sim.Error Test.System.FS.Sim.FsTree @@ -77,28 +83,34 @@ test-suite fs-sim-test default-language: Haskell2010 build-depends: - , base - , bifunctors - , bytestring - , containers - , deepseq - , fs-api - , fs-sim - , generics-sop - , io-classes:strict-stm - , pretty-show - , primitive - , QuickCheck - , quickcheck-state-machine >=0.10 - , random - , tasty - , tasty-hunit - , tasty-quickcheck - , temporary - , text + QuickCheck, + base, + bifunctors, + bytestring, + containers, + deepseq, + fs-api, + fs-sim, + generics-sop, + io-classes:strict-stm, + pretty-show, + primitive, + quickcheck-state-machine >=0.10, + random, + tasty, + tasty-hunit, + tasty-quickcheck, + temporary, + text, ghc-options: - -Wall -Wcompat -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wpartial-fields -Widentities - -Wredundant-constraints -Wmissing-export-lists -Wunused-packages + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wunused-packages -fno-ignore-asserts diff --git a/fs-sim/src/System/FS/Sim/Error.hs b/fs-sim/src/System/FS/Sim/Error.hs index d0e1163..e83ee20 100644 --- a/fs-sim/src/System/FS/Sim/Error.hs +++ b/fs-sim/src/System/FS/Sim/Error.hs @@ -1,35 +1,40 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} -- | 'HasFS' instance wrapping 'SimFS' that generates errors, suitable for -- testing error handling. -module System.FS.Sim.Error ( - -- * Simulate Errors monad +module System.FS.Sim.Error + ( -- * Simulate Errors monad simErrorHasFS , simErrorHasFS' , runSimErrorFS , withErrors + -- * Streams , ErrorStream , ErrorStreamGetSome , ErrorStreamPutSome + -- * Generating partial reads/writes , Partial (..) , partialiseByteCount , partialiseWord64 , partialiseByteString + -- * Blob , Blob (..) , blobFromBS , blobToBS + -- * Generating corruption for 'hPutSome' , PutCorruption (..) , corruptByteString + -- * Error streams for 'HasFS' , Errors (..) , allNull @@ -38,38 +43,39 @@ module System.FS.Sim.Error ( , simpleErrors ) where -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad (unless, void) -import Control.Monad.Class.MonadThrow hiding (handle) -import Control.Monad.Primitive -import Data.ByteString (ByteString) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad (unless, void) +import Control.Monad.Class.MonadThrow hiding (handle) +import Control.Monad.Primitive +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as LC8 -import Data.Foldable (for_) -import Data.List (intercalate) +import Data.Foldable (for_) +import Data.List (intercalate) import qualified Data.List as List -import Data.Maybe (catMaybes) -import Data.Primitive.ByteArray -import Data.String (IsString (..)) -import Data.Word (Word64) -import Prelude hiding (null) -import SafeWildCards -import System.Posix.Types - -import qualified Test.QuickCheck as QC -import Test.QuickCheck (ASCIIString (..), Arbitrary (..), Gen, - suchThat) - -import System.FS.API -import System.FS.CallStack - +import Data.Maybe (catMaybes) +import Data.Primitive.ByteArray +import Data.String (IsString (..)) +import Data.Word (Word64) +import SafeWildCards +import System.FS.API +import System.FS.CallStack +import System.FS.Sim.MockFS (HandleMock, MockFS) import qualified System.FS.Sim.MockFS as MockFS -import System.FS.Sim.MockFS (HandleMock, MockFS) import qualified System.FS.Sim.STM as Sim +import System.FS.Sim.Stream (Stream) import qualified System.FS.Sim.Stream as Stream -import System.FS.Sim.Stream (Stream) +import System.Posix.Types +import Test.QuickCheck + ( ASCIIString (..) + , Arbitrary (..) + , Gen + , suchThat + ) +import qualified Test.QuickCheck as QC +import Prelude hiding (null) {------------------------------------------------------------------------------- Streams of errors @@ -106,12 +112,12 @@ type ErrorStreamPutSome = -- | A @'Partial' p@, where @p > 0@, is a number representing how many fewer -- bytes should be read or written than requested. newtype Partial = Partial Word64 - deriving (Show) + deriving Show instance Arbitrary Partial where arbitrary = Partial <$> QC.choose (1, 100) shrink (Partial p) = - [Partial p' | p' <- [1..p]] + [Partial p' | p' <- [1 .. p]] -- | Given a requested number of bytes to read/write, compute a partial number -- of bytes to read/write. @@ -121,23 +127,25 @@ instance Arbitrary Partial where -- was already 0, we can't simulate a partial read so we return 0 again. partialiseByteCount :: Partial -> ByteCount -> ByteCount partialiseByteCount (Partial p) c - | 0 <- c' = c - | p >= c' = 1 + | 0 <- c' = c + | p >= c' = 1 | otherwise = c - fromIntegral p - where c' = fromIntegral c + where + c' = fromIntegral c -- | Like 'partialiseByteCount', but for 'Word64'. partialiseWord64 :: Partial -> Word64 -> Word64 partialiseWord64 (Partial p) c - | 0 <- c = c - | p >= c = 1 + | 0 <- c = c + | p >= c = 1 | otherwise = c - p -- | Given a bytestring that is requested to be written to disk, use -- 'partialiseByteCount' to compute a partial bytestring. partialiseByteString :: Partial -> BS.ByteString -> BS.ByteString partialiseByteString p bs = BS.take (fromIntegral $ partialiseByteCount p len) bs - where len = fromIntegral (BS.length bs) + where + len = fromIntegral (BS.length bs) {------------------------------------------------------------------------------ Blob @@ -146,18 +154,19 @@ partialiseByteString p bs = BS.take (fromIntegral $ partialiseByteCount p len) b -- For the custom 'Show' and 'Arbitrary' instances -- -- A builder of a non-empty bytestring. -newtype Blob = MkBlob { getBlob :: ByteString } - deriving (Show) +newtype Blob = MkBlob {getBlob :: ByteString} + deriving Show instance Arbitrary Blob where - arbitrary = do - str <- (getASCIIString <$> arbitrary) `suchThat` (not . List.null) - return $ fromString str - shrink (MkBlob b) = - [ fromString s' - | let s = ASCIIString $ LC8.unpack $ BL.fromStrict b - , s' <- getASCIIString <$> shrink s - , not (List.null s') ] + arbitrary = do + str <- (getASCIIString <$> arbitrary) `suchThat` (not . List.null) + return $ fromString str + shrink (MkBlob b) = + [ fromString s' + | let s = ASCIIString $ LC8.unpack $ BL.fromStrict b + , s' <- getASCIIString <$> shrink s + , not (List.null s') + ] blobToBS :: Blob -> ByteString blobToBS = getBlob @@ -166,7 +175,7 @@ blobFromBS :: ByteString -> Blob blobFromBS = MkBlob instance IsString Blob where - fromString = blobFromBS . C8.pack + fromString = blobFromBS . C8.pack {------------------------------------------------------------------------------- Generating corruption for hPutSome @@ -174,21 +183,22 @@ instance IsString Blob where -- | Model possible corruptions that could happen to a 'hPutSome' call. data PutCorruption - = SubstituteWithJunk Blob - -- ^ The blob to write is substituted with corrupt junk - | PartialWrite Partial - -- ^ Only perform the write partially - deriving (Show) + = -- | The blob to write is substituted with corrupt junk + SubstituteWithJunk Blob + | -- | Only perform the write partially + PartialWrite Partial + deriving Show instance Arbitrary PutCorruption where - arbitrary = QC.oneof + arbitrary = + QC.oneof [ SubstituteWithJunk <$> arbitrary , PartialWrite <$> arbitrary ] shrink (SubstituteWithJunk blob) = - [SubstituteWithJunk blob' | blob' <- shrink blob] + [SubstituteWithJunk blob' | blob' <- shrink blob] shrink (PartialWrite partial) = - [PartialWrite partial' | partial' <- shrink partial] + [PartialWrite partial' | partial' <- shrink partial] -- | Apply the 'PutCorruption' to the 'BS.ByteString'. -- @@ -196,8 +206,8 @@ instance Arbitrary PutCorruption where -- __might__ be larger than the input bytestring. corruptByteString :: BS.ByteString -> PutCorruption -> BS.ByteString corruptByteString bs pc = case pc of - SubstituteWithJunk blob -> getBlob blob - PartialWrite partial -> partialiseByteString partial bs + SubstituteWithJunk blob -> getBlob blob + PartialWrite partial -> partialiseByteString partial bs -- | Apply the 'PutCorruption' to a 'MutableByteArray'. -- @@ -224,30 +234,32 @@ corruptByteString bs pc = case pc of -- this functions produces only one effect. Either the buffer contents are -- changed, or the 'ByteCount' is reduced. corruptBuffer :: - PrimMonad m - => MutableByteArray (PrimState m) - -> BufferOffset - -> ByteCount - -> PutCorruption - -> m (MutableByteArray (PrimState m), ByteCount) + PrimMonad m => + MutableByteArray (PrimState m) -> + BufferOffset -> + ByteCount -> + PutCorruption -> + m (MutableByteArray (PrimState m), ByteCount) corruptBuffer buf bufOff c pc = do - case pc of - SubstituteWithJunk blob -> do - len <- getSizeofMutableByteArray buf - -- this creates an unpinned byte array containing a copy of @buf@. It should - -- be fine that it is unpinned, because the simulation is fully in-memory. - copy <- freezeByteArray buf 0 len - buf' <- unsafeThawByteArray copy - -- Only corrupt up to the end of the bytearray. - let lenRemaining = len - unBufferOffset bufOff - b <- MockFS.intoBuffer buf' bufOff (BS.take lenRemaining (getBlob blob)) - -- Applying the corruption shouldn't have failed because we've ensured - -- that the bytestring isn't too large to fit into the buffer. - unless b $ error "corruptBuffer: corruption failed. This probably \ - \indicates a bug in the fs-sim library." - pure (buf', c) - PartialWrite partial -> - pure (buf, partialiseByteCount partial c) + case pc of + SubstituteWithJunk blob -> do + len <- getSizeofMutableByteArray buf + -- this creates an unpinned byte array containing a copy of @buf@. It should + -- be fine that it is unpinned, because the simulation is fully in-memory. + copy <- freezeByteArray buf 0 len + buf' <- unsafeThawByteArray copy + -- Only corrupt up to the end of the bytearray. + let lenRemaining = len - unBufferOffset bufOff + b <- MockFS.intoBuffer buf' bufOff (BS.take lenRemaining (getBlob blob)) + -- Applying the corruption shouldn't have failed because we've ensured + -- that the bytestring isn't too large to fit into the buffer. + unless b $ + error + "corruptBuffer: corruption failed. This probably \ + \indicates a bug in the fs-sim library." + pure (buf', c) + PartialWrite partial -> + pure (buf, partialiseByteCount partial c) {------------------------------------------------------------------------------- Simulated errors @@ -265,37 +277,39 @@ corruptBuffer buf bufOff c pc = do -- An 'Errors' is used in conjunction with 'SimErrorFS', which is a layer on -- top of 'SimFS' that simulates methods throwing 'FsError's. data Errors = Errors - { dumpStateE :: ErrorStream -- TODO remove - -- Operations on files - , hOpenE :: ErrorStream - , hCloseE :: ErrorStream - , hSeekE :: ErrorStream - , hGetSomeE :: ErrorStreamGetSome - , hGetSomeAtE :: ErrorStreamGetSome - , hPutSomeE :: ErrorStreamPutSome - , hTruncateE :: ErrorStream - , hGetSizeE :: ErrorStream - -- Operations on directories - , createDirectoryE :: ErrorStream + { dumpStateE :: ErrorStream -- TODO remove + -- Operations on files + , hOpenE :: ErrorStream + , hCloseE :: ErrorStream + , hSeekE :: ErrorStream + , hGetSomeE :: ErrorStreamGetSome + , hGetSomeAtE :: ErrorStreamGetSome + , hPutSomeE :: ErrorStreamPutSome + , hTruncateE :: ErrorStream + , hGetSizeE :: ErrorStream + , -- Operations on directories + createDirectoryE :: ErrorStream , createDirectoryIfMissingE :: ErrorStream - , listDirectoryE :: ErrorStream - , doesDirectoryExistE :: ErrorStream - , doesFileExistE :: ErrorStream + , listDirectoryE :: ErrorStream + , doesDirectoryExistE :: ErrorStream + , doesFileExistE :: ErrorStream , removeDirectoryRecursiveE :: ErrorStream - , removeFileE :: ErrorStream - , renameFileE :: ErrorStream - -- File I\/O with user-supplied buffers - , hGetBufSomeE :: ErrorStreamGetSome - , hGetBufSomeAtE :: ErrorStreamGetSome - , hPutBufSomeE :: ErrorStreamPutSome - , hPutBufSomeAtE :: ErrorStreamPutSome + , removeFileE :: ErrorStream + , renameFileE :: ErrorStream + , -- File I\/O with user-supplied buffers + hGetBufSomeE :: ErrorStreamGetSome + , hGetBufSomeAtE :: ErrorStreamGetSome + , hPutBufSomeE :: ErrorStreamPutSome + , hPutBufSomeAtE :: ErrorStreamPutSome } + $(pure []) -- https://blog.monadfix.com/th-groups -- | Return 'True' if all streams are empty ('null'). allNull :: Errors -> Bool -allNull $(fields 'Errors) = and [ - Stream.null dumpStateE +allNull $(fields 'Errors) = + and + [ Stream.null dumpStateE , Stream.null hOpenE , Stream.null hCloseE , Stream.null hSeekE @@ -312,43 +326,47 @@ allNull $(fields 'Errors) = and [ , Stream.null removeDirectoryRecursiveE , Stream.null removeFileE , Stream.null renameFileE - -- File I\/O with user-supplied buffers - , Stream.null hGetBufSomeE, Stream.null hGetBufSomeAtE - , Stream.null hPutBufSomeE, Stream.null hPutBufSomeAtE + , -- File I\/O with user-supplied buffers + Stream.null hGetBufSomeE + , Stream.null hGetBufSomeAtE + , Stream.null hPutBufSomeE + , Stream.null hPutBufSomeAtE ] instance Show Errors where show $(fields 'Errors) = - "Errors {" <> intercalate ", " streams <> "}" - where - -- | Show a stream unless it is empty - s :: Show a => String -> Stream a -> Maybe String - s fld str | Stream.null str = Nothing - | otherwise = Just $ fld <> " = " <> show str - - streams :: [String] - streams = catMaybes - [ s "dumpStateE" dumpStateE - , s "hOpenE" hOpenE - , s "hCloseE" hCloseE - , s "hSeekE" hSeekE - , s "hGetSomeE" hGetSomeE - , s "hGetSomeAtE" hGetSomeAtE - , s "hPutSomeE" hPutSomeE - , s "hTruncateE" hTruncateE - , s "hGetSizeE" hGetSizeE - , s "createDirectoryE" createDirectoryE + "Errors {" <> intercalate ", " streams <> "}" + where + -- \| Show a stream unless it is empty + s :: Show a => String -> Stream a -> Maybe String + s fld str + | Stream.null str = Nothing + | otherwise = Just $ fld <> " = " <> show str + + streams :: [String] + streams = + catMaybes + [ s "dumpStateE" dumpStateE + , s "hOpenE" hOpenE + , s "hCloseE" hCloseE + , s "hSeekE" hSeekE + , s "hGetSomeE" hGetSomeE + , s "hGetSomeAtE" hGetSomeAtE + , s "hPutSomeE" hPutSomeE + , s "hTruncateE" hTruncateE + , s "hGetSizeE" hGetSizeE + , s "createDirectoryE" createDirectoryE , s "createDirectoryIfMissingE" createDirectoryIfMissingE - , s "listDirectoryE" listDirectoryE - , s "doesDirectoryExistE" doesDirectoryExistE - , s "doesFileExistE" doesFileExistE + , s "listDirectoryE" listDirectoryE + , s "doesDirectoryExistE" doesDirectoryExistE + , s "doesFileExistE" doesFileExistE , s "removeDirectoryRecursiveE" removeDirectoryRecursiveE - , s "removeFileE" removeFileE - , s "renameFileE" renameFileE - -- File I\/O with user-supplied buffers - , s "hGetBufSomeE" hGetBufSomeE + , s "removeFileE" removeFileE + , s "renameFileE" renameFileE + , -- File I\/O with user-supplied buffers + s "hGetBufSomeE" hGetBufSomeE , s "hGetBufSomeAtE" hGetBufSomeAtE - , s "hPutBufSomeE" hPutBufSomeE + , s "hPutBufSomeE" hPutBufSomeE , s "hPutBufSomeAtE" hPutBufSomeAtE ] @@ -358,229 +376,356 @@ emptyErrors = simpleErrors Stream.empty -- | Use the given 'ErrorStream' for each field/method. No corruption of -- 'hPutSome'. simpleErrors :: ErrorStream -> Errors -simpleErrors es = Errors - { dumpStateE = es - , hOpenE = es - , hCloseE = es - , hSeekE = es - , hGetSomeE = Left <$> es - , hGetSomeAtE = Left <$> es - , hPutSomeE = Left . (, Nothing) <$> es - , hTruncateE = es - , hGetSizeE = es - , createDirectoryE = es +simpleErrors es = + Errors + { dumpStateE = es + , hOpenE = es + , hCloseE = es + , hSeekE = es + , hGetSomeE = Left <$> es + , hGetSomeAtE = Left <$> es + , hPutSomeE = Left . (,Nothing) <$> es + , hTruncateE = es + , hGetSizeE = es + , createDirectoryE = es , createDirectoryIfMissingE = es - , listDirectoryE = es - , doesDirectoryExistE = es - , doesFileExistE = es + , listDirectoryE = es + , doesDirectoryExistE = es + , doesFileExistE = es , removeDirectoryRecursiveE = es - , removeFileE = es - , renameFileE = es - -- File I\/O with user-supplied buffers - , hGetBufSomeE = Left <$> es + , removeFileE = es + , renameFileE = es + , -- File I\/O with user-supplied buffers + hGetBufSomeE = Left <$> es , hGetBufSomeAtE = Left <$> es - , hPutBufSomeE = Left . (, Nothing) <$> es - , hPutBufSomeAtE = Left . (, Nothing) <$> es + , hPutBufSomeE = Left . (,Nothing) <$> es + , hPutBufSomeAtE = Left . (,Nothing) <$> es } -- | Generator for 'Errors' that allows some things to be disabled. -- -- This is needed by the VolatileDB state machine tests, which try to predict -- what should happen based on the 'Errors', which is too complex sometimes. -genErrors :: Bool -- ^ 'True' -> generate partial writes - -> Bool -- ^ 'True' -> generate 'SubstituteWithJunk' corruptions - -> Gen Errors +genErrors :: + -- | 'True' -> generate partial writes + Bool -> + -- | 'True' -> generate 'SubstituteWithJunk' corruptions + Bool -> + Gen Errors genErrors genPartialWrites genSubstituteWithJunk = do - let -- TODO which errors are possible for these operations below (that - -- have dummy for now)? - dummy = streamGen 2 [ FsInsufficientPermissions ] - dumpStateE <- dummy - -- TODO let this one fail: - let hCloseE = Stream.empty - hTruncateE <- dummy - doesDirectoryExistE <- dummy - doesFileExistE <- dummy - hOpenE <- streamGen 1 - [ FsResourceDoesNotExist, FsResourceInappropriateType - , FsResourceAlreadyInUse, FsResourceAlreadyExist - , FsInsufficientPermissions, FsTooManyOpenFiles ] - hSeekE <- streamGen 3 [ FsReachedEOF ] - hGetSomeE <- commonGetErrors - hGetSomeAtE <- commonGetErrors - hPutSomeE <- commonPutErrors - hGetSizeE <- streamGen 2 [ FsResourceDoesNotExist ] - createDirectoryE <- streamGen 3 - [ FsInsufficientPermissions, FsResourceInappropriateType - , FsResourceAlreadyExist ] - createDirectoryIfMissingE <- streamGen 3 - [ FsInsufficientPermissions, FsResourceInappropriateType - , FsResourceAlreadyExist ] - listDirectoryE <- streamGen 3 - [ FsInsufficientPermissions, FsResourceInappropriateType - , FsResourceDoesNotExist ] - removeDirectoryRecursiveE <- streamGen 3 - [ FsInsufficientPermissions, FsResourceAlreadyInUse - , FsResourceDoesNotExist, FsResourceInappropriateType ] - removeFileE <- streamGen 3 - [ FsInsufficientPermissions, FsResourceAlreadyInUse - , FsResourceDoesNotExist, FsResourceInappropriateType ] - renameFileE <- streamGen 3 - [ FsInsufficientPermissions, FsResourceAlreadyInUse - , FsResourceDoesNotExist, FsResourceInappropriateType ] - -- File I\/O with user-supplied buffers - hGetBufSomeE <- commonGetErrors - hGetBufSomeAtE <- commonGetErrors - hPutBufSomeE <- commonPutErrors - hPutBufSomeAtE <- commonPutErrors - return Errors {..} - where - genMaybe' = Stream.genMaybe 2 - - streamGen l = Stream.genInfinite . genMaybe' l . QC.elements - streamGen' l = Stream.genInfinite . genMaybe' l . QC.frequency - - commonGetErrors = streamGen' 20 + let + -- TODO which errors are possible for these operations below (that + -- have dummy for now)? + dummy = streamGen 2 [FsInsufficientPermissions] + dumpStateE <- dummy + -- TODO let this one fail: + let hCloseE = Stream.empty + hTruncateE <- dummy + doesDirectoryExistE <- dummy + doesFileExistE <- dummy + hOpenE <- + streamGen + 1 + [ FsResourceDoesNotExist + , FsResourceInappropriateType + , FsResourceAlreadyInUse + , FsResourceAlreadyExist + , FsInsufficientPermissions + , FsTooManyOpenFiles + ] + hSeekE <- streamGen 3 [FsReachedEOF] + hGetSomeE <- commonGetErrors + hGetSomeAtE <- commonGetErrors + hPutSomeE <- commonPutErrors + hGetSizeE <- streamGen 2 [FsResourceDoesNotExist] + createDirectoryE <- + streamGen + 3 + [ FsInsufficientPermissions + , FsResourceInappropriateType + , FsResourceAlreadyExist + ] + createDirectoryIfMissingE <- + streamGen + 3 + [ FsInsufficientPermissions + , FsResourceInappropriateType + , FsResourceAlreadyExist + ] + listDirectoryE <- + streamGen + 3 + [ FsInsufficientPermissions + , FsResourceInappropriateType + , FsResourceDoesNotExist + ] + removeDirectoryRecursiveE <- + streamGen + 3 + [ FsInsufficientPermissions + , FsResourceAlreadyInUse + , FsResourceDoesNotExist + , FsResourceInappropriateType + ] + removeFileE <- + streamGen + 3 + [ FsInsufficientPermissions + , FsResourceAlreadyInUse + , FsResourceDoesNotExist + , FsResourceInappropriateType + ] + renameFileE <- + streamGen + 3 + [ FsInsufficientPermissions + , FsResourceAlreadyInUse + , FsResourceDoesNotExist + , FsResourceInappropriateType + ] + -- File I\/O with user-supplied buffers + hGetBufSomeE <- commonGetErrors + hGetBufSomeAtE <- commonGetErrors + hPutBufSomeE <- commonPutErrors + hPutBufSomeAtE <- commonPutErrors + return Errors{..} + where + genMaybe' = Stream.genMaybe 2 + + streamGen l = Stream.genInfinite . genMaybe' l . QC.elements + streamGen' l = Stream.genInfinite . genMaybe' l . QC.frequency + + commonGetErrors = + streamGen' + 20 [ (1, return $ Left FsReachedEOF) - , (3, Right <$> arbitrary) ] + , (3, Right <$> arbitrary) + ] - commonPutErrors = streamGen' 5 - [ (1, Left . (FsDeviceFull, ) <$> QC.frequency - [ (2, return Nothing) - , (1, Just . PartialWrite <$> arbitrary) - , (if genSubstituteWithJunk then 1 else 0, - Just . SubstituteWithJunk <$> arbitrary) - ]) - , (if genPartialWrites then 3 else 0, Right <$> arbitrary) ] + commonPutErrors = + streamGen' + 5 + [ + ( 1 + , Left . (FsDeviceFull,) + <$> QC.frequency + [ (2, return Nothing) + , (1, Just . PartialWrite <$> arbitrary) + , + ( if genSubstituteWithJunk then 1 else 0 + , Just . SubstituteWithJunk <$> arbitrary + ) + ] + ) + , (if genPartialWrites then 3 else 0, Right <$> arbitrary) + ] instance Arbitrary Errors where arbitrary = genErrors True True shrink err@($(fields 'Errors)) | allNull err = [] - | otherwise = emptyErrors : concatMap (filter (not . allNull)) - [ (\s' -> err { dumpStateE = s' }) <$> Stream.shrinkStream dumpStateE - , (\s' -> err { hOpenE = s' }) <$> Stream.shrinkStream hOpenE - , (\s' -> err { hCloseE = s' }) <$> Stream.shrinkStream hCloseE - , (\s' -> err { hSeekE = s' }) <$> Stream.shrinkStream hSeekE - , (\s' -> err { hGetSomeE = s' }) <$> Stream.shrinkStream hGetSomeE - , (\s' -> err { hGetSomeAtE = s' }) <$> Stream.shrinkStream hGetSomeAtE - , (\s' -> err { hPutSomeE = s' }) <$> Stream.shrinkStream hPutSomeE - , (\s' -> err { hTruncateE = s' }) <$> Stream.shrinkStream hTruncateE - , (\s' -> err { hGetSizeE = s' }) <$> Stream.shrinkStream hGetSizeE - , (\s' -> err { createDirectoryE = s' }) <$> Stream.shrinkStream createDirectoryE - , (\s' -> err { createDirectoryIfMissingE = s' }) <$> Stream.shrinkStream createDirectoryIfMissingE - , (\s' -> err { listDirectoryE = s' }) <$> Stream.shrinkStream listDirectoryE - , (\s' -> err { doesDirectoryExistE = s' }) <$> Stream.shrinkStream doesDirectoryExistE - , (\s' -> err { doesFileExistE = s' }) <$> Stream.shrinkStream doesFileExistE - , (\s' -> err { removeDirectoryRecursiveE = s' }) <$> Stream.shrinkStream removeDirectoryRecursiveE - , (\s' -> err { removeFileE = s' }) <$> Stream.shrinkStream removeFileE - , (\s' -> err { renameFileE = s' }) <$> Stream.shrinkStream renameFileE - -- File I\/O with user-supplied buffers - , (\s' -> err { hGetBufSomeE = s' }) <$> Stream.shrinkStream hGetBufSomeE - , (\s' -> err { hGetBufSomeAtE = s' }) <$> Stream.shrinkStream hGetBufSomeAtE - , (\s' -> err { hPutBufSomeE = s' }) <$> Stream.shrinkStream hPutBufSomeE - , (\s' -> err { hPutBufSomeAtE = s' }) <$> Stream.shrinkStream hPutBufSomeAtE - ] + | otherwise = + emptyErrors + : concatMap + (filter (not . allNull)) + [ (\s' -> err{dumpStateE = s'}) <$> Stream.shrinkStream dumpStateE + , (\s' -> err{hOpenE = s'}) <$> Stream.shrinkStream hOpenE + , (\s' -> err{hCloseE = s'}) <$> Stream.shrinkStream hCloseE + , (\s' -> err{hSeekE = s'}) <$> Stream.shrinkStream hSeekE + , (\s' -> err{hGetSomeE = s'}) <$> Stream.shrinkStream hGetSomeE + , (\s' -> err{hGetSomeAtE = s'}) <$> Stream.shrinkStream hGetSomeAtE + , (\s' -> err{hPutSomeE = s'}) <$> Stream.shrinkStream hPutSomeE + , (\s' -> err{hTruncateE = s'}) <$> Stream.shrinkStream hTruncateE + , (\s' -> err{hGetSizeE = s'}) <$> Stream.shrinkStream hGetSizeE + , (\s' -> err{createDirectoryE = s'}) <$> Stream.shrinkStream createDirectoryE + , (\s' -> err{createDirectoryIfMissingE = s'}) <$> Stream.shrinkStream createDirectoryIfMissingE + , (\s' -> err{listDirectoryE = s'}) <$> Stream.shrinkStream listDirectoryE + , (\s' -> err{doesDirectoryExistE = s'}) <$> Stream.shrinkStream doesDirectoryExistE + , (\s' -> err{doesFileExistE = s'}) <$> Stream.shrinkStream doesFileExistE + , (\s' -> err{removeDirectoryRecursiveE = s'}) <$> Stream.shrinkStream removeDirectoryRecursiveE + , (\s' -> err{removeFileE = s'}) <$> Stream.shrinkStream removeFileE + , (\s' -> err{renameFileE = s'}) <$> Stream.shrinkStream renameFileE + , -- File I\/O with user-supplied buffers + (\s' -> err{hGetBufSomeE = s'}) <$> Stream.shrinkStream hGetBufSomeE + , (\s' -> err{hGetBufSomeAtE = s'}) <$> Stream.shrinkStream hGetBufSomeAtE + , (\s' -> err{hPutBufSomeE = s'}) <$> Stream.shrinkStream hPutBufSomeE + , (\s' -> err{hPutBufSomeAtE = s'}) <$> Stream.shrinkStream hPutBufSomeAtE + ] {------------------------------------------------------------------------------- Simulate Errors monad -------------------------------------------------------------------------------} -- | Alternative to 'simErrorHasFS' that creates 'TVar's internally. -simErrorHasFS' :: (MonadSTM m, MonadThrow m, PrimMonad m) - => MockFS - -> Errors - -> m (HasFS m HandleMock) +simErrorHasFS' :: + (MonadSTM m, MonadThrow m, PrimMonad m) => + MockFS -> + Errors -> + m (HasFS m HandleMock) simErrorHasFS' mockFS errs = - simErrorHasFS <$> newTMVarIO mockFS <*> newTVarIO errs + simErrorHasFS <$> newTMVarIO mockFS <*> newTVarIO errs -- | Introduce possibility of errors -simErrorHasFS :: forall m. (MonadSTM m, MonadThrow m, PrimMonad m) - => StrictTMVar m MockFS - -> StrictTVar m Errors - -> HasFS m HandleMock +simErrorHasFS :: + forall m. + (MonadSTM m, MonadThrow m, PrimMonad m) => + StrictTMVar m MockFS -> + StrictTVar m Errors -> + HasFS m HandleMock simErrorHasFS fsVar errorsVar = - -- TODO: Lenses would be nice for the setters - case Sim.simHasFS fsVar of - hfs@HasFS{..} -> HasFS{ - dumpState = - withErr errorsVar (mkFsPath [""]) dumpState "dumpState" - dumpStateE (\e es -> es { dumpStateE = e }) - , hOpen = \p m -> - withErr errorsVar p (hOpen p m) "hOpen" - hOpenE (\e es -> es { hOpenE = e }) - , hClose = \h -> - withErr' errorsVar h (hClose h) "hClose" - hCloseE (\e es -> es { hCloseE = e }) - , hIsOpen = hIsOpen - , hSeek = \h m n -> - withErr' errorsVar h (hSeek h m n) "hSeek" - hSeekE (\e es -> es { hSeekE = e }) - , hGetSome = hGetSome' errorsVar hGetSome + -- TODO: Lenses would be nice for the setters + case Sim.simHasFS fsVar of + hfs@HasFS{..} -> + HasFS + { dumpState = + withErr + errorsVar + (mkFsPath [""]) + dumpState + "dumpState" + dumpStateE + (\e es -> es{dumpStateE = e}) + , hOpen = \p m -> + withErr + errorsVar + p + (hOpen p m) + "hOpen" + hOpenE + (\e es -> es{hOpenE = e}) + , hClose = \h -> + withErr' + errorsVar + h + (hClose h) + "hClose" + hCloseE + (\e es -> es{hCloseE = e}) + , hIsOpen = hIsOpen + , hSeek = \h m n -> + withErr' + errorsVar + h + (hSeek h m n) + "hSeek" + hSeekE + (\e es -> es{hSeekE = e}) + , hGetSome = hGetSome' errorsVar hGetSome , hGetSomeAt = hGetSomeAt' errorsVar hGetSomeAt - , hPutSome = hPutSome' errorsVar hPutSome - , hTruncate = \h w -> - withErr' errorsVar h (hTruncate h w) "hTruncate" - hTruncateE (\e es -> es { hTruncateE = e }) - , hGetSize = \h -> - withErr' errorsVar h (hGetSize h) "hGetSize" - hGetSizeE (\e es -> es { hGetSizeE = e }) - - , createDirectory = \p -> - withErr errorsVar p (createDirectory p) "createDirectory" - createDirectoryE (\e es -> es { createDirectoryE = e }) + , hPutSome = hPutSome' errorsVar hPutSome + , hTruncate = \h w -> + withErr' + errorsVar + h + (hTruncate h w) + "hTruncate" + hTruncateE + (\e es -> es{hTruncateE = e}) + , hGetSize = \h -> + withErr' + errorsVar + h + (hGetSize h) + "hGetSize" + hGetSizeE + (\e es -> es{hGetSizeE = e}) + , createDirectory = \p -> + withErr + errorsVar + p + (createDirectory p) + "createDirectory" + createDirectoryE + (\e es -> es{createDirectoryE = e}) , createDirectoryIfMissing = \b p -> - withErr errorsVar p (createDirectoryIfMissing b p) "createDirectoryIfMissing" - createDirectoryIfMissingE (\e es -> es { createDirectoryIfMissingE = e }) - , listDirectory = \p -> - withErr errorsVar p (listDirectory p) "listDirectory" - listDirectoryE (\e es -> es { listDirectoryE = e }) - , doesDirectoryExist = \p -> - withErr errorsVar p (doesDirectoryExist p) "doesDirectoryExist" - doesDirectoryExistE (\e es -> es { doesDirectoryExistE = e }) - , doesFileExist = \p -> - withErr errorsVar p (doesFileExist p) "doesFileExist" - doesFileExistE (\e es -> es { doesFileExistE = e }) + withErr + errorsVar + p + (createDirectoryIfMissing b p) + "createDirectoryIfMissing" + createDirectoryIfMissingE + (\e es -> es{createDirectoryIfMissingE = e}) + , listDirectory = \p -> + withErr + errorsVar + p + (listDirectory p) + "listDirectory" + listDirectoryE + (\e es -> es{listDirectoryE = e}) + , doesDirectoryExist = \p -> + withErr + errorsVar + p + (doesDirectoryExist p) + "doesDirectoryExist" + doesDirectoryExistE + (\e es -> es{doesDirectoryExistE = e}) + , doesFileExist = \p -> + withErr + errorsVar + p + (doesFileExist p) + "doesFileExist" + doesFileExistE + (\e es -> es{doesFileExistE = e}) , removeDirectoryRecursive = \p -> - withErr errorsVar p (removeDirectoryRecursive p) "removeFile" - removeDirectoryRecursiveE (\e es -> es { removeDirectoryRecursiveE = e }) - , removeFile = \p -> - withErr errorsVar p (removeFile p) "removeFile" - removeFileE (\e es -> es { removeFileE = e }) - , renameFile = \p1 p2 -> - withErr errorsVar p1 (renameFile p1 p2) "renameFile" - renameFileE (\e es -> es { renameFileE = e }) + withErr + errorsVar + p + (removeDirectoryRecursive p) + "removeFile" + removeDirectoryRecursiveE + (\e es -> es{removeDirectoryRecursiveE = e}) + , removeFile = \p -> + withErr + errorsVar + p + (removeFile p) + "removeFile" + removeFileE + (\e es -> es{removeFileE = e}) + , renameFile = \p1 p2 -> + withErr + errorsVar + p1 + (renameFile p1 p2) + "renameFile" + renameFileE + (\e es -> es{renameFileE = e}) , mkFsErrorPath = fsToFsErrorPathUnmounted , unsafeToFilePath = error "simErrorHasFS:unsafeToFilePath" - -- File I\/O with user-supplied buffers - , hGetBufSome = hGetBufSomeWithErr errorsVar hfs + , -- File I\/O with user-supplied buffers + hGetBufSome = hGetBufSomeWithErr errorsVar hfs , hGetBufSomeAt = hGetBufSomeAtWithErr errorsVar hfs - , hPutBufSome = hPutBufSomeWithErr errorsVar hfs + , hPutBufSome = hPutBufSomeWithErr errorsVar hfs , hPutBufSomeAt = hPutBufSomeAtWithErr errorsVar hfs } -- | Runs a computation provided an 'Errors' and an initial -- 'MockFS', producing a result and the final state of the filesystem. -runSimErrorFS :: (MonadSTM m, MonadThrow m, PrimMonad m) - => MockFS - -> Errors - -> (StrictTVar m Errors -> HasFS m HandleMock -> m a) - -> m (a, MockFS) +runSimErrorFS :: + (MonadSTM m, MonadThrow m, PrimMonad m) => + MockFS -> + Errors -> + (StrictTVar m Errors -> HasFS m HandleMock -> m a) -> + m (a, MockFS) runSimErrorFS mockFS errors action = do - fsVar <- newTMVarIO mockFS - errorsVar <- newTVarIO errors - a <- action errorsVar $ simErrorHasFS fsVar errorsVar - fs' <- atomically $ takeTMVar fsVar - return (a, fs') + fsVar <- newTMVarIO mockFS + errorsVar <- newTVarIO errors + a <- action errorsVar $ simErrorHasFS fsVar errorsVar + fs' <- atomically $ takeTMVar fsVar + return (a, fs') -- | Execute the next action using the given 'Errors'. After the action is -- finished, the previous 'Errors' are restored. withErrors :: (MonadSTM m, MonadThrow m) => StrictTVar m Errors -> Errors -> m a -> m a withErrors errorsVar tempErrors action = - bracket - (atomically $ swapTVar errorsVar tempErrors) - (\originalErrors -> atomically $ swapTVar errorsVar originalErrors) - $ \_ -> action + bracket + (atomically $ swapTVar errorsVar tempErrors) + (\originalErrors -> atomically $ swapTVar errorsVar originalErrors) + $ \_ -> action {------------------------------------------------------------------------------- Utilities @@ -590,120 +735,156 @@ withErrors errorsVar tempErrors action = -- 'Errors' stored in the 'StrictTVar'. Extracts the right error stream from -- the state with the @getter@ and stores the advanced error stream in the -- state with the @setter@. -next :: MonadSTM m - => StrictTVar m Errors - -> (Errors -> Stream a) -- ^ @getter@ - -> (Stream a -> Errors -> Errors) -- ^ @setter@ - -> m (Maybe a) +next :: + MonadSTM m => + StrictTVar m Errors -> + -- | @getter@ + (Errors -> Stream a) -> + -- | @setter@ + (Stream a -> Errors -> Errors) -> + m (Maybe a) next errorsVar getter setter = do - atomically $ do - errors <- readTVar errorsVar - let (mb, s') = Stream.runStream (getter errors) - writeTVar errorsVar (setter s' errors) - return mb + atomically $ do + errors <- readTVar errorsVar + let (mb, s') = Stream.runStream (getter errors) + writeTVar errorsVar (setter s' errors) + return mb -- | Execute an action or throw an error, depending on the corresponding -- 'ErrorStream' (see 'nextError'). -withErr :: (MonadSTM m, MonadThrow m, HasCallStack) - => StrictTVar m Errors - -> FsPath -- ^ The path for the error, if thrown - -> m a -- ^ Action in case no error is thrown - -> String -- ^ Extra message for in the 'fsErrorString' - -> (Errors -> ErrorStream) -- ^ @getter@ - -> (ErrorStream -> Errors -> Errors) -- ^ @setter@ - -> m a +withErr :: + (MonadSTM m, MonadThrow m, HasCallStack) => + StrictTVar m Errors -> + -- | The path for the error, if thrown + FsPath -> + -- | Action in case no error is thrown + m a -> + -- | Extra message for in the 'fsErrorString' + String -> + -- | @getter@ + (Errors -> ErrorStream) -> + -- | @setter@ + (ErrorStream -> Errors -> Errors) -> + m a withErr errorsVar path action msg getter setter = do - mbErr <- next errorsVar getter setter - case mbErr of - Nothing -> action - Just errType -> throwIO FsError - { fsErrorType = errType - , fsErrorPath = fsToFsErrorPathUnmounted path - , fsErrorString = "simulated error: " <> msg - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } + mbErr <- next errorsVar getter setter + case mbErr of + Nothing -> action + Just errType -> + throwIO + FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted path + , fsErrorString = "simulated error: " <> msg + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } -- | Variant of 'withErr' that works with 'Handle's. -- -- The path of the handle is retrieved from the 'MockFS' using 'handleFsPath'. -withErr' :: (MonadSTM m, MonadThrow m, HasCallStack) - => StrictTVar m Errors - -> Handle HandleMock -- ^ The path for the error, if thrown - -> m a -- ^ Action in case no error is thrown - -> String -- ^ Extra message for in the 'fsErrorString' - -> (Errors -> ErrorStream) -- ^ @getter@ - -> (ErrorStream -> Errors -> Errors) -- ^ @setter@ - -> m a +withErr' :: + (MonadSTM m, MonadThrow m, HasCallStack) => + StrictTVar m Errors -> + -- | The path for the error, if thrown + Handle HandleMock -> + -- | Action in case no error is thrown + m a -> + -- | Extra message for in the 'fsErrorString' + String -> + -- | @getter@ + (Errors -> ErrorStream) -> + -- | @setter@ + (ErrorStream -> Errors -> Errors) -> + m a withErr' errorsVar handle action msg getter setter = - withErr errorsVar (handlePath handle) action msg getter setter + withErr errorsVar (handlePath handle) action msg getter setter -- | Execute the wrapped 'hGetSome', throw an error, or simulate a partial -- read, depending on the corresponding 'ErrorStreamGetSome' (see -- 'nextError'). -hGetSome' :: (MonadSTM m, MonadThrow m, HasCallStack) - => StrictTVar m Errors - -> (Handle HandleMock -> Word64 -> m BS.ByteString) -- ^ Wrapped 'hGetSome' - -> Handle HandleMock -> Word64 -> m BS.ByteString +hGetSome' :: + (MonadSTM m, MonadThrow m, HasCallStack) => + StrictTVar m Errors -> + -- | Wrapped 'hGetSome' + (Handle HandleMock -> Word64 -> m BS.ByteString) -> + Handle HandleMock -> + Word64 -> + m BS.ByteString hGetSome' errorsVar hGetSomeWrapped handle n = - next errorsVar hGetSomeE (\e es -> es { hGetSomeE = e }) >>= \case - Nothing -> hGetSomeWrapped handle n - Just (Left errType) -> throwIO FsError - { fsErrorType = errType - , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle - , fsErrorString = "simulated error: hGetSome" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - Just (Right partial) -> - hGetSomeWrapped handle (partialiseWord64 partial n) + next errorsVar hGetSomeE (\e es -> es{hGetSomeE = e}) >>= \case + Nothing -> hGetSomeWrapped handle n + Just (Left errType) -> + throwIO + FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle + , fsErrorString = "simulated error: hGetSome" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + Just (Right partial) -> + hGetSomeWrapped handle (partialiseWord64 partial n) -- | In the thread safe version of 'hGetSome', we simulate exactly the same errors. -hGetSomeAt' :: (MonadSTM m, MonadThrow m, HasCallStack) - => StrictTVar m Errors - -> (Handle HandleMock -> Word64 -> AbsOffset -> m BS.ByteString) -- ^ Wrapped 'hGetSomeAt' - -> Handle HandleMock -> Word64 -> AbsOffset -> m BS.ByteString +hGetSomeAt' :: + (MonadSTM m, MonadThrow m, HasCallStack) => + StrictTVar m Errors -> + -- | Wrapped 'hGetSomeAt' + (Handle HandleMock -> Word64 -> AbsOffset -> m BS.ByteString) -> + Handle HandleMock -> + Word64 -> + AbsOffset -> + m BS.ByteString hGetSomeAt' errorsVar hGetSomeAtWrapped handle n offset = - next errorsVar hGetSomeAtE (\e es -> es { hGetSomeAtE = e }) >>= \case - Nothing -> hGetSomeAtWrapped handle n offset - Just (Left errType) -> throwIO FsError - { fsErrorType = errType - , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle - , fsErrorString = "simulated error: hGetSomeAt" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - Just (Right partial) -> - hGetSomeAtWrapped handle (partialiseWord64 partial n) offset + next errorsVar hGetSomeAtE (\e es -> es{hGetSomeAtE = e}) >>= \case + Nothing -> hGetSomeAtWrapped handle n offset + Just (Left errType) -> + throwIO + FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle + , fsErrorString = "simulated error: hGetSomeAt" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + Just (Right partial) -> + hGetSomeAtWrapped handle (partialiseWord64 partial n) offset -- | Execute the wrapped 'hPutSome', throw an error and apply possible -- corruption to the blob to write, or simulate a partial write, depending on -- the corresponding 'ErrorStreamPutSome' (see 'nextError'). -hPutSome' :: (MonadSTM m, MonadThrow m, HasCallStack) - => StrictTVar m Errors - -> (Handle HandleMock -> BS.ByteString -> m Word64) -- ^ Wrapped 'hPutSome' - -> Handle HandleMock -> BS.ByteString -> m Word64 +hPutSome' :: + (MonadSTM m, MonadThrow m, HasCallStack) => + StrictTVar m Errors -> + -- | Wrapped 'hPutSome' + (Handle HandleMock -> BS.ByteString -> m Word64) -> + Handle HandleMock -> + BS.ByteString -> + m Word64 hPutSome' errorsVar hPutSomeWrapped handle bs = - next errorsVar hPutSomeE (\e es -> es { hPutSomeE = e }) >>= \case - Nothing -> hPutSomeWrapped handle bs - Just (Left (errType, mbCorr)) -> do - for_ mbCorr $ \corr -> - void $ hPutSomeWrapped handle (corruptByteString bs corr) - throwIO FsError - { fsErrorType = errType - , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle - , fsErrorString = "simulated error: hPutSome" <> case mbCorr of - Nothing -> "" - Just corr -> " with corruption: " <> show corr - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False + next errorsVar hPutSomeE (\e es -> es{hPutSomeE = e}) >>= \case + Nothing -> hPutSomeWrapped handle bs + Just (Left (errType, mbCorr)) -> do + for_ mbCorr $ \corr -> + void $ hPutSomeWrapped handle (corruptByteString bs corr) + throwIO + FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle + , fsErrorString = + "simulated error: hPutSome" <> case mbCorr of + Nothing -> "" + Just corr -> " with corruption: " <> show corr + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False } - Just (Right partial) -> - hPutSomeWrapped handle (partialiseByteString partial bs) + Just (Right partial) -> + hPutSomeWrapped handle (partialiseByteString partial bs) {------------------------------------------------------------------------------- File I\/O with user-supplied buffers @@ -711,132 +892,140 @@ hPutSome' errorsVar hPutSomeWrapped handle bs = -- | Short-hand for the type of 'hGetBufSome' type HGetBufSome m = - Handle HandleMock - -> MutableByteArray (PrimState m) - -> BufferOffset - -> ByteCount - -> m ByteCount + Handle HandleMock -> + MutableByteArray (PrimState m) -> + BufferOffset -> + ByteCount -> + m ByteCount -- | Execute the wrapped 'hGetBufSome', throw an error, or simulate a partial -- read, depending on the corresponding 'ErrorStreamGetSome' (see 'nextError'). -hGetBufSomeWithErr :: - (MonadSTM m, MonadThrow m, HasCallStack) - => StrictTVar m Errors - -> HasFS m HandleMock - -> HGetBufSome m +hGetBufSomeWithErr :: + (MonadSTM m, MonadThrow m, HasCallStack) => + StrictTVar m Errors -> + HasFS m HandleMock -> + HGetBufSome m hGetBufSomeWithErr errorsVar hfs h buf bufOff c = - next errorsVar hGetBufSomeE (\e es -> es { hGetBufSomeE = e }) >>= \case - Nothing -> hGetBufSome hfs h buf bufOff c - Just (Left errType) -> throwIO FsError - { fsErrorType = errType - , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h - , fsErrorString = "simulated error: hGetBufSome" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - Just (Right partial) -> - hGetBufSome hfs h buf bufOff (partialiseByteCount partial c) + next errorsVar hGetBufSomeE (\e es -> es{hGetBufSomeE = e}) >>= \case + Nothing -> hGetBufSome hfs h buf bufOff c + Just (Left errType) -> + throwIO + FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h + , fsErrorString = "simulated error: hGetBufSome" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + Just (Right partial) -> + hGetBufSome hfs h buf bufOff (partialiseByteCount partial c) -- | Short-hand for the type of 'hGetBufSomeAt' type HGetBufSomeAt m = - Handle HandleMock - -> MutableByteArray (PrimState m) - -> BufferOffset - -> ByteCount - -> AbsOffset - -> m ByteCount + Handle HandleMock -> + MutableByteArray (PrimState m) -> + BufferOffset -> + ByteCount -> + AbsOffset -> + m ByteCount -- | Execute the wrapped 'hGetBufSomeAt', throw an error, or simulate a partial -- read, depending on the corresponding 'ErrorStreamGetSome' (see 'nextError'). -hGetBufSomeAtWithErr :: - (MonadSTM m, MonadThrow m, HasCallStack) - => StrictTVar m Errors - -> HasFS m HandleMock - -> HGetBufSomeAt m +hGetBufSomeAtWithErr :: + (MonadSTM m, MonadThrow m, HasCallStack) => + StrictTVar m Errors -> + HasFS m HandleMock -> + HGetBufSomeAt m hGetBufSomeAtWithErr errorsVar hfs h buf bufOff c off = - next errorsVar hGetBufSomeAtE (\e es -> es { hGetBufSomeAtE = e }) >>= \case - Nothing -> hGetBufSomeAt hfs h buf bufOff c off - Just (Left errType) -> throwIO FsError - { fsErrorType = errType - , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h - , fsErrorString = "simulated error: hGetBufSomeAt" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - Just (Right partial) -> - hGetBufSomeAt hfs h buf bufOff (partialiseByteCount partial c) off + next errorsVar hGetBufSomeAtE (\e es -> es{hGetBufSomeAtE = e}) >>= \case + Nothing -> hGetBufSomeAt hfs h buf bufOff c off + Just (Left errType) -> + throwIO + FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h + , fsErrorString = "simulated error: hGetBufSomeAt" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + Just (Right partial) -> + hGetBufSomeAt hfs h buf bufOff (partialiseByteCount partial c) off -- | Short-hand for the type of 'hPutBufSome' type HPutBufSome m = - Handle HandleMock - -> MutableByteArray (PrimState m) - -> BufferOffset - -> ByteCount - -> m ByteCount + Handle HandleMock -> + MutableByteArray (PrimState m) -> + BufferOffset -> + ByteCount -> + m ByteCount -- | Execute the wrapped 'hPutBufSome', throw an error and apply possible -- corruption to the blob to write, or simulate a partial write, depending on -- the corresponding 'ErrorStreamPutSome' (see 'nextError'). hPutBufSomeWithErr :: - (MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack) - => StrictTVar m Errors - -> HasFS m HandleMock - -> HPutBufSome m + (MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack) => + StrictTVar m Errors -> + HasFS m HandleMock -> + HPutBufSome m hPutBufSomeWithErr errorsVar hfs h buf bufOff c = - next errorsVar hPutBufSomeE (\e es -> es { hPutBufSomeE = e }) >>= \case - Nothing -> hPutBufSome hfs h buf bufOff c - Just (Left (errType, mbCorr)) -> do - for_ mbCorr $ \corr -> do - (buf', c') <- corruptBuffer buf bufOff c corr - void $ hPutBufSome hfs h buf' bufOff c' - throwIO FsError - { fsErrorType = errType - , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h - , fsErrorString = "simulated error: hPutSome" <> case mbCorr of - Nothing -> "" - Just corr -> " with corruption: " <> show corr - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False + next errorsVar hPutBufSomeE (\e es -> es{hPutBufSomeE = e}) >>= \case + Nothing -> hPutBufSome hfs h buf bufOff c + Just (Left (errType, mbCorr)) -> do + for_ mbCorr $ \corr -> do + (buf', c') <- corruptBuffer buf bufOff c corr + void $ hPutBufSome hfs h buf' bufOff c' + throwIO + FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h + , fsErrorString = + "simulated error: hPutSome" <> case mbCorr of + Nothing -> "" + Just corr -> " with corruption: " <> show corr + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False } - Just (Right partial) -> - hPutBufSome hfs h buf bufOff (partialiseByteCount partial c) + Just (Right partial) -> + hPutBufSome hfs h buf bufOff (partialiseByteCount partial c) -- | Short-hand for the type of 'hPutBufSomeAt' type HPutBufSomeAt m = - Handle HandleMock - -> MutableByteArray (PrimState m) - -> BufferOffset - -> ByteCount - -> AbsOffset - -> m ByteCount + Handle HandleMock -> + MutableByteArray (PrimState m) -> + BufferOffset -> + ByteCount -> + AbsOffset -> + m ByteCount -- | Execute the wrapped 'hPutBufSomeAt', throw an error and apply possible -- corruption to the blob to write, or simulate a partial write, depending on -- the corresponding 'ErrorStreamPutSome' (see 'nextError'). hPutBufSomeAtWithErr :: - (MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack) - => StrictTVar m Errors - -> HasFS m HandleMock - -> HPutBufSomeAt m + (MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack) => + StrictTVar m Errors -> + HasFS m HandleMock -> + HPutBufSomeAt m hPutBufSomeAtWithErr errorsVar hfs h buf bufOff c off = - next errorsVar hPutBufSomeAtE (\e es -> es { hPutBufSomeAtE = e }) >>= \case - Nothing -> hPutBufSomeAt hfs h buf bufOff c off - Just (Left (errType, mbCorr)) -> do - for_ mbCorr $ \corr -> do - (buf', c') <- corruptBuffer buf bufOff c corr - void $ hPutBufSomeAt hfs h buf' bufOff c' off - throwIO FsError - { fsErrorType = errType - , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h - , fsErrorString = "simulated error: hPutSome" <> case mbCorr of - Nothing -> "" - Just corr -> " with corruption: " <> show corr - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False + next errorsVar hPutBufSomeAtE (\e es -> es{hPutBufSomeAtE = e}) >>= \case + Nothing -> hPutBufSomeAt hfs h buf bufOff c off + Just (Left (errType, mbCorr)) -> do + for_ mbCorr $ \corr -> do + (buf', c') <- corruptBuffer buf bufOff c corr + void $ hPutBufSomeAt hfs h buf' bufOff c' off + throwIO + FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h + , fsErrorString = + "simulated error: hPutSome" <> case mbCorr of + Nothing -> "" + Just corr -> " with corruption: " <> show corr + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False } - Just (Right partial) -> - hPutBufSomeAt hfs h buf bufOff (partialiseByteCount partial c) off + Just (Right partial) -> + hPutBufSomeAt hfs h buf bufOff (partialiseByteCount partial c) off diff --git a/fs-sim/src/System/FS/Sim/FsTree.hs b/fs-sim/src/System/FS/Sim/FsTree.hs index aa06bb4..d1a6479 100644 --- a/fs-sim/src/System/FS/Sim/FsTree.hs +++ b/fs-sim/src/System/FS/Sim/FsTree.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Internal part of the mock file system @@ -12,17 +12,20 @@ -- -- > import System.FS.Sim.FsTree (FsTree) -- > import qualified System.FS.Sim.FsTree as FS -module System.FS.Sim.FsTree ( - -- * FsTree type and indexing functions +module System.FS.Sim.FsTree + ( -- * FsTree type and indexing functions FsTree (..) , FsTreeError (..) , example + -- * Construction , empty + -- * Indexing , getDir , getFile , index + -- * File system operations , createDirIfMissing , createDirWithParents @@ -31,24 +34,25 @@ module System.FS.Sim.FsTree ( , removeFile , renameFile , replace + -- * Path-listing , find + -- * Pretty-printing , pretty ) where -import Data.Functor.Const -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map.Strict (Map) +import Data.Functor.Const +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Data.Text (Text) +import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text as Text -import Data.Tree -import GHC.Generics (Generic) -import GHC.Stack - -import System.FS.API.Types +import Data.Tree +import GHC.Generics (Generic) +import GHC.Stack +import System.FS.API.Types {------------------------------------------------------------------------------- FsTree type and general indexing functions @@ -63,125 +67,167 @@ type Folder a = Map Text (FsTree a) -- | Example example :: Monoid a => FsTree a example = - Folder $ M.fromList [ - ("usr", Folder $ M.fromList [ - ("local", Folder $ M.fromList [ - ("bin", Folder mempty) - ]) - ]) - , ("var", Folder $ M.fromList [ - ("log", Folder mempty) - , ("mail", Folder mempty) - , ("run", Folder mempty) - , ("tmp", Folder $ M.fromList [ - ("foo.txt", File mempty) - ]) - ]) + Folder $ + M.fromList + [ + ( "usr" + , Folder $ + M.fromList + [ + ( "local" + , Folder $ + M.fromList + [ ("bin", Folder mempty) + ] + ) + ] + ) + , + ( "var" + , Folder $ + M.fromList + [ ("log", Folder mempty) + , ("mail", Folder mempty) + , ("run", Folder mempty) + , + ( "tmp" + , Folder $ + M.fromList + [ ("foo.txt", File mempty) + ] + ) + ] + ) ] -- | File access error -data FsTreeError = - -- | A path @../a/..@ where @a@ is a file rather than a dir +data FsTreeError + = -- | A path @../a/..@ where @a@ is a file rather than a dir -- -- We record both the full path and the invalid suffix. FsExpectedDir FsPath (NonEmpty Text) - - -- | A path @../a/..@ where @a@ is a dir rather than a file + | -- | A path @../a/..@ where @a@ is a dir rather than a file -- -- No suffix is specified (it /must/ be the last part of the file) - | FsExpectedFile FsPath - - -- | A path @../a/..@ or @../a@ where directory or file @a@ is missing + FsExpectedFile FsPath + | -- | A path @../a/..@ or @../a@ where directory or file @a@ is missing -- -- We record both the full path and the missing suffix. - | FsMissing FsPath (NonEmpty Text) - - -- | A file was opened with the O_EXCL flag, but it already existed. - | FsExists FsPath - deriving (Show) + FsMissing FsPath (NonEmpty Text) + | -- | A file was opened with the O_EXCL flag, but it already existed. + FsExists FsPath + deriving Show setFsTreeErrorPath :: FsPath -> FsTreeError -> FsTreeError -setFsTreeErrorPath fp (FsExpectedDir _ suffix) = FsExpectedDir fp suffix -setFsTreeErrorPath fp (FsExpectedFile _) = FsExpectedFile fp -setFsTreeErrorPath fp (FsMissing _ suffix) = FsMissing fp suffix -setFsTreeErrorPath fp (FsExists _) = FsExists fp +setFsTreeErrorPath fp (FsExpectedDir _ suffix) = FsExpectedDir fp suffix +setFsTreeErrorPath fp (FsExpectedFile _) = FsExpectedFile fp +setFsTreeErrorPath fp (FsMissing _ suffix) = FsMissing fp suffix +setFsTreeErrorPath fp (FsExists _) = FsExists fp {------------------------------------------------------------------------------- Altering -------------------------------------------------------------------------------} -- | Most general indexing function -alterF :: forall f a. Functor f - => FsPath -- ^ Path to look for - -> (FsTreeError -> f (Maybe (FsTree a))) -- ^ Action on error - -> (FsTree a -> f (Maybe (FsTree a))) -- ^ Alter the tree when found - -> (FsTree a -> f (FsTree a)) +alterF :: + forall f a. + Functor f => + -- | Path to look for + FsPath -> + -- | Action on error + (FsTreeError -> f (Maybe (FsTree a))) -> + -- | Alter the tree when found + (FsTree a -> f (Maybe (FsTree a))) -> + (FsTree a -> f (FsTree a)) alterF fp onErr f = fmap (fromMaybe empty) . go (fsPathToList fp) - where - go :: [Text] -> FsTree a -> f (Maybe (FsTree a)) - go [] t = f t - go (p:ps) (File _) = onErr (FsExpectedDir fp (p :| ps)) - go (p:ps) (Folder m) = Just . Folder <$> M.alterF f' p m - where - f' :: Maybe (FsTree a) -> f (Maybe (FsTree a)) - f' Nothing = onErr (FsMissing fp (p :| ps)) - f' (Just t) = go ps t - -alterDir :: forall f a. Functor f - => FsPath - -> (FsTreeError -> f (FsTree a)) -- ^ Action on error - -> f (Folder a) -- ^ If directory does not exist - -> (Folder a -> f (Folder a)) -- ^ If directory exists - -> (FsTree a -> f (FsTree a)) + where + go :: [Text] -> FsTree a -> f (Maybe (FsTree a)) + go [] t = f t + go (p : ps) (File _) = onErr (FsExpectedDir fp (p :| ps)) + go (p : ps) (Folder m) = Just . Folder <$> M.alterF f' p m + where + f' :: Maybe (FsTree a) -> f (Maybe (FsTree a)) + f' Nothing = onErr (FsMissing fp (p :| ps)) + f' (Just t) = go ps t + +alterDir :: + forall f a. + Functor f => + FsPath -> + -- | Action on error + (FsTreeError -> f (FsTree a)) -> + -- | If directory does not exist + f (Folder a) -> + -- | If directory exists + (Folder a -> f (Folder a)) -> + (FsTree a -> f (FsTree a)) alterDir p onErr onNotExists onExists = - alterDirMaybe p - (fmap Just . onErr) - (fmap Just onNotExists) - (fmap Just . onExists) + alterDirMaybe + p + (fmap Just . onErr) + (fmap Just onNotExists) + (fmap Just . onExists) -- | alterDirMaybe might remove a directory -alterDirMaybe :: forall f a. Functor f - => FsPath - -> (FsTreeError -> f (Maybe (FsTree a))) -- ^ Action on error - -> f (Maybe (Folder a)) -- ^ If directory does not exist - -> (Folder a -> f (Maybe (Folder a))) -- ^ If directory exists - -> (FsTree a -> f (FsTree a)) +alterDirMaybe :: + forall f a. + Functor f => + FsPath -> + -- | Action on error + (FsTreeError -> f (Maybe (FsTree a))) -> + -- | If directory does not exist + f (Maybe (Folder a)) -> + -- | If directory exists + (Folder a -> f (Maybe (Folder a))) -> + (FsTree a -> f (FsTree a)) alterDirMaybe p onErr onNotExists onExists = alterF p onErr' f - where - onErr' :: FsTreeError -> f (Maybe (FsTree a)) - onErr' (FsMissing _ (_ :| [])) = fmap Folder <$> onNotExists - onErr' err = onErr err - - f :: FsTree a -> f (Maybe (FsTree a)) - f (Folder m) = fmap Folder <$> onExists m - f (File _) = onErr $ FsExpectedDir p (pathLast p :| []) - -alterFileMaybe :: forall f a. Functor f - => FsPath - -> (FsTreeError -> f (Maybe (FsTree a))) -- ^ Action on error - -> f (Maybe a) -- ^ If file does not exist - -> (a -> f (Maybe a)) -- ^ If file exists - -> (FsTree a -> f (FsTree a)) + where + onErr' :: FsTreeError -> f (Maybe (FsTree a)) + onErr' (FsMissing _ (_ :| [])) = fmap Folder <$> onNotExists + onErr' err = onErr err + + f :: FsTree a -> f (Maybe (FsTree a)) + f (Folder m) = fmap Folder <$> onExists m + f (File _) = onErr $ FsExpectedDir p (pathLast p :| []) + +alterFileMaybe :: + forall f a. + Functor f => + FsPath -> + -- | Action on error + (FsTreeError -> f (Maybe (FsTree a))) -> + -- | If file does not exist + f (Maybe a) -> + -- | If file exists + (a -> f (Maybe a)) -> + (FsTree a -> f (FsTree a)) alterFileMaybe p onErr onNotExists onExists = alterF p onErr' f - where - onErr' :: FsTreeError -> f (Maybe (FsTree a)) - onErr' (FsMissing _ (_ :| [])) = fmap File <$> onNotExists - onErr' err = onErr err - - f :: FsTree a -> f (Maybe (FsTree a)) - f (File a) = fmap File <$> onExists a - f (Folder _) = onErr $ FsExpectedFile p - -alterFile :: forall f a. Functor f - => FsPath - -> (FsTreeError -> f (FsTree a)) -- ^ Action on error - -> f a -- ^ If file does not exist - -> (a -> f a) -- ^ If file exists - -> (FsTree a -> f (FsTree a)) + where + onErr' :: FsTreeError -> f (Maybe (FsTree a)) + onErr' (FsMissing _ (_ :| [])) = fmap File <$> onNotExists + onErr' err = onErr err + + f :: FsTree a -> f (Maybe (FsTree a)) + f (File a) = fmap File <$> onExists a + f (Folder _) = onErr $ FsExpectedFile p + +alterFile :: + forall f a. + Functor f => + FsPath -> + -- | Action on error + (FsTreeError -> f (FsTree a)) -> + -- | If file does not exist + f a -> + -- | If file exists + (a -> f a) -> + (FsTree a -> f (FsTree a)) alterFile p onErr onNotExists onExists = - alterFileMaybe p (fmap Just . onErr) (fmap Just onNotExists) - (fmap Just . onExists) - + alterFileMaybe + p + (fmap Just . onErr) + (fmap Just onNotExists) + (fmap Just . onExists) {------------------------------------------------------------------------------- Construction @@ -196,16 +242,17 @@ empty = Folder M.empty pathLast :: HasCallStack => FsPath -> Text pathLast fp = case fsPathSplit fp of - Nothing -> error "pathLast: empty path" - Just (_, p) -> p + Nothing -> error "pathLast: empty path" + Just (_, p) -> p pathInits :: FsPath -> [FsPath] pathInits = reverse . go - where - go :: FsPath -> [FsPath] - go fp = fp : case fsPathSplit fp of - Nothing -> [] - Just (fp', _) -> go fp' + where + go :: FsPath -> [FsPath] + go fp = + fp : case fsPathSplit fp of + Nothing -> [] + Just (fp', _) -> go fp' {------------------------------------------------------------------------------- Indexing @@ -217,15 +264,15 @@ index fp = getConst . alterF fp (Const . Left) (Const . Right) getFile :: FsPath -> FsTree a -> Either FsTreeError a getFile fp = - getConst . alterFile fp (Const . Left) errNotExist (Const . Right) - where - errNotExist = Const . Left $ FsMissing fp (pathLast fp :| []) + getConst . alterFile fp (Const . Left) errNotExist (Const . Right) + where + errNotExist = Const . Left $ FsMissing fp (pathLast fp :| []) getDir :: FsPath -> FsTree a -> Either FsTreeError (Folder a) getDir fp = - getConst . alterDir fp (Const . Left) errNotExist (Const . Right) - where - errNotExist = Const . Left $ FsMissing fp (pathLast fp :| []) + getConst . alterDir fp (Const . Left) errNotExist (Const . Right) + where + errNotExist = Const . Left $ FsMissing fp (pathLast fp :| []) {------------------------------------------------------------------------------- Specific file system functions @@ -235,26 +282,27 @@ getDir fp = -- 1. It existed already while we were supposed to create it from scratch -- (when passed 'MustBeNew'). -- 2. It did not already exists when we expected to (when passed 'MustExist'). -openFile :: Monoid a - => FsPath -> AllowExisting -> FsTree a -> Either FsTreeError (FsTree a) +openFile :: + Monoid a => + FsPath -> AllowExisting -> FsTree a -> Either FsTreeError (FsTree a) openFile fp ex = alterFile fp Left caseDoesNotExist caseAlreadyExist - where - caseAlreadyExist a = case ex of - AllowExisting -> Right a - MustBeNew -> Left (FsExists fp) - MustExist -> Right a + where + caseAlreadyExist a = case ex of + AllowExisting -> Right a + MustBeNew -> Left (FsExists fp) + MustExist -> Right a - caseDoesNotExist = case ex of - AllowExisting -> Right mempty - MustBeNew -> Right mempty - MustExist -> Left (FsMissing fp (pathLast fp :| [])) + caseDoesNotExist = case ex of + AllowExisting -> Right mempty + MustBeNew -> Right mempty + MustExist -> Left (FsMissing fp (pathLast fp :| [])) -- | Replace the contents of the specified file (which must exist) replace :: FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a) replace fp new = - alterFile fp Left errNotExist (\_old -> Right new) - where - errNotExist = Left (FsMissing fp (pathLast fp :| [])) + alterFile fp Left errNotExist (\_old -> Right new) + where + errNotExist = Left (FsMissing fp (pathLast fp :| [])) -- | Create a directory if it does not already exist createDirIfMissing :: FsPath -> FsTree a -> Either FsTreeError (FsTree a) @@ -263,44 +311,44 @@ createDirIfMissing fp = alterDir fp Left (Right M.empty) Right -- | Create a directory and its parents if they do not already exist createDirWithParents :: FsPath -> FsTree a -> Either FsTreeError (FsTree a) createDirWithParents fp = - -- Report full path in the error, not the prefix at the point of failure - either (Left . setFsTreeErrorPath fp) Right + -- Report full path in the error, not the prefix at the point of failure + either (Left . setFsTreeErrorPath fp) Right . repeatedlyM createDirIfMissing (pathInits fp) - where - repeatedlyM :: Monad m => (a -> b -> m b) -> ([a] -> b -> m b) - repeatedlyM = flip . foldlM' . flip + where + repeatedlyM :: Monad m => (a -> b -> m b) -> ([a] -> b -> m b) + repeatedlyM = flip . foldlM' . flip - foldlM' :: forall m a b. Monad m => (b -> a -> m b) -> b -> [a] -> m b - foldlM' f = go - where - go :: b -> [a] -> m b - go !acc [] = return acc - go !acc (x:xs) = f acc x >>= \acc' -> go acc' xs + foldlM' :: forall m a b. Monad m => (b -> a -> m b) -> b -> [a] -> m b + foldlM' f = go + where + go :: b -> [a] -> m b + go !acc [] = return acc + go !acc (x : xs) = f acc x >>= \acc' -> go acc' xs -- | Remove a directory (which must exist) and its contents removeDirRecursive :: FsPath -> FsTree a -> Either FsTreeError (FsTree a) removeDirRecursive fp = - alterDirMaybe fp Left errNotExist (const (Right Nothing)) - where - errNotExist = Left (FsMissing fp (pathLast fp :| [])) + alterDirMaybe fp Left errNotExist (const (Right Nothing)) + where + errNotExist = Left (FsMissing fp (pathLast fp :| [])) -- | Remove a file (which must exist) removeFile :: FsPath -> FsTree a -> Either FsTreeError (FsTree a) removeFile fp = - alterFileMaybe fp Left errNotExist (const (Right Nothing)) - where - errNotExist = Left (FsMissing fp (pathLast fp :| [])) + alterFileMaybe fp Left errNotExist (const (Right Nothing)) + where + errNotExist = Left (FsMissing fp (pathLast fp :| [])) -- | Rename the file (which must exist) from the first path to the second -- path. If there is already a file at the latter path, it is replaced by the -- new one. renameFile :: FsPath -> FsPath -> FsTree a -> Either FsTreeError (FsTree a) renameFile fpOld fpNew tree = do - oldF <- getFile fpOld tree - -- Remove the old file - tree' <- removeFile fpOld tree - -- Overwrite the new file with the old one - alterFile fpNew Left (Right oldF) (const (Right oldF)) tree' + oldF <- getFile fpOld tree + -- Remove the old file + tree' <- removeFile fpOld tree + -- Overwrite the new file with the old one + alterFile fpNew Left (Right oldF) (const (Right oldF)) tree' {------------------------------------------------------------------------------- Path-listing @@ -330,26 +378,28 @@ renameFile fpOld fpNew tree = do -- -- If the given file system path does not exist, a (Left FsMissing{}) is -- returned. -find :: forall a . FsPath -> FsTree a -> Either FsTreeError [FsPath] +find :: forall a. FsPath -> FsTree a -> Either FsTreeError [FsPath] find fp fs = fmap (appendStartingDir . findTree) $ getDir fp fs - where - appendStartingDir :: [[Text]] -> [FsPath] - appendStartingDir fps = fmap fsPathFromList - $ fmap (fsPathToList fp <>) - $ []: fps - - findTree :: Folder a -> [[Text]] - findTree folder = concat - $ fmap appendFileNameAndFind - $ M.toList folder - where - appendFileNameAndFind :: (Text, FsTree a) -> [[Text]] - appendFileNameAndFind (fileName, t) = - [fileName] : (fmap ([fileName] <>) $ findFsTree t) - - findFsTree :: FsTree a -> [[Text]] - findFsTree (File _ ) = [] - findFsTree (Folder folder') = findTree folder' + where + appendStartingDir :: [[Text]] -> [FsPath] + appendStartingDir fps = + fmap fsPathFromList $ + fmap (fsPathToList fp <>) $ + [] : fps + + findTree :: Folder a -> [[Text]] + findTree folder = + concat $ + fmap appendFileNameAndFind $ + M.toList folder + where + appendFileNameAndFind :: (Text, FsTree a) -> [[Text]] + appendFileNameAndFind (fileName, t) = + [fileName] : (fmap ([fileName] <>) $ findFsTree t) + + findFsTree :: FsTree a -> [[Text]] + findFsTree (File _) = [] + findFsTree (Folder folder') = findTree folder' {------------------------------------------------------------------------------- Pretty-printing @@ -357,17 +407,17 @@ find fp fs = fmap (appendStartingDir . findTree) $ getDir fp fs pretty :: forall a. (a -> String) -> FsTree a -> String pretty f = drawTree . fmap renderNode . toTree - where - renderNode :: (Text, Maybe a) -> String - renderNode (fp, Nothing) = Text.unpack fp - renderNode (fp, Just a) = Text.unpack fp ++ ": " ++ f a + where + renderNode :: (Text, Maybe a) -> String + renderNode (fp, Nothing) = Text.unpack fp + renderNode (fp, Just a) = Text.unpack fp ++ ": " ++ f a -- | Translate to a tree toTree :: FsTree a -> Tree (Text, Maybe a) toTree = \case - File _ -> error "toTree: root must be directory" - Folder m -> Node ("/", Nothing) $ map go (M.toList m) - where - go :: (Text, FsTree a) -> Tree (Text, Maybe a) - go (parent, File a) = Node (parent, Just a) [] - go (parent, Folder m) = Node (parent, Nothing) $ map go (M.toList m) + File _ -> error "toTree: root must be directory" + Folder m -> Node ("/", Nothing) $ map go (M.toList m) + where + go :: (Text, FsTree a) -> Tree (Text, Maybe a) + go (parent, File a) = Node (parent, Just a) [] + go (parent, Folder m) = Node (parent, Nothing) $ map go (M.toList m) diff --git a/fs-sim/src/System/FS/Sim/MockFS.hs b/fs-sim/src/System/FS/Sim/MockFS.hs index 2b3b991..2a6e91f 100644 --- a/fs-sim/src/System/FS/Sim/MockFS.hs +++ b/fs-sim/src/System/FS/Sim/MockFS.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- | Mock file system implementation -- @@ -17,15 +17,17 @@ -- -- > import System.FS.Sim.MockFS (MockFS) -- > import qualified System.FS.Sim.MockFS as Mock -module System.FS.Sim.MockFS ( - empty +module System.FS.Sim.MockFS + ( empty , example , handleIsOpen , numOpenHandles , openHandles , pretty + -- * Debugging , dumpState + -- * Operations on files , hClose , hGetSize @@ -36,6 +38,7 @@ module System.FS.Sim.MockFS ( , hPutSome , hSeek , hTruncate + -- * Operations on directories , createDirectory , createDirectoryIfMissing @@ -45,17 +48,21 @@ module System.FS.Sim.MockFS ( , removeDirectoryRecursive , removeFile , renameFile + -- * Exported for the benefit of tests only , Files , mockFiles + -- ** opaque , ClosedHandleState , FilePtr , HandleState , OpenHandleState + -- * opaque , HandleMock , MockFS + -- * HasBufFS , fromBuffer , intoBuffer @@ -65,43 +72,41 @@ module System.FS.Sim.MockFS ( , hPutBufSomeAt ) where -import Control.Monad (forM, forM_, unless, when) -import Control.Monad.Except (MonadError, throwError) -import Control.Monad.Primitive (PrimMonad (..)) -import Control.Monad.State.Strict (MonadState, get, gets, put) -import Data.Bifunctor -import Data.ByteString (ByteString) +import Control.Monad (forM, forM_, unless, when) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Primitive (PrimMonad (..)) +import Control.Monad.State.Strict (MonadState, get, gets, put) +import Data.Bifunctor +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 -import Data.Int (Int64) -import Data.Map.Strict (Map) +import Data.Int (Int64) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe) import qualified Data.Primitive as P -import Data.Primitive.ByteArray -import Data.Set (Set) +import Data.Primitive.ByteArray +import Data.Set (Set) import qualified Data.Set as S import qualified Data.Text as Text -import Data.Word (Word64, Word8) -import GHC.Generics (Generic) -import System.Posix.Types (ByteCount) - -import System.FS.API (BufferOffset (..)) -import System.FS.API.Types -import System.FS.CallStack - +import Data.Word (Word64, Word8) +import GHC.Generics (Generic) +import System.FS.API (BufferOffset (..)) +import System.FS.API.Types +import System.FS.CallStack +import System.FS.Sim.FsTree (FsTree (..), FsTreeError (..)) import qualified System.FS.Sim.FsTree as FS -import System.FS.Sim.FsTree (FsTree (..), FsTreeError (..)) +import System.Posix.Types (ByteCount) {------------------------------------------------------------------------------- Mock FS types -------------------------------------------------------------------------------} -data MockFS = MockFS { - mockFiles :: !Files - , mockHandles :: !(Map HandleMock HandleState) - , mockNextHandle :: !HandleMock - } +data MockFS = MockFS + { mockFiles :: !Files + , mockHandles :: !(Map HandleMock HandleState) + , mockNextHandle :: !HandleMock + } deriving (Generic, Show) -- | We store the files as an 'FsTree' of the file contents @@ -111,49 +116,48 @@ type Files = FsTree ByteString -- -- This is only meaningful when interpreted against a 'MockFS'. newtype HandleMock = HandleMock Int - deriving stock (Show, Eq, Ord, Generic) - deriving newtype (Enum) + deriving stock (Show, Eq, Ord, Generic) + deriving newtype Enum -- | Instantiate 'Handle' with the mock handle type Handle' = Handle HandleMock -- | Mock handle internal state -data HandleState = - HandleOpen !OpenHandleState +data HandleState + = HandleOpen !OpenHandleState | HandleClosed !ClosedHandleState deriving (Show, Generic) -data OpenHandleState = OpenHandle { - openFilePath :: !FsPath - , openPtr :: !FilePtr - } +data OpenHandleState = OpenHandle + { openFilePath :: !FsPath + , openPtr :: !FilePtr + } deriving (Show, Generic) -- | Check whether the file handle is in write/append mode. isWriteHandle :: OpenHandleState -> Bool isWriteHandle OpenHandle{..} = case openPtr of - RW _ True _ -> True - Append -> True - _ -> False + RW _ True _ -> True + Append -> True + _ -> False -- | File pointer -- -- This is purely an internal abstraction. -data FilePtr = - -- | Read/write pointer +data FilePtr + = -- | Read/write pointer -- -- We record if we can read and/or write, and the current offset RW !Bool !Bool !Word64 - - -- | Append-only pointer + | -- | Append-only pointer -- -- Offset is always the end of the file in append mode - | Append + Append deriving (Show, Generic) -data ClosedHandleState = ClosedHandle { - closedFilePath :: FsPath - } +data ClosedHandleState = ClosedHandle + { closedFilePath :: FsPath + } deriving (Show, Generic) -- | Monads in which we can simulate the file system @@ -163,7 +167,7 @@ empty :: MockFS empty = MockFS FS.empty M.empty (HandleMock 0) example :: MockFS -example = empty { mockFiles = FS.example } +example = empty{mockFiles = FS.example} {------------------------------------------------------------------------------- Auxiliary @@ -174,26 +178,26 @@ example = empty { mockFiles = FS.example } -- Throws an exception if the handle is unknown. handleIsOpen :: MockFS -> HandleMock -> Bool handleIsOpen MockFS{..} h = - case M.lookup h mockHandles of - Nothing -> - error "handleIOMode: unknown handle" - Just (HandleOpen OpenHandle{}) -> True - Just (HandleClosed _) -> False + case M.lookup h mockHandles of + Nothing -> + error "handleIOMode: unknown handle" + Just (HandleOpen OpenHandle{}) -> True + Just (HandleClosed _) -> False openHandles :: MockFS -> [OpenHandleState] openHandles MockFS{..} = mapMaybe isOpen $ M.elems mockHandles - where - isOpen :: HandleState -> Maybe OpenHandleState - isOpen (HandleOpen hs) = Just hs - isOpen (HandleClosed _ ) = Nothing + where + isOpen :: HandleState -> Maybe OpenHandleState + isOpen (HandleOpen hs) = Just hs + isOpen (HandleClosed _) = Nothing -- | A set containing each file path that some open handle refers to. openFilePaths :: MockFS -> Set FsPath openFilePaths MockFS{..} = foldMap handleOpenFilePath $ M.elems mockHandles - where - handleOpenFilePath :: HandleState -> Set FsPath - handleOpenFilePath (HandleOpen hs) = S.singleton $ openFilePath hs - handleOpenFilePath (HandleClosed _) = S.empty + where + handleOpenFilePath :: HandleState -> Set FsPath + handleOpenFilePath (HandleOpen hs) = S.singleton $ openFilePath hs + handleOpenFilePath (HandleClosed _) = S.empty -- | Number of open handles numOpenHandles :: MockFS -> Int @@ -204,164 +208,179 @@ numOpenHandles = length . openHandles -- We lift this out as a separate concept primarily for the benefit of tests. -- -- See 'hSeek' for limitations. -seekFilePtr :: MonadError FsError m - => MockFS -> Handle' -> SeekMode -> Int64 -> m FilePtr +seekFilePtr :: + MonadError FsError m => + MockFS -> Handle' -> SeekMode -> Int64 -> m FilePtr seekFilePtr MockFS{..} (Handle h _) seekMode o = do - case mockHandles M.! h of - HandleClosed ClosedHandle{..} -> - throwError FsError { - fsErrorType = FsIllegalOperation - , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath + case mockHandles M.! h of + HandleClosed ClosedHandle{..} -> + throwError + FsError + { fsErrorType = FsIllegalOperation + , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath , fsErrorString = "handle closed" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False } - HandleOpen OpenHandle{..} -> do - file <- checkFsTree $ FS.getFile openFilePath mockFiles - let fsize = fromIntegral (BS.length file) :: Word64 - case (openPtr, seekMode, sign64 o) of - (RW r w _cur, AbsoluteSeek, Positive o') -> do - when (o' > fsize) $ throwError (errPastEnd openFilePath) - return $ RW r w o' - (_, AbsoluteSeek, Negative _) -> - throwError $ errNegative openFilePath - (RW r w cur, RelativeSeek, Positive o') -> do - let cur' = cur + o' - when (cur' > fsize) $ throwError (errPastEnd openFilePath) - return $ RW r w cur' - (RW r w cur, RelativeSeek, Negative o') -> do - when (o' > cur) $ throwError (errNegative openFilePath) - let cur' = cur - o' - return $ RW r w cur' - (RW r w _cur, SeekFromEnd, Positive 0) -> - return $ RW r w fsize - (RW _ _ _, SeekFromEnd, Positive _) -> - throwError (errPastEnd openFilePath) - (RW r w _, SeekFromEnd, Negative o') -> do - when (o' > fsize) $ throwError (errNegative openFilePath) - let cur' = fsize - o' - return $ RW r w cur' - (Append, _, _) -> - throwError (errAppend openFilePath) - where - errPastEnd fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "seek past EOF not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True - } - errAppend fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "seek in append mode not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True - } - errNegative fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "seek past beginning of file" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } + HandleOpen OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath mockFiles + let fsize = fromIntegral (BS.length file) :: Word64 + case (openPtr, seekMode, sign64 o) of + (RW r w _cur, AbsoluteSeek, Positive o') -> do + when (o' > fsize) $ throwError (errPastEnd openFilePath) + return $ RW r w o' + (_, AbsoluteSeek, Negative _) -> + throwError $ errNegative openFilePath + (RW r w cur, RelativeSeek, Positive o') -> do + let cur' = cur + o' + when (cur' > fsize) $ throwError (errPastEnd openFilePath) + return $ RW r w cur' + (RW r w cur, RelativeSeek, Negative o') -> do + when (o' > cur) $ throwError (errNegative openFilePath) + let cur' = cur - o' + return $ RW r w cur' + (RW r w _cur, SeekFromEnd, Positive 0) -> + return $ RW r w fsize + (RW _ _ _, SeekFromEnd, Positive _) -> + throwError (errPastEnd openFilePath) + (RW r w _, SeekFromEnd, Negative o') -> do + when (o' > fsize) $ throwError (errNegative openFilePath) + let cur' = fsize - o' + return $ RW r w cur' + (Append, _, _) -> + throwError (errAppend openFilePath) + where + errPastEnd fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "seek past EOF not supported" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + errAppend fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "seek in append mode not supported" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + errNegative fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "seek past beginning of file" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } {------------------------------------------------------------------------------- Internal utilities for implementing the mock FS -------------------------------------------------------------------------------} -- | Modify the mock file system without a file handle -modifyMockFS :: CanSimFS m - => (MockFS -> m (a, MockFS)) -> m a +modifyMockFS :: + CanSimFS m => + (MockFS -> m (a, MockFS)) -> m a modifyMockFS f = do - st <- get - (a, st') <- f st - put st' - return a + st <- get + (a, st') <- f st + put st' + return a -- | Access but do not modify the mock file system state without a file handle -readMockFS :: CanSimFS m - => (Files -> m a) -> m a -readMockFS f = modifyMockFS (\fs -> (, fs) <$> f (mockFiles fs)) +readMockFS :: + CanSimFS m => + (Files -> m a) -> m a +readMockFS f = modifyMockFS (\fs -> (,fs) <$> f (mockFiles fs)) -- | Require a file handle and may modify the mock file system -withHandleModify :: CanSimFS m - => Handle' - -> ( MockFS - -> HandleState - -> m (a, (Files, HandleState)) - ) - -> m a +withHandleModify :: + CanSimFS m => + Handle' -> + ( MockFS -> + HandleState -> + m (a, (Files, HandleState)) + ) -> + m a withHandleModify (Handle h _) f = do - st <- get - case M.lookup h (mockHandles st) of - Just hs -> do - (a, (fs', hs')) <- f st hs - put $ st { mockHandles = M.insert h hs' (mockHandles st) - , mockFiles = fs' - } - return a - Nothing -> - error "withHandleModify: handle not found" + st <- get + case M.lookup h (mockHandles st) of + Just hs -> do + (a, (fs', hs')) <- f st hs + put $ + st + { mockHandles = M.insert h hs' (mockHandles st) + , mockFiles = fs' + } + return a + Nothing -> + error "withHandleModify: handle not found" -- | Require a file handle but do not modify the mock file system -withHandleRead :: CanSimFS m - => Handle' - -> ( MockFS - -> HandleState - -> m (a, HandleState) - ) - -> m a +withHandleRead :: + CanSimFS m => + Handle' -> + ( MockFS -> + HandleState -> + m (a, HandleState) + ) -> + m a withHandleRead h f = - withHandleModify h $ \fs hs -> - second (mockFiles fs, ) <$> f fs hs + withHandleModify h $ \fs hs -> + second (mockFiles fs,) <$> f fs hs -- | Require an open file handle to modify the mock file system -withOpenHandleModify :: CanSimFS m - => Handle' - -> ( MockFS - -> OpenHandleState - -> m (a, (Files, OpenHandleState)) - ) - -> m a +withOpenHandleModify :: + CanSimFS m => + Handle' -> + ( MockFS -> + OpenHandleState -> + m (a, (Files, OpenHandleState)) + ) -> + m a withOpenHandleModify h f = - withHandleModify h $ \fs -> \case - HandleOpen hs -> - second (second HandleOpen) <$> f fs hs - HandleClosed ClosedHandle{..} -> - throwError FsError { - fsErrorType = FsIllegalOperation - , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath + withHandleModify h $ \fs -> \case + HandleOpen hs -> + second (second HandleOpen) <$> f fs hs + HandleClosed ClosedHandle{..} -> + throwError + FsError + { fsErrorType = FsIllegalOperation + , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath , fsErrorString = "handle closed" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False } -- | Require an open file handle but do not modify the mock file system -withOpenHandleRead :: CanSimFS m - => Handle' - -> ( MockFS - -> OpenHandleState - -> m (a, OpenHandleState) - ) - -> m a +withOpenHandleRead :: + CanSimFS m => + Handle' -> + ( MockFS -> + OpenHandleState -> + m (a, OpenHandleState) + ) -> + m a withOpenHandleRead h f = - withHandleRead h $ \fs -> \case - HandleOpen hs -> - second HandleOpen <$> f fs hs - HandleClosed ClosedHandle{..} -> - throwError FsError { - fsErrorType = FsIllegalOperation - , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath + withHandleRead h $ \fs -> \case + HandleOpen hs -> + second HandleOpen <$> f fs hs + HandleClosed ClosedHandle{..} -> + throwError + FsError + { fsErrorType = FsIllegalOperation + , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath , fsErrorString = "handle closed" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False } {------------------------------------------------------------------------------- @@ -375,85 +394,98 @@ dumpState = pretty <$> get Internal auxiliary -------------------------------------------------------------------------------} -checkFsTree' :: (MonadError FsError m, HasCallStack) - => Either FsTreeError a -> m (Either FsPath a) +checkFsTree' :: + (MonadError FsError m, HasCallStack) => + Either FsTreeError a -> m (Either FsPath a) checkFsTree' = go - where - go (Left (FsExpectedDir fp _)) = - throwError FsError { - fsErrorType = FsResourceInappropriateType - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "expected directory" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - go (Left (FsExpectedFile fp)) = - throwError FsError { - fsErrorType = FsResourceInappropriateType - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "expected file" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - go (Left (FsMissing fp _)) = - return (Left fp) - go (Left (FsExists fp)) = - throwError FsError { - fsErrorType = FsResourceAlreadyExist - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "file exists" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - go (Right a) = - return (Right a) + where + go (Left (FsExpectedDir fp _)) = + throwError + FsError + { fsErrorType = FsResourceInappropriateType + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "expected directory" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + go (Left (FsExpectedFile fp)) = + throwError + FsError + { fsErrorType = FsResourceInappropriateType + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "expected file" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + go (Left (FsMissing fp _)) = + return (Left fp) + go (Left (FsExists fp)) = + throwError + FsError + { fsErrorType = FsResourceAlreadyExist + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "file exists" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + go (Right a) = + return (Right a) -checkFsTree :: (MonadError FsError m, HasCallStack) - => Either FsTreeError a -> m a +checkFsTree :: + (MonadError FsError m, HasCallStack) => + Either FsTreeError a -> m a checkFsTree ma = do - ma' <- checkFsTree' ma - case ma' of - Left fp -> throwError FsError { - fsErrorType = FsResourceDoesNotExist - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "does not exist" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - Right a -> return a - -checkDoesNotExist :: (MonadError FsError m, HasCallStack) - => MockFS -> FsPath -> m () + ma' <- checkFsTree' ma + case ma' of + Left fp -> + throwError + FsError + { fsErrorType = FsResourceDoesNotExist + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "does not exist" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + Right a -> return a + +checkDoesNotExist :: + (MonadError FsError m, HasCallStack) => + MockFS -> FsPath -> m () checkDoesNotExist fs fp = do - exists <- fmap pathExists $ checkFsTree' $ FS.index fp (mockFiles fs) - if exists - then throwError FsError { - fsErrorType = FsResourceAlreadyExist - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "already exists" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } - else return () - where - pathExists :: Either a b -> Bool - pathExists (Left _) = False - pathExists (Right _) = True + exists <- fmap pathExists $ checkFsTree' $ FS.index fp (mockFiles fs) + if exists + then + throwError + FsError + { fsErrorType = FsResourceAlreadyExist + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "already exists" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + else return () + where + pathExists :: Either a b -> Bool + pathExists (Left _) = False + pathExists (Right _) = True newHandle :: MockFS -> OpenHandleState -> (Handle', MockFS) -newHandle fs hs = ( - Handle (mockNextHandle fs) (openFilePath hs) - , fs { mockNextHandle = succ (mockNextHandle fs) - , mockHandles = M.insert (mockNextHandle fs) - (HandleOpen hs) - (mockHandles fs) - } - ) +newHandle fs hs = + ( Handle (mockNextHandle fs) (openFilePath hs) + , fs + { mockNextHandle = succ (mockNextHandle fs) + , mockHandles = + M.insert + (mockNextHandle fs) + (HandleOpen hs) + (mockHandles fs) + } + ) {------------------------------------------------------------------------------- Operations on files @@ -469,48 +501,53 @@ newHandle fs hs = ( -- * We do not support create file on ReadMode. hOpen :: CanSimFS m => FsPath -> OpenMode -> m Handle' hOpen fp openMode = do - dirExists <- doesDirectoryExist fp - when dirExists $ throwError FsError { - fsErrorType = FsResourceInappropriateType - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "hOpen: directories not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True - } - modifyMockFS $ \fs -> do - let alreadyHasWriter = - any (\hs -> openFilePath hs == fp && isWriteHandle hs) $ + dirExists <- doesDirectoryExist fp + when dirExists $ + throwError + FsError + { fsErrorType = FsResourceInappropriateType + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "hOpen: directories not supported" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + modifyMockFS $ \fs -> do + let alreadyHasWriter = + any (\hs -> openFilePath hs == fp && isWriteHandle hs) $ openHandles fs - when (openMode /= ReadMode && alreadyHasWriter) $ - throwError FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + when (openMode /= ReadMode && alreadyHasWriter) $ + throwError + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "more than one concurrent writer not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } - files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs) - return $ newHandle (fs { mockFiles = files' }) - (OpenHandle fp (filePtr openMode)) - where - ex :: AllowExisting - ex = allowExisting openMode - - filePtr :: OpenMode -> FilePtr - filePtr ReadMode = RW True False 0 - filePtr (WriteMode _) = RW False True 0 - filePtr (ReadWriteMode _) = RW True True 0 - filePtr (AppendMode _) = Append + files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs) + return $ + newHandle + (fs{mockFiles = files'}) + (OpenHandle fp (filePtr openMode)) + where + ex :: AllowExisting + ex = allowExisting openMode + + filePtr :: OpenMode -> FilePtr + filePtr ReadMode = RW True False 0 + filePtr (WriteMode _) = RW False True 0 + filePtr (ReadWriteMode _) = RW True True 0 + filePtr (AppendMode _) = Append -- | Mock implementation of 'hClose' hClose :: CanSimFS m => Handle' -> m () hClose h = withHandleRead h $ \_fs -> \case - HandleOpen hs -> - return ((), HandleClosed (ClosedHandle (openFilePath hs))) - HandleClosed hs -> - return ((), HandleClosed hs) + HandleOpen hs -> + return ((), HandleClosed (ClosedHandle (openFilePath hs))) + HandleClosed hs -> + return ((), HandleClosed hs) -- | Mock implementation of 'hIsOpen' hIsOpen :: CanSimFS m => Handle' -> m Bool @@ -525,101 +562,107 @@ hIsOpen h = gets (`handleIsOpen` handleRaw h) -- * We do not allow seeking past the end of the file -- (this means that when using 'IO.SeekFromEnd', the only valid offset is 0) -- * We do /not/ return the new file offset -hSeek :: CanSimFS m - => Handle' -> SeekMode -> Int64 -> m () +hSeek :: + CanSimFS m => + Handle' -> SeekMode -> Int64 -> m () hSeek h seekMode o = withOpenHandleRead h $ \fs hs -> do - openPtr' <- seekFilePtr fs h seekMode o - return ((), hs { openPtr = openPtr' }) + openPtr' <- seekFilePtr fs h seekMode o + return ((), hs{openPtr = openPtr'}) -- | Get bytes from handle -- -- NOTE: Unlike real I/O, we disallow 'hGetSome' on a handle in append mode. hGetSome :: CanSimFS m => Handle' -> Word64 -> m ByteString hGetSome h n = - withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do - file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) - case openPtr of - RW r w o -> do - unless r $ throwError (errNoReadAccess openFilePath "write") - let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file - return (bs, hs { openPtr = RW True w (o + fromIntegral (BS.length bs)) }) - Append -> throwError (errNoReadAccess openFilePath "append") - where - errNoReadAccess fp mode = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + case openPtr of + RW r w o -> do + unless r $ throwError (errNoReadAccess openFilePath "write") + let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file + return (bs, hs{openPtr = RW True w (o + fromIntegral (BS.length bs))}) + Append -> throwError (errNoReadAccess openFilePath "append") + where + errNoReadAccess fp mode = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "cannot hGetSome in " <> mode <> " mode" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } -- | Thread safe version of 'hGetSome', which doesn't modify or read the file -- offset. -hGetSomeAt :: CanSimFS m - => Handle' - -> Word64 - -> AbsOffset - -> m ByteString +hGetSomeAt :: + CanSimFS m => + Handle' -> + Word64 -> + AbsOffset -> + m ByteString hGetSomeAt h n o = withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do - file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) - let o' = unAbsOffset o - let fsize = fromIntegral (BS.length file) :: Word64 - case openPtr of - RW r _ _ -> do - unless r $ throwError (errNoReadAccess openFilePath "write") - let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file - -- This is the same fsLimitation we get when we seek past the end of - -- EOF, in AbsoluteSeek mode. - when (o' > fsize) $ throwError (errPastEnd openFilePath) - return (bs, hs) - Append -> throwError (errNoReadAccess openFilePath "append") - where - errNoReadAccess fp mode = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + let o' = unAbsOffset o + let fsize = fromIntegral (BS.length file) :: Word64 + case openPtr of + RW r _ _ -> do + unless r $ throwError (errNoReadAccess openFilePath "write") + let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file + -- This is the same fsLimitation we get when we seek past the end of + -- EOF, in AbsoluteSeek mode. + when (o' > fsize) $ throwError (errPastEnd openFilePath) + return (bs, hs) + Append -> throwError (errNoReadAccess openFilePath "append") + where + errNoReadAccess fp mode = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "cannot hGetSomeAt in " <> mode <> " mode" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } - errPastEnd fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + errPastEnd fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "hGetSomeAt offset past EOF not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } hPutSome :: CanSimFS m => Handle' -> ByteString -> m Word64 hPutSome h toWrite = - withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do - case openPtr of - RW r w o -> do - unless w $ throwError (errReadOnly openFilePath) - file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) - let file' = replace o toWrite file - files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) - return (written, (files', hs { openPtr = RW r w (o + written) })) - Append -> do - file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) - let file' = file <> toWrite - files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) - return (written, (files', hs)) - where - written = toEnum $ BS.length toWrite - - errReadOnly fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "handle is read-only" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } + withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do + case openPtr of + RW r w o -> do + unless w $ throwError (errReadOnly openFilePath) + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + let file' = replace o toWrite file + files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) + return (written, (files', hs{openPtr = RW r w (o + written)})) + Append -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + let file' = file <> toWrite + files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) + return (written, (files', hs)) + where + written = toEnum $ BS.length toWrite + + errReadOnly fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "handle is read-only" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } -- | Truncate a file -- @@ -634,33 +677,35 @@ hPutSome h toWrite = -- even record it at all), appends always happen at the end of the file. hTruncate :: CanSimFS m => Handle' -> Word64 -> m () hTruncate h sz = - withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do - file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) - ptr' <- case (sz > fromIntegral (BS.length file), openPtr) of - (True, _) -> - throwError FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted openFilePath - , fsErrorString = "truncate cannot make the file larger" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True - } - (False, RW{}) -> - throwError FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted openFilePath - , fsErrorString = "truncate only supported in append mode" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True - } - (False, Append) -> - return Append - let file' = BS.take (fromIntegral sz) file - files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) - -- TODO: Don't replace the file pointer (not changed) - return ((), (files', hs { openPtr = ptr' })) + withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + ptr' <- case (sz > fromIntegral (BS.length file), openPtr) of + (True, _) -> + throwError + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted openFilePath + , fsErrorString = "truncate cannot make the file larger" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + (False, RW{}) -> + throwError + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted openFilePath + , fsErrorString = "truncate only supported in append mode" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + (False, Append) -> + return Append + let file' = BS.take (fromIntegral sz) file + files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) + -- TODO: Don't replace the file pointer (not changed) + return ((), (files', hs{openPtr = ptr'})) -- | Get file size -- @@ -668,9 +713,9 @@ hTruncate h sz = -- only one writer, so concurrent threads cannot change the size of the file. hGetSize :: CanSimFS m => Handle' -> m Word64 hGetSize h = - withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do - file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) - return (fromIntegral (BS.length file), hs) + withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + return (fromIntegral (BS.length file), hs) {------------------------------------------------------------------------------- Operations on directories @@ -678,93 +723,102 @@ hGetSize h = createDirectory :: CanSimFS m => FsPath -> m () createDirectory dir = modifyMockFS $ \fs -> do - checkDoesNotExist fs dir - files' <- checkFsTree $ FS.createDirIfMissing dir (mockFiles fs) - return ((), fs { mockFiles = files' }) + checkDoesNotExist fs dir + files' <- checkFsTree $ FS.createDirIfMissing dir (mockFiles fs) + return ((), fs{mockFiles = files'}) -createDirectoryIfMissing :: CanSimFS m - => Bool -> FsPath -> m () +createDirectoryIfMissing :: + CanSimFS m => + Bool -> FsPath -> m () createDirectoryIfMissing createParents dir = do - -- Although @createDirectoryIfMissing /a/b/c@ will fail ("inappropriate - -- type") if @b@ is a file (not a directory), for some strange reason it - -- throws "already exists" if @c@ is is a file - fileExists <- doesFileExist dir - if fileExists then - throwError FsError { - fsErrorType = FsResourceAlreadyExist - , fsErrorPath = fsToFsErrorPathUnmounted dir - , fsErrorString = "a file with that name already exists" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = False - } + -- Although @createDirectoryIfMissing /a/b/c@ will fail ("inappropriate + -- type") if @b@ is a file (not a directory), for some strange reason it + -- throws "already exists" if @c@ is is a file + fileExists <- doesFileExist dir + if fileExists + then + throwError + FsError + { fsErrorType = FsResourceAlreadyExist + , fsErrorPath = fsToFsErrorPathUnmounted dir + , fsErrorString = "a file with that name already exists" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } else modifyMockFS $ \fs -> do files' <- checkFsTree $ go createParents (mockFiles fs) - return ((), fs { mockFiles = files' }) - where - go :: Bool -> Files -> Either FsTreeError Files - go True = FS.createDirWithParents dir - go False = FS.createDirIfMissing dir - -listDirectory :: CanSimFS m - => FsPath -> m (Set String) -listDirectory fp = readMockFS $ - fmap (S.fromList . map Text.unpack . M.keys) - . checkFsTree - . FS.getDir fp + return ((), fs{mockFiles = files'}) + where + go :: Bool -> Files -> Either FsTreeError Files + go True = FS.createDirWithParents dir + go False = FS.createDirIfMissing dir + +listDirectory :: + CanSimFS m => + FsPath -> m (Set String) +listDirectory fp = + readMockFS $ + fmap (S.fromList . map Text.unpack . M.keys) + . checkFsTree + . FS.getDir fp -- | Check if directory exists -- -- It seems real I/O maps what would be "inapproriate device" errors to False. doesDirectoryExist :: CanSimFS m => FsPath -> m Bool doesDirectoryExist fp = readMockFS $ \fs -> - return $ case FS.getDir fp fs of - Left _ -> False - Right _ -> True + return $ case FS.getDir fp fs of + Left _ -> False + Right _ -> True -- | Check if file exists -- -- See comments for 'doesDirectoryExist'. doesFileExist :: CanSimFS m => FsPath -> m Bool doesFileExist fp = readMockFS $ \fs -> - return $ case FS.getFile fp fs of - Left _ -> False - Right _ -> True + return $ case FS.getFile fp fs of + Left _ -> False + Right _ -> True -- | Remove a directory and its contents -- -- Same limitations as 'removeFile'. removeDirectoryRecursive :: CanSimFS m => FsPath -> m () removeDirectoryRecursive fp = do - modifyMockFS $ \fs -> do - reachablePaths <- fmap S.fromList $ checkFsTree $ FS.find fp (mockFiles fs) - let openReachablePaths = reachablePaths `S.intersection` openFilePaths fs - case fsPathToList fp of - [] - -> throwError FsError { - fsErrorType = FsIllegalOperation - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "cannot remove the root directory" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True - } - _ | openReachablePaths /= mempty - -> throwError FsError { - fsErrorType = FsIllegalOperation - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "cannot remove an open file. " - ++ "The following files are reachable from " - ++ show fp - ++ "and are still open: " - ++ show openReachablePaths - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True - } - _ -> do - files' <- checkFsTree $ FS.removeDirRecursive fp (mockFiles fs) - return ((), fs { mockFiles = files' }) + modifyMockFS $ \fs -> do + reachablePaths <- fmap S.fromList $ checkFsTree $ FS.find fp (mockFiles fs) + let openReachablePaths = reachablePaths `S.intersection` openFilePaths fs + case fsPathToList fp of + [] -> + throwError + FsError + { fsErrorType = FsIllegalOperation + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "cannot remove the root directory" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + _ + | openReachablePaths /= mempty -> + throwError + FsError + { fsErrorType = FsIllegalOperation + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = + "cannot remove an open file. " + ++ "The following files are reachable from " + ++ show fp + ++ "and are still open: " + ++ show openReachablePaths + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + _ -> do + files' <- checkFsTree $ FS.removeDirRecursive fp (mockFiles fs) + return ((), fs{mockFiles = files'}) -- | Remove a file -- @@ -785,72 +839,79 @@ removeDirectoryRecursive fp = do -- limitation of the mock file system. removeFile :: CanSimFS m => FsPath -> m () removeFile fp = - modifyMockFS $ \fs -> case fsPathToList fp of - [] - -> throwError FsError { - fsErrorType = FsIllegalOperation - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "cannot remove the root directory" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True - } - _ | fp `S.member` openFilePaths fs - -> throwError FsError { - fsErrorType = FsIllegalOperation - , fsErrorPath = fsToFsErrorPathUnmounted fp - , fsErrorString = "cannot remove an open file" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True - } - _ -> do - files' <- checkFsTree $ FS.removeFile fp (mockFiles fs) - return ((), fs { mockFiles = files' }) + modifyMockFS $ \fs -> case fsPathToList fp of + [] -> + throwError + FsError + { fsErrorType = FsIllegalOperation + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "cannot remove the root directory" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + _ + | fp `S.member` openFilePaths fs -> + throwError + FsError + { fsErrorType = FsIllegalOperation + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "cannot remove an open file" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + _ -> do + files' <- checkFsTree $ FS.removeFile fp (mockFiles fs) + return ((), fs{mockFiles = files'}) renameFile :: CanSimFS m => FsPath -> FsPath -> m () renameFile fpOld fpNew = - modifyMockFS $ \fs -> if + modifyMockFS $ \fs -> + if | not (sameDir fpOld fpNew) -> - throwError $ errDifferentDir fpOld + throwError $ errDifferentDir fpOld | fpOld `S.member` openFilePaths fs -> - throwError $ errRenameOpenFile fpOld + throwError $ errRenameOpenFile fpOld | fpNew `S.member` openFilePaths fs -> - throwError $ errRenameOpenFile fpNew + throwError $ errRenameOpenFile fpNew | Right _ <- FS.getDir fpNew (mockFiles fs) -> - throwError $ errRenameDir fpNew + throwError $ errRenameDir fpNew | otherwise -> do - files' <- checkFsTree $ FS.renameFile fpOld fpNew (mockFiles fs) - return ((), fs { mockFiles = files' }) - where - sameDir fp1 fp2 = - (fst <$> fsPathSplit fp1) == (fst <$> fsPathSplit fp2) - - errRenameOpenFile fp = FsError { - fsErrorType = FsIllegalOperation - , fsErrorPath = fsToFsErrorPathUnmounted fp + files' <- checkFsTree $ FS.renameFile fpOld fpNew (mockFiles fs) + return ((), fs{mockFiles = files'}) + where + sameDir fp1 fp2 = + (fst <$> fsPathSplit fp1) == (fst <$> fsPathSplit fp2) + + errRenameOpenFile fp = + FsError + { fsErrorType = FsIllegalOperation + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "cannot rename opened file" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } - errRenameDir fp = FsError { - fsErrorType = FsResourceInappropriateType - , fsErrorPath = fsToFsErrorPathUnmounted fp + errRenameDir fp = + FsError + { fsErrorType = FsResourceInappropriateType + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "is a directory" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } - errDifferentDir fp = FsError { - fsErrorType = FsIllegalOperation - , fsErrorPath = fsToFsErrorPathUnmounted fp + errDifferentDir fp = + FsError + { fsErrorType = FsIllegalOperation + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "files must be in the same directory" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } {------------------------------------------------------------------------------- @@ -861,27 +922,32 @@ renameFile fpOld fpNew = pretty :: MockFS -> String -- TODO: Right now does this not show the state of the handles. pretty = FS.pretty renderFile . mockFiles - where - renderFile :: ByteString -> String - renderFile = show . hexDump . B16.encode - - hexDump :: ByteString -> ByteString - hexDump = fst - . BS.foldl' (\(acc, n) w8 -> - if n == 2 then (acc <> " " <> BS.singleton w8, 1) - else (acc <> BS.singleton w8, n + 1) - ) (mempty, 0 :: Int) + where + renderFile :: ByteString -> String + renderFile = show . hexDump . B16.encode + + hexDump :: ByteString -> ByteString + hexDump = + fst + . BS.foldl' + ( \(acc, n) w8 -> + if n == 2 + then (acc <> " " <> BS.singleton w8, 1) + else (acc <> BS.singleton w8, n + 1) + ) + (mempty, 0 :: Int) {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} data Sign a = Negative a | Positive a - deriving (Functor) + deriving Functor sign :: (Num a, Ord a) => a -> Sign a -sign a | a < 0 = Negative (negate a) - | otherwise = Positive a +sign a + | a < 0 = Negative (negate a) + | otherwise = Positive a sign64 :: Int64 -> Sign Word64 sign64 = fmap fromIntegral . sign @@ -902,8 +968,8 @@ sign64 = fmap fromIntegral . sign -- return A <> D <> C replace :: Word64 -> ByteString -> ByteString -> ByteString replace n d abc = a <> d <> c - where - (a, c) = snip (fromIntegral n) (BS.length d) abc + where + (a, c) = snip (fromIntegral n) (BS.length d) abc -- Given -- @@ -916,30 +982,35 @@ replace n d abc = a <> d <> c -- return (A, C) snip :: Int -> Int -> ByteString -> (ByteString, ByteString) snip n m bs = (a, c) - where - (a, bc) = BS.splitAt n bs - c = BS.drop m bc + where + (a, bc) = BS.splitAt n bs + c = BS.drop m bc {------------------------------------------------------------------------------- HasBufFS -------------------------------------------------------------------------------} -packMutableByteArray :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> [Word8] -> m () -packMutableByteArray mba i bytes = forM_ (zip [unBufferOffset i..] bytes) $ uncurry (P.writeByteArray mba) +packMutableByteArray :: + PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> [Word8] -> m () +packMutableByteArray mba i bytes = forM_ (zip [unBufferOffset i ..] bytes) $ uncurry (P.writeByteArray mba) -intoBuffer :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteString -> m Bool +intoBuffer :: + PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteString -> m Bool intoBuffer buf bufOff bs = do - bufSize <- P.getSizeofMutableByteArray buf - let remaining = bufSize - unBufferOffset bufOff - if BS.length bs > remaining - then pure False - else packMutableByteArray buf bufOff (BS.unpack bs) + bufSize <- P.getSizeofMutableByteArray buf + let remaining = bufSize - unBufferOffset bufOff + if BS.length bs > remaining + then pure False + else + packMutableByteArray buf bufOff (BS.unpack bs) >> pure True -unpackMutableByteArray :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m [Word8] +unpackMutableByteArray :: + PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m [Word8] unpackMutableByteArray mba i c = forM [unBufferOffset i .. unBufferOffset i + fromIntegral c - 1] $ P.readByteArray mba -fromBuffer :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m (Maybe ByteString) +fromBuffer :: + PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m (Maybe ByteString) fromBuffer buf bufOff c = do bufSize <- P.getSizeofMutableByteArray buf let remaining = bufSize - unBufferOffset bufOff @@ -947,173 +1018,194 @@ fromBuffer buf bufOff c = do then pure Nothing else Just . BS.pack <$> unpackMutableByteArray buf bufOff c -hGetBufSome :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount +hGetBufSome :: + (CanSimFS m, PrimMonad m) => + Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount hGetBufSome h buf bufOff n = - withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do - file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) - case openPtr of - RW r w o -> do - unless r $ throwError (errNoReadAccess openFilePath "write") - let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file - success <- intoBuffer buf bufOff bs - -- we can't read more bytes than the buffer size - unless success $ throwError (errWritePastBufEnd openFilePath) - let readBytes = fromIntegral (BS.length bs) - return (readBytes, hs { openPtr = RW True w (o + fromIntegral readBytes)}) - Append -> throwError (errNoReadAccess openFilePath "append") - where - errNoReadAccess fp mode = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + case openPtr of + RW r w o -> do + unless r $ throwError (errNoReadAccess openFilePath "write") + let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file + success <- intoBuffer buf bufOff bs + -- we can't read more bytes than the buffer size + unless success $ throwError (errWritePastBufEnd openFilePath) + let readBytes = fromIntegral (BS.length bs) + return (readBytes, hs{openPtr = RW True w (o + fromIntegral readBytes)}) + Append -> throwError (errNoReadAccess openFilePath "append") + where + errNoReadAccess fp mode = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "cannot hGetBufSomeAt in " <> mode <> " mode" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } - errWritePastBufEnd fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + errWritePastBufEnd fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "hPutBufSomeAt: writing into buffer past end not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } -hGetBufSomeAt :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount +hGetBufSomeAt :: + (CanSimFS m, PrimMonad m) => + Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount hGetBufSomeAt h buf bufOff n o = - withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do - file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) - let o' = unAbsOffset o - let fsize = fromIntegral (BS.length file) :: Word64 - case openPtr of - RW r _ _ -> do - unless r $ throwError (errNoReadAccess openFilePath "write") - -- This is the same fsLimitation we get when we seek past the end of - -- EOF, in AbsoluteSeek mode. - when (o' > fsize) $ throwError (errPastEnd openFilePath) - let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file - success <- intoBuffer buf bufOff bs - -- we can't read more bytes than the buffer size - unless success $ throwError (errWritePastBufEnd openFilePath) - return (fromIntegral (BS.length bs), hs) - Append -> throwError (errNoReadAccess openFilePath "append") - where - errNoReadAccess fp mode = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + let o' = unAbsOffset o + let fsize = fromIntegral (BS.length file) :: Word64 + case openPtr of + RW r _ _ -> do + unless r $ throwError (errNoReadAccess openFilePath "write") + -- This is the same fsLimitation we get when we seek past the end of + -- EOF, in AbsoluteSeek mode. + when (o' > fsize) $ throwError (errPastEnd openFilePath) + let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file + success <- intoBuffer buf bufOff bs + -- we can't read more bytes than the buffer size + unless success $ throwError (errWritePastBufEnd openFilePath) + return (fromIntegral (BS.length bs), hs) + Append -> throwError (errNoReadAccess openFilePath "append") + where + errNoReadAccess fp mode = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "cannot hGetBufSomeAt in " <> mode <> " mode" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } - errPastEnd fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + errPastEnd fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "hGetBufSomeAt offset past EOF not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } - errWritePastBufEnd fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + errWritePastBufEnd fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "hPutBufSomeAt: writing into buffer past end not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } -hPutBufSome :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount +hPutBufSome :: + (CanSimFS m, PrimMonad m) => + Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount hPutBufSome h buf bufOff n = do - withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do - file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) - case openPtr of - RW r w o -> do - unless w $ throwError (errNoWriteAccess openFilePath "read") - -- We can't write more bytes than the buffer size - toWrite <- fromBuffer buf bufOff n >>= \case + withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + case openPtr of + RW r w o -> do + unless w $ throwError (errNoWriteAccess openFilePath "read") + -- We can't write more bytes than the buffer size + toWrite <- + fromBuffer buf bufOff n >>= \case Nothing -> throwError (errReadPastBufEnd openFilePath) Just bs -> pure bs - let file' = replace o toWrite file - files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) - let written = fromIntegral $ BS.length toWrite - return (written, (files', hs { openPtr = RW r w (o + fromIntegral written)})) - Append -> do - -- We can't write more bytes than the buffer size - toWrite <- fromBuffer buf bufOff n >>= \case + let file' = replace o toWrite file + files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) + let written = fromIntegral $ BS.length toWrite + return (written, (files', hs{openPtr = RW r w (o + fromIntegral written)})) + Append -> do + -- We can't write more bytes than the buffer size + toWrite <- + fromBuffer buf bufOff n >>= \case Nothing -> throwError (errReadPastBufEnd openFilePath) Just bs -> pure bs - let file' = file <> toWrite - files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) - let written = fromIntegral $ BS.length toWrite - return (written, (files', hs)) - where - errNoWriteAccess fp mode = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + let file' = file <> toWrite + files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) + let written = fromIntegral $ BS.length toWrite + return (written, (files', hs)) + where + errNoWriteAccess fp mode = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "cannot hPutBufSomeAt in " <> mode <> " mode" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } - errReadPastBufEnd fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + errReadPastBufEnd fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "hPutBufSomeAt: reading from buffer past end not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } -hPutBufSomeAt :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount +hPutBufSomeAt :: + (CanSimFS m, PrimMonad m) => + Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount hPutBufSomeAt h buf bufOff n o = do - withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do - file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) - let o' = unAbsOffset o - let fsize = fromIntegral (BS.length file) - case openPtr of - RW _ w _ -> do - unless w $ throwError (errNoWriteAccess openFilePath "read") - -- This is the same fsLimitation we get when we seek past the end of - -- EOF, in AbsoluteSeek mode. - when (o' > fsize) $ throwError (errPastEnd openFilePath) - -- We can't write more bytes than the buffer size - toWrite <- fromBuffer buf bufOff n >>= \case + withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + let o' = unAbsOffset o + let fsize = fromIntegral (BS.length file) + case openPtr of + RW _ w _ -> do + unless w $ throwError (errNoWriteAccess openFilePath "read") + -- This is the same fsLimitation we get when we seek past the end of + -- EOF, in AbsoluteSeek mode. + when (o' > fsize) $ throwError (errPastEnd openFilePath) + -- We can't write more bytes than the buffer size + toWrite <- + fromBuffer buf bufOff n >>= \case Nothing -> throwError (errReadPastBufEnd openFilePath) Just bs -> pure bs - let file' = replace o' toWrite file - files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) - let written = fromIntegral $ BS.length toWrite - return (written, (files', hs)) - Append -> throwError (errNoWriteAccess openFilePath "append") - where - errNoWriteAccess fp mode = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + let file' = replace o' toWrite file + files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) + let written = fromIntegral $ BS.length toWrite + return (written, (files', hs)) + Append -> throwError (errNoWriteAccess openFilePath "append") + where + errNoWriteAccess fp mode = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "cannot hPutBufSomeAt in " <> mode <> " mode" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } - errPastEnd fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + errPastEnd fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "hPutBufSomeAt offset past EOF not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } - errReadPastBufEnd fp = FsError { - fsErrorType = FsInvalidArgument - , fsErrorPath = fsToFsErrorPathUnmounted fp + errReadPastBufEnd fp = + FsError + { fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp , fsErrorString = "hPutBufSomeAt: reading from buffer past end not supported" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack - , fsLimitation = True + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True } diff --git a/fs-sim/src/System/FS/Sim/Prim.hs b/fs-sim/src/System/FS/Sim/Prim.hs index 0bb981f..0a7df53 100644 --- a/fs-sim/src/System/FS/Sim/Prim.hs +++ b/fs-sim/src/System/FS/Sim/Prim.hs @@ -1,36 +1,40 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} -- | Mocked, monad transformer-based implementation of the 'HasFS' interface. -module System.FS.Sim.Prim ( - FSSimT +module System.FS.Sim.Prim + ( FSSimT , runFSSimT , primHasMockFS ) where -import Control.Monad.Except -import Control.Monad.Primitive -import Control.Monad.State - -import System.FS.API - +import Control.Monad.Except +import Control.Monad.Primitive +import Control.Monad.State +import System.FS.API +import System.FS.Sim.MockFS (MockFS) import qualified System.FS.Sim.MockFS as Mock -import System.FS.Sim.MockFS (MockFS) -- | Monad transformer that extends a monad @m@ with pure features: (i) 'MockFS' -- state, and (ii) throwing/catching 'FsError's. -newtype FSSimT m a = PureSimFS { - unFSSimT :: StateT MockFS (ExceptT FsError m) a +newtype FSSimT m a = PureSimFS + { unFSSimT :: StateT MockFS (ExceptT FsError m) a } - deriving newtype ( Functor, Applicative, Monad - , MonadState MockFS, MonadError FsError, PrimMonad ) + deriving newtype + ( Functor + , Applicative + , Monad + , MonadState MockFS + , MonadError FsError + , PrimMonad + ) runFSSimT :: FSSimT m a -> MockFS -> m (Either FsError (a, MockFS)) runFSSimT act !st = runExceptT $ flip runStateT st $ unFSSimT act @@ -49,30 +53,31 @@ primHasMockFS :: PrimMonad m => HasFS (FSSimT m) Mock.HandleMock -- 'Control.Monad.ST.ST', and used 'Control.Monad.Class.MonadST.stToIO' to -- convert between a pure and 'IO' version. However, it's simpler to just -- overload this function. -primHasMockFS = HasFS { - dumpState = Mock.dumpState - , hOpen = Mock.hOpen - , hClose = Mock.hClose - , hIsOpen = Mock.hIsOpen - , hSeek = Mock.hSeek - , hGetSome = Mock.hGetSome - , hGetSomeAt = Mock.hGetSomeAt - , hPutSome = Mock.hPutSome - , hTruncate = Mock.hTruncate - , hGetSize = Mock.hGetSize - , createDirectory = Mock.createDirectory +primHasMockFS = + HasFS + { dumpState = Mock.dumpState + , hOpen = Mock.hOpen + , hClose = Mock.hClose + , hIsOpen = Mock.hIsOpen + , hSeek = Mock.hSeek + , hGetSome = Mock.hGetSome + , hGetSomeAt = Mock.hGetSomeAt + , hPutSome = Mock.hPutSome + , hTruncate = Mock.hTruncate + , hGetSize = Mock.hGetSize + , createDirectory = Mock.createDirectory , createDirectoryIfMissing = Mock.createDirectoryIfMissing - , listDirectory = Mock.listDirectory - , doesDirectoryExist = Mock.doesDirectoryExist - , doesFileExist = Mock.doesFileExist + , listDirectory = Mock.listDirectory + , doesDirectoryExist = Mock.doesDirectoryExist + , doesFileExist = Mock.doesFileExist , removeDirectoryRecursive = Mock.removeDirectoryRecursive - , removeFile = Mock.removeFile - , renameFile = Mock.renameFile - , mkFsErrorPath = fsToFsErrorPathUnmounted - , unsafeToFilePath = \_ -> error "pureHasFS:unsafeToFilePath" - -- File I\/O with user-supplied buffers - , hGetBufSome = Mock.hGetBufSome - , hGetBufSomeAt = Mock.hGetBufSomeAt - , hPutBufSome = Mock.hPutBufSome - , hPutBufSomeAt = Mock.hPutBufSomeAt + , removeFile = Mock.removeFile + , renameFile = Mock.renameFile + , mkFsErrorPath = fsToFsErrorPathUnmounted + , unsafeToFilePath = \_ -> error "pureHasFS:unsafeToFilePath" + , -- File I\/O with user-supplied buffers + hGetBufSome = Mock.hGetBufSome + , hGetBufSomeAt = Mock.hGetBufSomeAt + , hPutBufSome = Mock.hPutBufSome + , hPutBufSomeAt = Mock.hPutBufSomeAt } diff --git a/fs-sim/src/System/FS/Sim/STM.hs b/fs-sim/src/System/FS/Sim/STM.hs index e83c699..ea2f5f2 100644 --- a/fs-sim/src/System/FS/Sim/STM.hs +++ b/fs-sim/src/System/FS/Sim/STM.hs @@ -1,23 +1,21 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | 'HasFS' instance using 'MockFS' stored in an STM variable -module System.FS.Sim.STM ( - runSimFS +module System.FS.Sim.STM + ( runSimFS , simHasFS , simHasFS' ) where -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadThrow -import Control.Monad.Primitive - -import System.FS.API - +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadThrow +import Control.Monad.Primitive +import System.FS.API +import System.FS.Sim.MockFS (HandleMock, MockFS) import qualified System.FS.Sim.MockFS as Mock -import System.FS.Sim.MockFS (HandleMock, MockFS) -import System.FS.Sim.Prim +import System.FS.Sim.Prim {------------------------------------------------------------------------------ The simulation-related types @@ -26,73 +24,78 @@ import System.FS.Sim.Prim --- | Runs a computation provided an initial 'MockFS', producing a --- result, the final state of the filesystem and a sequence of actions occurred --- in the filesystem. -runSimFS :: (MonadSTM m, MonadThrow m, PrimMonad m) - => MockFS - -> (HasFS m HandleMock -> m a) - -> m (a, MockFS) +runSimFS :: + (MonadSTM m, MonadThrow m, PrimMonad m) => + MockFS -> + (HasFS m HandleMock -> m a) -> + m (a, MockFS) runSimFS fs act = do - var <- newTMVarIO fs - a <- act (simHasFS var) - fs' <- atomically $ takeTMVar var - return (a, fs') + var <- newTMVarIO fs + a <- act (simHasFS var) + fs' <- atomically $ takeTMVar var + return (a, fs') -- | Alternative to 'simHasFS' that creates 'TVar's internally. -simHasFS' :: (MonadSTM m, MonadThrow m, PrimMonad m) - => MockFS - -> m (HasFS m HandleMock) +simHasFS' :: + (MonadSTM m, MonadThrow m, PrimMonad m) => + MockFS -> + m (HasFS m HandleMock) simHasFS' mockFS = simHasFS <$> newTMVarIO mockFS -- | Equip @m@ with a @HasFs@ instance using the mock file system -simHasFS :: forall m. (MonadSTM m, MonadThrow m, PrimMonad m) - => StrictTMVar m MockFS - -> HasFS m HandleMock -simHasFS var = HasFS { - dumpState = sim Mock.dumpState - , hOpen = sim .: Mock.hOpen - , hClose = sim . Mock.hClose - , hIsOpen = sim . Mock.hIsOpen - , hSeek = sim ..: Mock.hSeek - , hGetSome = sim .: Mock.hGetSome - , hGetSomeAt = sim ..: Mock.hGetSomeAt - , hPutSome = sim .: Mock.hPutSome - , hTruncate = sim .: Mock.hTruncate - , hGetSize = sim . Mock.hGetSize - , createDirectory = sim . Mock.createDirectory - , createDirectoryIfMissing = sim .: Mock.createDirectoryIfMissing - , listDirectory = sim . Mock.listDirectory - , doesDirectoryExist = sim . Mock.doesDirectoryExist - , doesFileExist = sim . Mock.doesFileExist - , removeDirectoryRecursive = sim . Mock.removeDirectoryRecursive - , removeFile = sim . Mock.removeFile - , renameFile = sim .: Mock.renameFile - , mkFsErrorPath = fsToFsErrorPathUnmounted - , unsafeToFilePath = \_ -> error "simHasFS:unsafeToFilePath" - -- File I\/O with user-supplied buffers - , hGetBufSome = sim ...: Mock.hGetBufSome - , hGetBufSomeAt = sim ....: Mock.hGetBufSomeAt - , hPutBufSome = sim ...: Mock.hPutBufSome - , hPutBufSomeAt = sim ....: Mock.hPutBufSomeAt +simHasFS :: + forall m. + (MonadSTM m, MonadThrow m, PrimMonad m) => + StrictTMVar m MockFS -> + HasFS m HandleMock +simHasFS var = + HasFS + { dumpState = sim Mock.dumpState + , hOpen = sim .: Mock.hOpen + , hClose = sim . Mock.hClose + , hIsOpen = sim . Mock.hIsOpen + , hSeek = sim ..: Mock.hSeek + , hGetSome = sim .: Mock.hGetSome + , hGetSomeAt = sim ..: Mock.hGetSomeAt + , hPutSome = sim .: Mock.hPutSome + , hTruncate = sim .: Mock.hTruncate + , hGetSize = sim . Mock.hGetSize + , createDirectory = sim . Mock.createDirectory + , createDirectoryIfMissing = sim .: Mock.createDirectoryIfMissing + , listDirectory = sim . Mock.listDirectory + , doesDirectoryExist = sim . Mock.doesDirectoryExist + , doesFileExist = sim . Mock.doesFileExist + , removeDirectoryRecursive = sim . Mock.removeDirectoryRecursive + , removeFile = sim . Mock.removeFile + , renameFile = sim .: Mock.renameFile + , mkFsErrorPath = fsToFsErrorPathUnmounted + , unsafeToFilePath = \_ -> error "simHasFS:unsafeToFilePath" + , -- File I\/O with user-supplied buffers + hGetBufSome = sim ...: Mock.hGetBufSome + , hGetBufSomeAt = sim ....: Mock.hGetBufSomeAt + , hPutBufSome = sim ...: Mock.hPutBufSome + , hPutBufSomeAt = sim ....: Mock.hPutBufSomeAt } - where - sim :: FSSimT m a -> m a - sim m = do - st <- atomically $ takeTMVar var - runFSSimT m st >>= \case - Left e -> do - atomically $ putTMVar var st - throwIO e - Right (a, st') -> do - atomically $ putTMVar var st' - pure a + where + sim :: FSSimT m a -> m a + sim m = do + st <- atomically $ takeTMVar var + runFSSimT m st >>= \case + Left e -> do + atomically $ putTMVar var st + throwIO e + Right (a, st') -> do + atomically $ putTMVar var st' + pure a - (.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z) - (f .: g) x0 x1 = f (g x0 x1) + (.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z) + (f .: g) x0 x1 = f (g x0 x1) - (..:) :: (y -> z) -> (x0 -> x1 -> x2 -> y) -> (x0 -> x1 -> x2 -> z) - (f ..: g) x0 x1 x2 = f (g x0 x1 x2) + (..:) :: (y -> z) -> (x0 -> x1 -> x2 -> y) -> (x0 -> x1 -> x2 -> z) + (f ..: g) x0 x1 x2 = f (g x0 x1 x2) - (...:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> y) -> (x0 -> x1 -> x2 -> x3 -> z) - (f ...: g) x0 x1 x2 x3 = f (g x0 x1 x2 x3) + (...:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> y) -> (x0 -> x1 -> x2 -> x3 -> z) + (f ...: g) x0 x1 x2 x3 = f (g x0 x1 x2 x3) - (....:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> x4 -> y) -> (x0 -> x1 -> x2 -> x3 -> x4 -> z) - (f ....: g) x0 x1 x2 x3 x4 = f (g x0 x1 x2 x3 x4) + (....:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> x4 -> y) -> (x0 -> x1 -> x2 -> x3 -> x4 -> z) + (f ....: g) x0 x1 x2 x3 x4 = f (g x0 x1 x2 x3 x4) diff --git a/fs-sim/src/System/FS/Sim/Stream.hs b/fs-sim/src/System/FS/Sim/Stream.hs index b9a1690..23e21ee 100644 --- a/fs-sim/src/System/FS/Sim/Stream.hs +++ b/fs-sim/src/System/FS/Sim/Stream.hs @@ -1,27 +1,32 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Finite and infinite streams of @'Maybe' a@s. -module System.FS.Sim.Stream ( - -- * Streams +module System.FS.Sim.Stream + ( -- * Streams Stream (..) , InternalInfo (..) + -- * Running , runStream , runStreamN , runStreamIndefinitely + -- * Construction , always , empty , repeating , unsafeMkInfinite , unsafeMkFinite + -- * Modify , filter + -- * Query , null , isFinite , isInfinite + -- * Generation and shrinking , genFinite , genFiniteN @@ -31,42 +36,42 @@ module System.FS.Sim.Stream ( , liftShrinkStream ) where -import Control.Monad (replicateM) -import Prelude hiding (filter, isInfinite, null) -import qualified Prelude +import Control.Monad (replicateM) +import Test.QuickCheck (Gen) import qualified Test.QuickCheck as QC -import Test.QuickCheck (Gen) +import Prelude hiding (filter, isInfinite, null) +import qualified Prelude {------------------------------------------------------------------------------- Streams -------------------------------------------------------------------------------} -- | A stream of @'Maybe' a@s that can be infinite. -data Stream a = - -- | UNSAFE: when constructing, modifying, or accessing the internals of a - -- 'Stream', it is the responsibility of the user to preserve the following - -- invariant: - -- - -- INVARIANT: if the stream is marked as 'Infinite', then the internal list - -- should be infinite. If the stream is marked as 'Finite', then the internal - -- list should finite. - -- - -- * If the internal list is infinite but marked as 'Finite', then 'QC.shrink' - -- or 'show' on the corresponding stream will diverge. - -- - -- * If the internal list is finite but marked as 'Infinite', then 'QC.shrink' - -- on the corresponding stream will degrade to an infinite list of empty - -- streams. - UnsafeStream { - -- | UNSAFE: see 'UnsafeStream' for more information. - -- - -- Info about the finiteness of the stream. It is used for 'QC.shrink'ing - -- and the 'Show' instance. - unsafeStreamInternalInfo :: InternalInfo - -- | UNSAFE: see 'UnsafeStream' for more information. - -- - -- The internal list underlying the stream. - , unsafeStreamList :: [Maybe a] +data Stream a + = -- | UNSAFE: when constructing, modifying, or accessing the internals of a + -- 'Stream', it is the responsibility of the user to preserve the following + -- invariant: + -- + -- INVARIANT: if the stream is marked as 'Infinite', then the internal list + -- should be infinite. If the stream is marked as 'Finite', then the internal + -- list should finite. + -- + -- * If the internal list is infinite but marked as 'Finite', then 'QC.shrink' + -- or 'show' on the corresponding stream will diverge. + -- + -- * If the internal list is finite but marked as 'Infinite', then 'QC.shrink' + -- on the corresponding stream will degrade to an infinite list of empty + -- streams. + UnsafeStream + { unsafeStreamInternalInfo :: InternalInfo + -- ^ UNSAFE: see 'UnsafeStream' for more information. + -- + -- Info about the finiteness of the stream. It is used for 'QC.shrink'ing + -- and the 'Show' instance. + , unsafeStreamList :: [Maybe a] + -- ^ UNSAFE: see 'UnsafeStream' for more information. + -- + -- The internal list underlying the stream. } deriving Functor @@ -80,11 +85,12 @@ data InternalInfo = Infinite | Finite -- it is infinite. instance Show a => Show (Stream a) where showsPrec n (UnsafeStream info xs) = case info of - Infinite -> ("" ++) - Finite -> (if n > 10 then ('(':) else id) - . shows xs - . (" ++ ..." ++) - . (if n > 10 then (')':) else id) + Infinite -> ("" ++) + Finite -> + (if n > 10 then ('(' :) else id) + . shows xs + . (" ++ ..." ++) + . (if n > 10 then (')' :) else id) {------------------------------------------------------------------------------- Running @@ -95,8 +101,8 @@ instance Show a => Show (Stream a) where -- -- Returns 'Nothing' by default if the 'Stream' is empty. runStream :: Stream a -> (Maybe a, Stream a) -runStream s@(UnsafeStream _ [] ) = (Nothing, s) -runStream (UnsafeStream info (a:as)) = (a, UnsafeStream info as) +runStream s@(UnsafeStream _ []) = (Nothing, s) +runStream (UnsafeStream info (a : as)) = (a, UnsafeStream info as) -- | \( O(n) \): like 'runStream', but advancing the stream @n@ times. -- @@ -106,8 +112,8 @@ runStreamN n s | n <= 0 = ([], s) | otherwise = let (x, s') = runStream s - (xs, s'') = runStreamN (n-1) s' - in (x:xs, s'') + (xs, s'') = runStreamN (n - 1) s' + in (x : xs, s'') -- | \( O(\infty) \): like 'runStream', but advancing the stream indefinitely. -- @@ -164,16 +170,16 @@ filter p (UnsafeStream info xs) = UnsafeStream info (Prelude.filter p xs) -- be empty. In particular, @'null' ('always' Nothing) /= True@. null :: Stream a -> Bool null (UnsafeStream Finite []) = True -null _ = False +null _ = False -- | Check that the stream is finite isFinite :: Stream a -> Bool -isFinite (UnsafeStream Finite _) = True +isFinite (UnsafeStream Finite _) = True isFinite (UnsafeStream Infinite _) = False -- | Check that the stream is infinite isInfinite :: Stream a -> Bool -isInfinite (UnsafeStream Finite _) = False +isInfinite (UnsafeStream Finite _) = False isInfinite (UnsafeStream Infinite _) = True {------------------------------------------------------------------------------- @@ -194,14 +200,14 @@ isInfinite (UnsafeStream Infinite _) = True -- finiteness. shrinkStream :: Stream a -> [Stream a] shrinkStream (UnsafeStream info xs0) = case info of - Infinite -> UnsafeStream Finite <$> [take n xs0 | n <- map (2^) [0 :: Int ..]] - Finite -> UnsafeStream Finite <$> QC.shrinkList (const []) xs0 + Infinite -> UnsafeStream Finite <$> [take n xs0 | n <- map (2 ^) [0 :: Int ..]] + Finite -> UnsafeStream Finite <$> QC.shrinkList (const []) xs0 -- | Like 'shrinkStream', but with a custom shrinker for elements of the stream. liftShrinkStream :: (Maybe a -> [Maybe a]) -> Stream a -> [Stream a] liftShrinkStream shrinkOne (UnsafeStream info xs0) = case info of - Infinite -> UnsafeStream Finite <$> [take n xs0 | n <- map (2^) [0 :: Int ..]] - Finite -> UnsafeStream Finite <$> QC.shrinkList shrinkOne xs0 + Infinite -> UnsafeStream Finite <$> [take n xs0 | n <- map (2 ^) [0 :: Int ..]] + Finite -> UnsafeStream Finite <$> QC.shrinkList shrinkOne xs0 -- | Make a @'Maybe' a@ generator based on an @a@ generator. -- @@ -209,30 +215,34 @@ liftShrinkStream shrinkOne (UnsafeStream info xs0) = case info of -- with the given @a@ generator (wrapped in a 'Just'). These /likelihoods/ are -- passed to 'QC.frequency'. genMaybe :: - Int -- ^ Likelihood of 'Nothing' - -> Int -- ^ Likelihood of @'Just' a@ - -> Gen a - -> Gen (Maybe a) -genMaybe nLi jLi genA = QC.frequency + -- | Likelihood of 'Nothing' + Int -> + -- | Likelihood of @'Just' a@ + Int -> + Gen a -> + Gen (Maybe a) +genMaybe nLi jLi genA = + QC.frequency [ (nLi, return Nothing) , (jLi, Just <$> genA) ] -- | Generate a finite 'Stream' of length @n@. genFiniteN :: - Int -- ^ Requested size of finite stream. - -> Gen (Maybe a) - -> Gen (Stream a) + -- | Requested size of finite stream. + Int -> + Gen (Maybe a) -> + Gen (Stream a) genFiniteN n gen = UnsafeStream Finite <$> replicateM n gen -- | Generate a sized, finite 'Stream'. genFinite :: - Gen (Maybe a) - -> Gen (Stream a) + Gen (Maybe a) -> + Gen (Stream a) genFinite gen = UnsafeStream Finite <$> QC.listOf gen -- | Generate an infinite 'Stream'. genInfinite :: - Gen (Maybe a) - -> Gen (Stream a) + Gen (Maybe a) -> + Gen (Stream a) genInfinite gen = UnsafeStream Infinite <$> QC.infiniteListOf gen diff --git a/fs-sim/test/Main.hs b/fs-sim/test/Main.hs index 3156005..3cc678e 100644 --- a/fs-sim/test/Main.hs +++ b/fs-sim/test/Main.hs @@ -4,12 +4,15 @@ import qualified Test.System.FS.Sim.Error import qualified Test.System.FS.Sim.FsTree import qualified Test.System.FS.Sim.Stream import qualified Test.System.FS.StateMachine -import Test.Tasty +import Test.Tasty main :: IO () -main = defaultMain $ testGroup "fs-sim-test" [ - Test.System.FS.Sim.Error.tests - , Test.System.FS.Sim.FsTree.tests - , Test.System.FS.Sim.Stream.tests - , Test.System.FS.StateMachine.tests - ] +main = + defaultMain $ + testGroup + "fs-sim-test" + [ Test.System.FS.Sim.Error.tests + , Test.System.FS.Sim.FsTree.tests + , Test.System.FS.Sim.Stream.tests + , Test.System.FS.StateMachine.tests + ] diff --git a/fs-sim/test/Test/System/FS/Sim/Error.hs b/fs-sim/test/Test/System/FS/Sim/Error.hs index 49e11f3..6de969e 100644 --- a/fs-sim/test/Test/System/FS/Sim/Error.hs +++ b/fs-sim/test/Test/System/FS/Sim/Error.hs @@ -2,152 +2,166 @@ module Test.System.FS.Sim.Error (tests) where -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad (unless, void) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad (unless, void) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as LBS -import Data.Primitive (newPinnedByteArray) -import Data.Word -import System.FS.API +import Data.Primitive (newPinnedByteArray) +import Data.Word +import System.FS.API +import System.FS.API.Lazy (hGetExactlyAt) import qualified System.FS.API.Lazy as Lazy -import System.FS.API.Lazy (hGetExactlyAt) import qualified System.FS.API.Strict as Strict -import System.FS.Sim.Error +import System.FS.Sim.Error +import System.FS.Sim.MockFS (HandleMock) import qualified System.FS.Sim.MockFS as MockFS -import System.FS.Sim.MockFS (HandleMock) import qualified System.FS.Sim.Stream as Stream -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Util -import Test.Util.WithEntryCounter +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Util +import Test.Util.WithEntryCounter -- For simplicity: + -- * We always use the full bytestring that is an argument to a property. + -- * File offsets are always 0. + -- * Byte counts are always the length of the argument bytestring. + -- * Offsets into user-supplied buffers are always 0. + -- * User-supplied buffers are always precisely as large as they need to be. tests :: TestTree -tests = testGroup "Test.System.FS.Sim.Error" [ - -- putters - testProperty "propPutterPutsAll hPutSome (expects failure)" $ expectFailure $ - let toInput = pure - in propPutterPutsAll hPutSomeC hPutSome toInput +tests = + testGroup + "Test.System.FS.Sim.Error" + [ -- putters + testProperty "propPutterPutsAll hPutSome (expects failure)" $ + expectFailure $ + let toInput = pure + in propPutterPutsAll hPutSomeC hPutSome toInput , testProperty "propPutterPutsAll Strict.hPutAllStrict" $ let toInput = pure - in propPutterPutsAll hPutSomeC Strict.hPutAllStrict toInput + in propPutterPutsAll hPutSomeC Strict.hPutAllStrict toInput , testProperty "propPutterPutsAll Lazy.hPutAll" $ let toInput = pure . LBS.fromStrict - in propPutterPutsAll hPutSomeC Lazy.hPutAll toInput + in propPutterPutsAll hPutSomeC Lazy.hPutAll toInput , testProperty "propPutterPutsAll Lazy.hPut" $ let toInput = pure . BB.byteString - in propPutterPutsAll hPutSomeC Lazy.hPut toInput + in propPutterPutsAll hPutSomeC Lazy.hPut toInput , testProperty "propPutterPutsAll hPutBufSome (expects failure)" $ expectFailure $ \p bs -> - let put hfs h mba = fromIntegral <$> - hPutBufSome hfs h mba 0 (fromIntegral $ BS.length bs) + let put hfs h mba = + fromIntegral + <$> hPutBufSome hfs h mba 0 (fromIntegral $ BS.length bs) toInput _ = do - mba <- newPinnedByteArray (BS.length bs) - success <- MockFS.intoBuffer mba 0 bs - unless success $ error "toInput: should not fail" - pure mba - in propPutterPutsAll hPutBufSomeC put toInput p bs + mba <- newPinnedByteArray (BS.length bs) + success <- MockFS.intoBuffer mba 0 bs + unless success $ error "toInput: should not fail" + pure mba + in propPutterPutsAll hPutBufSomeC put toInput p bs , testProperty "propPutterPutsAll hPutBufSomeAt (expects failure)" $ expectFailure $ \p bs -> - let put hfs h mba = fromIntegral <$> - hPutBufSomeAt hfs h mba 0 (fromIntegral $ BS.length bs) 0 + let put hfs h mba = + fromIntegral + <$> hPutBufSomeAt hfs h mba 0 (fromIntegral $ BS.length bs) 0 toInput _ = do - mba <- newPinnedByteArray (BS.length bs) - success <- MockFS.intoBuffer mba 0 bs - unless success $ error "toInput: should not fail" - pure mba - in propPutterPutsAll hPutBufSomeAtC put toInput p bs + mba <- newPinnedByteArray (BS.length bs) + success <- MockFS.intoBuffer mba 0 bs + unless success $ error "toInput: should not fail" + pure mba + in propPutterPutsAll hPutBufSomeAtC put toInput p bs , testProperty "propPutterPutsAll hPutBufAll" $ \p bs -> - let put hfs h mba = fromIntegral <$> - hPutBufExactly hfs h mba 0 (fromIntegral $ BS.length bs) + let put hfs h mba = + fromIntegral + <$> hPutBufExactly hfs h mba 0 (fromIntegral $ BS.length bs) toInput _ = do - mba <- newPinnedByteArray (BS.length bs) - success <- MockFS.intoBuffer mba 0 bs - unless success $ error "toInput: should not fail" - pure mba - in propPutterPutsAll hPutBufSomeC put toInput p bs + mba <- newPinnedByteArray (BS.length bs) + success <- MockFS.intoBuffer mba 0 bs + unless success $ error "toInput: should not fail" + pure mba + in propPutterPutsAll hPutBufSomeC put toInput p bs , testProperty "propPutterPutsAll hPutBufAllAt" $ \p bs -> - let put hfs h mba = fromIntegral <$> - hPutBufExactlyAt hfs h mba 0 (fromIntegral $ BS.length bs) 0 + let put hfs h mba = + fromIntegral + <$> hPutBufExactlyAt hfs h mba 0 (fromIntegral $ BS.length bs) 0 toInput _ = do - mba <- newPinnedByteArray (BS.length bs) - success <- MockFS.intoBuffer mba 0 bs - unless success $ error "toInput: should not fail" - pure mba - in propPutterPutsAll hPutBufSomeAtC put toInput p bs - -- getters - , testProperty "propGetterGetsAll hGetSome (expect failure)" $ expectFailure $ \p bs -> - let get hfs h = hGetSome hfs h (fromIntegral $ BS.length bs) + mba <- newPinnedByteArray (BS.length bs) + success <- MockFS.intoBuffer mba 0 bs + unless success $ error "toInput: should not fail" + pure mba + in propPutterPutsAll hPutBufSomeAtC put toInput p bs + , -- getters + testProperty "propGetterGetsAll hGetSome (expect failure)" $ expectFailure $ \p bs -> + let get hfs h = hGetSome hfs h (fromIntegral $ BS.length bs) fromOutput = pure - in propGetterGetsAll hGetSomeC get fromOutput p bs + in propGetterGetsAll hGetSomeC get fromOutput p bs , testProperty "propGetterGetsAll hGetSomeAt (expect failure)" $ expectFailure $ \p bs -> - let get hfs h = hGetSomeAt hfs h (fromIntegral $ BS.length bs) 0 + let get hfs h = hGetSomeAt hfs h (fromIntegral $ BS.length bs) 0 fromOutput = pure - in propGetterGetsAll hGetSomeC get fromOutput p bs + in propGetterGetsAll hGetSomeC get fromOutput p bs , testProperty "propGetterGetsAll Lazy.hGetExactly" $ \p bs -> - let get hfs h = Lazy.hGetExactly hfs h (fromIntegral $ BS.length bs) + let get hfs h = Lazy.hGetExactly hfs h (fromIntegral $ BS.length bs) fromOutput = pure . LBS.toStrict - in propGetterGetsAll hGetSomeC get fromOutput p bs + in propGetterGetsAll hGetSomeC get fromOutput p bs , testProperty "propGetterGetsAll Lazy.hGetExactlyAt" $ \p bs -> - let get hfs h = Lazy.hGetExactlyAt hfs h (fromIntegral $ BS.length bs) 0 + let get hfs h = Lazy.hGetExactlyAt hfs h (fromIntegral $ BS.length bs) 0 fromOutput = pure . LBS.toStrict - in propGetterGetsAll hGetSomeAtC get fromOutput p bs + in propGetterGetsAll hGetSomeAtC get fromOutput p bs , testProperty "propGetterGetsAll Lazy.hGetAll" $ \p bs -> - let get = Lazy.hGetAll + let get = Lazy.hGetAll fromOutput = pure . LBS.toStrict - in propGetterGetsAll hGetSomeC get fromOutput p bs + in propGetterGetsAll hGetSomeC get fromOutput p bs , testProperty "propGetterGetsAll Lazy.hGetAllAt" $ \p bs -> - let get hfs h = Lazy.hGetAllAt hfs h 0 + let get hfs h = Lazy.hGetAllAt hfs h 0 fromOutput = pure . LBS.toStrict - in propGetterGetsAll hGetSomeAtC get fromOutput p bs + in propGetterGetsAll hGetSomeAtC get fromOutput p bs , testProperty "propGetterGetsAll hGetBufSome (expects failure)" $ expectFailure $ \p bs -> let get hfs h = do - mba <- newPinnedByteArray (BS.length bs) - void $ hGetBufSome hfs h mba 0 (fromIntegral $ BS.length bs) - pure mba + mba <- newPinnedByteArray (BS.length bs) + void $ hGetBufSome hfs h mba 0 (fromIntegral $ BS.length bs) + pure mba fromOutput mba = do - MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>= - maybe (error "fromOutput: should not fail") pure - in propGetterGetsAll hGetBufSomeC get fromOutput p bs + MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) + >>= maybe (error "fromOutput: should not fail") pure + in propGetterGetsAll hGetBufSomeC get fromOutput p bs , testProperty "propGetterGetsAll hGetBufSomeAt (expects failure)" $ expectFailure $ \p bs -> let get hfs h = do - mba <- newPinnedByteArray (BS.length bs) - void $ hGetBufSomeAt hfs h mba 0 (fromIntegral $ BS.length bs) 0 - pure mba + mba <- newPinnedByteArray (BS.length bs) + void $ hGetBufSomeAt hfs h mba 0 (fromIntegral $ BS.length bs) 0 + pure mba fromOutput mba = do - MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>= - maybe (error "fromOutput: should not fail") pure - in propGetterGetsAll hGetBufSomeAtC get fromOutput p bs + MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) + >>= maybe (error "fromOutput: should not fail") pure + in propGetterGetsAll hGetBufSomeAtC get fromOutput p bs , testProperty "propGetterGetsAll hGetBufExactly" $ \p bs -> let get hfs h = do - mba <- newPinnedByteArray (BS.length bs) - void $ hGetBufExactly hfs h mba 0 (fromIntegral $ BS.length bs) - pure mba + mba <- newPinnedByteArray (BS.length bs) + void $ hGetBufExactly hfs h mba 0 (fromIntegral $ BS.length bs) + pure mba fromOutput mba = do - MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>= - maybe (error "fromOutput: should not fail") pure - in propGetterGetsAll hGetBufSomeC get fromOutput p bs + MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) + >>= maybe (error "fromOutput: should not fail") pure + in propGetterGetsAll hGetBufSomeC get fromOutput p bs , testProperty "propGetterGetsAll hGetBufExactlyAt" $ \p bs -> let get hfs h = do - mba <- newPinnedByteArray (BS.length bs) - void $ hGetBufExactlyAt hfs h mba 0 (fromIntegral $ BS.length bs) 0 - pure mba + mba <- newPinnedByteArray (BS.length bs) + void $ hGetBufExactlyAt hfs h mba 0 (fromIntegral $ BS.length bs) 0 + pure mba fromOutput mba = do - MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>= - maybe (error "fromOutput: should not fail") pure - in propGetterGetsAll hGetBufSomeAtC get fromOutput p bs - - -- Generators and shrinkers + MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) + >>= maybe (error "fromOutput: should not fail") pure + in propGetterGetsAll hGetBufSomeAtC get fromOutput p bs + , -- Generators and shrinkers - , testProperty "prop_regression_shrinkErrors" + testProperty + "prop_regression_shrinkErrors" prop_regression_shrinkErrors - , testProperty "prop_regression_shrinkNonEmptyErrors" + , testProperty + "prop_regression_shrinkNonEmptyErrors" prop_regression_shrinkNonEmptyErrors - , testProperty "prop_regression_shrinkEmptyErrors" + , testProperty + "prop_regression_shrinkEmptyErrors" prop_regression_shrinkEmptyErrors ] @@ -159,46 +173,49 @@ instance Arbitrary BS.ByteString where Read functions get all requested bytes -------------------------------------------------------------------------------} -newtype SometimesPartialWrites = SometimesPartialWrites { - getSometimesPartialWrites :: ErrorStreamPutSome +newtype SometimesPartialWrites = SometimesPartialWrites + { getSometimesPartialWrites :: ErrorStreamPutSome } deriving Show instance Arbitrary SometimesPartialWrites where arbitrary = SometimesPartialWrites <$> Stream.genInfinite (fmap Right <$> (arbitrary :: Gen (Maybe Partial))) - shrink = fmap SometimesPartialWrites . Stream.shrinkStream . getSometimesPartialWrites + shrink = fmap SometimesPartialWrites . Stream.shrinkStream . getSometimesPartialWrites type GetCounter = EntryCounters (StrictTVar IO) -> StrictTVar IO Word64 type PutFunction input = HasFS IO HandleMock -> Handle HandleMock -> input -> IO Word64 type ToInput input = BS.ByteString -> IO input propPutterPutsAll :: - GetCounter - -> PutFunction input - -> ToInput input - -> SometimesPartialWrites - -> BS.ByteString - -> Property + GetCounter -> + PutFunction input -> + ToInput input -> + SometimesPartialWrites -> + BS.ByteString -> + Property propPutterPutsAll getCounter put toInput (SometimesPartialWrites errStream) bs = - ioProperty $ do - fsVar <- newTMVarIO MockFS.empty - errVar <- newTVarIO onlyPutErrors - counters <- zeroEntryCounters - let hfs = withEntryCounters counters $ simErrorHasFS fsVar errVar - withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do - inp <- toInput bs - n' <- put hfs h inp - let n = fromIntegral $ BS.length bs - bs' <- LBS.toStrict <$> hGetExactlyAt hfs h n 0 - putN <- readTVarIO (getCounter counters) - pure $ checkCoverage - $ tabulate "number of writes (>1 indicates partial writes)" - [showPowersOf 2 $ fromIntegral putN] - . cover 0.60 (putN > 1) "At least one partial write" - $ n === n' .&&. bs === bs' - where - onlyPutErrors = emptyErrors { - hPutSomeE = errStream + ioProperty $ do + fsVar <- newTMVarIO MockFS.empty + errVar <- newTVarIO onlyPutErrors + counters <- zeroEntryCounters + let hfs = withEntryCounters counters $ simErrorHasFS fsVar errVar + withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do + inp <- toInput bs + n' <- put hfs h inp + let n = fromIntegral $ BS.length bs + bs' <- LBS.toStrict <$> hGetExactlyAt hfs h n 0 + putN <- readTVarIO (getCounter counters) + pure + $ checkCoverage + $ tabulate + "number of writes (>1 indicates partial writes)" + [showPowersOf 2 $ fromIntegral putN] + . cover 0.60 (putN > 1) "At least one partial write" + $ n === n' .&&. bs === bs' + where + onlyPutErrors = + emptyErrors + { hPutSomeE = errStream , hPutBufSomeE = errStream , hPutBufSomeAtE = errStream } @@ -207,46 +224,49 @@ propPutterPutsAll getCounter put toInput (SometimesPartialWrites errStream) bs = Write functions put all requested bytes -------------------------------------------------------------------------------} -newtype SometimesPartialReads = SometimesPartialReads { - getSometimesPartialReads :: ErrorStreamGetSome +newtype SometimesPartialReads = SometimesPartialReads + { getSometimesPartialReads :: ErrorStreamGetSome } deriving Show instance Arbitrary SometimesPartialReads where arbitrary = SometimesPartialReads <$> Stream.genInfinite (fmap Right <$> (arbitrary :: Gen (Maybe Partial))) - shrink = fmap SometimesPartialReads . Stream.shrinkStream . getSometimesPartialReads + shrink = fmap SometimesPartialReads . Stream.shrinkStream . getSometimesPartialReads type GetFunction output = HasFS IO HandleMock -> Handle HandleMock -> IO output type FromOutput output = output -> IO BS.ByteString propGetterGetsAll :: - GetCounter - -> GetFunction output - -> FromOutput output - -> SometimesPartialReads - -> BS.ByteString - -> Property + GetCounter -> + GetFunction output -> + FromOutput output -> + SometimesPartialReads -> + BS.ByteString -> + Property propGetterGetsAll getCounter get fromOutput (SometimesPartialReads errStream) bs = - ioProperty $ do - fsVar <- newTMVarIO MockFS.empty - errVar <- newTVarIO onlyGetErrors - counters <- zeroEntryCounters - let hfs = withEntryCounters counters $ simErrorHasFS fsVar errVar - withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do - n' <- Strict.hPutAllStrict hfs h bs - let n = fromIntegral $ BS.length bs - hSeek hfs h AbsoluteSeek 0 - outp <- get hfs h - bs' <- fromOutput outp - getN <- readTVarIO (getCounter counters) - pure $ checkCoverage - $ tabulate "number of reads (>1 indicates partial reads)" - [showPowersOf 2 $ fromIntegral getN] - . cover 60 (getN > 1) "At least one partial read" - $ n === n' .&&. bs === bs' - where - onlyGetErrors = emptyErrors { - hGetSomeE = errStream + ioProperty $ do + fsVar <- newTMVarIO MockFS.empty + errVar <- newTVarIO onlyGetErrors + counters <- zeroEntryCounters + let hfs = withEntryCounters counters $ simErrorHasFS fsVar errVar + withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do + n' <- Strict.hPutAllStrict hfs h bs + let n = fromIntegral $ BS.length bs + hSeek hfs h AbsoluteSeek 0 + outp <- get hfs h + bs' <- fromOutput outp + getN <- readTVarIO (getCounter counters) + pure + $ checkCoverage + $ tabulate + "number of reads (>1 indicates partial reads)" + [showPowersOf 2 $ fromIntegral getN] + . cover 60 (getN > 1) "At least one partial read" + $ n === n' .&&. bs === bs' + where + onlyGetErrors = + emptyErrors + { hGetSomeE = errStream , hGetSomeAtE = errStream , hGetBufSomeE = errStream , hGetBufSomeAtE = errStream @@ -258,22 +278,27 @@ propGetterGetsAll getCounter get fromOutput (SometimesPartialReads errStream) bs -- | See fs-sim#84 prop_regression_shrinkErrors :: Errors -> Property -prop_regression_shrinkErrors _errs = expectFailure $ +prop_regression_shrinkErrors _errs = + expectFailure $ property False -- | See fs-sim#84 prop_regression_shrinkNonEmptyErrors :: Errors -> Property -prop_regression_shrinkNonEmptyErrors errs = expectFailure $ - not (allNull errs) ==> property False +prop_regression_shrinkNonEmptyErrors errs = + expectFailure $ + not (allNull errs) ==> + property False newtype EmptyErrors = EmptyErrors Errors deriving Show instance Arbitrary EmptyErrors where - arbitrary = EmptyErrors <$> oneof [ pure emptyErrors ] + arbitrary = EmptyErrors <$> oneof [pure emptyErrors] shrink (EmptyErrors errs) = EmptyErrors <$> shrink errs -- | See fs-sim#84 prop_regression_shrinkEmptyErrors :: EmptyErrors -> Property -prop_regression_shrinkEmptyErrors (EmptyErrors errs) = expectFailure $ - allNull errs ==> property False +prop_regression_shrinkEmptyErrors (EmptyErrors errs) = + expectFailure $ + allNull errs ==> + property False diff --git a/fs-sim/test/Test/System/FS/Sim/FsTree.hs b/fs-sim/test/Test/System/FS/Sim/FsTree.hs index e74a7ca..3640bf0 100644 --- a/fs-sim/test/Test/System/FS/Sim/FsTree.hs +++ b/fs-sim/test/Test/System/FS/Sim/FsTree.hs @@ -2,52 +2,57 @@ module Test.System.FS.Sim.FsTree (tests) where -import Data.List ((\\)) +import Data.List ((\\)) import qualified Data.Map.Strict as M -import Data.Text (Text) - -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?)) -import Text.Show.Pretty (ppShow, ppShowList) - -import System.FS.API.Types (FsPath, fsPathFromList) -import System.FS.Sim.FsTree (FsTree (File, Folder), - FsTreeError (FsMissing), find) +import Data.Text (Text) +import System.FS.API.Types (FsPath, fsPathFromList) +import System.FS.Sim.FsTree + ( FsTree (File, Folder) + , FsTreeError (FsMissing) + , find + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?)) +import Text.Show.Pretty (ppShow, ppShowList) tests :: TestTree tests = - testGroup "FsTree" - [ testGroup "find command returns exactly what's expected" - [ testCase "usr" $ checkResultsOfFind ["usr"] example findUsr - , testCase "var" $ checkResultsOfFind ["var"] example findVar - , testCase "var/log" $ checkResultsOfFind ["var", "log"] example findVarLog - , testCase "root" $ checkResultsOfFind [] example findRoot - - -- Bad weather - , testCase "boom" $ ["boom"] `shouldReportMissingFileIn` example - ] + testGroup + "FsTree" + [ testGroup + "find command returns exactly what's expected" + [ testCase "usr" $ checkResultsOfFind ["usr"] example findUsr + , testCase "var" $ checkResultsOfFind ["var"] example findVar + , testCase "var/log" $ checkResultsOfFind ["var", "log"] example findVarLog + , testCase "root" $ checkResultsOfFind [] example findRoot + , -- Bad weather + testCase "boom" $ ["boom"] `shouldReportMissingFileIn` example + ] ] checkResultsOfFind :: [Text] -> FsTree () -> [FsPath] -> Assertion checkResultsOfFind fp fs expectedResult = do - (expectedResult \\ filePathsFound) - `shouldBeEmptyOtherwise` "Not all expected paths were found" - (filePathsFound \\ expectedResult) - `shouldBeEmptyOtherwise` "Find returned unexpected paths" - where - filePathsFound = either (error . ppShow) id - $ find (fsPathFromList fp) fs - shouldBeEmptyOtherwise x msg = - null x @? msg ++ ":\n" ++ ppShowList x + (expectedResult \\ filePathsFound) + `shouldBeEmptyOtherwise` "Not all expected paths were found" + (filePathsFound \\ expectedResult) + `shouldBeEmptyOtherwise` "Find returned unexpected paths" + where + filePathsFound = + either (error . ppShow) id $ + find (fsPathFromList fp) fs + shouldBeEmptyOtherwise x msg = + null x @? msg ++ ":\n" ++ ppShowList x shouldReportMissingFileIn :: [Text] -> FsTree () -> Assertion shouldReportMissingFileIn fp fs = - case find (fsPathFromList fp) fs of - Left FsMissing {} -> pure () - Left err -> assertFailure $ "Unexpected error: " ++ ppShow err - Right _ -> assertFailure $ ppShow fp - ++ " was found on this filesystem:\n" - ++ ppShow fs + case find (fsPathFromList fp) fs of + Left FsMissing{} -> pure () + Left err -> assertFailure $ "Unexpected error: " ++ ppShow err + Right _ -> + assertFailure $ + ppShow fp + ++ " was found on this filesystem:\n" + ++ ppShow fs {------------------------------------------------------------------------------- Examples and expected results @@ -55,71 +60,105 @@ shouldReportMissingFileIn fp fs = example :: FsTree () example = - Folder $ M.fromList [ - ("usr", Folder $ M.fromList [ - ("local", Folder $ M.fromList [ - ("bin", Folder mempty) - ]) - ]) - , ("var", Folder $ M.fromList [ - ("log", Folder $ M.fromList [ - ("some.log", File mempty) - , ("apt", Folder mempty) - , ("cups", Folder $ M.fromList [ - ("bar.txt", File mempty) - , ("baz.txt", File mempty) - , ("buz", Folder $ M.fromList [ - ("sample.log", File mempty) - ]) - , ("biz", Folder mempty) - ]) - ]) - , ("mail", Folder mempty) - , ("run", Folder mempty) - , ("tmp", Folder $ M.fromList [ - ("foo.txt", File mempty) - ]) - ]) + Folder $ + M.fromList + [ + ( "usr" + , Folder $ + M.fromList + [ + ( "local" + , Folder $ + M.fromList + [ ("bin", Folder mempty) + ] + ) + ] + ) + , + ( "var" + , Folder $ + M.fromList + [ + ( "log" + , Folder $ + M.fromList + [ ("some.log", File mempty) + , ("apt", Folder mempty) + , + ( "cups" + , Folder $ + M.fromList + [ ("bar.txt", File mempty) + , ("baz.txt", File mempty) + , + ( "buz" + , Folder $ + M.fromList + [ ("sample.log", File mempty) + ] + ) + , ("biz", Folder mempty) + ] + ) + ] + ) + , ("mail", Folder mempty) + , ("run", Folder mempty) + , + ( "tmp" + , Folder $ + M.fromList + [ ("foo.txt", File mempty) + ] + ) + ] + ) ] findUsr :: [FsPath] findUsr = - fmap fsPathFromList [ ["usr"] - , ["usr", "local"] - , ["usr", "local", "bin"] - ] - + fmap + fsPathFromList + [ ["usr"] + , ["usr", "local"] + , ["usr", "local", "bin"] + ] findVar :: [FsPath] findVar = - fmap fsPathFromList [ ["var"] - , ["var", "log"] - , ["var", "log", "some.log"] - , ["var", "log", "apt"] - , ["var", "log", "cups"] - , ["var", "log", "cups", "bar.txt"] - , ["var", "log", "cups", "baz.txt"] - , ["var", "log", "cups", "buz"] - , ["var", "log", "cups", "buz", "sample.log"] - , ["var", "log", "cups", "biz"] - , ["var", "mail"] - , ["var", "run"] - , ["var", "tmp"] - , ["var", "tmp", "foo.txt"] - ] + fmap + fsPathFromList + [ ["var"] + , ["var", "log"] + , ["var", "log", "some.log"] + , ["var", "log", "apt"] + , ["var", "log", "cups"] + , ["var", "log", "cups", "bar.txt"] + , ["var", "log", "cups", "baz.txt"] + , ["var", "log", "cups", "buz"] + , ["var", "log", "cups", "buz", "sample.log"] + , ["var", "log", "cups", "biz"] + , ["var", "mail"] + , ["var", "run"] + , ["var", "tmp"] + , ["var", "tmp", "foo.txt"] + ] findVarLog :: [FsPath] findVarLog = - fmap fsPathFromList [ ["var", "log"] - , ["var", "log", "some.log"] - , ["var", "log", "apt"] - , ["var", "log", "cups"] - , ["var", "log", "cups", "bar.txt"] - , ["var", "log", "cups", "baz.txt"] - , ["var", "log", "cups", "buz"] - , ["var", "log", "cups", "buz", "sample.log"] - , ["var", "log", "cups", "biz"] - ] + fmap + fsPathFromList + [ ["var", "log"] + , ["var", "log", "some.log"] + , ["var", "log", "apt"] + , ["var", "log", "cups"] + , ["var", "log", "cups", "bar.txt"] + , ["var", "log", "cups", "baz.txt"] + , ["var", "log", "cups", "buz"] + , ["var", "log", "cups", "buz", "sample.log"] + , ["var", "log", "cups", "biz"] + ] findRoot :: [FsPath] findRoot = [fsPathFromList []] <> findUsr <> findVar diff --git a/fs-sim/test/Test/System/FS/Sim/Stream.hs b/fs-sim/test/Test/System/FS/Sim/Stream.hs index 41acf7e..2b2ece6 100644 --- a/fs-sim/test/Test/System/FS/Sim/Stream.hs +++ b/fs-sim/test/Test/System/FS/Sim/Stream.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} - -- The @base@ library throws warnings on uses of @head@ on later GHC versions. -- This is a just a test module, so we ignore the warning. {-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-} @@ -13,25 +11,29 @@ module Test.System.FS.Sim.Stream (tests) where -import Control.DeepSeq -import Data.Maybe (isJust, isNothing) -import Prelude hiding (filter, isInfinite, null) +import Control.DeepSeq +import Data.Maybe (isJust, isNothing) +import System.FS.Sim.Stream +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Util +import Prelude hiding (filter, isInfinite, null) import qualified Prelude -import System.FS.Sim.Stream -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Util tests :: TestTree -tests = testGroup "Test.System.FS.Sim.Stream" [ - testProperty "prop_runStream" $ +tests = + testGroup + "Test.System.FS.Sim.Stream" + [ testProperty "prop_runStream" $ prop_runStream @Int , testProperty "prop_runStreamN" $ prop_runStreamN @Int - , testProperty "prop_null" + , testProperty + "prop_null" prop_null - , testGroup "Shrinkers" [ - testProperty "prop_shrinkStreamFail" $ + , testGroup + "Shrinkers" + [ testProperty "prop_shrinkStreamFail" $ prop_shrinkStreamFail @Int , testProperty "prop_eventuallyJust @InfiniteStream" $ \(InfiniteStream s) -> prop_eventuallyJust @Int s @@ -40,8 +42,9 @@ tests = testGroup "Test.System.FS.Sim.Stream" [ , testProperty "prop_eventuallyNothing @FiniteStream" $ \(FiniteStream s) -> prop_eventuallyNothing @Int s ] - , testGroup "Generators and shrinkers" [ - testGroup "Stream" $ + , testGroup + "Generators and shrinkers" + [ testGroup "Stream" $ prop_forAllArbitraryAndShrinkSatisfy @(Stream Int) arbitrary @@ -77,18 +80,18 @@ tests = testGroup "Test.System.FS.Sim.Stream" [ -- | Advancing a stream behaves like a head on an equivalent list. prop_runStream :: (Eq a, Show a) => Stream a -> Property prop_runStream s = - x === head ys - where - (x, _s') = runStream s - ys = runStreamIndefinitely s + x === head ys + where + (x, _s') = runStream s + ys = runStreamIndefinitely s -- | Advancing a stream @n@ times behaves likes @take n@ on an equivalent list. prop_runStreamN :: (Eq a, Show a) => Int -> Stream a -> Property prop_runStreamN n s = - xs === take n ys - where - (xs, _s') = runStreamN n s - ys = runStreamIndefinitely s + xs === take n ys + where + (xs, _s') = runStreamN n s + ys = runStreamIndefinitely s -- | Empty streams are null prop_null :: Property @@ -101,9 +104,10 @@ prop_null = once $ property $ null empty -- | A simple property that is expected to fail, but should exercise the -- shrinker a little bit. prop_shrinkStreamFail :: Stream a -> Property -prop_shrinkStreamFail s = expectFailure $ +prop_shrinkStreamFail s = + expectFailure $ let xs = fst (runStreamN 10 s) - in property $ length (Prelude.filter isJust xs) /= length (Prelude.filter isNothing xs) + in property $ length (Prelude.filter isJust xs) /= length (Prelude.filter isNothing xs) -- | A stream eventually produces a 'Just' prop_eventuallyJust :: Stream a -> Property @@ -115,12 +119,12 @@ prop_eventuallyNothing = eventually isNothing eventually :: (Maybe a -> Bool) -> Stream a -> Property eventually p = go 1 - where - go !n s = - let (x, s') = runStream s in - if p x - then tabulate "Number of elements inspected" [showPowersOf 2 n] $ property True - else go (n+1) s' + where + go !n s = + let (x, s') = runStream s + in if p x + then tabulate "Number of elements inspected" [showPowersOf 2 n] $ property True + else go (n + 1) s' {------------------------------------------------------------------------------- Generators and shrinkers @@ -129,25 +133,27 @@ eventually p = go 1 -- | A 'Stream' is either finite or infinite prop_stream :: NFData a => Stream a -> Property prop_stream s = - prop_finiteStream s + prop_finiteStream s .||. prop_infiniteStream s -- | A stream is finite prop_finiteStream :: NFData a => Stream a -> Property prop_finiteStream s = - property (isFinite s) .&&. property (not (isInfinite s)) .&&. - prop_deepseqStream s + property (isFinite s) + .&&. property (not (isInfinite s)) + .&&. prop_deepseqStream s -- | An stream is infinite prop_infiniteStream :: Stream a -> Property prop_infiniteStream s = - property (isInfinite s) .&&. property (not (isFinite s)) + property (isInfinite s) .&&. property (not (isFinite s)) -- | A stream is non-empty, and finite or infinite prop_nonEmptyStream :: NFData a => Stream a -> Property prop_nonEmptyStream s = - property $ not (null s) - .&&. prop_stream s + property $ + not (null s) + .&&. prop_stream s prop_deepseqStream :: NFData a => Stream a -> Property prop_deepseqStream (UnsafeStream info xs) = property (rwhnf info `seq` rnf xs) @@ -157,47 +163,55 @@ prop_deepseqStream (UnsafeStream info xs) = property (rwhnf info `seq` rnf xs) -------------------------------------------------------------------------------} prop_arbitraryAndShrinkSatisfy :: - forall a. (Arbitrary a, Show a) - => (a -> Property) -- ^ Generator property - -> (a -> Property) -- ^ Shrinker property - -> [TestTree] + forall a. + (Arbitrary a, Show a) => + -- | Generator property + (a -> Property) -> + -- | Shrinker property + (a -> Property) -> + [TestTree] prop_arbitraryAndShrinkSatisfy = - prop_forAllArbitraryAndShrinkSatisfy arbitrary shrink + prop_forAllArbitraryAndShrinkSatisfy arbitrary shrink prop_forAllArbitraryAndShrinkSatisfy :: - forall a. Show a - => Gen a - -> (a -> [a]) - -> (a -> Property) -- ^ Generator property - -> (a -> Property) -- ^ Shrinker property - -> [TestTree] + forall a. + Show a => + Gen a -> + (a -> [a]) -> + -- | Generator property + (a -> Property) -> + -- | Shrinker property + (a -> Property) -> + [TestTree] prop_forAllArbitraryAndShrinkSatisfy gen shr pgen pshr = - [ prop_forAllArbitrarySatisfies gen shr pgen - , prop_forAllShrinkSatisfies gen shr pshr - ] + [ prop_forAllArbitrarySatisfies gen shr pgen + , prop_forAllShrinkSatisfies gen shr pshr + ] prop_forAllArbitrarySatisfies :: - forall a. Show a - => Gen a - -> (a -> [a]) - -> (a -> Property) - -> TestTree + forall a. + Show a => + Gen a -> + (a -> [a]) -> + (a -> Property) -> + TestTree prop_forAllArbitrarySatisfies gen shr p = - testProperty "Arbitrary satisfies property" $ - forAllShrink gen shr p + testProperty "Arbitrary satisfies property" $ + forAllShrink gen shr p prop_forAllShrinkSatisfies :: - forall a. Show a - => Gen a - -> (a -> [a]) - -> (a -> Property) - -> TestTree + forall a. + Show a => + Gen a -> + (a -> [a]) -> + (a -> Property) -> + TestTree prop_forAllShrinkSatisfies gen shr p = - testProperty "Shrinking satisfies property" $ - forAll gen $ \x -> - case shr x of - [] -> label "no shrinks" $ property True - xs -> forAll (growingElements xs) p + testProperty "Shrinking satisfies property" $ + forAll gen $ \x -> + case shr x of + [] -> label "no shrinks" $ property True + xs -> forAll (growingElements xs) p {------------------------------------------------------------------------------- Arbitrary instances @@ -208,8 +222,9 @@ prop_forAllShrinkSatisfies gen shr p = -- instance Arbitrary a => Arbitrary (Stream a) where - arbitrary = oneof [ - genFinite arbitrary + arbitrary = + oneof + [ genFinite arbitrary , genInfinite arbitrary ] shrink = liftShrinkStream shrink @@ -222,26 +237,29 @@ newtype NonEmptyStream a = NonEmptyStream (Stream a) deriving stock Show instance Arbitrary a => Arbitrary (NonEmptyStream a) where - arbitrary = NonEmptyStream <$> oneof [ - genFiniteNonEmpty - , genInfinite arbitrary - ] - where - genFiniteNonEmpty = do - x <- arbitrary - xs <- arbitrary - pure $ unsafeMkFinite (x : xs) + arbitrary = + NonEmptyStream + <$> oneof + [ genFiniteNonEmpty + , genInfinite arbitrary + ] + where + genFiniteNonEmpty = do + x <- arbitrary + xs <- arbitrary + pure $ unsafeMkFinite (x : xs) shrink (NonEmptyStream s) = - [ NonEmptyStream s' - | s' <- shrink s - , not (Prelude.null (unsafeStreamList s')) ] + [ NonEmptyStream s' + | s' <- shrink s + , not (Prelude.null (unsafeStreamList s')) + ] -- -- FiniteStream -- -newtype FiniteStream a = FiniteStream { - getFiniteStream :: Stream a +newtype FiniteStream a = FiniteStream + { getFiniteStream :: Stream a } deriving stock Show @@ -253,8 +271,8 @@ instance Arbitrary a => Arbitrary (FiniteStream a) where -- InfiniteStream -- -newtype InfiniteStream a = InfiniteStream { - getInfiniteStream :: Stream a +newtype InfiniteStream a = InfiniteStream + { getInfiniteStream :: Stream a } deriving stock Show @@ -271,4 +289,4 @@ newtype Tiny a = Tiny a instance Arbitrary (Tiny Int) where arbitrary = Tiny <$> choose (0, 5) - shrink (Tiny x) = [ Tiny x' | x' <- shrink x, 0 <= x', x' <= 5] + shrink (Tiny x) = [Tiny x' | x' <- shrink x, 0 <= x', x' <= 5] diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index cc0e810..279a61a 100644 --- a/fs-sim/test/Test/System/FS/StateMachine.hs +++ b/fs-sim/test/Test/System/FS/StateMachine.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} + {- HLINT ignore "Use camelCase" -} -- | Tests for our filesystem abstractions. @@ -51,9 +51,8 @@ -- file system, but we are of course not developing a file system. Instead, the -- tests serve to make sure that we got the model right, which we can then use -- in the tests of the rest of the consensus layer. --- -module Test.System.FS.StateMachine ( - showLabelledExamples +module Test.System.FS.StateMachine + ( showLabelledExamples , tests ) where @@ -62,75 +61,71 @@ import Data.Foldable (foldl') #endif import qualified Control.Exception as E -import Control.Monad -import Control.Monad.Primitive -import Control.Monad.ST.Strict (runST) -import Data.Bifoldable -import Data.Bifunctor +import Control.Monad +import Control.Monad.Primitive +import Control.Monad.ST.Strict (runST) +import Data.Bifoldable +import Data.Bifunctor import qualified Data.Bifunctor.TH as TH -import Data.Bitraversable -import Data.ByteString (ByteString) +import Data.Bitraversable +import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Functor.Classes -import Data.Int (Int64) +import Data.Functor.Classes +import Data.Int (Int64) import qualified Data.List as L -import Data.Map.Strict (Map) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust) -import Data.Primitive (MutableByteArray, newPinnedByteArray) -import Data.Proxy -import Data.Set (Set) +import Data.Maybe (fromJust) +import Data.Primitive (MutableByteArray, newPinnedByteArray) +import Data.Proxy +import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as Text -import Data.Word (Word64) +import Data.Word (Word64) +import GHC.Generics +import GHC.Stack hiding (prettyCallStack) import qualified Generics.SOP as SOP -import GHC.Generics -import GHC.Stack hiding (prettyCallStack) -import System.IO.Temp (withSystemTempDirectory) -import System.Posix.Types (ByteCount) -import System.Random (getStdRandom, randomR) -import Test.StateMachine.TreeDiff -import Text.Read (readMaybe) -import Text.Show.Pretty (ppShow) - -import Test.QuickCheck +import System.FS.API +import System.FS.CallStack +import System.FS.Condense +import System.FS.IO +import System.FS.Sim.FsTree (FsTree (..)) +import System.FS.Sim.MockFS (HandleMock, MockFS) +import qualified System.FS.Sim.MockFS as Mock +import System.FS.Sim.Prim +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Types (ByteCount) +import System.Random (getStdRandom, randomR) +import Test.QuickCheck import qualified Test.QuickCheck.Monadic as QC -import Test.QuickCheck.Random (mkQCGen) +import Test.QuickCheck.Random (mkQCGen) +import Test.StateMachine (Concrete, Symbolic) import qualified Test.StateMachine as QSM -import Test.StateMachine (Concrete, Symbolic) import qualified Test.StateMachine.Labelling as C import qualified Test.StateMachine.Sequential as QSM +import Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types as QSM import qualified Test.StateMachine.Types.Rank2 as Rank2 -import Test.Tasty (TestTree, localOption, testGroup) -import Test.Tasty.QuickCheck - -import System.FS.API -import System.FS.CallStack -import System.FS.Condense -import System.FS.IO - -import System.FS.Sim.FsTree (FsTree (..)) -import qualified System.FS.Sim.MockFS as Mock -import System.FS.Sim.MockFS (HandleMock, MockFS) -import System.FS.Sim.Prim - +import Test.Tasty (TestTree, localOption, testGroup) +import Test.Tasty.QuickCheck +import Test.Util.RefEnv (RefEnv) import qualified Test.Util.RefEnv as RE -import Test.Util.RefEnv (RefEnv) +import Text.Read (readMaybe) +import Text.Show.Pretty (ppShow) {------------------------------------------------------------------------------- Path expressions -------------------------------------------------------------------------------} -data PathExpr fp = - PExpPath FsPath - | PExpRef fp +data PathExpr fp + = PExpPath FsPath + | PExpRef fp | PExpParentOf fp deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) evalPathExpr :: PathExpr FsPath -> FsPath -evalPathExpr (PExpPath fp) = fp -evalPathExpr (PExpRef fp) = fp +evalPathExpr (PExpPath fp) = fp +evalPathExpr (PExpRef fp) = fp evalPathExpr (PExpParentOf fp) = fsPathInit fp {------------------------------------------------------------------------------- @@ -150,99 +145,102 @@ evalPathExpr (PExpParentOf fp) = fsPathInit fp -- -- TODO: Program such as "copy what you read" is currently not expressible -- in our language. Does this matter? -data Cmd fp h = - Open (PathExpr fp) OpenMode - | Close h - | IsOpen h - | Seek h SeekMode Int64 - | Get h Word64 - | GetAt h Word64 AbsOffset - | GetBuf h ByteCount - | GetBufAt h ByteCount AbsOffset - | Put h ByteString - | PutBuf h ByteString ByteCount - | PutBufAt h ByteString ByteCount AbsOffset - | Truncate h Word64 - | GetSize h - | CreateDir (PathExpr fp) +data Cmd fp h + = Open (PathExpr fp) OpenMode + | Close h + | IsOpen h + | Seek h SeekMode Int64 + | Get h Word64 + | GetAt h Word64 AbsOffset + | GetBuf h ByteCount + | GetBufAt h ByteCount AbsOffset + | Put h ByteString + | PutBuf h ByteString ByteCount + | PutBufAt h ByteString ByteCount AbsOffset + | Truncate h Word64 + | GetSize h + | CreateDir (PathExpr fp) | CreateDirIfMissing Bool (PathExpr fp) - | ListDirectory (PathExpr fp) + | ListDirectory (PathExpr fp) | DoesDirectoryExist (PathExpr fp) - | DoesFileExist (PathExpr fp) + | DoesFileExist (PathExpr fp) | RemoveDirRecursive (PathExpr fp) - | RemoveFile (PathExpr fp) - | RenameFile (PathExpr fp) (PathExpr fp) + | RemoveFile (PathExpr fp) + | RenameFile (PathExpr fp) (PathExpr fp) deriving (Generic, Show, Functor, Foldable, Traversable) -deriving instance SOP.Generic (Cmd fp h) +deriving instance SOP.Generic (Cmd fp h) deriving instance SOP.HasDatatypeInfo (Cmd fp h) -- | Successful result -data Success fp h = - WHandle fp h - | RHandle h - | Unit () - | Path fp () - | Word64 Word64 +data Success fp h + = WHandle fp h + | RHandle h + | Unit () + | Path fp () + | Word64 Word64 | ByteString ByteString - | ByteCount ByteCount -- PutBuf, PutBufAt - | BCBS ByteCount ByteString -- GetBuf, GetBufAt - | Strings (Set String) - | Bool Bool + | ByteCount ByteCount -- PutBuf, PutBufAt + | BCBS ByteCount ByteString -- GetBuf, GetBufAt + | Strings (Set String) + | Bool Bool deriving (Eq, Show, Functor, Foldable) -- | Successful semantics -run :: forall m h. (PrimMonad m, HasCallStack) - => HasFS m h - -> Cmd FsPath (Handle h) - -> m (Success FsPath (Handle h)) +run :: + forall m h. + (PrimMonad m, HasCallStack) => + HasFS m h -> + Cmd FsPath (Handle h) -> + m (Success FsPath (Handle h)) run hasFS@HasFS{..} = go - where - go :: Cmd FsPath (Handle h) -> m (Success FsPath (Handle h)) - go (Open pe mode) = - case mode of - ReadMode -> withPE pe (\_ -> RHandle) $ \fp -> hOpen fp mode - _otherwise -> withPE pe WHandle $ \fp -> hOpen fp mode - - go (CreateDir pe) = withPE pe Path $ createDirectory - go (CreateDirIfMissing b pe) = withPE pe Path $ createDirectoryIfMissing b - go (IsOpen h ) = Bool <$> hIsOpen h - go (Close h ) = Unit <$> hClose h - go (Seek h mode sz ) = Unit <$> hSeek h mode sz - -- Note: we're not using 'hGetSome', 'hGetSomeAt' and 'hPutSome' that may - -- produce partial reads/writes, but wrappers around them that handle - -- partial reads/writes, see #502. - go (Get h n ) = ByteString <$> hGetSomeChecked hasFS h n - go (GetAt h n o ) = ByteString <$> hGetSomeAtChecked hasFS h n o - go (GetBuf h n ) = uncurry BCBS <$> hGetBufSomeChecked hasFS h n - go (GetBufAt h n o ) = uncurry BCBS <$> hGetBufSomeAtChecked hasFS h n o - go (Put h bs ) = Word64 <$> hPutSomeChecked hasFS h bs - go (PutBuf h bs n ) = ByteCount <$> hPutBufSomeChecked hasFS h bs n - go (PutBufAt h bs n o ) = ByteCount <$> hPutBufSomeAtChecked hasFS h bs n o - go (Truncate h sz ) = Unit <$> hTruncate h sz - go (GetSize h ) = Word64 <$> hGetSize h - go (ListDirectory pe ) = withPE pe (const Strings) $ listDirectory - go (DoesDirectoryExist pe ) = withPE pe (const Bool) $ doesDirectoryExist - go (DoesFileExist pe ) = withPE pe (const Bool) $ doesFileExist - go (RemoveDirRecursive pe ) = withPE pe (const Unit) $ removeDirectoryRecursive - go (RemoveFile pe ) = withPE pe (const Unit) $ removeFile - go (RenameFile pe1 pe2 ) = withPEs pe1 pe2 (\_ _ -> Unit) $ renameFile - - withPE :: PathExpr FsPath - -> (FsPath -> a -> Success FsPath (Handle h)) - -> (FsPath -> m a) - -> m (Success FsPath (Handle h)) - withPE pe r f = let fp = evalPathExpr pe in r fp <$> f fp - - withPEs :: PathExpr FsPath - -> PathExpr FsPath - -> (FsPath -> FsPath -> a -> Success FsPath (Handle h)) - -> (FsPath -> FsPath -> m a) - -> m (Success FsPath (Handle h)) - withPEs pe1 pe2 r f = - let fp1 = evalPathExpr pe1 - fp2 = evalPathExpr pe2 - in r fp1 fp2 <$> f fp1 fp2 + where + go :: Cmd FsPath (Handle h) -> m (Success FsPath (Handle h)) + go (Open pe mode) = + case mode of + ReadMode -> withPE pe (\_ -> RHandle) $ \fp -> hOpen fp mode + _otherwise -> withPE pe WHandle $ \fp -> hOpen fp mode + go (CreateDir pe) = withPE pe Path $ createDirectory + go (CreateDirIfMissing b pe) = withPE pe Path $ createDirectoryIfMissing b + go (IsOpen h) = Bool <$> hIsOpen h + go (Close h) = Unit <$> hClose h + go (Seek h mode sz) = Unit <$> hSeek h mode sz + -- Note: we're not using 'hGetSome', 'hGetSomeAt' and 'hPutSome' that may + -- produce partial reads/writes, but wrappers around them that handle + -- partial reads/writes, see #502. + go (Get h n) = ByteString <$> hGetSomeChecked hasFS h n + go (GetAt h n o) = ByteString <$> hGetSomeAtChecked hasFS h n o + go (GetBuf h n) = uncurry BCBS <$> hGetBufSomeChecked hasFS h n + go (GetBufAt h n o) = uncurry BCBS <$> hGetBufSomeAtChecked hasFS h n o + go (Put h bs) = Word64 <$> hPutSomeChecked hasFS h bs + go (PutBuf h bs n) = ByteCount <$> hPutBufSomeChecked hasFS h bs n + go (PutBufAt h bs n o) = ByteCount <$> hPutBufSomeAtChecked hasFS h bs n o + go (Truncate h sz) = Unit <$> hTruncate h sz + go (GetSize h) = Word64 <$> hGetSize h + go (ListDirectory pe) = withPE pe (const Strings) $ listDirectory + go (DoesDirectoryExist pe) = withPE pe (const Bool) $ doesDirectoryExist + go (DoesFileExist pe) = withPE pe (const Bool) $ doesFileExist + go (RemoveDirRecursive pe) = withPE pe (const Unit) $ removeDirectoryRecursive + go (RemoveFile pe) = withPE pe (const Unit) $ removeFile + go (RenameFile pe1 pe2) = withPEs pe1 pe2 (\_ _ -> Unit) $ renameFile + + withPE :: + PathExpr FsPath -> + (FsPath -> a -> Success FsPath (Handle h)) -> + (FsPath -> m a) -> + m (Success FsPath (Handle h)) + withPE pe r f = let fp = evalPathExpr pe in r fp <$> f fp + + withPEs :: + PathExpr FsPath -> + PathExpr FsPath -> + (FsPath -> FsPath -> a -> Success FsPath (Handle h)) -> + (FsPath -> FsPath -> m a) -> + m (Success FsPath (Handle h)) + withPEs pe1 pe2 r f = + let fp1 = evalPathExpr pe1 + fp2 = evalPathExpr pe2 + in r fp1 fp2 <$> f fp1 fp2 {------------------------------------------------------------------------------- Detecting partial reads/writes of the tested IO implementation @@ -286,89 +284,108 @@ run hasFS@HasFS{..} = go the real implementation are in sync. -} -hGetSomeChecked :: (Monad m, HasCallStack) - => HasFS m h -> Handle h -> Word64 -> m ByteString +hGetSomeChecked :: + (Monad m, HasCallStack) => + HasFS m h -> Handle h -> Word64 -> m ByteString hGetSomeChecked HasFS{..} h n = do - bytes <- hGetSome h n - when (fromIntegral (BS.length bytes) /= n) $ do + bytes <- hGetSome h n + when (fromIntegral (BS.length bytes) /= n) $ do + moreBytes <- hGetSome h 1 + -- If we can actually read more bytes, the last read was partial. If we + -- cannot, we really were at EOF. + unless (BS.null moreBytes) $ + error "Unsupported partial read detected, see Note [Checking for partial reads/writes]" + return bytes + +hGetSomeAtChecked :: + (Monad m, HasCallStack) => + HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString +hGetSomeAtChecked HasFS{..} h n o = do + bytes <- hGetSomeAt h n o + when (fromIntegral (BS.length bytes) /= n) $ do + moreBytes <- hGetSomeAt h 1 $ o + fromIntegral (BS.length bytes) + -- If we can actually read more bytes, the last read was partial. If we + -- cannot, we really were at EOF. + unless (BS.null moreBytes) $ + error "Unsupported partial read detected, see Note [Checking for partial reads/writes]" + return bytes + +hPutSomeChecked :: + (Monad m, HasCallStack) => + HasFS m h -> Handle h -> ByteString -> m Word64 +hPutSomeChecked HasFS{..} h bytes = do + n <- hPutSome h bytes + if fromIntegral (BS.length bytes) /= n + then error "Unsupported partial write detected, see Note [Checking for partial reads/writes]" + else return n + +hGetBufSomeChecked :: + (HasCallStack, PrimMonad m) => + HasFS m h -> + Handle h -> + ByteCount -> + m (ByteCount, ByteString) +hGetBufSomeChecked HasFS{..} h n = do + allocaMutableByteArray (fromIntegral n) $ \buf -> do + n' <- hGetBufSome h buf 0 n + bs <- fromJust <$> Mock.fromBuffer buf 0 n' + when (n /= n') $ do moreBytes <- hGetSome h 1 -- If we can actually read more bytes, the last read was partial. If we -- cannot, we really were at EOF. unless (BS.null moreBytes) $ - error "Unsupported partial read detected, see Note [Checking for partial reads/writes]" - return bytes - -hGetSomeAtChecked :: (Monad m, HasCallStack) - => HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString -hGetSomeAtChecked HasFS{..} h n o = do - bytes <- hGetSomeAt h n o - when (fromIntegral (BS.length bytes) /= n) $ do - moreBytes <- hGetSomeAt h 1 $ o + fromIntegral (BS.length bytes) + error "Unsupported partial read detected, see #502" + pure (n', bs) + +hGetBufSomeAtChecked :: + (HasCallStack, PrimMonad m) => + HasFS m h -> + Handle h -> + ByteCount -> + AbsOffset -> + m (ByteCount, ByteString) +hGetBufSomeAtChecked HasFS{..} h n o = do + allocaMutableByteArray (fromIntegral n) $ \buf -> do + n' <- hGetBufSomeAt h buf 0 n o + bs <- fromJust <$> Mock.fromBuffer buf 0 n' + when (n /= n') $ do + moreBytes <- hGetSomeAt h 1 $ o + fromIntegral n' -- If we can actually read more bytes, the last read was partial. If we -- cannot, we really were at EOF. unless (BS.null moreBytes) $ - error "Unsupported partial read detected, see Note [Checking for partial reads/writes]" - return bytes - -hPutSomeChecked :: (Monad m, HasCallStack) - => HasFS m h -> Handle h -> ByteString -> m Word64 -hPutSomeChecked HasFS{..} h bytes = do - n <- hPutSome h bytes - if fromIntegral (BS.length bytes) /= n - then error "Unsupported partial write detected, see Note [Checking for partial reads/writes]" + error "Unsupported partial read detected, see #502" + pure (n', bs) + +hPutBufSomeChecked :: + (HasCallStack, PrimMonad m) => + HasFS m h -> + Handle h -> + ByteString -> + ByteCount -> + m ByteCount +hPutBufSomeChecked HasFS{..} h bs n = + allocaMutableByteArray (min (fromIntegral n) (BS.length bs)) $ \buf -> do + void $ Mock.intoBuffer buf 0 (BS.take (fromIntegral n) bs) + n' <- hPutBufSome h buf 0 n + if n /= n' + then error "Unsupported partial write detected, see #502" else return n -hGetBufSomeChecked :: (HasCallStack, PrimMonad m) - => HasFS m h - -> Handle h -> ByteCount -> m (ByteCount, ByteString) -hGetBufSomeChecked HasFS{..} h n = do - allocaMutableByteArray (fromIntegral n) $ \buf -> do - n' <- hGetBufSome h buf 0 n - bs <- fromJust <$> Mock.fromBuffer buf 0 n' - when (n /= n') $ do - moreBytes <- hGetSome h 1 - -- If we can actually read more bytes, the last read was partial. If we - -- cannot, we really were at EOF. - unless (BS.null moreBytes) $ - error "Unsupported partial read detected, see #502" - pure (n', bs) - -hGetBufSomeAtChecked :: (HasCallStack, PrimMonad m) - => HasFS m h - -> Handle h -> ByteCount -> AbsOffset -> m (ByteCount, ByteString) -hGetBufSomeAtChecked HasFS{..} h n o = do - allocaMutableByteArray (fromIntegral n) $ \buf -> do - n' <- hGetBufSomeAt h buf 0 n o - bs <- fromJust <$> Mock.fromBuffer buf 0 n' - when (n /= n') $ do - moreBytes <- hGetSomeAt h 1 $ o + fromIntegral n' - -- If we can actually read more bytes, the last read was partial. If we - -- cannot, we really were at EOF. - unless (BS.null moreBytes) $ - error "Unsupported partial read detected, see #502" - pure (n', bs) - -hPutBufSomeChecked :: (HasCallStack, PrimMonad m) - => HasFS m h - -> Handle h -> ByteString -> ByteCount -> m ByteCount -hPutBufSomeChecked HasFS{..} h bs n = - allocaMutableByteArray (min (fromIntegral n) (BS.length bs)) $ \buf -> do - void $ Mock.intoBuffer buf 0 (BS.take (fromIntegral n) bs) - n' <- hPutBufSome h buf 0 n - if n /= n' - then error "Unsupported partial write detected, see #502" - else return n - -hPutBufSomeAtChecked :: (HasCallStack, PrimMonad m) - => HasFS m h - -> Handle h -> ByteString -> ByteCount -> AbsOffset -> m ByteCount +hPutBufSomeAtChecked :: + (HasCallStack, PrimMonad m) => + HasFS m h -> + Handle h -> + ByteString -> + ByteCount -> + AbsOffset -> + m ByteCount hPutBufSomeAtChecked HasFS{..} h bs n o = - allocaMutableByteArray (min (fromIntegral n) (BS.length bs)) $ \buf -> do - void $ Mock.intoBuffer buf 0 (BS.take (fromIntegral n) bs) - n' <- hPutBufSomeAt h buf 0 n o - if n /= n' - then error "Unsupported partial write detected, see #502" - else return n + allocaMutableByteArray (min (fromIntegral n) (BS.length bs)) $ \buf -> do + void $ Mock.intoBuffer buf 0 (BS.take (fromIntegral n) bs) + n' <- hPutBufSomeAt h buf 0 n o + if n /= n' + then error "Unsupported partial write detected, see #502" + else return n allocaMutableByteArray :: PrimMonad m => Int -> (MutableByteArray (PrimState m) -> m a) -> m a allocaMutableByteArray size action = newPinnedByteArray size >>= action @@ -426,43 +443,48 @@ sameError = sameFsError #endif -- | Responses are either successful termination or an error -newtype Resp fp h = Resp { getResp :: Either FsError (Success fp h) } +newtype Resp fp h = Resp {getResp :: Either FsError (Success fp h)} deriving (Show, Functor, Foldable) -- | The 'Eq' instance for 'Resp' uses 'sameError' instance (Eq fp, Eq h) => Eq (Resp fp h) where - Resp (Left e) == Resp (Left e') = sameError e e' + Resp (Left e) == Resp (Left e') = sameError e e' Resp (Right a) == Resp (Right a') = a == a' - _ == _ = False + _ == _ = False -runPure :: Cmd FsPath (Handle HandleMock) - -> MockFS -> (Resp FsPath (Handle HandleMock), MockFS) +runPure :: + Cmd FsPath (Handle HandleMock) -> + MockFS -> + (Resp FsPath (Handle HandleMock), MockFS) runPure cmd mockFS = - aux $ runST $ runFSSimT (run primHasMockFS cmd) mockFS - where - aux :: Either FsError (Success FsPath (Handle HandleMock), MockFS) - -> (Resp FsPath (Handle HandleMock), MockFS) - aux (Left e) = (Resp (Left e), mockFS) - aux (Right (r, mockFS')) = (Resp (Right r), mockFS') - -runIO :: HasFS IO HandleIO - -> Cmd FsPath (Handle HandleIO) -> IO (Resp FsPath (Handle HandleIO)) + aux $ runST $ runFSSimT (run primHasMockFS cmd) mockFS + where + aux :: + Either FsError (Success FsPath (Handle HandleMock), MockFS) -> + (Resp FsPath (Handle HandleMock), MockFS) + aux (Left e) = (Resp (Left e), mockFS) + aux (Right (r, mockFS')) = (Resp (Right r), mockFS') + +runIO :: + HasFS IO HandleIO -> + Cmd FsPath (Handle HandleIO) -> + IO (Resp FsPath (Handle HandleIO)) runIO hfs cmd = Resp <$> E.try (run hfs cmd) {------------------------------------------------------------------------------- Bitraversable instances -------------------------------------------------------------------------------} -TH.deriveBifunctor ''Cmd -TH.deriveBifoldable ''Cmd +TH.deriveBifunctor ''Cmd +TH.deriveBifoldable ''Cmd TH.deriveBitraversable ''Cmd -TH.deriveBifunctor ''Success -TH.deriveBifoldable ''Success +TH.deriveBifunctor ''Success +TH.deriveBifoldable ''Success TH.deriveBitraversable ''Success -TH.deriveBifunctor ''Resp -TH.deriveBifoldable ''Resp +TH.deriveBifunctor ''Resp +TH.deriveBifoldable ''Resp TH.deriveBitraversable ''Resp {------------------------------------------------------------------------------- @@ -470,10 +492,10 @@ TH.deriveBitraversable ''Resp -------------------------------------------------------------------------------} paths :: Bitraversable t => t fp h -> [fp] -paths = bifoldMap (:[]) (const []) +paths = bifoldMap (: []) (const []) handles :: Bitraversable t => t fp h -> [h] -handles = bifoldMap (const []) (:[]) +handles = bifoldMap (const []) (: []) {------------------------------------------------------------------------------- Model @@ -495,11 +517,11 @@ resolvePathExpr :: Eq1 r => KnownPaths r -> PathExpr (PathRef r) -> FsPath resolvePathExpr knownPaths = evalPathExpr . fmap (knownPaths RE.!) -- | Execution model -data Model r = Model { - mockFS :: MockFS - , knownPaths :: KnownPaths r - , knownHandles :: KnownHandles r - } +data Model r = Model + { mockFS :: MockFS + , knownPaths :: KnownPaths r + , knownHandles :: KnownHandles r + } deriving (Show, Generic) -- | Initial model @@ -507,24 +529,26 @@ initModel :: Model r initModel = Model Mock.empty RE.empty RE.empty -- | Key property of the model is that we can go from real to mock responses -toMock :: (Bifunctor t, Eq1 r) - => Model r -> t :@ r -> t FsPath (Handle HandleMock) +toMock :: + (Bifunctor t, Eq1 r) => + Model r -> t :@ r -> t FsPath (Handle HandleMock) toMock Model{..} (At r) = bimap (knownPaths RE.!) (knownHandles RE.!) r -- | Step the mock semantics -- -- We cannot step the whole Model here (see 'Event', below) -step :: Eq1 r - => Model r -> Cmd :@ r -> (Resp FsPath (Handle HandleMock), MockFS) +step :: + Eq1 r => + Model r -> Cmd :@ r -> (Resp FsPath (Handle HandleMock), MockFS) step model@Model{..} cmd = runPure (toMock model cmd) mockFS -- | Open read handles openHandles :: Model r -> [Handle HandleMock] openHandles Model{..} = - filter isOpen (RE.elems knownHandles) - where - isOpen :: Handle HandleMock -> Bool - isOpen (Handle h _) = Mock.handleIsOpen mockFS h + filter isOpen (RE.elems knownHandles) + where + isOpen :: Handle HandleMock -> Bool + isOpen (Handle h _) = Mock.handleIsOpen mockFS h {------------------------------------------------------------------------------- Wrapping in quickcheck-state-machine references @@ -534,33 +558,34 @@ openHandles Model{..} = -- -- > Cmd :@ Concrete ~ Cmd (PathRef Concrete) (HandleRef Concrete) newtype At t r = At {unAt :: (t (PathRef r) (HandleRef r))} - deriving (Generic) + deriving Generic -- | Alias for 'At' type (:@) t r = At t r -deriving instance Show1 r => Show (Cmd :@ r) +deriving instance Show1 r => Show (Cmd :@ r) deriving instance Show1 r => Show (Resp :@ r) -deriving instance Eq1 r => Eq (Resp :@ r) +deriving instance Eq1 r => Eq (Resp :@ r) instance Bifoldable t => Rank2.Foldable (At t) where foldMap = \f (At x) -> bifoldMap (app f) (app f) x - where - app :: (r x -> m) -> QSM.Reference x r -> m - app f (QSM.Reference x) = f x + where + app :: (r x -> m) -> QSM.Reference x r -> m + app f (QSM.Reference x) = f x instance Bifunctor t => Rank2.Functor (At t) where fmap = \f (At x) -> At (bimap (app f) (app f) x) - where - app :: (r x -> r' x) -> QSM.Reference x r -> QSM.Reference x r' - app f (QSM.Reference x) = QSM.Reference (f x) + where + app :: (r x -> r' x) -> QSM.Reference x r -> QSM.Reference x r' + app f (QSM.Reference x) = QSM.Reference (f x) instance Bitraversable t => Rank2.Traversable (At t) where traverse = \f (At x) -> At <$> bitraverse (app f) (app f) x - where - app :: Functor f - => (r x -> f (r' x)) -> QSM.Reference x r -> f (QSM.Reference x r') - app f (QSM.Reference x) = QSM.Reference <$> f x + where + app :: + Functor f => + (r x -> f (r' x)) -> QSM.Reference x r -> f (QSM.Reference x r') + app f (QSM.Reference x) = QSM.Reference <$> f x {------------------------------------------------------------------------------- Events @@ -568,13 +593,13 @@ instance Bitraversable t => Rank2.Traversable (At t) where -- | An event records the model before and after a command along with the -- command itself and its response -data Event r = Event { - eventBefore :: Model r - , eventCmd :: Cmd :@ r - , eventAfter :: Model r - , eventMockResp :: Resp FsPath (Handle HandleMock) - } - deriving (Show) +data Event r = Event + { eventBefore :: Model r + , eventCmd :: Cmd :@ r + , eventAfter :: Model r + , eventMockResp :: Resp FsPath (Handle HandleMock) + } + deriving Show eventMockCmd :: Eq1 r => Event r -> Cmd FsPath (Handle HandleMock) eventMockCmd Event{..} = toMock eventBefore eventCmd @@ -583,114 +608,124 @@ eventMockCmd Event{..} = toMock eventBefore eventCmd -- -- When we execute both the model and the real implementation in lockstep, -- we get two responses: this suffices to update the model. -lockstep :: forall r. (Show1 r, Ord1 r, HasCallStack) - => Model r - -> Cmd :@ r - -> Resp :@ r - -> Event r -lockstep model@Model{..} cmd (At resp) = Event { - eventBefore = model - , eventCmd = cmd - , eventAfter = Model { - mockFS = mockFS' - , knownPaths = knownPaths `RE.union` newPaths - , knownHandles = knownHandles `RE.union` newHandles - } +lockstep :: + forall r. + (Show1 r, Ord1 r, HasCallStack) => + Model r -> + Cmd :@ r -> + Resp :@ r -> + Event r +lockstep model@Model{..} cmd (At resp) = + Event + { eventBefore = model + , eventCmd = cmd + , eventAfter = + Model + { mockFS = mockFS' + , knownPaths = knownPaths `RE.union` newPaths + , knownHandles = knownHandles `RE.union` newHandles + } , eventMockResp = resp' } - where - (resp', mockFS') = step model cmd - newPaths = RE.fromList $ zip (paths resp) (paths resp') - newHandles = RE.fromList $ zip (handles resp) (handles resp') + where + (resp', mockFS') = step model cmd + newPaths = RE.fromList $ zip (paths resp) (paths resp') + newHandles = RE.fromList $ zip (handles resp) (handles resp') {------------------------------------------------------------------------------- Generator -------------------------------------------------------------------------------} generator :: Model Symbolic -> Gen (Cmd :@ Symbolic) -generator Model{..} = oneof $ concat [ - withoutHandle - , if RE.null knownHandles then [] else withHandle +generator Model{..} = + oneof $ + concat + [ withoutHandle + , if RE.null knownHandles then [] else withHandle + ] + where + withoutHandle :: [Gen (Cmd :@ Symbolic)] + withoutHandle = + [ fmap At $ genOpen + , fmap At $ CreateDir <$> genPathExpr + , fmap At $ CreateDirIfMissing <$> arbitrary <*> genPathExpr + , fmap At $ ListDirectory <$> genPathExpr + , fmap At $ DoesDirectoryExist <$> genPathExpr + , fmap At $ DoesFileExist <$> genPathExpr + , fmap At $ RemoveDirRecursive <$> genPathExpr + , fmap At $ RemoveFile <$> genPathExpr + , fmap At $ RenameFile <$> genPathExpr <*> genPathExpr ] - where - withoutHandle :: [Gen (Cmd :@ Symbolic)] - withoutHandle = [ - fmap At $ genOpen - , fmap At $ CreateDir <$> genPathExpr - , fmap At $ CreateDirIfMissing <$> arbitrary <*> genPathExpr - , fmap At $ ListDirectory <$> genPathExpr - , fmap At $ DoesDirectoryExist <$> genPathExpr - , fmap At $ DoesFileExist <$> genPathExpr - , fmap At $ RemoveDirRecursive <$> genPathExpr - , fmap At $ RemoveFile <$> genPathExpr - , fmap At $ RenameFile <$> genPathExpr <*> genPathExpr - ] - withHandle :: [Gen (Cmd :@ Symbolic)] - withHandle = [ - fmap At $ Close <$> genHandle - , fmap At $ IsOpen <$> genHandle - , fmap At $ Seek <$> genHandle <*> genSeekMode <*> genOffset - , fmap At $ Get <$> genHandle <*> (getSmall <$> arbitrary) - , fmap At $ GetAt <$> genHandle <*> (getSmall <$> arbitrary) <*> arbitrary - , fmap At $ GetBuf <$> genHandle <*> (getSmall <$> arbitrary) - , fmap At $ GetBufAt <$> genHandle <*> (getSmall <$> arbitrary) <*> arbitrary - , fmap At $ Put <$> genHandle <*> (BS.pack <$> arbitrary) - , fmap At $ PutBuf <$> genHandle <*> (BS.pack <$> arbitrary) <*> (getSmall <$> arbitrary) - , fmap At $ PutBufAt <$> genHandle <*> (BS.pack <$> arbitrary) <*> (getSmall <$> arbitrary) <*> arbitrary - , fmap At $ Truncate <$> genHandle <*> (getSmall . getNonNegative <$> arbitrary) - , fmap At $ GetSize <$> genHandle - ] - - genOpen :: Gen (Cmd (PathRef Symbolic) (HandleRef Symbolic)) - genOpen = do - path <- genPath - mode <- genMode $ elem path (RE.elems knownPaths) - return $ Open (PExpPath path) mode - - -- Wrap path in a simple path expression - -- (References are generated during shrinking only) - genPathExpr :: Gen (PathExpr fp) - genPathExpr = PExpPath <$> genPath - - -- We choose from a small list of names so that we reuse names often - -- We use the same set of files and directories so that we can test - -- things like trying to open a directory as if it were a file - genPath :: Gen FsPath - genPath = do - n <- choose (0, 3) - mkFsPath <$> replicateM n (elements ["x", "y", "z"]) - - genHandle :: Gen (HandleRef Symbolic) - genHandle = elements (RE.keys knownHandles) - - genMode :: Bool -> Gen OpenMode - genMode fileExists = frequency [ - (rf, return ReadMode) - , (wf, WriteMode <$> genAllowExisting) - , (wf, AppendMode <$> genAllowExisting) - , (wf, ReadWriteMode <$> genAllowExisting) - ] - where - -- we try to avoid 'ReadMode' when the file does not exist. - (rf, wf) = if fileExists then (10,3) else (1,3) - - genAllowExisting :: Gen AllowExisting - genAllowExisting = elements [AllowExisting, MustBeNew, MustExist] - - genSeekMode :: Gen SeekMode - genSeekMode = elements [ - AbsoluteSeek - , RelativeSeek - , SeekFromEnd - ] + withHandle :: [Gen (Cmd :@ Symbolic)] + withHandle = + [ fmap At $ Close <$> genHandle + , fmap At $ IsOpen <$> genHandle + , fmap At $ Seek <$> genHandle <*> genSeekMode <*> genOffset + , fmap At $ Get <$> genHandle <*> (getSmall <$> arbitrary) + , fmap At $ GetAt <$> genHandle <*> (getSmall <$> arbitrary) <*> arbitrary + , fmap At $ GetBuf <$> genHandle <*> (getSmall <$> arbitrary) + , fmap At $ GetBufAt <$> genHandle <*> (getSmall <$> arbitrary) <*> arbitrary + , fmap At $ Put <$> genHandle <*> (BS.pack <$> arbitrary) + , fmap At $ PutBuf <$> genHandle <*> (BS.pack <$> arbitrary) <*> (getSmall <$> arbitrary) + , fmap At $ + PutBufAt <$> genHandle <*> (BS.pack <$> arbitrary) <*> (getSmall <$> arbitrary) <*> arbitrary + , fmap At $ Truncate <$> genHandle <*> (getSmall . getNonNegative <$> arbitrary) + , fmap At $ GetSize <$> genHandle + ] - genOffset :: Gen Int64 - genOffset = oneof - [ return 0 - , choose (1, 10) - , choose (-1, -10) - ] + genOpen :: Gen (Cmd (PathRef Symbolic) (HandleRef Symbolic)) + genOpen = do + path <- genPath + mode <- genMode $ elem path (RE.elems knownPaths) + return $ Open (PExpPath path) mode + + -- Wrap path in a simple path expression + -- (References are generated during shrinking only) + genPathExpr :: Gen (PathExpr fp) + genPathExpr = PExpPath <$> genPath + + -- We choose from a small list of names so that we reuse names often + -- We use the same set of files and directories so that we can test + -- things like trying to open a directory as if it were a file + genPath :: Gen FsPath + genPath = do + n <- choose (0, 3) + mkFsPath <$> replicateM n (elements ["x", "y", "z"]) + + genHandle :: Gen (HandleRef Symbolic) + genHandle = elements (RE.keys knownHandles) + + genMode :: Bool -> Gen OpenMode + genMode fileExists = + frequency + [ (rf, return ReadMode) + , (wf, WriteMode <$> genAllowExisting) + , (wf, AppendMode <$> genAllowExisting) + , (wf, ReadWriteMode <$> genAllowExisting) + ] + where + -- we try to avoid 'ReadMode' when the file does not exist. + (rf, wf) = if fileExists then (10, 3) else (1, 3) + + genAllowExisting :: Gen AllowExisting + genAllowExisting = elements [AllowExisting, MustBeNew, MustExist] + + genSeekMode :: Gen SeekMode + genSeekMode = + elements + [ AbsoluteSeek + , RelativeSeek + , SeekFromEnd + ] + + genOffset :: Gen Int64 + genOffset = + oneof + [ return 0 + , choose (1, 10) + , choose (-1, -10) + ] instance Arbitrary AbsOffset where arbitrary = AbsOffset . getSmall <$> arbitrary @@ -702,7 +737,7 @@ instance Arbitrary AbsOffset where -- | Temp files are numbered from 1 newtype TempFile = TempFile Int - deriving (Show) + deriving Show instance Condense TempFile where -- basically GNTD condense (TempFile n) = condense n @@ -712,11 +747,12 @@ tempToExpr (TempFile n) = PExpPath (mkFsPath ['t' : show n]) tempFromPath :: FsPath -> Maybe TempFile tempFromPath fp = - case map Text.unpack (fsPathToList fp) of - ['t' : suf] -> do n <- readMaybe suf - guard (n >= 1) - return $ TempFile n - _otherwise -> Nothing + case map Text.unpack (fsPathToList fp) of + ['t' : suf] -> do + n <- readMaybe suf + guard (n >= 1) + return $ TempFile n + _otherwise -> Nothing {------------------------------------------------------------------------------- Shrinking @@ -728,90 +764,96 @@ tempFromPath fp = -- can shrink later. This is hard to avoid in greedy algorithms. shrinker :: Model Symbolic -> Cmd :@ Symbolic -> [Cmd :@ Symbolic] shrinker Model{..} (At cmd) = - case cmd of - Open pe mode -> concat [ - case tempFromPath fp of - Just n -> - map (\n' -> At $ Open (tempToExpr n') mode) - $ shrinkTempFile n - Nothing -> - let mode' = case mode of - ReadMode -> ReadWriteMode AllowExisting - _otherwise -> mode - in [At $ Open (tempToExpr (TempFile numTempFiles)) mode'] - , case mode of - ReadWriteMode ex -> [ - At $ Open pe ReadMode - , At $ Open pe (WriteMode ex) - ] - _otherwise -> - [] - , map (\pe' -> At $ Open pe' mode) $ - replaceWithRef pe (== fp) PExpRef - ] - where - fp :: FsPath - fp = resolvePathExpr knownPaths pe - - ListDirectory pe -> concat [ - map (At . ListDirectory) $ - replaceWithRef pe ((== fp) . fsPathInit) PExpParentOf - ] - where - fp :: FsPath - fp = resolvePathExpr knownPaths pe - - Get h n -> At . Get h <$> shrink n - GetAt h n o -> At <$> - [GetAt h n o' | o' <- shrink o] <> - [GetAt h n' o | n' <- shrink n] - GetBuf h n -> At <$> - [GetBuf h n' | n' <- shrink n] - GetBufAt h n o -> At <$> - [GetBufAt h n' o | n' <- shrink n] <> - [GetBufAt h n o' | o' <- shrink o] - Put h bs -> At . Put h <$> shrinkBytes bs - PutBuf h bs n -> At <$> - [PutBuf h bs' n | bs' <- BS.pack <$> shrink (BS.unpack bs)] <> - [PutBuf h bs n' | n' <- shrink n] - PutBufAt h bs n o -> At <$> - [PutBufAt h bs' n o | bs' <- BS.pack <$> shrink (BS.unpack bs)] <> - [PutBufAt h bs n' o | n' <- shrink n] <> - [PutBufAt h bs n o' | o' <- shrink o] - Truncate h n -> At . Truncate h <$> shrink n - - _otherwise -> - [] - where - -- Replace path with reference - -- - -- If we are replacing one reference with another, be careful to impose - -- an ordering so that we don't end up toggling between references. - replaceWithRef :: PathExpr (PathRef Symbolic) - -- current - -> (FsPath -> Bool) - -- evaluate candidate - -> (PathRef Symbolic -> PathExpr (PathRef Symbolic)) - -- construct replacement - -> [PathExpr (PathRef Symbolic)] - replaceWithRef pe p f = - filter (canReplace pe) $ map f $ RE.reverseLookup p knownPaths - where - canReplace :: PathExpr (PathRef Symbolic) -- current - -> PathExpr (PathRef Symbolic) -- candidate - -> Bool - canReplace (PExpRef ref) (PExpRef ref') = ref' < ref - canReplace (PExpParentOf ref) (PExpParentOf ref') = ref' < ref - canReplace _ _ = True - - shrinkTempFile :: TempFile -> [TempFile] - shrinkTempFile (TempFile n) = TempFile . getPositive <$> shrink (Positive n) - - shrinkBytes :: ByteString -> [ByteString] - shrinkBytes = map BS.pack . shrink . BS.unpack - - numTempFiles :: Int - numTempFiles = 100 + case cmd of + Open pe mode -> + concat + [ case tempFromPath fp of + Just n -> + map (\n' -> At $ Open (tempToExpr n') mode) $ + shrinkTempFile n + Nothing -> + let mode' = case mode of + ReadMode -> ReadWriteMode AllowExisting + _otherwise -> mode + in [At $ Open (tempToExpr (TempFile numTempFiles)) mode'] + , case mode of + ReadWriteMode ex -> + [ At $ Open pe ReadMode + , At $ Open pe (WriteMode ex) + ] + _otherwise -> + [] + , map (\pe' -> At $ Open pe' mode) $ + replaceWithRef pe (== fp) PExpRef + ] + where + fp :: FsPath + fp = resolvePathExpr knownPaths pe + ListDirectory pe -> + concat + [ map (At . ListDirectory) $ + replaceWithRef pe ((== fp) . fsPathInit) PExpParentOf + ] + where + fp :: FsPath + fp = resolvePathExpr knownPaths pe + Get h n -> At . Get h <$> shrink n + GetAt h n o -> + At + <$> [GetAt h n o' | o' <- shrink o] + <> [GetAt h n' o | n' <- shrink n] + GetBuf h n -> + At + <$> [GetBuf h n' | n' <- shrink n] + GetBufAt h n o -> + At + <$> [GetBufAt h n' o | n' <- shrink n] + <> [GetBufAt h n o' | o' <- shrink o] + Put h bs -> At . Put h <$> shrinkBytes bs + PutBuf h bs n -> + At + <$> [PutBuf h bs' n | bs' <- BS.pack <$> shrink (BS.unpack bs)] + <> [PutBuf h bs n' | n' <- shrink n] + PutBufAt h bs n o -> + At + <$> [PutBufAt h bs' n o | bs' <- BS.pack <$> shrink (BS.unpack bs)] + <> [PutBufAt h bs n' o | n' <- shrink n] + <> [PutBufAt h bs n o' | o' <- shrink o] + Truncate h n -> At . Truncate h <$> shrink n + _otherwise -> + [] + where + -- Replace path with reference + -- + -- If we are replacing one reference with another, be careful to impose + -- an ordering so that we don't end up toggling between references. + replaceWithRef :: + PathExpr (PathRef Symbolic) -> + -- current + (FsPath -> Bool) -> + -- evaluate candidate + (PathRef Symbolic -> PathExpr (PathRef Symbolic)) -> + -- construct replacement + [PathExpr (PathRef Symbolic)] + replaceWithRef pe p f = + filter (canReplace pe) $ map f $ RE.reverseLookup p knownPaths + where + canReplace :: + PathExpr (PathRef Symbolic) -> -- current + PathExpr (PathRef Symbolic) -> -- candidate + Bool + canReplace (PExpRef ref) (PExpRef ref') = ref' < ref + canReplace (PExpParentOf ref) (PExpParentOf ref') = ref' < ref + canReplace _ _ = True + + shrinkTempFile :: TempFile -> [TempFile] + shrinkTempFile (TempFile n) = TempFile . getPositive <$> shrink (Positive n) + + shrinkBytes :: ByteString -> [ByteString] + shrinkBytes = map BS.pack . shrink . BS.unpack + + numTempFiles :: Int + numTempFiles = 100 {------------------------------------------------------------------------------- Limitations/known bugs @@ -822,11 +864,11 @@ shrinker Model{..} (At cmd) = -- NOTE: Can assume all used handles are in known in the model. knownLimitation :: Model Symbolic -> Cmd :@ Symbolic -> QSM.Logic knownLimitation model cmd = - case getResp resp of - Left FsError{..} -> QSM.Boolean fsLimitation - _otherwise -> QSM.Bot - where - (resp, _mockFS') = step model cmd + case getResp resp of + Left FsError{..} -> QSM.Boolean fsLimitation + _otherwise -> QSM.Bot + where + (resp, _mockFS') = step model cmd {------------------------------------------------------------------------------- The final state machine @@ -836,21 +878,22 @@ knownLimitation model cmd = -- -- We do this by running the pure semantics and then generating mock -- references for any new handles. -mock :: Model Symbolic - -> Cmd :@ Symbolic - -> QSM.GenSym (Resp :@ Symbolic) +mock :: + Model Symbolic -> + Cmd :@ Symbolic -> + QSM.GenSym (Resp :@ Symbolic) mock model cmd = At <$> bitraverse (const QSM.genSym) (const QSM.genSym) resp - where - (resp, _mockFS') = step model cmd + where + (resp, _mockFS') = step model cmd precondition :: Model Symbolic -> Cmd :@ Symbolic -> QSM.Logic precondition m@Model{..} (At cmd) = - QSM.forAll (handles cmd) (`QSM.member` RE.keys knownHandles) + QSM.forAll (handles cmd) (`QSM.member` RE.keys knownHandles) QSM.:&& QSM.Boolean (Mock.numOpenHandles mockFS < maxNumOpenHandles) QSM.:&& QSM.Not (knownLimitation m (At cmd)) - where - -- Limit number of open handles to avoid exceeding OS limits - maxNumOpenHandles = 100 + where + -- Limit number of open handles to avoid exceeding OS limits + maxNumOpenHandles = 100 -- | Step the model -- @@ -858,257 +901,226 @@ precondition m@Model{..} (At cmd) = transition :: (Show1 r, Ord1 r) => Model r -> Cmd :@ r -> Resp :@ r -> Model r transition model cmd = eventAfter . lockstep model cmd -postcondition :: Model Concrete - -> Cmd :@ Concrete - -> Resp :@ Concrete - -> QSM.Logic +postcondition :: + Model Concrete -> + Cmd :@ Concrete -> + Resp :@ Concrete -> + QSM.Logic postcondition model cmd resp = - toMock (eventAfter ev) resp QSM..== eventMockResp ev + toMock (eventAfter ev) resp + QSM..== eventMockResp ev QSM..&& errorHasMountPoint (getResp $ unAt resp) - where - ev = lockstep model cmd resp + where + ev = lockstep model cmd resp - errorHasMountPoint :: Either FsError a -> QSM.Logic - errorHasMountPoint (Right _) = QSM.Top - errorHasMountPoint (Left fsError) = QSM.Boolean $ hasMountPoint fsError + errorHasMountPoint :: Either FsError a -> QSM.Logic + errorHasMountPoint (Right _) = QSM.Top + errorHasMountPoint (Left fsError) = QSM.Boolean $ hasMountPoint fsError semantics :: HasFS IO HandleIO -> Cmd :@ Concrete -> IO (Resp :@ Concrete) semantics hfs (At cmd) = - At . bimap QSM.reference QSM.reference <$> - runIO hfs (bimap QSM.concrete QSM.concrete cmd) + At . bimap QSM.reference QSM.reference + <$> runIO hfs (bimap QSM.concrete QSM.concrete cmd) -- | The state machine proper sm :: HasFS IO HandleIO -> QSM.StateMachine Model (At Cmd) IO (At Resp) -sm hfs = QSM.StateMachine { - initModel = initModel - , transition = transition - , precondition = precondition +sm hfs = + QSM.StateMachine + { initModel = initModel + , transition = transition + , precondition = precondition , postcondition = postcondition - , generator = Just . generator - , shrinker = shrinker - , semantics = semantics hfs - , mock = mock - , cleanup = QSM.noCleanup - , invariant = Nothing + , generator = Just . generator + , shrinker = shrinker + , semantics = semantics hfs + , mock = mock + , cleanup = QSM.noCleanup + , invariant = Nothing } {------------------------------------------------------------------------------- Labelling -------------------------------------------------------------------------------} -data Tag = - -- | Create directory then list its parent +data Tag + = -- | Create directory then list its parent -- -- > CreateDir [x, .., y, z] -- > ListDirectory [x, .., y] TagCreateDirThenListDir - - -- | Create a directory with its parents, then list its parents + | -- | Create a directory with its parents, then list its parents -- -- > CreateDirIfMissing True [x, .., y, z] -- > ListDirectory [x, .., y] -- -- Note that this implies all directories must have been created. - | TagCreateDirWithParentsThenListDir - - -- | Have a least N open files + TagCreateDirWithParentsThenListDir + | -- | Have a least N open files -- -- > Open .. -- > .. -- -- > Open .. -- -- (with not too many Close calls in between). - | TagAtLeastNOpenFiles Int - - -- | Write, then truncate, then write again + TagAtLeastNOpenFiles Int + | -- | Write, then truncate, then write again -- -- > Put .. -- > Truncate .. (deleting some but not all of the bytes already written) -- > Put (write some different bytes) -- -- Verifies that we correctly modify the file pointer. - | TagPutTruncatePut - - -- | Concurrent writer and reader + TagPutTruncatePut + | -- | Concurrent writer and reader -- -- > h1 <- Open fp WriteMode .. -- > h2 <- Open fp ReadMode .. -- > Put h1 .. -- > Get h2 .. - | TagConcurrentWriterReader + TagConcurrentWriterReader + | -- > Get h2 .. -- | Writing many times should append the bytes. -- -- > h1 <- Open fp WriteMode .. | > h2 <- Open fp ReadMode .. -- > Put h1 .. | -- > Put h1 .. | - - -- > Get h2 .. - | TagWriteWriteRead - - -- | Try to open a directory - -- - -- > CreateDirectoryIfMissing True fp - -- > Open hp IO.WriteMode - | TagOpenDirectory - - -- | Write to a file - -- - -- > Put h1 - | TagWrite - - -- | Seek from end of a file - -- - -- > Seek h IO.SeekFromEnd n (n<0) - | TagSeekFromEnd - - -- | Create a directory - -- - -- > CreateDirIfMissing True .. - | TagCreateDirectory - - -- | DoesFileExistOK returns True - | TagDoesFileExistOK - - -- | DoesFileExistOK returns False - | TagDoesFileExistKO - - -- | DoesDirectoryExistOK returns True - | TagDoesDirectoryExistOK - - -- | DoesDirectoryExistOK returns False - | TagDoesDirectoryExistKO - - -- | Remove a directory recursively - -- - -- > RemoveDirRecursively fe - -- > DoesFileExist fe - | TagRemoveDirectoryRecursive - - -- | Remove a file - -- - -- > RemoveFile fe - -- > DoesFileExist fe - | TagRemoveFile - - -- | Rename a file - -- - -- > _ <- Open fe1 WriteMode - -- > RenameFile fe2 fe2 - | TagRenameFile - - -- | Put truncate and Get - -- - -- > Put .. - -- > Truncate .. - -- > Get .. - | TagPutTruncateGet - - -- | Close a handle 2 times - -- - -- > h <- Open .. - -- > close h - -- > close h - | TagClosedTwice - - -- | Open an existing file with ReadMode and then with WriteMode - -- - -- > open fp ReadMode - -- > open fp Write - | TagOpenReadThenWrite - - -- | Open 2 Readers of a file. - -- - -- > open fp ReadMode - -- > open fp ReadMode - | TagOpenReadThenRead - - -- | ListDir on a non empty dirextory. - -- - -- > CreateDirIfMissing True a/b - -- > ListDirectory a - | TagCreateDirWithParentsThenListDirNotNull - - -- | Read from an AppendMode file - -- - -- > h <- Open fp AppendMode - -- > Read h .. - | TagReadInvalid - - -- | Write to a read only file - -- - -- > h <- Open fp ReadMode - -- > Put h .. - | TagWriteInvalid - - -- | Put Seek and Get - -- - -- > Put .. - -- > Seek .. - -- > Get .. - | TagPutSeekGet - - -- | Put Seek (negative) and Get - -- - -- > Put .. - -- > Seek .. (negative) - -- > Get .. - | TagPutSeekNegGet - - -- | Open with MustBeNew (O_EXCL flag), but the file already existed. - -- - -- > h <- Open fp (AppendMode _) - -- > Close h - -- > Open fp (AppendMode MustBeNew) - | TagExclusiveFail - - -- | Open a file in read mode successfully - -- - -- > h <- Open fp (WriteMode _) - -- > Close h - -- > h <- Open fp ReadMode - | TagReadModeMustExist - - -- | Open a file in read mode, but it fails because the file does not exist. - -- - -- > h <- Open fp ReadMode - | TagReadModeMustExistFail - - -- | Open a file in non-read mode with 'MustExist' successfully. - -- - -- > h <- Open fp (_ MustBeNew) - -- > Close h - -- > h <- Open fp (_ MustExist) - | TagFileMustExist - - -- | Open a file in non-read mode with 'MustExist', but it fails because the - -- files does not exist. - -- - -- > h <- Open fp (_ MustExist) - | TagFileMustExistFail - - -- | Reading returns an empty bytestring when EOF - -- - -- > h <- open fp ReadMode - -- > Get h 1 == "" - | TagReadEOF - - -- | GetAt - -- - -- > GetAt ... - | TagPread - - -- | Roundtrip for I/O with user-supplied buffers - -- - -- > PutBuf h bs c - -- > GetBuf h c (==bs) - | TagPutGetBuf - - -- | Roundtrip for I/O with user-supplied buffers - -- - -- > PutBufAt h bs c o - -- > GetBufAt h c o (==bs) - | TagPutGetBufAt + TagWriteWriteRead + | -- | Try to open a directory + -- + -- > CreateDirectoryIfMissing True fp + -- > Open hp IO.WriteMode + TagOpenDirectory + | -- | Write to a file + -- + -- > Put h1 + TagWrite + | -- | Seek from end of a file + -- + -- > Seek h IO.SeekFromEnd n (n<0) + TagSeekFromEnd + | -- | Create a directory + -- + -- > CreateDirIfMissing True .. + TagCreateDirectory + | -- | DoesFileExistOK returns True + TagDoesFileExistOK + | -- | DoesFileExistOK returns False + TagDoesFileExistKO + | -- | DoesDirectoryExistOK returns True + TagDoesDirectoryExistOK + | -- | DoesDirectoryExistOK returns False + TagDoesDirectoryExistKO + | -- | Remove a directory recursively + -- + -- > RemoveDirRecursively fe + -- > DoesFileExist fe + TagRemoveDirectoryRecursive + | -- | Remove a file + -- + -- > RemoveFile fe + -- > DoesFileExist fe + TagRemoveFile + | -- | Rename a file + -- + -- > _ <- Open fe1 WriteMode + -- > RenameFile fe2 fe2 + TagRenameFile + | -- | Put truncate and Get + -- + -- > Put .. + -- > Truncate .. + -- > Get .. + TagPutTruncateGet + | -- | Close a handle 2 times + -- + -- > h <- Open .. + -- > close h + -- > close h + TagClosedTwice + | -- | Open an existing file with ReadMode and then with WriteMode + -- + -- > open fp ReadMode + -- > open fp Write + TagOpenReadThenWrite + | -- | Open 2 Readers of a file. + -- + -- > open fp ReadMode + -- > open fp ReadMode + TagOpenReadThenRead + | -- | ListDir on a non empty dirextory. + -- + -- > CreateDirIfMissing True a/b + -- > ListDirectory a + TagCreateDirWithParentsThenListDirNotNull + | -- | Read from an AppendMode file + -- + -- > h <- Open fp AppendMode + -- > Read h .. + TagReadInvalid + | -- | Write to a read only file + -- + -- > h <- Open fp ReadMode + -- > Put h .. + TagWriteInvalid + | -- | Put Seek and Get + -- + -- > Put .. + -- > Seek .. + -- > Get .. + TagPutSeekGet + | -- | Put Seek (negative) and Get + -- + -- > Put .. + -- > Seek .. (negative) + -- > Get .. + TagPutSeekNegGet + | -- | Open with MustBeNew (O_EXCL flag), but the file already existed. + -- + -- > h <- Open fp (AppendMode _) + -- > Close h + -- > Open fp (AppendMode MustBeNew) + TagExclusiveFail + | -- | Open a file in read mode successfully + -- + -- > h <- Open fp (WriteMode _) + -- > Close h + -- > h <- Open fp ReadMode + TagReadModeMustExist + | -- | Open a file in read mode, but it fails because the file does not exist. + -- + -- > h <- Open fp ReadMode + TagReadModeMustExistFail + | -- | Open a file in non-read mode with 'MustExist' successfully. + -- + -- > h <- Open fp (_ MustBeNew) + -- > Close h + -- > h <- Open fp (_ MustExist) + TagFileMustExist + | -- | Open a file in non-read mode with 'MustExist', but it fails because the + -- files does not exist. + -- + -- > h <- Open fp (_ MustExist) + TagFileMustExistFail + | -- | Reading returns an empty bytestring when EOF + -- + -- > h <- open fp ReadMode + -- > Get h 1 == "" + TagReadEOF + | -- | GetAt + -- + -- > GetAt ... + TagPread + | -- | Roundtrip for I/O with user-supplied buffers + -- + -- > PutBuf h bs c + -- > GetBuf h c (==bs) + TagPutGetBuf + | -- | Roundtrip for I/O with user-supplied buffers + -- + -- > PutBufAt h bs c o + -- > GetBufAt h c o (==bs) + TagPutGetBufAt deriving (Show, Eq) -- | Predicate on events @@ -1117,22 +1129,24 @@ type EventPred = C.Predicate (Event Symbolic) Tag -- | Convenience combinator for creating classifiers for successful commands -- -- For convenience we pair handles with the paths they refer to -successful :: ( Event Symbolic - -> Success FsPath (Handle HandleMock) - -> Either Tag EventPred - ) - -> EventPred +successful :: + ( Event Symbolic -> + Success FsPath (Handle HandleMock) -> + Either Tag EventPred + ) -> + EventPred successful f = C.predicate $ \ev -> - case eventMockResp ev of - Resp (Left _ ) -> Right $ successful f - Resp (Right ok) -> f ev ok + case eventMockResp ev of + Resp (Left _) -> Right $ successful f + Resp (Right ok) -> f ev ok -- | Tag commands -- -- Tagging works on symbolic events, so that we can tag without doing real IO. tag :: [Event Symbolic] -> [Tag] -tag = C.classify [ - tagCreateDirThenListDir Set.empty +tag = + C.classify + [ tagCreateDirThenListDir Set.empty , tagCreateDirWithParentsThenListDir Set.empty , tagAtLeastNOpenFiles 0 , tagPutTruncatePut Map.empty Map.empty Map.empty @@ -1168,411 +1182,466 @@ tag = C.classify [ , tagPutGetBuf Set.empty , tagPutGetBufAt Set.empty ] - where - tagCreateDirThenListDir :: Set FsPath -> EventPred - tagCreateDirThenListDir created = successful $ \ev _ -> - case eventMockCmd ev of - CreateDir fe -> - Right $ tagCreateDirThenListDir (Set.insert fp created) - where - fp = evalPathExpr fe - ListDirectory fe | fp `Set.member` (Set.map fsPathInit created) -> - Left TagCreateDirThenListDir - where - fp = evalPathExpr fe - _otherwise -> - Right $ tagCreateDirThenListDir created - - tagCreateDirWithParentsThenListDir :: Set FsPath -> EventPred - tagCreateDirWithParentsThenListDir created = successful $ \ev _ -> - case eventMockCmd ev of - CreateDirIfMissing True fe | length (fsPathToList fp) > 1 -> - Right $ tagCreateDirWithParentsThenListDir (Set.insert fp created) - where - fp = evalPathExpr fe - ListDirectory fe | fp `Set.member` (Set.map fsPathInit created) -> - Left TagCreateDirWithParentsThenListDir - where - fp = evalPathExpr fe - _otherwise -> - Right $ tagCreateDirWithParentsThenListDir created - - tagCreateDirWithParentsThenListDirNotNull :: Set FsPath -> EventPred - tagCreateDirWithParentsThenListDirNotNull created = successful $ \ev suc -> - case (eventMockCmd ev, suc) of - (CreateDirIfMissing True fe, _) | length (fsPathToList fp) > 1 -> - Right $ tagCreateDirWithParentsThenListDirNotNull (Set.insert fp created) - where - fp = evalPathExpr fe - (ListDirectory fe, Strings set) | fp `Set.member` (Set.map fsPathInit created) - && not (Set.null set) -> - Left TagCreateDirWithParentsThenListDirNotNull - where - fp = evalPathExpr fe - _otherwise -> - Right $ tagCreateDirWithParentsThenListDirNotNull created - - - -- TODO: It turns out we never hit the 10 (or higher) open handles case - -- Not sure if this is a problem or not. - tagAtLeastNOpenFiles :: Int -> EventPred - tagAtLeastNOpenFiles maxNumOpen = C.Predicate { - predApply = \ev -> - let maxNumOpen' = max maxNumOpen (countOpen (eventAfter ev)) - in Right $ tagAtLeastNOpenFiles maxNumOpen' - , predFinish = case maxNumOpen of - 0 -> Nothing - 1 -> Just $ TagAtLeastNOpenFiles 1 - 2 -> Just $ TagAtLeastNOpenFiles 2 - n | n < 10 -> Just $ TagAtLeastNOpenFiles 3 - n -> Just $ TagAtLeastNOpenFiles (n `div` 10 * 10) - } - where - countOpen :: Model r -> Int - countOpen = Mock.numOpenHandles . mockFS - - tagPutTruncateGet :: Map (HandleMock, FsPath) Int - -> Set (HandleMock, FsPath) - -> EventPred - tagPutTruncateGet put truncated = successful $ \ev _ -> - case eventMockCmd ev of - Put (Handle h fp) bs | BS.length bs /= 0 -> - let - f Nothing = Just $ BS.length bs + where + tagCreateDirThenListDir :: Set FsPath -> EventPred + tagCreateDirThenListDir created = successful $ \ev _ -> + case eventMockCmd ev of + CreateDir fe -> + Right $ tagCreateDirThenListDir (Set.insert fp created) + where + fp = evalPathExpr fe + ListDirectory fe + | fp `Set.member` (Set.map fsPathInit created) -> + Left TagCreateDirThenListDir + where + fp = evalPathExpr fe + _otherwise -> + Right $ tagCreateDirThenListDir created + + tagCreateDirWithParentsThenListDir :: Set FsPath -> EventPred + tagCreateDirWithParentsThenListDir created = successful $ \ev _ -> + case eventMockCmd ev of + CreateDirIfMissing True fe + | length (fsPathToList fp) > 1 -> + Right $ tagCreateDirWithParentsThenListDir (Set.insert fp created) + where + fp = evalPathExpr fe + ListDirectory fe + | fp `Set.member` (Set.map fsPathInit created) -> + Left TagCreateDirWithParentsThenListDir + where + fp = evalPathExpr fe + _otherwise -> + Right $ tagCreateDirWithParentsThenListDir created + + tagCreateDirWithParentsThenListDirNotNull :: Set FsPath -> EventPred + tagCreateDirWithParentsThenListDirNotNull created = successful $ \ev suc -> + case (eventMockCmd ev, suc) of + (CreateDirIfMissing True fe, _) + | length (fsPathToList fp) > 1 -> + Right $ tagCreateDirWithParentsThenListDirNotNull (Set.insert fp created) + where + fp = evalPathExpr fe + (ListDirectory fe, Strings set) + | fp `Set.member` (Set.map fsPathInit created) + && not (Set.null set) -> + Left TagCreateDirWithParentsThenListDirNotNull + where + fp = evalPathExpr fe + _otherwise -> + Right $ tagCreateDirWithParentsThenListDirNotNull created + + -- TODO: It turns out we never hit the 10 (or higher) open handles case + -- Not sure if this is a problem or not. + tagAtLeastNOpenFiles :: Int -> EventPred + tagAtLeastNOpenFiles maxNumOpen = + C.Predicate + { predApply = \ev -> + let maxNumOpen' = max maxNumOpen (countOpen (eventAfter ev)) + in Right $ tagAtLeastNOpenFiles maxNumOpen' + , predFinish = case maxNumOpen of + 0 -> Nothing + 1 -> Just $ TagAtLeastNOpenFiles 1 + 2 -> Just $ TagAtLeastNOpenFiles 2 + n | n < 10 -> Just $ TagAtLeastNOpenFiles 3 + n -> Just $ TagAtLeastNOpenFiles (n `div` 10 * 10) + } + where + countOpen :: Model r -> Int + countOpen = Mock.numOpenHandles . mockFS + + tagPutTruncateGet :: + Map (HandleMock, FsPath) Int -> + Set (HandleMock, FsPath) -> + EventPred + tagPutTruncateGet put truncated = successful $ \ev _ -> + case eventMockCmd ev of + Put (Handle h fp) bs + | BS.length bs /= 0 -> + let + f Nothing = Just $ BS.length bs f (Just n) = Just $ (BS.length bs) + n put' = Map.alter f (h, fp) put - in Right $ tagPutTruncateGet put' truncated - Truncate (Handle h fp) sz | sz > 0 -> case Map.lookup (h, fp) put of - Just p | fromIntegral sz < p -> - let truncated' = Set.insert (h, fp) truncated - in Right $ tagPutTruncateGet put truncated' - _otherwise -> Right $ tagPutTruncateGet put truncated - Get (Handle h fp) n | n > 0 && (not $ Set.null $ - Set.filter (\(hRead, fp') -> fp' == fp && not (hRead == h)) truncated) -> + in + Right $ tagPutTruncateGet put' truncated + Truncate (Handle h fp) sz | sz > 0 -> case Map.lookup (h, fp) put of + Just p + | fromIntegral sz < p -> + let truncated' = Set.insert (h, fp) truncated + in Right $ tagPutTruncateGet put truncated' + _otherwise -> Right $ tagPutTruncateGet put truncated + Get (Handle h fp) n + | n > 0 + && ( not $ + Set.null $ + Set.filter (\(hRead, fp') -> fp' == fp && not (hRead == h)) truncated + ) -> Left TagPutTruncateGet - GetAt (Handle h fp) n _ | n > 0 && (not $ Set.null $ - Set.filter (\(hRead, fp') -> fp' == fp && not (hRead == h)) truncated) -> + GetAt (Handle h fp) n _ + | n > 0 + && ( not $ + Set.null $ + Set.filter (\(hRead, fp') -> fp' == fp && not (hRead == h)) truncated + ) -> Left TagPutTruncateGet - _otherwise -> Right $ tagPutTruncateGet put truncated - - tagPutTruncatePut :: Map HandleMock ByteString - -> Map HandleMock ByteString - -> Map HandleMock ByteString - -> EventPred - tagPutTruncatePut before truncated after = successful $ \ev _ -> - case eventMockCmd ev of - Put (Handle h _) bs | BS.length bs /= 0 -> - case Map.lookup h truncated of - Nothing -> -- not yet truncated - let before' = Map.alter (appTo bs) h before in - Right $ tagPutTruncatePut before' truncated after - Just deleted -> - let putAfter = Map.findWithDefault mempty h after <> bs - after' = Map.insert h putAfter after in - if deleted /= BS.take (BS.length deleted) putAfter - then Left $ TagPutTruncatePut + _otherwise -> Right $ tagPutTruncateGet put truncated + + tagPutTruncatePut :: + Map HandleMock ByteString -> + Map HandleMock ByteString -> + Map HandleMock ByteString -> + EventPred + tagPutTruncatePut before truncated after = successful $ \ev _ -> + case eventMockCmd ev of + Put (Handle h _) bs | BS.length bs /= 0 -> + case Map.lookup h truncated of + Nothing -> + -- not yet truncated + let before' = Map.alter (appTo bs) h before + in Right $ tagPutTruncatePut before' truncated after + Just deleted -> + let putAfter = Map.findWithDefault mempty h after <> bs + after' = Map.insert h putAfter after + in if deleted /= BS.take (BS.length deleted) putAfter + then Left $ TagPutTruncatePut else Right $ tagPutTruncatePut before truncated after' - Truncate (Handle h _) sz | sz > 0 -> - let putBefore = Map.findWithDefault mempty h before + Truncate (Handle h _) sz + | sz > 0 -> + let putBefore = Map.findWithDefault mempty h before (putBefore', deleted) = BS.splitAt (fromIntegral sz) putBefore - before' = Map.insert h putBefore' before - truncated' = Map.insert h deleted truncated - after' = Map.delete h after - in Right $ tagPutTruncatePut before' truncated' after' - _otherwise -> - Right $ tagPutTruncatePut before truncated after - where - appTo :: Monoid a => a -> Maybe a -> Maybe a - appTo b Nothing = Just b - appTo b (Just a) = Just (a <> b) - - tagConcurrentWriterReader :: Map HandleMock (Set HandleMock) -> EventPred - tagConcurrentWriterReader put = successful $ \ev@Event{..} _ -> - case eventMockCmd ev of - Put (Handle h fp) bs | BS.length bs > 0 -> + before' = Map.insert h putBefore' before + truncated' = Map.insert h deleted truncated + after' = Map.delete h after + in Right $ tagPutTruncatePut before' truncated' after' + _otherwise -> + Right $ tagPutTruncatePut before truncated after + where + appTo :: Monoid a => a -> Maybe a -> Maybe a + appTo b Nothing = Just b + appTo b (Just a) = Just (a <> b) + + tagConcurrentWriterReader :: Map HandleMock (Set HandleMock) -> EventPred + tagConcurrentWriterReader put = successful $ \ev@Event{..} _ -> + case eventMockCmd ev of + Put (Handle h fp) bs + | BS.length bs > 0 -> -- Remember the other handles to the same file open at this time let readHs :: Set HandleMock - readHs = Set.fromList - $ map handleRaw - $ filter (\(Handle h' fp') -> h /= h' && fp == fp') - $ openHandles eventBefore + readHs = + Set.fromList $ + map handleRaw $ + filter (\(Handle h' fp') -> h /= h' && fp == fp') $ + openHandles eventBefore put' :: Map HandleMock (Set HandleMock) put' = Map.alter (Just . maybe readHs (Set.union readHs)) h put - - in Right $ tagConcurrentWriterReader put' - Close (Handle h _) -> - Right $ tagConcurrentWriterReader (Map.delete h put) - Get (Handle h _) n | h `elem` Set.unions (Map.elems put), n > 0 -> + in Right $ tagConcurrentWriterReader put' + Close (Handle h _) -> + Right $ tagConcurrentWriterReader (Map.delete h put) + Get (Handle h _) n + | h `elem` Set.unions (Map.elems put) + , n > 0 -> Left TagConcurrentWriterReader - GetAt (Handle h _) n _ | h `elem` Set.unions (Map.elems put), n > 0 -> + GetAt (Handle h _) n _ + | h `elem` Set.unions (Map.elems put) + , n > 0 -> Left TagConcurrentWriterReader - _otherwise -> - Right $ tagConcurrentWriterReader put - - tagOpenReadThenWrite :: Set FsPath -> EventPred - tagOpenReadThenWrite readOpen = successful $ \ev _ -> - case eventMockCmd ev of - Open (PExpPath fp) ReadMode -> - Right $ tagOpenReadThenWrite $ Set.insert fp readOpen - Open (PExpPath fp) (WriteMode _) | Set.member fp readOpen -> - Left TagOpenReadThenWrite - _otherwise -> Right $ tagOpenReadThenWrite readOpen - - tagOpenReadThenRead :: Set FsPath -> EventPred - tagOpenReadThenRead readOpen = successful $ \ev _ -> - case eventMockCmd ev of - Open (PExpPath fp) ReadMode | Set.member fp readOpen -> - Left TagOpenReadThenRead - Open (PExpPath fp) ReadMode -> - Right $ tagOpenReadThenRead $ Set.insert fp readOpen - _otherwise -> Right $ tagOpenReadThenRead readOpen - - tagWriteWriteRead :: Map (HandleMock, FsPath) Int -> EventPred - tagWriteWriteRead wr = successful $ \ev _ -> - case eventMockCmd ev of - Put (Handle h fp) bs | BS.length bs > 0 -> - let f Nothing = Just 0 - f (Just x) = Just $ x + 1 - in Right $ tagWriteWriteRead $ Map.alter f (h, fp) wr - Get (Handle hRead fp) n | n > 1 -> - if not $ Map.null $ Map.filterWithKey (\(hWrite, fp') times -> fp' == fp && times > 1 && not (hWrite == hRead)) wr - then Left TagWriteWriteRead - else Right $ tagWriteWriteRead wr - GetAt (Handle hRead fp) n _ | n > 1 -> - if not $ Map.null $ Map.filterWithKey (\(hWrite, fp') times -> fp' == fp && times > 1 && not (hWrite == hRead)) wr - then Left TagWriteWriteRead - else Right $ tagWriteWriteRead wr - _otherwise -> - Right $ tagWriteWriteRead wr - - -- this never succeeds because of an fsLimitation - tagOpenDirectory :: Set FsPath -> EventPred - tagOpenDirectory created = C.predicate $ \ev -> - case (eventMockCmd ev, eventMockResp ev) of - (CreateDir fe, Resp (Right _)) -> - Right $ tagOpenDirectory (Set.insert fp created) - where - fp = evalPathExpr fe - (CreateDirIfMissing True fe, Resp (Right _)) -> - Right $ tagOpenDirectory (Set.insert fp created) - where - fp = evalPathExpr fe - (Open fe _mode, _) | Set.member (evalPathExpr fe) created -> + _otherwise -> + Right $ tagConcurrentWriterReader put + + tagOpenReadThenWrite :: Set FsPath -> EventPred + tagOpenReadThenWrite readOpen = successful $ \ev _ -> + case eventMockCmd ev of + Open (PExpPath fp) ReadMode -> + Right $ tagOpenReadThenWrite $ Set.insert fp readOpen + Open (PExpPath fp) (WriteMode _) + | Set.member fp readOpen -> + Left TagOpenReadThenWrite + _otherwise -> Right $ tagOpenReadThenWrite readOpen + + tagOpenReadThenRead :: Set FsPath -> EventPred + tagOpenReadThenRead readOpen = successful $ \ev _ -> + case eventMockCmd ev of + Open (PExpPath fp) ReadMode + | Set.member fp readOpen -> + Left TagOpenReadThenRead + Open (PExpPath fp) ReadMode -> + Right $ tagOpenReadThenRead $ Set.insert fp readOpen + _otherwise -> Right $ tagOpenReadThenRead readOpen + + tagWriteWriteRead :: Map (HandleMock, FsPath) Int -> EventPred + tagWriteWriteRead wr = successful $ \ev _ -> + case eventMockCmd ev of + Put (Handle h fp) bs + | BS.length bs > 0 -> + let f Nothing = Just 0 + f (Just x) = Just $ x + 1 + in Right $ tagWriteWriteRead $ Map.alter f (h, fp) wr + Get (Handle hRead fp) n + | n > 1 -> + if not $ + Map.null $ + Map.filterWithKey (\(hWrite, fp') times -> fp' == fp && times > 1 && not (hWrite == hRead)) wr + then Left TagWriteWriteRead + else Right $ tagWriteWriteRead wr + GetAt (Handle hRead fp) n _ + | n > 1 -> + if not $ + Map.null $ + Map.filterWithKey (\(hWrite, fp') times -> fp' == fp && times > 1 && not (hWrite == hRead)) wr + then Left TagWriteWriteRead + else Right $ tagWriteWriteRead wr + _otherwise -> + Right $ tagWriteWriteRead wr + + -- this never succeeds because of an fsLimitation + tagOpenDirectory :: Set FsPath -> EventPred + tagOpenDirectory created = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (CreateDir fe, Resp (Right _)) -> + Right $ tagOpenDirectory (Set.insert fp created) + where + fp = evalPathExpr fe + (CreateDirIfMissing True fe, Resp (Right _)) -> + Right $ tagOpenDirectory (Set.insert fp created) + where + fp = evalPathExpr fe + (Open fe _mode, _) + | Set.member (evalPathExpr fe) created -> Left TagOpenDirectory - _otherwise -> - Right $ tagOpenDirectory created - - tagWrite :: EventPred - tagWrite = successful $ \ev _ -> - case eventMockCmd ev of - Put _ bs | BS.length bs > 0 -> - Left TagWrite - _otherwise -> Right tagWrite - - tagSeekFromEnd :: EventPred - tagSeekFromEnd = successful $ \ev _ -> - case eventMockCmd ev of - Seek _ SeekFromEnd n | n < 0 -> Left TagSeekFromEnd - _otherwise -> Right tagSeekFromEnd - - tagCreateDirectory :: EventPred - tagCreateDirectory = successful $ \ev _ -> - case eventMockCmd ev of - CreateDirIfMissing True (PExpPath fp) | length (fsPathToList fp) > 1 -> - Left TagCreateDirectory - _otherwise -> - Right tagCreateDirectory - - tagDoesFileExistOK :: EventPred - tagDoesFileExistOK = successful $ \ev suc -> - case (eventMockCmd ev, suc) of - (DoesFileExist _, Bool True) -> Left TagDoesFileExistOK - _otherwise -> Right tagDoesFileExistOK - - tagDoesFileExistKO :: EventPred - tagDoesFileExistKO = successful $ \ev suc -> - case (eventMockCmd ev, suc) of - (DoesFileExist _, Bool False) -> Left TagDoesFileExistKO - _otherwise -> Right tagDoesFileExistKO - - tagDoesDirectoryExistOK :: EventPred - tagDoesDirectoryExistOK = successful $ \ev suc -> - case (eventMockCmd ev, suc) of - (DoesDirectoryExist (PExpPath fp), Bool True) | not (fp == mkFsPath ["/"]) - -> Left TagDoesDirectoryExistOK - _otherwise -> Right tagDoesDirectoryExistOK - - tagDoesDirectoryExistKO :: EventPred - tagDoesDirectoryExistKO = successful $ \ev suc -> - case (eventMockCmd ev, suc) of - (DoesDirectoryExist _, Bool False) -> Left TagDoesDirectoryExistKO - _otherwise -> Right tagDoesDirectoryExistKO - - tagRemoveDirectoryRecursive :: Set FsPath -> EventPred - tagRemoveDirectoryRecursive removed = successful $ \ev _suc -> - case eventMockCmd ev of - RemoveDirRecursive fe -> Right $ tagRemoveDirectoryRecursive $ Set.insert fp removed - where - fp = evalPathExpr fe - DoesFileExist fe -> if Set.member fp removed + _otherwise -> + Right $ tagOpenDirectory created + + tagWrite :: EventPred + tagWrite = successful $ \ev _ -> + case eventMockCmd ev of + Put _ bs + | BS.length bs > 0 -> + Left TagWrite + _otherwise -> Right tagWrite + + tagSeekFromEnd :: EventPred + tagSeekFromEnd = successful $ \ev _ -> + case eventMockCmd ev of + Seek _ SeekFromEnd n | n < 0 -> Left TagSeekFromEnd + _otherwise -> Right tagSeekFromEnd + + tagCreateDirectory :: EventPred + tagCreateDirectory = successful $ \ev _ -> + case eventMockCmd ev of + CreateDirIfMissing True (PExpPath fp) + | length (fsPathToList fp) > 1 -> + Left TagCreateDirectory + _otherwise -> + Right tagCreateDirectory + + tagDoesFileExistOK :: EventPred + tagDoesFileExistOK = successful $ \ev suc -> + case (eventMockCmd ev, suc) of + (DoesFileExist _, Bool True) -> Left TagDoesFileExistOK + _otherwise -> Right tagDoesFileExistOK + + tagDoesFileExistKO :: EventPred + tagDoesFileExistKO = successful $ \ev suc -> + case (eventMockCmd ev, suc) of + (DoesFileExist _, Bool False) -> Left TagDoesFileExistKO + _otherwise -> Right tagDoesFileExistKO + + tagDoesDirectoryExistOK :: EventPred + tagDoesDirectoryExistOK = successful $ \ev suc -> + case (eventMockCmd ev, suc) of + (DoesDirectoryExist (PExpPath fp), Bool True) + | not (fp == mkFsPath ["/"]) -> + Left TagDoesDirectoryExistOK + _otherwise -> Right tagDoesDirectoryExistOK + + tagDoesDirectoryExistKO :: EventPred + tagDoesDirectoryExistKO = successful $ \ev suc -> + case (eventMockCmd ev, suc) of + (DoesDirectoryExist _, Bool False) -> Left TagDoesDirectoryExistKO + _otherwise -> Right tagDoesDirectoryExistKO + + tagRemoveDirectoryRecursive :: Set FsPath -> EventPred + tagRemoveDirectoryRecursive removed = successful $ \ev _suc -> + case eventMockCmd ev of + RemoveDirRecursive fe -> Right $ tagRemoveDirectoryRecursive $ Set.insert fp removed + where + fp = evalPathExpr fe + DoesFileExist fe -> + if Set.member fp removed then Left TagRemoveDirectoryRecursive else Right $ tagRemoveDirectoryRecursive removed - where - fp = evalPathExpr fe - _otherwise -> Right $ tagRemoveDirectoryRecursive removed - - tagRemoveFile :: Set FsPath -> EventPred - tagRemoveFile removed = successful $ \ev _suc -> - case eventMockCmd ev of - RemoveFile fe -> Right $ tagRemoveFile $ Set.insert fp removed - where - fp = evalPathExpr fe - DoesFileExist fe -> if Set.member fp removed + where + fp = evalPathExpr fe + _otherwise -> Right $ tagRemoveDirectoryRecursive removed + + tagRemoveFile :: Set FsPath -> EventPred + tagRemoveFile removed = successful $ \ev _suc -> + case eventMockCmd ev of + RemoveFile fe -> Right $ tagRemoveFile $ Set.insert fp removed + where + fp = evalPathExpr fe + DoesFileExist fe -> + if Set.member fp removed then Left TagRemoveFile else Right $ tagRemoveFile removed - where - fp = evalPathExpr fe - _otherwise -> Right $ tagRemoveFile removed - - tagRenameFile :: EventPred - tagRenameFile = successful $ \ev _suc -> - case eventMockCmd ev of - RenameFile {} -> Left TagRenameFile - _otherwise -> Right tagRenameFile - - tagClosedTwice :: Set HandleMock -> EventPred - tagClosedTwice closed = successful $ \ev _suc -> - case eventMockCmd ev of - Close (Handle h _) | Set.member h closed -> Left TagClosedTwice - Close (Handle h _) -> Right $ tagClosedTwice $ Set.insert h closed - _otherwise -> Right $ tagClosedTwice closed - - -- this never succeeds because of an fsLimitation - tagReadInvalid :: Set HandleMock -> EventPred - tagReadInvalid openAppend = C.predicate $ \ev -> - case (eventMockCmd ev, eventMockResp ev) of - (Open _ (AppendMode _), Resp (Right (WHandle _ (Handle h _)))) -> - Right $ tagReadInvalid $ Set.insert h openAppend - (Close (Handle h _), Resp (Right _)) -> - Right $ tagReadInvalid $ Set.delete h openAppend - (Get (Handle h _) _, Resp (Left _)) | Set.member h openAppend -> - Left TagReadInvalid - (GetAt (Handle h _) _ _, Resp (Left _)) | Set.member h openAppend -> - Left TagReadInvalid - _otherwise -> Right $ tagReadInvalid openAppend - - tagWriteInvalid :: Set HandleMock -> EventPred - tagWriteInvalid openRead = C.predicate $ \ev -> - case (eventMockCmd ev, eventMockResp ev) of - (Open _ ReadMode, Resp (Right (RHandle (Handle h _)))) -> - Right $ tagWriteInvalid $ Set.insert h openRead - (Close (Handle h _), Resp (Right _)) -> - Right $ tagWriteInvalid $ Set.delete h openRead - (Put (Handle h _) _, _) | Set.member h openRead -> - Left TagWriteInvalid - _otherwise -> Right $ tagWriteInvalid openRead - - tagPutSeekGet :: Set HandleMock -> Set HandleMock -> EventPred - tagPutSeekGet put seek = successful $ \ev _suc -> - case eventMockCmd ev of - Put (Handle h _) bs | BS.length bs > 0 -> - Right $ tagPutSeekGet (Set.insert h put) seek - Seek (Handle h _) RelativeSeek n | n > 0 && Set.member h put -> - Right $ tagPutSeekGet put (Set.insert h seek) - Get (Handle h _) n | n > 0 && Set.member h seek -> - Left TagPutSeekGet - GetAt (Handle h _) n _ | n > 0 && Set.member h seek -> - Left TagPutSeekGet - _otherwise -> Right $ tagPutSeekGet put seek - - tagPutSeekNegGet :: Set HandleMock -> Set HandleMock -> EventPred - tagPutSeekNegGet put seek = successful $ \ev _suc -> - case eventMockCmd ev of - Put (Handle h _) bs | BS.length bs > 0 -> - Right $ tagPutSeekNegGet (Set.insert h put) seek - Seek (Handle h _) RelativeSeek n | n < 0 && Set.member h put -> - Right $ tagPutSeekNegGet put (Set.insert h seek) - Get (Handle h _) n | n > 0 && Set.member h seek -> - Left TagPutSeekNegGet - GetAt (Handle h _) n _ | n > 0 && Set.member h seek -> - Left TagPutSeekNegGet - _otherwise -> Right $ tagPutSeekNegGet put seek - - tagExclusiveFail :: EventPred - tagExclusiveFail = C.predicate $ \ev -> - case (eventMockCmd ev, eventMockResp ev) of - (Open _ mode, Resp (Left fsError)) - | MustBeNew <- allowExisting mode - , fsErrorType fsError == FsResourceAlreadyExist -> + where + fp = evalPathExpr fe + _otherwise -> Right $ tagRemoveFile removed + + tagRenameFile :: EventPred + tagRenameFile = successful $ \ev _suc -> + case eventMockCmd ev of + RenameFile{} -> Left TagRenameFile + _otherwise -> Right tagRenameFile + + tagClosedTwice :: Set HandleMock -> EventPred + tagClosedTwice closed = successful $ \ev _suc -> + case eventMockCmd ev of + Close (Handle h _) | Set.member h closed -> Left TagClosedTwice + Close (Handle h _) -> Right $ tagClosedTwice $ Set.insert h closed + _otherwise -> Right $ tagClosedTwice closed + + -- this never succeeds because of an fsLimitation + tagReadInvalid :: Set HandleMock -> EventPred + tagReadInvalid openAppend = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ (AppendMode _), Resp (Right (WHandle _ (Handle h _)))) -> + Right $ tagReadInvalid $ Set.insert h openAppend + (Close (Handle h _), Resp (Right _)) -> + Right $ tagReadInvalid $ Set.delete h openAppend + (Get (Handle h _) _, Resp (Left _)) + | Set.member h openAppend -> + Left TagReadInvalid + (GetAt (Handle h _) _ _, Resp (Left _)) + | Set.member h openAppend -> + Left TagReadInvalid + _otherwise -> Right $ tagReadInvalid openAppend + + tagWriteInvalid :: Set HandleMock -> EventPred + tagWriteInvalid openRead = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ ReadMode, Resp (Right (RHandle (Handle h _)))) -> + Right $ tagWriteInvalid $ Set.insert h openRead + (Close (Handle h _), Resp (Right _)) -> + Right $ tagWriteInvalid $ Set.delete h openRead + (Put (Handle h _) _, _) + | Set.member h openRead -> + Left TagWriteInvalid + _otherwise -> Right $ tagWriteInvalid openRead + + tagPutSeekGet :: Set HandleMock -> Set HandleMock -> EventPred + tagPutSeekGet put seek = successful $ \ev _suc -> + case eventMockCmd ev of + Put (Handle h _) bs + | BS.length bs > 0 -> + Right $ tagPutSeekGet (Set.insert h put) seek + Seek (Handle h _) RelativeSeek n + | n > 0 && Set.member h put -> + Right $ tagPutSeekGet put (Set.insert h seek) + Get (Handle h _) n + | n > 0 && Set.member h seek -> + Left TagPutSeekGet + GetAt (Handle h _) n _ + | n > 0 && Set.member h seek -> + Left TagPutSeekGet + _otherwise -> Right $ tagPutSeekGet put seek + + tagPutSeekNegGet :: Set HandleMock -> Set HandleMock -> EventPred + tagPutSeekNegGet put seek = successful $ \ev _suc -> + case eventMockCmd ev of + Put (Handle h _) bs + | BS.length bs > 0 -> + Right $ tagPutSeekNegGet (Set.insert h put) seek + Seek (Handle h _) RelativeSeek n + | n < 0 && Set.member h put -> + Right $ tagPutSeekNegGet put (Set.insert h seek) + Get (Handle h _) n + | n > 0 && Set.member h seek -> + Left TagPutSeekNegGet + GetAt (Handle h _) n _ + | n > 0 && Set.member h seek -> + Left TagPutSeekNegGet + _otherwise -> Right $ tagPutSeekNegGet put seek + + tagExclusiveFail :: EventPred + tagExclusiveFail = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ mode, Resp (Left fsError)) + | MustBeNew <- allowExisting mode + , fsErrorType fsError == FsResourceAlreadyExist -> Left TagExclusiveFail - _otherwise -> Right tagExclusiveFail - - tagReadModeMustExist :: EventPred - tagReadModeMustExist = C.predicate $ \ev -> - case (eventMockCmd ev, eventMockResp ev) of - (Open _ ReadMode, Resp (Right (RHandle _))) -> Left TagReadModeMustExist - _otherwise -> Right tagReadModeMustExist - - tagReadModeMustExistFail :: EventPred - tagReadModeMustExistFail = C.predicate $ \ev -> - case (eventMockCmd ev, eventMockResp ev) of - (Open _ ReadMode, Resp (Left fsError)) - | fsErrorType fsError == FsResourceDoesNotExist -> + _otherwise -> Right tagExclusiveFail + + tagReadModeMustExist :: EventPred + tagReadModeMustExist = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ ReadMode, Resp (Right (RHandle _))) -> Left TagReadModeMustExist + _otherwise -> Right tagReadModeMustExist + + tagReadModeMustExistFail :: EventPred + tagReadModeMustExistFail = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ ReadMode, Resp (Left fsError)) + | fsErrorType fsError == FsResourceDoesNotExist -> Left TagReadModeMustExistFail - _otherwise -> Right tagReadModeMustExistFail - - tagFileMustExist :: EventPred - tagFileMustExist = C.predicate $ \ev -> - case (eventMockCmd ev, eventMockResp ev) of - (Open _ mode, Resp (Right (WHandle _ _))) - | MustExist <- allowExisting mode - , mode /= ReadMode - -> Left TagFileMustExist - _otherwise -> Right tagFileMustExist - - tagFileMustExistFail :: EventPred - tagFileMustExistFail = C.predicate $ \ev -> - case (eventMockCmd ev, eventMockResp ev) of - (Open _ mode, Resp (Left fsError)) - | MustExist <- allowExisting mode - , mode /= ReadMode - , fsErrorType fsError == FsResourceDoesNotExist -> + _otherwise -> Right tagReadModeMustExistFail + + tagFileMustExist :: EventPred + tagFileMustExist = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ mode, Resp (Right (WHandle _ _))) + | MustExist <- allowExisting mode + , mode /= ReadMode -> + Left TagFileMustExist + _otherwise -> Right tagFileMustExist + + tagFileMustExistFail :: EventPred + tagFileMustExistFail = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ mode, Resp (Left fsError)) + | MustExist <- allowExisting mode + , mode /= ReadMode + , fsErrorType fsError == FsResourceDoesNotExist -> Left TagFileMustExistFail - _otherwise -> Right tagFileMustExistFail - - tagReadEOF :: EventPred - tagReadEOF = successful $ \ev suc -> - case (eventMockCmd ev, suc) of - (Get _ n, ByteString bl) - | n > 0, BS.null bl -> Left TagReadEOF - _otherwise -> Right tagReadEOF - - tagPread :: EventPred - tagPread = successful $ \ev _ -> - case eventMockCmd ev of - GetAt{} -> Left TagPread - _otherwise -> Right tagPread - - tagPutGetBufAt :: Set HandleMock -> EventPred - tagPutGetBufAt put = successful $ \ev _ -> - case eventMockCmd ev of - PutBufAt (Handle h _) bs c _ | BS.length bs > 0 && c > 0 -> - Right (tagPutGetBufAt (Set.insert h put)) - GetBufAt _ c _ | c > 0 -> - Left TagPutGetBufAt - _otherwise -> - Right (tagPutGetBufAt put) - - tagPutGetBuf :: Set HandleMock -> EventPred - tagPutGetBuf put = successful $ \ev _ -> - case eventMockCmd ev of - PutBuf (Handle h _) bs c | BS.length bs > 0 && c > 0 -> - Right (tagPutGetBuf (Set.insert h put)) - GetBuf _ c | c > 0 -> - Left TagPutGetBuf - _otherwise -> - Right (tagPutGetBuf put) + _otherwise -> Right tagFileMustExistFail + + tagReadEOF :: EventPred + tagReadEOF = successful $ \ev suc -> + case (eventMockCmd ev, suc) of + (Get _ n, ByteString bl) + | n > 0, BS.null bl -> Left TagReadEOF + _otherwise -> Right tagReadEOF + + tagPread :: EventPred + tagPread = successful $ \ev _ -> + case eventMockCmd ev of + GetAt{} -> Left TagPread + _otherwise -> Right tagPread + + tagPutGetBufAt :: Set HandleMock -> EventPred + tagPutGetBufAt put = successful $ \ev _ -> + case eventMockCmd ev of + PutBufAt (Handle h _) bs c _ + | BS.length bs > 0 && c > 0 -> + Right (tagPutGetBufAt (Set.insert h put)) + GetBufAt _ c _ + | c > 0 -> + Left TagPutGetBufAt + _otherwise -> + Right (tagPutGetBufAt put) + + tagPutGetBuf :: Set HandleMock -> EventPred + tagPutGetBuf put = successful $ \ev _ -> + case eventMockCmd ev of + PutBuf (Handle h _) bs c + | BS.length bs > 0 && c > 0 -> + Right (tagPutGetBuf (Set.insert h put)) + GetBuf _ c + | c > 0 -> + Left TagPutGetBuf + _otherwise -> + Right (tagPutGetBuf put) -- | Step the model using a 'QSM.Command' (i.e., a command associated with -- an explicit set of variables) @@ -1582,10 +1651,10 @@ execCmd model (QSM.Command cmd resp _vars) = lockstep model cmd resp -- | 'execCmds' is just the repeated form of 'execCmd' execCmds :: QSM.Commands (At Cmd) (At Resp) -> [Event Symbolic] execCmds = \(QSM.Commands cs) -> go initModel cs - where - go :: Model Symbolic -> [QSM.Command (At Cmd) (At Resp)] -> [Event Symbolic] - go _ [] = [] - go m (c : cs) = let ev = execCmd m c in ev : go (eventAfter ev) cs + where + go :: Model Symbolic -> [QSM.Command (At Cmd) (At Resp)] -> [Event Symbolic] + go _ [] = [] + go m (c : cs) = let ev = execCmd m c in ev : go (eventAfter ev) cs {------------------------------------------------------------------------------- Required instances @@ -1593,31 +1662,31 @@ execCmds = \(QSM.Commands cs) -> go initModel cs The 'ToExpr' constraints come from "Data.TreeDiff". -------------------------------------------------------------------------------} -constrInfo :: SOP.HasDatatypeInfo a - => proxy a - -> SOP.NP SOP.ConstructorInfo (SOP.Code a) +constrInfo :: + SOP.HasDatatypeInfo a => + proxy a -> + SOP.NP SOP.ConstructorInfo (SOP.Code a) constrInfo = SOP.constructorInfo . SOP.datatypeInfo constrName :: forall a. SOP.HasDatatypeInfo a => a -> String constrName a = - SOP.hcollapse $ SOP.hliftA2 go (constrInfo p) (SOP.unSOP (SOP.from a)) - where - go :: SOP.ConstructorInfo b -> SOP.NP SOP.I b -> SOP.K String b - go nfo _ = SOP.K $ SOP.constructorName nfo + SOP.hcollapse $ SOP.hliftA2 go (constrInfo p) (SOP.unSOP (SOP.from a)) + where + go :: SOP.ConstructorInfo b -> SOP.NP SOP.I b -> SOP.K String b + go nfo _ = SOP.K $ SOP.constructorName nfo - p = Proxy @a + p = Proxy @a constrNames :: SOP.HasDatatypeInfo a => proxy a -> [String] constrNames p = - SOP.hcollapse $ SOP.hmap go (constrInfo p) - where - go :: SOP.ConstructorInfo a -> SOP.K String a - go nfo = SOP.K $ SOP.constructorName nfo - + SOP.hcollapse $ SOP.hmap go (constrInfo p) + where + go :: SOP.ConstructorInfo a -> SOP.K String a + go nfo = SOP.K $ SOP.constructorName nfo instance QSM.CommandNames (At Cmd) where - cmdName (At cmd) = constrName cmd - cmdNames _ = constrNames (Proxy @(Cmd () ())) + cmdName (At cmd) = constrName cmd + cmdNames _ = constrNames (Proxy @(Cmd () ())) deriving instance ToExpr a => ToExpr (FsTree a) deriving instance ToExpr fp => ToExpr (PathExpr fp) @@ -1642,71 +1711,82 @@ deriving instance ToExpr (Model Concrete) -- | Show minimal examples for each of the generated tags -- -- TODO: The examples listed are not always minimal. I'm not entirely sure why. -showLabelledExamples' :: Maybe Int - -- ^ Seed - -> Int - -- ^ Number of tests to run to find examples - -> (Tag -> Bool) - -- ^ Tag filter (can be @const True@) - -> IO () +showLabelledExamples' :: + -- | Seed + Maybe Int -> + -- | Number of tests to run to find examples + Int -> + -- | Tag filter (can be @const True@) + (Tag -> Bool) -> + IO () showLabelledExamples' mReplay numTests focus = do - replaySeed <- case mReplay of - Nothing -> getStdRandom (randomR (1,999999)) - Just seed -> return seed - - labelledExamplesWith (stdArgs { replay = Just (mkQCGen replaySeed, 0) - , maxSuccess = numTests - }) $ - forAllShrinkShow (QSM.generateCommands sm' Nothing) - (QSM.shrinkCommands sm') - pp $ \cmds -> - collects (filter focus . tag . execCmds $ cmds) $ - property True - - putStrLn $ "Used replaySeed " ++ show replaySeed - where - sm' = sm unusedHasFS - pp = \x -> ppShow x ++ "\n" ++ condense x - - collects :: Show a => [a] -> Property -> Property - collects = repeatedly collect - where - repeatedly :: (a -> b -> b) -> ([a] -> b -> b) - repeatedly = flip . foldl' . flip + replaySeed <- case mReplay of + Nothing -> getStdRandom (randomR (1, 999999)) + Just seed -> return seed + + labelledExamplesWith + ( stdArgs + { replay = Just (mkQCGen replaySeed, 0) + , maxSuccess = numTests + } + ) + $ forAllShrinkShow + (QSM.generateCommands sm' Nothing) + (QSM.shrinkCommands sm') + pp + $ \cmds -> + collects (filter focus . tag . execCmds $ cmds) $ + property True + + putStrLn $ "Used replaySeed " ++ show replaySeed + where + sm' = sm unusedHasFS + pp = \x -> ppShow x ++ "\n" ++ condense x + + collects :: Show a => [a] -> Property -> Property + collects = repeatedly collect + where + repeatedly :: (a -> b -> b) -> ([a] -> b -> b) + repeatedly = flip . foldl' . flip showLabelledExamples :: IO () showLabelledExamples = showLabelledExamples' Nothing 1000 (const True) prop_sequential :: Property -prop_sequential = withMaxSuccess 1000 $ - QSM.forAllCommands (sm unusedHasFS) Nothing $ runCmds +prop_sequential = + withMaxSuccess 1000 $ + QSM.forAllCommands (sm unusedHasFS) Nothing $ + runCmds runCmds :: QSM.Commands (At Cmd) (At Resp) -> Property runCmds cmds = QC.monadicIO $ do - (tstTmpDir, hist, res) <- QC.run $ - withSystemTempDirectory "StateMachine" $ \tstTmpDir -> do - let mount = MountPoint tstTmpDir - hfs = ioHasFS mount - sm' = sm hfs + (tstTmpDir, hist, res) <- QC.run $ + withSystemTempDirectory "StateMachine" $ \tstTmpDir -> do + let mount = MountPoint tstTmpDir + hfs = ioHasFS mount + sm' = sm hfs - (hist, model, res) <- QSM.runCommands' sm' cmds + (hist, model, res) <- QSM.runCommands' sm' cmds - -- Close all open handles - forM_ (RE.keys (knownHandles model)) $ hClose hfs . QSM.concrete + -- Close all open handles + forM_ (RE.keys (knownHandles model)) $ hClose hfs . QSM.concrete - return (tstTmpDir, hist, res) + return (tstTmpDir, hist, res) - QSM.prettyCommands (sm unusedHasFS) hist - $ QSM.checkCommandNames cmds - $ tabulate "Tags" (map show $ tag (execCmds cmds)) - $ counterexample ("Mount point: " ++ tstTmpDir) - $ res === QSM.Ok + QSM.prettyCommands (sm unusedHasFS) hist $ + QSM.checkCommandNames cmds $ + tabulate "Tags" (map show $ tag (execCmds cmds)) $ + counterexample ("Mount point: " ++ tstTmpDir) $ + res === QSM.Ok tests :: TestTree -tests = testGroup "Test.System.FS.StateMachine" [ - testProperty "q-s-m" $ prop_sequential - , localOption (QuickCheckTests 1) - $ testProperty "regression_removeFileOnDir" $ runCmds regression_removeFileOnDir +tests = + testGroup + "Test.System.FS.StateMachine" + [ testProperty "q-s-m" $ prop_sequential + , localOption (QuickCheckTests 1) $ + testProperty "regression_removeFileOnDir" $ + runCmds regression_removeFileOnDir ] -- | Unused HasFS @@ -1726,28 +1806,53 @@ unusedHasFS = error "HasFS not used during command generation" -- model-SUT discrepancy to occur without making the tests fail. We might revist -- this /temporary/ fix in the future, see fs-sim#45. regression_removeFileOnDir :: QSM.Commands (At Cmd) (At Resp) -regression_removeFileOnDir = QSM.Commands {unCommands = [ - QSM.Command - (At {unAt = - CreateDirIfMissing - True - (PExpPath (mkFsPath ["x"]))}) - (At {unAt = Resp {getResp = - Right (Path (QSM.Reference (QSM.Symbolic (QSM.Var 0))) ())}}) - [QSM.Var 0] - , QSM.Command - (At {unAt = - RemoveFile - (PExpPath (mkFsPath ["x"]))}) - (At {unAt = Resp {getResp = - Left (FsError { - fsErrorType = FsResourceInappropriateType - , fsErrorPath = FsErrorPath Nothing (mkFsPath ["x"]) - , fsErrorString = "expected file" - , fsErrorNo = Nothing - , fsErrorStack = prettyCallStack, fsLimitation = False})}}) - [] - ]} +regression_removeFileOnDir = + QSM.Commands + { unCommands = + [ QSM.Command + ( At + { unAt = + CreateDirIfMissing + True + (PExpPath (mkFsPath ["x"])) + } + ) + ( At + { unAt = + Resp + { getResp = + Right (Path (QSM.Reference (QSM.Symbolic (QSM.Var 0))) ()) + } + } + ) + [QSM.Var 0] + , QSM.Command + ( At + { unAt = + RemoveFile + (PExpPath (mkFsPath ["x"])) + } + ) + ( At + { unAt = + Resp + { getResp = + Left + ( FsError + { fsErrorType = FsResourceInappropriateType + , fsErrorPath = FsErrorPath Nothing (mkFsPath ["x"]) + , fsErrorString = "expected file" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + ) + } + } + ) + [] + ] + } {------------------------------------------------------------------------------- Debugging @@ -1756,57 +1861,61 @@ regression_removeFileOnDir = QSM.Commands {unCommands = [ -- | Debugging: show @n@ levels of shrink steps (with some required tags) -- -- This can be useful when debugging the shrinker -_showTaggedShrinks :: ([Tag] -> Bool) -- ^ Required tags - -> Int -- ^ Number of shrink steps - -> QSM.Commands (At Cmd) (At Resp) - -> IO () +_showTaggedShrinks :: + -- | Required tags + ([Tag] -> Bool) -> + -- | Number of shrink steps + Int -> + QSM.Commands (At Cmd) (At Resp) -> + IO () _showTaggedShrinks hasRequiredTags numLevels = go 0 - where - go :: Int -> QSM.Commands (At Cmd) (At Resp) -> IO () - go n _ | n == numLevels = return () - go n cmds = do - if hasRequiredTags tags then do + where + go :: Int -> QSM.Commands (At Cmd) (At Resp) -> IO () + go n _ | n == numLevels = return () + go n cmds = do + if hasRequiredTags tags + then do putStrLn $ replicate n '\t' ++ condense (cmds, tags) forM_ shrinks $ go (n + 1) else return () - where - tags = tag $ execCmds cmds - shrinks = QSM.shrinkCommands (sm unusedHasFS) cmds + where + tags = tag $ execCmds cmds + shrinks = QSM.shrinkCommands (sm unusedHasFS) cmds {------------------------------------------------------------------------------- Pretty-printing -------------------------------------------------------------------------------} instance Condense fp => Condense (PathExpr fp) where - condense (PExpPath fp) = condense fp - condense (PExpRef fp) = condense fp + condense (PExpPath fp) = condense fp + condense (PExpRef fp) = condense fp condense (PExpParentOf fp) = condense fp ++ "/.." instance (Condense fp, Condense h) => Condense (Cmd fp h) where condense = L.intercalate " " . go - where - go (Open fp mode) = ["open", condense fp, condense mode] - go (Close h) = ["close", condense h] - go (IsOpen h) = ["isOpen", condense h] - go (Seek h mode o) = ["seek", condense h, condense mode, condense o] - go (Get h n) = ["get", condense h, condense n] - go (GetAt h n o) = ["getAt", condense h, condense n, condense o] - go (GetBuf h n) = ["getBuf", condense h, condense n] - go (GetBufAt h n o) = ["getBufAt", condense h, condense n, condense o] - go (Put h bs) = ["put", condense h, condense bs] - go (PutBuf h bs n) = ["putBuf", condense h, condense bs, condense n] - go (PutBufAt h bs n o) = ["putBufAt", condense h, condense bs, condense n, condense o] - go (Truncate h sz) = ["truncate", condense h, condense sz] - go (GetSize h) = ["getSize", condense h] - go (CreateDir fp) = ["createDir", condense fp] - go (CreateDirIfMissing p fp) = ["createDirIfMissing", condense p, condense fp] - go (ListDirectory fp) = ["listDirectory", condense fp] - go (DoesDirectoryExist fp) = ["doesDirectoryExist", condense fp] - go (DoesFileExist fp) = ["doesFileExist", condense fp] - go (RemoveDirRecursive fp) = ["removeDirectoryRecursive", condense fp] - go (RemoveFile fp) = ["removeFile", condense fp] - go (RenameFile fp1 fp2) = ["renameFile", condense fp1, condense fp2] + where + go (Open fp mode) = ["open", condense fp, condense mode] + go (Close h) = ["close", condense h] + go (IsOpen h) = ["isOpen", condense h] + go (Seek h mode o) = ["seek", condense h, condense mode, condense o] + go (Get h n) = ["get", condense h, condense n] + go (GetAt h n o) = ["getAt", condense h, condense n, condense o] + go (GetBuf h n) = ["getBuf", condense h, condense n] + go (GetBufAt h n o) = ["getBufAt", condense h, condense n, condense o] + go (Put h bs) = ["put", condense h, condense bs] + go (PutBuf h bs n) = ["putBuf", condense h, condense bs, condense n] + go (PutBufAt h bs n o) = ["putBufAt", condense h, condense bs, condense n, condense o] + go (Truncate h sz) = ["truncate", condense h, condense sz] + go (GetSize h) = ["getSize", condense h] + go (CreateDir fp) = ["createDir", condense fp] + go (CreateDirIfMissing p fp) = ["createDirIfMissing", condense p, condense fp] + go (ListDirectory fp) = ["listDirectory", condense fp] + go (DoesDirectoryExist fp) = ["doesDirectoryExist", condense fp] + go (DoesFileExist fp) = ["doesFileExist", condense fp] + go (RemoveDirRecursive fp) = ["removeDirectoryRecursive", condense fp] + go (RemoveFile fp) = ["removeFile", condense fp] + go (RenameFile fp1 fp2) = ["renameFile", condense fp1, condense fp2] instance Condense1 r => Condense (Cmd :@ r) where condense (At cmd) = condense cmd @@ -1838,14 +1947,14 @@ instance (Condense1 r, Condense a) => Condense (QSM.Reference a r) where instance Condense (cmd Symbolic) => Condense (QSM.Command cmd resp) where condense = \(QSM.Command cmd _resp vars) -> - L.intercalate " " $ go cmd vars - where - go :: cmd Symbolic -> [QSM.Var] -> [String] - go cmd [] = [condense cmd] - go cmd xs = [condense xs, "<-", condense cmd] + L.intercalate " " $ go cmd vars + where + go :: cmd Symbolic -> [QSM.Var] -> [String] + go cmd [] = [condense cmd] + go cmd xs = [condense xs, "<-", condense cmd] instance Condense (cmd Symbolic) => Condense (QSM.Commands cmd resp) where condense (QSM.Commands cmds) = unlines $ "do" : map (indent . condense) cmds - where - indent :: String -> String - indent = (" " ++) + where + indent :: String -> String + indent = (" " ++) diff --git a/fs-sim/test/Test/Util.hs b/fs-sim/test/Test/Util.hs index 0857ed2..73ee81e 100644 --- a/fs-sim/test/Test/Util.hs +++ b/fs-sim/test/Test/Util.hs @@ -1,11 +1,11 @@ -module Test.Util ( - showPowersOf10 +module Test.Util + ( showPowersOf10 , showPowersOf ) where -import Data.List (find) -import Data.Maybe (fromJust) -import Text.Printf +import Data.List (find) +import Data.Maybe (fromJust) +import Text.Printf showPowersOf10 :: Int -> String showPowersOf10 = showPowersOf 10 @@ -13,9 +13,9 @@ showPowersOf10 = showPowersOf 10 showPowersOf :: Int -> Int -> String showPowersOf factor n | factor <= 1 = error "showPowersOf: factor must be larger than 1" - | n < 0 = "n < 0" - | n == 0 = "n == 0" - | otherwise = printf "%d <= n < %d" lb ub - where - ub = fromJust (find (n <) (iterate (* factor) factor)) - lb = ub `div` factor + | n < 0 = "n < 0" + | n == 0 = "n == 0" + | otherwise = printf "%d <= n < %d" lb ub + where + ub = fromJust (find (n <) (iterate (* factor) factor)) + lb = ub `div` factor diff --git a/fs-sim/test/Test/Util/RefEnv.hs b/fs-sim/test/Test/Util/RefEnv.hs index 02b6385..88bf21c 100644 --- a/fs-sim/test/Test/Util/RefEnv.hs +++ b/fs-sim/test/Test/Util/RefEnv.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} -- | Environments of QSM references. -module Test.Util.RefEnv ( - RefEnv - -- opaque +module Test.Util.RefEnv + ( RefEnv + -- opaque , elems , empty , filter @@ -24,63 +24,70 @@ module Test.Util.RefEnv ( , (!) ) where -import Prelude hiding (filter, lookup, null) -import qualified Prelude - -import Data.Bifunctor -import Data.Functor.Classes -import Data.List (intercalate) -import GHC.Generics (Generic) -import GHC.Stack -import Test.StateMachine (Reference) -import Test.StateMachine.TreeDiff +import Data.Bifunctor +import Data.Functor.Classes +import Data.List (intercalate) +import GHC.Generics (Generic) +import GHC.Stack +import Test.StateMachine (Reference) +import Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2 as Rank2 +import Prelude hiding (filter, lookup, null) +import qualified Prelude -data RefEnv k a r = RefEnv { toList :: [(Reference k r, a)] } +data RefEnv k a r = RefEnv {toList :: [(Reference k r, a)]} deriving (Generic, ToExpr, Show) -- | Extend mapping -- -- We don't insist that the keys are disjoint, but if the same key appears -- twice, the value must agree. -extendMapping :: forall k v. (Eq k, Eq v, Show k, Show v, HasCallStack) - => [(k, v)] -- Mapping known to have duplicate keys - -> [(k, v)] -- With potential duplicates - -> [(k, v)] -extendMapping acc [] = acc +extendMapping :: + forall k v. + (Eq k, Eq v, Show k, Show v, HasCallStack) => + [(k, v)] -> -- Mapping known to have duplicate keys + [(k, v)] -> -- With potential duplicates + [(k, v)] +extendMapping acc [] = acc extendMapping acc ((k, v) : kvs) = - case Prelude.lookup k acc of - Just v' | v /= v' -> error $ renderError v' - _otherwise -> extendMapping ((k, v) : acc) kvs - where - renderError :: v -> String - renderError v' = intercalate " " [ - "Key" - , show k - , "with two different values" - , show v - , "and" - , show v' - ] - -fromList :: (Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) - => [(Reference k r, a)] -> RefEnv k a r + case Prelude.lookup k acc of + Just v' | v /= v' -> error $ renderError v' + _otherwise -> extendMapping ((k, v) : acc) kvs + where + renderError :: v -> String + renderError v' = + intercalate + " " + [ "Key" + , show k + , "with two different values" + , show v + , "and" + , show v' + ] + +fromList :: + (Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) => + [(Reference k r, a)] -> RefEnv k a r fromList = RefEnv . extendMapping [] instance Rank2.Functor (RefEnv k a) where - fmap f (RefEnv ras) = RefEnv $ + fmap f (RefEnv ras) = + RefEnv $ fmap (first (Rank2.fmap f)) ras instance Rank2.Foldable (RefEnv k a) where foldMap f (RefEnv ras) = - foldMap (Rank2.foldMap f . fst) ras + foldMap (Rank2.foldMap f . fst) ras instance Rank2.Traversable (RefEnv k a) where - traverse f (RefEnv ras) = RefEnv <$> - traverse (\(r, a) -> (,a) <$> Rank2.traverse f r) ras + traverse f (RefEnv ras) = + RefEnv + <$> traverse (\(r, a) -> (,a) <$> Rank2.traverse f r) ras -union :: (Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) - => RefEnv k a r -> RefEnv k a r -> RefEnv k a r +union :: + (Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) => + RefEnv k a r -> RefEnv k a r -> RefEnv k a r union (RefEnv ras1) (RefEnv ras2) = RefEnv (extendMapping ras1 ras2) -- | Empty environment @@ -95,8 +102,8 @@ lookup r (RefEnv ras) = Prelude.lookup r ras (!) :: (Eq k, Eq1 r) => RefEnv k a r -> Reference k r -> a env ! r = case lookup r env of - Just a -> a - Nothing -> error "(RefEnv.!): key not found" + Just a -> a + Nothing -> error "(RefEnv.!): key not found" keys :: RefEnv k a r -> [Reference k r] keys (RefEnv ras) = map fst ras diff --git a/fs-sim/test/Test/Util/WithEntryCounter.hs b/fs-sim/test/Test/Util/WithEntryCounter.hs index ef856ed..775e62f 100644 --- a/fs-sim/test/Test/Util/WithEntryCounter.hs +++ b/fs-sim/test/Test/Util/WithEntryCounter.hs @@ -1,65 +1,83 @@ {-# LANGUAGE RecordWildCards #-} -module Test.Util.WithEntryCounter ( - EntryCounters (..) +module Test.Util.WithEntryCounter + ( EntryCounters (..) , zeroEntryCounters , incrTVar , withEntryCounters ) where -import Control.Concurrent.Class.MonadSTM.Strict -import Data.Word -import System.FS.API +import Control.Concurrent.Class.MonadSTM.Strict +import Data.Word +import System.FS.API -data EntryCounters f = EntryCounters { - dumpStateC :: f Word64 - -- file operations - , hOpenC :: f Word64 - , hCloseC :: f Word64 - , hIsOpenC :: f Word64 - , hSeekC :: f Word64 - , hGetSomeC :: f Word64 - , hGetSomeAtC :: f Word64 - , hPutSomeC :: f Word64 - , hTruncateC :: f Word64 - , hGetSizeC :: f Word64 - -- directory operations - , createDirectoryC :: f Word64 +data EntryCounters f = EntryCounters + { dumpStateC :: f Word64 + , -- file operations + hOpenC :: f Word64 + , hCloseC :: f Word64 + , hIsOpenC :: f Word64 + , hSeekC :: f Word64 + , hGetSomeC :: f Word64 + , hGetSomeAtC :: f Word64 + , hPutSomeC :: f Word64 + , hTruncateC :: f Word64 + , hGetSizeC :: f Word64 + , -- directory operations + createDirectoryC :: f Word64 , createDirectoryIfMissingC :: f Word64 - , listDirectoryC :: f Word64 - , doesDirectoryExistC :: f Word64 - , doesFileExistC :: f Word64 + , listDirectoryC :: f Word64 + , doesDirectoryExistC :: f Word64 + , doesFileExistC :: f Word64 , removeDirectoryRecursiveC :: f Word64 - , removeFileC :: f Word64 - , renameFileC :: f Word64 - -- file I\/O with user-supplied buffers - , hGetBufSomeC :: f Word64 - , hGetBufSomeAtC :: f Word64 - , hPutBufSomeC :: f Word64 - , hPutBufSomeAtC :: f Word64 + , removeFileC :: f Word64 + , renameFileC :: f Word64 + , -- file I\/O with user-supplied buffers + hGetBufSomeC :: f Word64 + , hGetBufSomeAtC :: f Word64 + , hPutBufSomeC :: f Word64 + , hPutBufSomeAtC :: f Word64 } zeroEntryCounters :: MonadSTM m => m (EntryCounters (StrictTVar m)) -zeroEntryCounters = EntryCounters <$> - newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> - newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> - newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> - newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> - newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> - newTVarIO 0 <*> newTVarIO 0 +zeroEntryCounters = + EntryCounters + <$> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 incrTVar :: MonadSTM m => StrictTVar m Word64 -> m () -incrTVar var = atomically $ modifyTVar var (+1) +incrTVar var = atomically $ modifyTVar var (+ 1) withEntryCounters :: - MonadSTM m - => EntryCounters (StrictTVar m) - -> HasFS m h - -> HasFS m h -withEntryCounters EntryCounters{..} HasFS{..} = HasFS { - dumpState = incrTVar dumpStateC >> dumpState - -- file operatoins - , hOpen = \a b -> incrTVar hOpenC >> hOpen a b + MonadSTM m => + EntryCounters (StrictTVar m) -> + HasFS m h -> + HasFS m h +withEntryCounters EntryCounters{..} HasFS{..} = + HasFS + { dumpState = incrTVar dumpStateC >> dumpState + , -- file operatoins + hOpen = \a b -> incrTVar hOpenC >> hOpen a b , hClose = \a -> incrTVar hCloseC >> hClose a , hIsOpen = \a -> incrTVar hIsOpenC >> hIsOpen a , hSeek = \a b c -> incrTVar hSeekC >> hSeek a b c @@ -68,8 +86,8 @@ withEntryCounters EntryCounters{..} HasFS{..} = HasFS { , hPutSome = \a b -> incrTVar hPutSomeC >> hPutSome a b , hTruncate = \a b -> incrTVar hTruncateC >> hTruncate a b , hGetSize = \a -> incrTVar hGetSizeC >> hGetSize a - -- directory operations - , createDirectory = \a -> incrTVar createDirectoryC >> createDirectory a + , -- directory operations + createDirectory = \a -> incrTVar createDirectoryC >> createDirectory a , createDirectoryIfMissing = \a b -> incrTVar createDirectoryIfMissingC >> createDirectoryIfMissing a b , listDirectory = \a -> incrTVar listDirectoryC >> listDirectory a , doesDirectoryExist = \a -> incrTVar doesDirectoryExistC >> doesDirectoryExist a @@ -79,8 +97,8 @@ withEntryCounters EntryCounters{..} HasFS{..} = HasFS { , renameFile = \a b -> incrTVar renameFileC >> renameFile a b , mkFsErrorPath = mkFsErrorPath , unsafeToFilePath = unsafeToFilePath - -- file I\/O with user-supplied buffers - , hGetBufSome = \a b c d -> incrTVar hGetBufSomeC >> hGetBufSome a b c d + , -- file I\/O with user-supplied buffers + hGetBufSome = \a b c d -> incrTVar hGetBufSomeC >> hGetBufSome a b c d , hGetBufSomeAt = \a b c d e -> incrTVar hGetBufSomeAtC >> hGetBufSomeAt a b c d e , hPutBufSome = \a b c d -> incrTVar hPutBufSomeC >> hPutBufSome a b c d , hPutBufSomeAt = \a b c d e -> incrTVar hPutBufSomeAtC >> hPutBufSomeAt a b c d e diff --git a/scripts/format-cabal.sh b/scripts/format-cabal.sh index bddaa90..f140e85 100755 --- a/scripts/format-cabal.sh +++ b/scripts/format-cabal.sh @@ -2,4 +2,26 @@ set -euo pipefail -fdfind -p . -e cabal -x cabal-fmt -i +# First, try to find the 'fd' command +fdcmd="fd" +if ! command -v "$fdcmd" &> /dev/null; then + # In Ubuntu systems the fd command is called fdfind. + # If 'fd' is not found, try 'fdfind' + fdcmd="fdfind" + if ! command -v "$fdcmd" &> /dev/null; then + echo "Error: Neither 'fd' nor 'fdfind' command found." >&2 + exit 1 + fi +fi + +case "$(uname -s)" in + MINGW*) path="$(pwd -W | sed 's_/_\\\\_g')\\\\(fs-api|fs-sim)";; + *) path="$(pwd)/(fs-api|fs-sim)";; +esac + +$fdcmd --full-path "$path" -e cabal -x cabal-gild -i {} -o {} + +case "$(uname -s)" in + MINGW*) git ls-files --eol | grep "w/crlf" | awk '{print $4}' | xargs dos2unix;; + *) ;; +esac || true diff --git a/scripts/format-fourmolu.sh b/scripts/format-fourmolu.sh new file mode 100755 index 0000000..96d2f7c --- /dev/null +++ b/scripts/format-fourmolu.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash + +set -e + +echo "The custom options for formatting this repo are:" +fourmolu --version +fourmolu --print-defaults | diff - ./fourmolu.yaml | grep -E "^>.*[[:alnum:]]" | grep -v "#" +printf "\nFormatting haskell files...\n" + +export LC_ALL=C.UTF-8 +# First, try to find the 'fd' command +fdcmd="fd" +if ! command -v "$fdcmd" &> /dev/null; then + # In Ubuntu systems the fd command is called fdfind. + # If 'fd' is not found, try 'fdfind' + fdcmd="fdfind" + if ! command -v "$fdcmd" &> /dev/null; then + echo "Error: Neither 'fd' nor 'fdfind' command found." >&2 + exit 1 + fi +fi + +case "$(uname -s)" in + MINGW*) path="$(pwd -W | sed 's_/_\\\\_g')\\\\(fs-api|fs-sim)";; + *) path="$(pwd)/(fs-api|fs-sim)";; +esac + +$fdcmd --full-path "$path" \ + --extension hs \ + --exec-batch fourmolu --config fourmolu.yaml -i + +case "$(uname -s)" in + MINGW*) git ls-files --eol | grep "w/crlf" | awk '{print $4}' | xargs dos2unix;; + *) ;; +esac || true diff --git a/scripts/format-stylish.sh b/scripts/format-stylish.sh deleted file mode 100755 index a54990b..0000000 --- a/scripts/format-stylish.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env bash - -set -euo pipefail - -PARGS="-p ." -CARGS="" - -while getopts p:cd flag -do - case "${flag}" in - p) PARGS="-p ${OPTARG}";; - c) CARGS="-c ${OPTARG}";; - d) CARGS="-c .stylish-haskell.yaml";; - esac -done - -echo "Running stylish-haskell script with arguments: $PARGS $CARGS" - -export LC_ALL=C.UTF-8 - -fdfind $PARGS -e hs -X stylish-haskell $CARGS -i