├── .gitattributes ├── .github └── workflows │ ├── lint.yml │ ├── stan.yml │ └── tests.yml ├── .gitignore ├── .hindent.yaml ├── .hlint.yaml ├── .stan.toml ├── .yamllint.yaml ├── CONTRIBUTING.md ├── ChangeLog.md ├── LICENSE ├── README.md ├── app └── test-pretty-exceptions │ ├── Main.hs │ ├── unix │ ├── PathAbsExamples.hs │ └── System │ │ └── Terminal.hsc │ └── windows │ ├── PathAbsExamples.hs │ └── System │ └── Terminal.hs ├── attic ├── hpack-0.1.2.3.tar.gz ├── package-0.1.2.3.tar.gz └── symlink-to-dir.tar.gz ├── int └── Pantry │ ├── HPack.hs │ ├── Internal.hs │ ├── SHA256.hs │ └── Types.hs ├── package.yaml ├── pantry.cabal ├── src ├── Hackage │ └── Security │ │ └── Client │ │ └── Repository │ │ └── HttpLib │ │ └── HttpClient.hs ├── Pantry.hs ├── Pantry │ ├── Archive.hs │ ├── Casa.hs │ ├── HTTP.hs │ ├── Hackage.hs │ ├── Internal │ │ └── Stackage.hs │ ├── Repo.hs │ ├── SQLite.hs │ ├── Storage.hs │ └── Tree.hs ├── unix │ └── System │ │ └── IsWindows.hs └── windows │ └── System │ └── IsWindows.hs ├── stack-ghc-9.10.1.yaml ├── stack-ghc-9.12.2.yaml ├── stack-ghc-9.2.8.yaml ├── stack-ghc-9.4.8.yaml ├── stack-ghc-9.6.7.yaml ├── stack-ghc-9.8.4.yaml ├── stack.yaml └── test ├── Pantry ├── ArchiveSpec.hs ├── BuildPlanSpec.hs ├── CabalSpec.hs ├── CasaSpec.hs ├── FileSpec.hs ├── GlobalHintsSpec.hs ├── HackageSpec.hs ├── InternalSpec.hs ├── TreeSpec.hs └── TypesSpec.hs └── Spec.hs /.gitattributes: -------------------------------------------------------------------------------- 1 | /pantry.cabal linguist-generated=true 2 | /*.yaml.lock linguist-generated=true 3 | -------------------------------------------------------------------------------- /.github/workflows/lint.yml: -------------------------------------------------------------------------------- 1 | name: Linting 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: 7 | - master 8 | 9 | jobs: 10 | style: 11 | name: Linting 12 | runs-on: ubuntu-latest 13 | steps: 14 | - name: Clone project 15 | uses: actions/checkout@v4 16 | - name: Apply yamllint 17 | uses: ibiqlik/action-yamllint@v3 18 | with: 19 | format: github 20 | - name: Set up HLint 21 | uses: haskell-actions/hlint-setup@v2 22 | with: 23 | version: "3.10" 24 | - name: Apply HLint 25 | run: | 26 | set -ex 27 | hlint app/test-pretty-exceptions 28 | hlint int/ 29 | hlint src/ 30 | hlint test/ 31 | -------------------------------------------------------------------------------- /.github/workflows/stan.yml: -------------------------------------------------------------------------------- 1 | name: Apply stan 2 | 3 | on: 4 | pull_request: 5 | workflow_dispatch: 6 | 7 | jobs: 8 | build: 9 | name: Apply stan 10 | runs-on: ubuntu-latest 11 | 12 | steps: 13 | - name: Clone project 14 | uses: actions/checkout@v4 15 | 16 | - name: Cache dependencies 17 | uses: actions/cache@v4 18 | with: 19 | path: ~/.stack 20 | key: ${{ runner.os }}-${{ runner.arch }}-${{ hashFiles('stack.yaml') }} 21 | 22 | - name: Install stan 23 | run: | 24 | git clone https://github.com/kowainik/stan.git 25 | cd stan 26 | stack --local-bin-path ../.bin install 27 | cd .. 28 | 29 | - name: Generate .hie for analysis 30 | run: stack build pantry:lib 31 | 32 | - name: Run stan 33 | run: .bin/stan report --cabal-file-path=pantry.cabal 34 | 35 | - name: Upload HTML report 36 | uses: actions/upload-artifact@v4 37 | with: 38 | name: Stan_report 39 | path: stan.html 40 | -------------------------------------------------------------------------------- /.github/workflows/tests.yml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: 7 | - master 8 | workflow_dispatch: 9 | 10 | # As of 27 March 2025, ubuntu-latest and windows-latest come with 11 | # Stack 3.3.1. However, macos-13 and macos-latest do not come with Haskell 12 | # tools. 13 | 14 | jobs: 15 | build: 16 | name: CI 17 | runs-on: ${{ matrix.os }} 18 | strategy: 19 | fail-fast: false 20 | matrix: 21 | os: 22 | - ubuntu-latest 23 | snapshot: 24 | - stack-ghc-9.6.7.yaml 25 | - stack-ghc-9.8.4.yaml 26 | - stack-ghc-9.10.1.yaml 27 | - stack-ghc-9.12.2.yaml 28 | include: 29 | - os: macos-13 30 | snapshot: stack-ghc-9.8.4.yaml 31 | # macos-latest provides macOS/AArch64 (M1) 32 | - os: macos-latest 33 | snapshot: stack-ghc-9.8.4.yaml 34 | - os: windows-latest 35 | snapshot: stack-ghc-9.8.4.yaml 36 | steps: 37 | - name: Clone project 38 | uses: actions/checkout@v4 39 | - name: Cache dependencies on Unix-like OS 40 | if: startsWith(runner.os, 'Linux') || startsWith(runner.os, 'macOS') 41 | uses: actions/cache@v4 42 | with: 43 | path: ~/.stack 44 | key: ${{ runner.os }}-${{ runner.arch }}-${{ matrix.snapshot }} 45 | - name: Cache dependencies on Windows 46 | if: startsWith(runner.os, 'Windows') 47 | uses: actions/cache@v4 48 | with: 49 | path: | 50 | ~\AppData\Roaming\stack 51 | ~\AppData\Local\Programs\stack 52 | key: ${{ runner.os }}-${{ runner.arch }}-${{ matrix.snapshot }} 53 | - name: Build and run tests 54 | shell: bash 55 | run: | 56 | set -ex 57 | 58 | if [[ "${{ matrix.os }}" == "macos-13" || "${{ matrix.os }}" == "macos-latest" ]] 59 | then 60 | # macos-13 and macos-latest do not include Haskell tools as at 2024-12-13. 61 | curl -sSL https://get.haskellstack.org/ | sh 62 | fi 63 | 64 | stack --resolver ${{ matrix.snapshot }} test --bench --no-run-benchmarks --haddock --no-haddock-deps 65 | test-pretty-exceptions: 66 | name: Test build of test-pretty-exceptions 67 | runs-on: ${{ matrix.os }} 68 | strategy: 69 | fail-fast: false 70 | matrix: 71 | os: 72 | - ubuntu-latest 73 | - windows-latest 74 | snapshot: 75 | - stack-ghc-9.8.4.yaml 76 | steps: 77 | - name: Clone project 78 | uses: actions/checkout@v4 79 | - name: Cache dependencies on Unix-like OS 80 | if: startsWith(runner.os, 'Linux') || startsWith(runner.os, 'macOS') 81 | uses: actions/cache@v4 82 | with: 83 | path: ~/.stack 84 | key: ${{ runner.os }}-${{ runner.arch }}-${{ matrix.snapshot }}-pretty 85 | - name: Cache dependencies on Windows 86 | if: startsWith(runner.os, 'Windows') 87 | uses: actions/cache@v4 88 | with: 89 | path: | 90 | ~\AppData\Roaming\stack 91 | ~\AppData\Local\Programs\stack 92 | key: ${{ runner.os }}-${{ runner.arch }}-${{ matrix.snapshot }}-pretty 93 | - name: Build test-pretty-exceptions 94 | shell: bash 95 | run: | 96 | set -ex 97 | stack --resolver ${{ matrix.snapshot }} build --flag pantry:test-pretty-exceptions 98 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.swp 3 | 4 | # Haskell Tool Stack-related 5 | .stack-work/ 6 | *.yaml.lock 7 | 8 | # Cabal (the tool)-related 9 | dist-newstyle/ 10 | 11 | # Haskell Language Server-related 12 | hie.yaml 13 | 14 | # Stan-related 15 | .hie 16 | stan.html 17 | 18 | # VS Code Counter (Visual Studio Code Extension)-related 19 | .VSCodeCounter 20 | -------------------------------------------------------------------------------- /.hindent.yaml: -------------------------------------------------------------------------------- 1 | indent-size: 2 2 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # Not considered useful hints 2 | - ignore: 3 | name: "Use camelCase" 4 | within: 5 | - System.Terminal 6 | - ignore: 7 | name: "Use fewer imports" 8 | within: 9 | - Pantry.Types 10 | - ignore: 11 | name: "Functor law" 12 | within: 13 | - Pantry.Types 14 | -------------------------------------------------------------------------------- /.stan.toml: -------------------------------------------------------------------------------- 1 | # Partial: base/last 2 | # On Windows 3 | # To exclude .stack-work\dist\\build\internal\autogen\Paths_pantry.hs 4 | [[check]] 5 | id = "STAN-0004" 6 | directory = ".stack-work\\dist" 7 | type = "Exclude" 8 | 9 | # Partial: base/last 10 | # On Unix-like operating systems 11 | # To exclude .stack-work/dist//build/internal/autogen/Paths_pantry.hs 12 | [[check]] 13 | id = "STAN-0004" 14 | directory = ".stack-work/dist" 15 | type = "Exclude" 16 | 17 | # Infinite: base/reverse 18 | # Usage of the 'reverse' function that hangs on infinite lists 19 | # Pantry uses Data.List.reverse in many places 20 | [[check]] 21 | id = "STAN-0101" 22 | scope = "all" 23 | type = "Exclude" 24 | 25 | # Anti-pattern: Data.ByteString.Char8.pack 26 | [[ignore]] 27 | id = "OBS-STAN-0203-RDkR59-114:17" 28 | # ✦ Description: Usage of 'pack' function that doesn't handle Unicode characters 29 | # ✦ Category: #AntiPattern 30 | # ✦ File: src/Hackage\Security\Client\Repository\HttpLib\HttpClient.hs 31 | # 32 | # 109 ┃ 33 | # 110 ┃ rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1) 34 | # 111 ┃ ^^^^^^^^^^ 35 | 36 | # Data types with non-strict fields 37 | # Defining lazy fields in data types can lead to unexpected space leaks 38 | # Pantry uses lazy fields in many places 39 | [[check]] 40 | id = "STAN-0206" 41 | scope = "all" 42 | type = "Exclude" 43 | 44 | # Anti-pattern: Slow 'length' for Text 45 | [[ignore]] 46 | id = "OBS-STAN-0208-gkCCTP-1150:14" 47 | # ✦ Description: Usage of 'length' for 'Text' that runs in linear time 48 | # ✦ Category: #AntiPattern 49 | # ✦ File: src/Pantry.hs 50 | # 51 | # 1099 ┃ 52 | # 1100 ┃ isSHA1 t = T.length t == 40 && T.all isHexDigit t 53 | # 1101 ┃ ^^^^^^^^ 54 | 55 | # Anti-pattern: Pattern matching on '_' 56 | # Pattern matching on '_' for sum types can create maintainability issues 57 | # Pantry uses pattern matching on '_' in many places. 58 | [[check]] 59 | id = "STAN-0213" 60 | scope = "all" 61 | type = "Exclude" 62 | 63 | # Big tuples 64 | # Using tuples of big size (>= 4) can decrease code readability 65 | # In serveral places Pantry uses 4-tuples. 66 | [[check]] 67 | id = "STAN-0302" 68 | scope = "all" 69 | type = "Exclude" 70 | -------------------------------------------------------------------------------- /.yamllint.yaml: -------------------------------------------------------------------------------- 1 | # Configuration file for yamllint 2 | extends: default 3 | rules: 4 | comments: 5 | min-spaces-from-content: 1 6 | document-start: disable 7 | indentation: 8 | spaces: 2 9 | indent-sequences: false 10 | line-length: disable 11 | new-lines: 12 | type: platform 13 | truthy: 14 | check-keys: false 15 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributors Guide 2 | 3 | Thank you for considering contributing to the maintenance or development of 4 | pantry! We hope that the following information will encourage and assist you. We 5 | start with some advice about pantry's governance. 6 | 7 | ## pantry's governance 8 | 9 | People involved in maintaining or developing pantry with rights to make commits 10 | to the repository can be classified into two groups: 'committers' and 11 | 'maintainers'. 12 | 13 | ### pantry's committers 14 | 15 | We encourages a wide range of people to be granted rights to make commits to the 16 | repository. 17 | 18 | People are encouraged to take initiative to make non-controversial changes, such 19 | as documentation improvements, bug fixes, performance improvements, and feature enhancements. 20 | 21 | Maintainers should be included in discussions of controversial changes and 22 | tricky code changes. 23 | 24 | Our general approach is **"it's easier to ask forgiveness than permission"**. If 25 | there is ever a bad change, it can always be rolled back. 26 | 27 | ### pantry's maintainers 28 | 29 | pantry's maintainers are long-term contributors to the project. Michael Snoyman 30 | (@snoyberg) was the founder of pantry, and its initial maintainer - and he has 31 | added others. Michael's current interests and priorities mean that he is no 32 | longer actively involved in adding new features to pantry. 33 | 34 | Maintainers are recognized for their contributions including: 35 | 36 | * Direct code contribution 37 | * Review of pull requests 38 | * Interactions on the GitHub issue tracker 39 | 40 | The maintainer team make certain decisions when that is necessary, specifically: 41 | 42 | * How to proceed, if there is disagreement on how to do so on a specific topic 43 | * Whether to add or remove (see further below) a maintainer 44 | 45 | Generally, maintainers are only removed due to non-participation or actions 46 | unhealthy to the project. Removal due to non-participation is not a punishment, 47 | simply a recognition that maintainership is for active participants only. 48 | 49 | We hope that removal due to unhealthy actions will never be necessary, but would 50 | include protection for cases of: 51 | 52 | * Disruptive behavior in public channels related to pantry 53 | * Impairing the codebase through bad commits/merges 54 | 55 | Like committers, maintainers are broadly encouraged to make autonomous 56 | decisions. Each maintainer is empowered to make a unilateral decision. However, 57 | maintainers should favor getting consensus first if: 58 | 59 | * They are uncertain what is the best course of action 60 | * They anticipate that other maintainers or users of pantry will disagree on the 61 | decision 62 | 63 | ## Bug Reports 64 | 65 | Please [open an issue](https://github.com/commercialhaskell/pantry/issues/new) 66 | and use the provided template to include all necessary details. 67 | 68 | The more detailed your report, the faster it can be resolved and will ensure it 69 | is resolved in the right way. Once your bug has been resolved, the responsible 70 | person will tag the issue as _Needs confirmation_ and assign the issue back to 71 | you. Once you have tested and confirmed that the issue is resolved, close the 72 | issue. If you are not a member of the project, you will be asked for 73 | confirmation and we will close it. 74 | 75 | ## Error messages 76 | 77 | To support the Haskell Foundation's 78 | [Haskell Error Index](https://errors.haskell.org/) initiative, all pantry 79 | error messages generated by pantry itself should have a unique initial line: 80 | 81 | ~~~text 82 | Error: [S-nnn] 83 | ~~~ 84 | 85 | where `nnn` is a three-digit number in the range 100 to 999. 86 | 87 | If you create a new pantry error, select a number using a random number 88 | generator (see, for example, [RANDOM.ORG](https://www.random.org/)) and check 89 | that number is not already in use in pantry's code. If it is, pick another until 90 | the number is unique. 91 | 92 | All exceptions generated by pantry itself are implemented using data 93 | constructors of closed sum types. Typically, there is one such type for each 94 | module that exports functions that throw exceptions. 95 | 96 | ## Code 97 | 98 | If you would like to contribute code to fix a bug, add a new feature, or 99 | otherwise improve pantry, pull requests are most welcome. It's a good idea to 100 | [submit an issue](https://github.com/commercialhaskell/pantry/issues/new) to 101 | discuss the change before plowing into writing code. 102 | 103 | Please include a 104 | [ChangeLog](https://github.com/commercialhaskell/pantry/blob/master/ChangeLog.md) 105 | entry with your pull request. 106 | 107 | ## Code Quality 108 | 109 | The pantry project uses [yamllint](https://github.com/adrienverge/yamllint) as a 110 | YAML file quality tool and [HLint](https://github.com/ndmitchell/hlint) as a 111 | code quality tool. 112 | 113 | ### Linting of YAML files 114 | 115 | The yamllint configuration extends the tools default and is set out in 116 | `.yamllint.yaml`. In particular, indentation is set at 2 spaces and `- ` in 117 | sequences is treated as part of the indentation. 118 | 119 | ### Linting of Haskell source code 120 | 121 | The HLint configurations is set out in `.hlint.yaml`. 122 | 123 | pantry contributors need not follow dogmatically the suggested HLint hints but 124 | are encouraged to debate their usefulness. If you find a HLint hint is not 125 | useful and detracts from readability of code, consider marking it in the 126 | [configuration file](https://github.com/commercialhaskell/pantry/blob/master/.hlint.yaml) 127 | to be ignored. Please refer to the 128 | [HLint manual](https://github.com/ndmitchell/hlint#readme) 129 | for configuration syntax. 130 | 131 | We are optimizing for code clarity, not code concision or what HLint thinks. 132 | 133 | You can install HLint with Stack. You might want to install it in the global 134 | project in case you run into dependency conflicts. HLint can report hints in 135 | your favourite text editor. Refer to the HLint repository for more details. 136 | 137 | To install, command: 138 | 139 | ~~~text 140 | stack install hlint 141 | ~~~ 142 | 143 | ## Code Style 144 | 145 | A single code style is not applied consistently to pantry's code and pantry is 146 | not Procrustean about matters of style. Rules of thumb, however, are: 147 | 148 | * keep pull requests that simply reformat code separate from those that make 149 | other changes to code; and 150 | * when making changes to code other than reformatting, follow the existing style 151 | of the function(s) or module(s) in question. 152 | 153 | That said, the following may help: 154 | 155 | * pantry's code generally avoids the use of C preprocessor (CPP) directives. 156 | Windows and non-Windows code is separated in separate source code directories 157 | and distinguished in pantry's Cabal file. Multi-line strings are generally 158 | formatted on the assumption that GHC's `CPP` language pragma is not being 159 | used. 160 | * Language pragmas usually start with `NoImplictPrelude`, where applicable, and 161 | then all others are listed alphabetically. The closing `#-}` are aligned, for 162 | purely aesthetic reasons. 163 | * pantry is compiled with GHC's `-Wall` enabled, which includes `-Wtabs` (no 164 | tabs in source code). Most modules are based on two spaces (with one space for 165 | a `where`) for indentation but older and larger modules are still based on 166 | four spaces. 167 | * pantry's code and documentation tends to be based on lines of no more than 80 168 | characters or, if longer, no longer than necessary. 169 | * pantry uses export lists. 170 | * pantry's imports are listed alphabetically. The module names are left aligned, 171 | with space left for `qualified` where it is absent. 172 | * pantry's code is sufficiently stable that explict import lists can sensibly be 173 | used. Not all modules have comprehensive explicit import lists. 174 | * Short explicit import lists follow the module name. Longer lists start on the 175 | line below the module name. Spaces are used to separate listed items from 176 | their enclosing parentheses. 177 | * In function type signatures, the `::` is kept on the same line as the 178 | function's name. This format is Haskell syntax highlighter-friendly. 179 | * If `where` is used, the declarations follow on a separate line. 180 | 181 | ## Continuous integration (CI) 182 | 183 | We use [GitHub Actions](https://docs.github.com/en/actions) to do CI on pantry. 184 | The configuration of the workflows is in the YAML files in `.github/workflows`. 185 | The current active workflows are: 186 | 187 | ### Linting - `lint.yml` 188 | 189 | This workflow will run if: 190 | 191 | * there is a pull request 192 | * commits are pushed to this branch: `master` 193 | 194 | The workflow has one job (`style`). It runs on `ubuntu` only and applies 195 | yamllint and Hlint. 196 | 197 | ### Stan tool - `stan.yml` 198 | 199 | [Stan](https://hackage.haskell.org/package/stan) is a Haskell static analysis 200 | tool. As of `stan-0.1.0.1`, it supports GHC >= 9.6.3. The tool is configured by 201 | the contents of the `.stan.toml` file. 202 | 203 | This workflow will run if: 204 | 205 | * there is a pull request 206 | * requested 207 | 208 | ## Haskell Language Server 209 | 210 | You may be using [Visual Studio Code](https://code.visualstudio.com/) (VS Code) 211 | with its 212 | [Haskell extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell), 213 | which is powered by the 214 | [Haskell Language Server](https://github.com/haskell/haskell-language-server) 215 | (HLS). 216 | 217 | pantry can be built with Stack (which is recommended) or with Cabal (the tool). 218 | 219 | === "Stack" 220 | 221 | If you use Stack to build Stack, command `stack ghci` in the root directory 222 | of the pantry project should work as expected, if you have first commanded 223 | `stack build` once. 224 | 225 | `ghc` should be on the PATH if you run VS Code itself in the Stack 226 | environment: 227 | ~~~text 228 | stack exec -- code . 229 | ~~~ 230 | 231 | The following [cradle (`hie.yaml`)](https://github.com/haskell/hie-bios) 232 | should suffice to configure Haskell Language Server (HLS) explicitly for 233 | each of the buildable components in pantry's Cabal file: 234 | ~~~yaml 235 | cradle: 236 | stack: 237 | - path: "./src" 238 | component: "pantry:lib" 239 | - path: "./int" 240 | component: "pantry:lib" 241 | - path: "./app" 242 | component: "pantry:exe:test-pretty-exceptions" 243 | - path: "./test" 244 | component: "pantry:test:spec" 245 | ~~~ 246 | 247 | === "Cabal (the tool)" 248 | 249 | If you use Cabal (the tool) to build Stack, command `cabal repl` in the root 250 | directory of the Stack project should work as expected, if you have GHC and 251 | (on Windows) MSYS2 on the PATH. 252 | 253 | `ghc` and (on Windows) MSYS2 should be on the PATH if you run commands 254 | (including `cabal`) in the Stack environment: 255 | ~~~text 256 | stack exec --no-ghc-package-path -- cabal repl 257 | ~~~ 258 | 259 | or 260 | ~~~text 261 | stack exec --no-ghc-package-path -- code . 262 | ~~~ 263 | 264 | Use of GHC's environment variable `GHC_PACKAGE_PATH` is not compatible with 265 | Cabal (the tool). That is why the `--no-ghc-package-path` flag must be 266 | specified with `stack exec` when relying on Cabal (the tool). 267 | 268 | The following [cradle (`hie.yaml`)](https://github.com/haskell/hie-bios) 269 | should suffice to configure Haskell Language Server (HLS) explicitly for 270 | each of the buildable components in pantry's Cabal file: 271 | ~~~yaml 272 | cradle: 273 | cabal: 274 | - path: "./src" 275 | component: "lib:pantry" 276 | - path: "./int" 277 | component: "lib:pantry" 278 | - path: "./app" 279 | component: "exe:test-pretty-exceptions" 280 | - path: "./test" 281 | component: "test:spec" 282 | ~~~ 283 | 284 | A cradle is not committed to pantry's repository because it imposes a choice of 285 | build tool. 286 | 287 | ## Slack channel 288 | 289 | If you're making deep changes and real-time communication with the pantry team 290 | would be helpful, we have a `#stack-collaborators` Slack channel in the 291 | Haskell Foundation workspace. To join the workspace, follow this 292 | [link](https://haskell-foundation.slack.com/join/shared_invite/zt-z45o9x38-8L55P27r12YO0YeEufcO2w#/shared-invite/email). 293 | 294 | ## Matrix room 295 | 296 | There is also a 297 | [Stack and Stackage room](https://matrix.to/#/#haskell-stack:matrix.org) 298 | at address `#haskell-stack:matrix.org` on [Matrix](https://matrix.org/). 299 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for pantry 2 | 3 | ## v0.10.1 4 | 5 | * Expose new `parseRawPackageLocationImmutables`. 6 | * Add errors S-925 (`RawPackageLocationImmutableParseFail`) and S-775 7 | (`RawPackageLocationImmutableParseWarnings`). 8 | 9 | ## v0.10.0 10 | 11 | * Name of tar file of local cache of package index is not hard coded. 12 | * `withPantryConfig` and `withPantryConfig'` require the location of global 13 | hints to be specified. 14 | * `GlobalHintsLocation`, `defaultGlobalHintsLocation`, `globalHintsLocation` and 15 | `parseGlobalHintsLocation` added. 16 | * `withPantryConfig'` now requires the specification of whether or not Hpack's 17 | `--force` flag is to be applied. 18 | * Expose `hpackForceL`, a lens to view or modify the `Force` (Hpack) of a 19 | `PantryConfig`. 20 | 21 | ## v0.9.3.2 22 | 23 | * Support `ansi-terminal-1.0.2`. 24 | * Bug fix: On Windows, `loadPackageRaw` supports repositories with submodules, 25 | as intended. 26 | 27 | ## v0.9.3.1 28 | 29 | * Depend on `aeson-warning-parser-0.1.1`. 30 | 31 | ## v0.9.3 32 | 33 | * Add error S-628 (`LocalNoArchiveFileFound`). 34 | * Depend on `rio-prettyprint-0.1.7.0`. 35 | 36 | ## v0.9.2 37 | 38 | * `defaultCasaRepoPrefix` references https://casa.stackage.org, instead of 39 | https://casa.fpcomplete.com. 40 | * Depend on `crypton` instead of `cryptonite`. 41 | * Depend on `tar-conduit-0.4.0`, which will tolerate long filenames and 42 | directory names in archives created by `git archive`. 43 | 44 | ## v0.9.1 45 | 46 | * Expose module `Pantry.SQLite`. 47 | 48 | ## v0.9.0 49 | 50 | * Remove module `Pantry.Internal.AesonExtended` and depend on 51 | `aeson-warning-parser` package. 52 | * Remove module `Pantry.Internal.Companion` and depend on `companion` package. 53 | * Remove module `Pantry.Internal.StaticBytes` and depend on `static-bytes` 54 | package. 55 | * Remove module `Pantry.Internal`, previously exposed only for testing. 56 | * Update Hackage bootstrap root key set. 57 | 58 | ## v0.8.3 59 | 60 | * Expose `withPantryConfig'`, which allows for optional use of Casa. 61 | `NoCasaConfig` is now a data constructor of `PantryException`. 62 | * `withRepo`, in the case of Git, will now, if necessary, fetch the specific 63 | commit. (For example, GitHub repositories include the commits of unmerged pull 64 | requests but these are not fetched when the repository is cloned.) 65 | 66 | ## v0.8.2.2 67 | 68 | * Add error S-395 (`NoLocalPackageDirFound`). 69 | 70 | ## v0.8.2.1 71 | 72 | * On Windows, avoid fatal `tar: Cannot connect to C: resolve failed` bug when 73 | archiving repository submodules. 74 | 75 | ## v0.8.2 76 | 77 | * `PantryException` is now an instance of the 78 | `Text.PrettyPrint.Leijen.Extended.Pretty` class (provided by the 79 | `rio-prettyprint` package). 80 | * Module `Pantry` now exports `FuzzyResults`, `Mismatch` and `SafeFilePath` (and 81 | `mkSafeFilePath`), used in data constructors of `PantryException`. 82 | 83 | ## v0.8.1 84 | 85 | * Support `hpack-0.35.1`, and prettier `HpackLibraryException` error messages. 86 | 87 | ## v0.8.0 88 | 89 | * `findOrGenerateCabalFile`, `loadCabalFilePath`, `loadCabalFile` and 90 | `loadCabalFileRaw` no longer assume that the program name used by Hpack (the 91 | library) is "stack", and take a new initial argument of type `Maybe Text` to 92 | specify the desired program name. The default is "hpack". 93 | 94 | ## v0.7.1 95 | 96 | * To support the Haskell Foundation's 97 | [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry 98 | error messages generated by Pantry itself begin with an unique code in the 99 | form `[S-nnn]`, where `nnn` is a three-digit number. 100 | 101 | ## v0.7.0 102 | 103 | * Change `defaultHackageSecurityConfig` such that field 104 | `hscIgnoreExpiry = True`, to be consistent with the defaults of the 105 | `WithJSONWarnings HackageSecurityConfig` instance of `FromJSON`. 106 | 107 | ## v0.6.0 108 | 109 | * Rename `HackageSecurityConfig` as `PackageIndexConfig`, 110 | `defaultHackageSecurityConfig` as `defaultPackageIndexConfig`, and 111 | `pcHackageSecurity` field of `PantryConfig` as `pcPackageIndex`. 112 | * Expose new `HackageSecurityConfig` and `defaultHackageSecurityConfig`. The 113 | former represents Hackage Security configurations (only - no download prefix). 114 | * Change the data constructor of `PackageIndexConfig` to have fields for a 115 | download prefix (type `Text`) and of type `HackageSecurityConfig`. 116 | * The `WithJSONWarnings PackageIndexConfig` instance of `FromJSON` now assigns 117 | default value `defaultHackageSecurityConfig` if the `hackage-security` key is 118 | absent from the JSON object. 119 | * Expose `defaultDownloadPrefix`, for the official Hackage server. 120 | 121 | ## v0.5.7 122 | 123 | * Expose `loadAndCompleteSnapshotRaw'` and `loadAndCompleteSnapshot'`, which 124 | allow the toggling of the debug output of the raw snapshot layer. See 125 | [#55](https://github.com/commercialhaskell/pantry/pull/55). 126 | * Support GHC 9.4. 127 | 128 | ## v0.5.6 129 | 130 | * Remove operational and mirror keys from bootstrap key set. See 131 | [#53](https://github.com/commercialhaskell/pantry/pull/53). 132 | 133 | ## v0.5.5 134 | 135 | * Support `Cabal-3.6.0.0`. 136 | 137 | ## v0.5.4 138 | 139 | * Support `aeson-2.0.0.0`. 140 | 141 | ## v0.5.3 142 | 143 | * improve and expose `fetchRepos`/`fetchReposRaw`. 144 | 145 | ## v0.5.2.3 146 | 147 | * Support for GHC 9.0. See 148 | [#39](https://github.com/commercialhaskell/pantry/pull/39). 149 | 150 | ## v0.5.2.2 151 | 152 | * Support for `Cabal-3.4.0.0`. See 153 | [#38](https://github.com/commercialhaskell/pantry/pull/38). 154 | 155 | ## v0.5.2.1 156 | 157 | * Support `persistent-2.13.0.0`. See 158 | [#35](https://github.com/commercialhaskell/pantry/issues/35). 159 | 160 | ## v0.5.2 161 | 162 | * Fall back to BSD tar when type cannot be detected. See 163 | [#33](https://github.com/commercialhaskell/pantry/issues/33). 164 | 165 | ## v0.5.1.5 166 | * Switch back to `hackage.haskell.org`. See 167 | [#30](https://github.com/commercialhaskell/pantry/pull/30). 168 | * Pass through basic auth credentials specified in URLs. See 169 | [#32](https://github.com/commercialhaskell/pantry/pull/32). 170 | 171 | ## v0.5.1.4 172 | 173 | * Allow building with `persistent-2.11.0.0`. See 174 | [#28](https://github.com/commercialhaskell/pantry/pull/28). 175 | 176 | ## v0.5.1.3 177 | 178 | * Handle case where tree exists in cache by blobs are missing. See 179 | [#27](https://github.com/commercialhaskell/pantry/issues/27). 180 | 181 | ## v0.5.1.2 182 | 183 | * Skip a test for issue 184 | [#26](https://github.com/commercialhaskell/pantry/issues/26). 185 | 186 | ## v0.5.1.1 187 | 188 | * Fix to allow multiple relative path of symlink. 189 | 190 | ## v0.5.1.0 191 | 192 | * Catch all exceptions from Casa calls and recover. 193 | 194 | ## v0.5.0.0 195 | 196 | * Make the location of LTS/Nightly snapshots configurable. 197 | 198 | ## v0.4.0.1 199 | 200 | * Removed errant log message. 201 | 202 | ## v0.4.0.0 203 | 204 | * Add a deprecation warning when using a repo/archive without a Cabal file, see 205 | Stack issue [#5210](https://github.com/commercialhaskell/stack/issues/5210). 206 | * Do not include repo/archive dependencies which do not include Cabal files in 207 | lock files. 208 | * Remove some no longer used functions. 209 | 210 | ## v0.3.0.0 211 | 212 | * Upgrade to `Cabal-3.0.0.0`. 213 | 214 | ## v0.2.0.0 215 | 216 | Bug fixes: 217 | 218 | * Don't compare the hashes of Cabal files. Addresses bugs such as Stack issue 219 | [#5045](https://github.com/commercialhaskell/stack/issues/5045). Data type 220 | changes: removed the `pmCabal` and `rpmCabal` fields. 221 | 222 | ## v0.1.1.2 223 | 224 | Bug fixes: 225 | 226 | * Module mapping insertions into the database are now atomic. Previously, if 227 | you SIGTERMed at the wrong time while running a script, you could end up with 228 | an inconsistent database state. 229 | 230 | ## v0.1.1.1 231 | 232 | Other changes: 233 | 234 | * Support building with `persistent-template-2.7.0`. 235 | 236 | ## v0.1.1.0 237 | 238 | **Changes since 0.1.0.0** 239 | 240 | Bug fixes: 241 | 242 | * Fix to allow dependencies on specific versions of local git repositories. See 243 | Stack pull request 244 | [#4862](https://github.com/commercialhaskell/stack/pull/4862). 245 | 246 | Behavior changes: 247 | 248 | * By default, do not perform expiry checks in Hackage Security. See Stack issue 249 | [#4928](https://github.com/commercialhaskell/stack/issues/4928). 250 | 251 | Other changes: 252 | 253 | * Rename `pantry-tmp` package back to `pantry`, now that we have gained 254 | maintainership (which had been used by someone else for a candidate-only test 255 | that made it look like the name was free but prevented uploading a real 256 | package). 257 | 258 | 259 | ## 0.1.0.0 260 | 261 | * Initial release. 262 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2022, Stack contributors 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of Stack nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # pantry 2 | 3 | [![Build Status](https://dev.azure.com/commercialhaskell/pantry/_apis/build/status/commercialhaskell.pantry?branchName=master)](https://dev.azure.com/commercialhaskell/pantry/_build/latest?definitionId=6&branchName=master) 4 | 5 | Content addressable Haskell package management, providing for secure, 6 | reproducible acquisition of Haskell package contents and metadata. 7 | 8 | ## What is Pantry 9 | 10 | * A Haskell library, storage specification, and network protocol 11 | * Intended for content-addressable storage of Haskell packages 12 | * Allows non-centralized package storage 13 | * Primarily for use by Stackage and Stack, hopefully other tools as well 14 | 15 | ## Goals 16 | 17 | * Efficient, distributed package storage for Haskell 18 | * Superset of existing storage mechanisms 19 | * Security via content addressable storage 20 | * Allow more Stackage-style snapshots to exist 21 | * Allow authors to bypass Hackage for uploads 22 | * Allow Stackage to create forks of packages on Hackage 23 | 24 | __TODO__ 25 | 26 | Content below needs to be updated. 27 | 28 | * Support for hpack in PackageLocationImmutable? 29 | 30 | ## Package definition 31 | 32 | Pantry defines the following concepts: 33 | 34 | * __Blob__: a raw byte sequence, identified by its key (SHA256 of the 35 | contents) 36 | * __Tree entry__: contents of a single file (identified by blob key) 37 | and whether or not it is executable. 38 | * NOTE: existing package formats like tarballs support more 39 | sophisticated options. We explicitly do not support those. If 40 | such functionality is needed, fallback to those mechanism is 41 | required. 42 | * __Tree__: mapping from relative path to a tree entry. Some basic 43 | sanity rules apply to the paths: no `.` or `..` directory 44 | components, no newlines in filepaths, does not begin with `/`, no 45 | `\\` (we normalize to POSIX-style paths). A tree is identified by a 46 | tree key (SHA256 of the tree's serialized format). 47 | * __Package__: a tree key for the package contents, package name, 48 | version number, and cabal file blob key. Requirements: there must be 49 | a single file with a `.cabal` file extension at the root of the 50 | tree, and it must match the cabal file blob key. The cabal file must 51 | be located at `pkgname.cabal`. Each tree can be in at most one 52 | package, and therefore tree keys work as package keys too. 53 | 54 | Note that with the above, a tree key is all the information necessary 55 | to uniquely identify a package. However, including additional 56 | information (package name, version, cabal key) in config files may be 57 | useful for optimizations or user friendliness. If such extra 58 | information is ever included, it must be validated to concur with the 59 | package contents itself. 60 | 61 | ### Package location 62 | 63 | Packages will optionally be sourced from some location: 64 | 65 | * __Hackage__ requires the package name, version number, and revision 66 | number. Each revision of a package will end up with a different tree 67 | key. 68 | * __Archive__ takes a URL pointing to a tarball (gzipped or not) or a 69 | ZIP file. An implicit assumption is that archives remain immutable 70 | over time. Use tree keys to verify this assumption. (Same applies to 71 | Hackage for that matter.) 72 | * __Repository__ takes a repo type (Git or Mercurial), URL, and 73 | commit. Assuming the veracity of the cryptographic hashes on the 74 | repos, this should guarantee a unique set of files. 75 | 76 | In order to deal with _megarepos_ (repos and archives containing more 77 | than one package), there is also a subdirectory for the archive and 78 | repository cases. An empty subdir `""` would be the case for a 79 | standard repo/archive. 80 | 81 | In order to meet the rules of a package listed above, the following 82 | logic is applied to all three types above: 83 | 84 | * Find all of the files in the raw location, and represent as `Map 85 | FilePath TreeEntry` (or equivalent). 86 | * Remove a wrapper directory. If _all_ filepaths in that `Map` are 87 | contained within the same directory, strip it from all of the 88 | paths. For example, if the paths are `foo/bar` and `foo/baz`, the 89 | paths will be reduced to `bar` and `baz`. 90 | * After this wrapper is removed, then subdirectory logic is applied, 91 | essentially applying `stripPrefix` to the filepaths. If the subdir 92 | is `yesod-bin` and files exist called `yesod-core/yesod-core.cabal` 93 | and `yesod-bin/yesod-bin.cabal`, the only file remaining after 94 | subdir stripping would be `yesod-bin.cabal`. Note that trailing 95 | slashes must be handled appropriately, and that an empty subdir 96 | string results in this step being a noop. 97 | 98 | The result of all of this is that, given one of the three package 99 | locations above, we can receive a tree key which will provide an 100 | installable package. That tree key will remain immutable. 101 | 102 | ### How tooling refers to packages 103 | 104 | We'll get to the caching mechanism for Pantry below. However, the 105 | recommended approach for tooling is to support some kind of composite 106 | of the Pantry keys, parsed info, and raw package location. This allows 107 | for more efficient lookups when available, with a fallback when 108 | mirrors don't have the needed information. 109 | 110 | An example: 111 | 112 | ```yaml 113 | extra-deps: 114 | - name: foobar 115 | version: 1.2.3.4 116 | pantry: deadbeef # tree key 117 | cabal-file: 12345678 # blob key 118 | archive: https://example.com/foobar-1.2.3.4.tar.gz 119 | ``` 120 | 121 | It is also recommended that tooling provide an easy way to generate 122 | such complete information from, e.g., just the URL of the tarball, and 123 | that upon reading information, hashes, package names, and version 124 | numbers are all checked for correctness. 125 | 126 | ## Pantry caching 127 | 128 | One simplistic option for Pantry would be that, every time a piece of 129 | data is needed, Pantry downloads the necessary tarball/Git 130 | repo/etc. However, this would in practice be highly wasteful, since 131 | downloading Git repos and archives just to get a single cabal file 132 | (for plan construction purposes) is overkill. Instead, here's the 133 | basic idea for how caching works: 134 | 135 | * All data for Pantry can be stored in a SQL database. Local tools 136 | like Stack will use an SQLite database. Servers will use PostgreSQL. 137 | * We'll define a network protocol (initially just HTTP, maybe 138 | extending to something more efficient if desired) for querying blobs 139 | and trees. 140 | * When a blob or tree is needed, it is first checked for in the local 141 | SQLite cache. If it's not available there, a request to the Pantry 142 | mirrors (configurable) will be made for the data. Since everything 143 | is content addressable, it is safe to use untrusted mirrors. 144 | * If the data is not available in a mirror, and a location is 145 | provided, the location will be downloaded and cached locally. 146 | 147 | We may also allow these Pantry mirrors to provide some kind of query 148 | interface to find out, e.g., the latest version of a package on 149 | Hackage. That's still TBD. 150 | 151 | ## Example: resolving a package location 152 | 153 | To work through a full example, the following three stanzas are intended to 154 | have equivalent behavior: 155 | 156 | ```yaml 157 | - archive: https://example.com/foobar-1.2.3.4.tar.gz 158 | 159 | - name: foobar 160 | version: 1.2.3.4 161 | pantry: deadbeef # tree key 162 | cabal-file: 12345678 # blob key 163 | archive: https://example.com/foobar-1.2.3.4.tar.gz 164 | 165 | - pantry: deadbeef 166 | 167 | ``` 168 | 169 | The question is: how does the first one (presumably what a user would want to 170 | enter) be resolved into the second and third? Pantry would follow this set of 171 | steps: 172 | 173 | * Download the tarball from the given URL 174 | * Place each file in the tarball into its store as a blob, getting a blob key 175 | for each. The tarball is now represented as `Map FilePath BlobKey` 176 | * Perform the root directory stripping step, removing a shared path 177 | * Since there's no subdirectory: no subdirectory stripping would be performed 178 | * Serialize the `Map FilePath BlobKey` to a binary format and take its hash to 179 | get a tree key 180 | * Store the tree in the store referenced by its tree key. In our example: the 181 | tree key is `deadbeef`. 182 | * Ensure that the tree is a valid package by checking for a single cabal file 183 | at the root. In our example, that's found in `foobar.cabal` with blob key 184 | `12345678`. 185 | * Parse the cabal file and ensure that it is a valid cabal file, and that its 186 | package name is `foobar`. Grab the version number (1.2.3.4). 187 | * We now know that tree key `deadbeef` is a valid package, and can refer to it 188 | by tree key exclusively. However, including the other information allows us 189 | to verify our assumptions, provide user-friendly readable data, and provide a 190 | fallback if the package isn't in the Pantry cache. 191 | 192 | ## More advanced content discovery 193 | 194 | There are three more advanced cases to consider: 195 | 196 | * Providing fall-back locations for content, such as out of concern for a 197 | single URL being removed in the future 198 | * Closed corporate setups, where access to the general internet may either be 199 | impossible or undesirable 200 | * Automatic discovery of missing content by hash 201 | 202 | The following extensions are possible to address these cases: 203 | 204 | * Instead of a single package location, provide a list of package locations 205 | with fallback semantics. 206 | * Corporate environments will be encouraged to run a local Pantry mirror, and 207 | configure clients like Stack to speak to these mirrors instead of the default 208 | ones (or in addition to). 209 | * Provide some kind of federation protocol for Pantry where servers can 210 | registry with each other and requests for content can be pinged to each 211 | other. 212 | 213 | Providing override at the client level for Pantry mirror locations is a 214 | __MUST__. Making it easy to run in a corporate environment is a __SHOULD__. 215 | Providing the fallback package locations seems easy enough that we should 216 | include it initially, but falls under a __SHOULD__. The federated protocol 217 | should be added on-demand. 218 | -------------------------------------------------------------------------------- /app/test-pretty-exceptions/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | -- | An executable to allow a person to inspect in a terminal the form of 6 | -- Pantry's pretty exceptions. 7 | module Main 8 | ( main 9 | ) where 10 | 11 | import Data.Aeson.WarningParser ( JSONWarning (..) ) 12 | import qualified Data.Conduit.Tar as Tar 13 | import Data.Maybe ( fromJust ) 14 | import qualified Data.Text as T 15 | import qualified Distribution.Parsec.Error as C 16 | import qualified Distribution.Parsec.Position as C 17 | import qualified Distribution.Parsec.Warning as C 18 | import qualified Distribution.Types.PackageName as C 19 | import qualified Distribution.Types.Version as C 20 | import Options.Applicative 21 | ( Parser, (<**>), auto, execParser, fullDesc, header, help 22 | , helper, info, long, metavar, option, progDesc, showDefault 23 | , strOption, value 24 | ) 25 | import Network.HTTP.Types.Status ( Status, mkStatus ) 26 | import Pantry 27 | ( ArchiveLocation (..), BlobKey (..), CabalFileInfo (..) 28 | , FileSize (..), FuzzyResults (..), Mismatch (..) 29 | , PackageName, PantryException (..), PackageIdentifier (..) 30 | , PackageIdentifierRevision (..), PackageMetadata (..) 31 | , RawPackageLocationImmutable (..), RawPackageMetadata (..) 32 | , RawSnapshotLocation (..), RelFilePath (..), Repo (..) 33 | , RepoType (..), ResolvedPath (..), Revision (..), SHA256 34 | , SafeFilePath, SimpleRepo (..), SnapName (..) 35 | , TreeKey (..), Version, WantedCompiler (..), mkSafeFilePath 36 | ) 37 | import Pantry.SHA256 ( hashBytes ) 38 | import Path ( File ) 39 | import PathAbsExamples 40 | ( pathAbsDirExample, pathAbsFileExample 41 | , pathAbsFileExamples 42 | ) 43 | import RIO 44 | import qualified RIO.List as L 45 | import RIO.NonEmpty ( nonEmpty ) 46 | import RIO.PrettyPrint ( pretty, prettyError ) 47 | import RIO.PrettyPrint.Simple ( SimplePrettyApp, runSimplePrettyApp ) 48 | import RIO.PrettyPrint.StylesUpdate 49 | ( StylesUpdate, parseStylesUpdateFromString ) 50 | import RIO.Time ( fromGregorian ) 51 | import System.Terminal ( hIsTerminalDeviceOrMinTTY, getTerminalWidth ) 52 | 53 | -- | Type representing options that can be specified at the command line 54 | data Options = Options 55 | { colours :: String 56 | , theme :: Theme 57 | } 58 | 59 | -- | Type representing styles identified by a theme name 60 | data Theme 61 | = Default 62 | | SolarizedDark 63 | deriving (Bounded, Enum, Read, Show) 64 | 65 | options :: Parser Options 66 | options = Options 67 | <$> strOption 68 | ( long "colours" 69 | <> metavar "STYLES" 70 | <> help "Specify the output styles; STYLES is a colon-delimited \ 71 | \sequence of key=value, where 'key' is a style name and \ 72 | \'value' is a semicolon-delimited list of 'ANSI' SGR (Select \ 73 | \Graphic Rendition) control codes (in decimal). In shells \ 74 | \where a semicolon is a command separator, enclose STYLES in \ 75 | \quotes." 76 | <> value "" 77 | ) 78 | <*> option auto 79 | ( long "theme" 80 | <> metavar "THEME" 81 | <> help ( "Specify a theme for output styles. THEME is one of: " 82 | <> showThemes <> "." 83 | ) 84 | <> value Default 85 | <> showDefault 86 | ) 87 | where 88 | showThemes = L.intercalate " " $ map show ([minBound .. maxBound] :: [Theme]) 89 | 90 | fromTheme :: Theme -> StylesUpdate 91 | fromTheme Default = mempty 92 | fromTheme SolarizedDark = parseStylesUpdateFromString 93 | "error=31:good=32:shell=35:dir=34:recommendation=32:target=95:module=35:package-component=95:secondary=92:highlight=32" 94 | 95 | main :: IO () 96 | main = do 97 | isTerminal <- hIsTerminalDeviceOrMinTTY stderr 98 | if isTerminal 99 | then do 100 | terminalWidth <- fromMaybe 80 <$> getTerminalWidth 101 | mainInTerminal terminalWidth =<< execParser opts 102 | else 103 | putStrLn "This executable is intended to be run with the standard error \ 104 | \ channel connected to a terminal. No terminal detected." 105 | where 106 | opts = info (options <**> helper) 107 | ( fullDesc 108 | <> progDesc "Allows a person to inspect in a terminal the form of Pantry's \ 109 | \pretty exceptions." 110 | <> header "test-pretty-exceptions - test Pantry's pretty exceptions" 111 | ) 112 | 113 | mainInTerminal :: Int -> Options -> IO () 114 | mainInTerminal terminalWidth Options{..} = do 115 | let stylesUpdate = fromTheme theme <> parseStylesUpdateFromString colours 116 | runSimplePrettyApp terminalWidth stylesUpdate action 117 | where 118 | action :: RIO SimplePrettyApp () 119 | action = mapM_ (prettyError . pretty) examples 120 | 121 | -- | The intention is that there shoud be examples for every data constructor of 122 | -- the PantryException type. 123 | examples :: [PantryException] 124 | examples = concat 125 | [ [ PackageIdentifierRevisionParseFail hackageMsg ] 126 | , [ RawPackageLocationImmutableParseFail "example text" someExceptionExample ] 127 | , [ RawPackageLocationImmutableParseWarnings "example text" jsonWarningsExample] 128 | , [ InvalidCabalFile loc version pErrorExamples pWarningExamples 129 | | loc <- map Left rawPackageLocationImmutableExamples <> [Right pathAbsFileExample] 130 | , version <- [Nothing, Just versionExample] 131 | ] 132 | , [ TreeWithoutCabalFile rawPackageLocationImmutable 133 | | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples 134 | ] 135 | , [ TreeWithMultipleCabalFiles rawPackageLocationImmutable safeFilePathExamples 136 | | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples 137 | ] 138 | , [ MismatchedCabalName pathAbsFileExample packageNameExample ] 139 | , [ NoCabalFileFound pathAbsDirExample ] 140 | , [ MultipleCabalFilesFound pathAbsDirExample pathAbsFileExamples ] 141 | , [ InvalidWantedCompiler "my-wanted-compiler" ] 142 | , [ InvalidSnapshotLocation pathAbsDirExample rawPathExample ] 143 | , [ InvalidOverrideCompiler wantedCompiler1 wantedCompiler2 144 | | wantedCompiler1 <- wantedCompilerExamples 145 | , wantedCompiler2 <- wantedCompilerExamples 146 | ] 147 | , [ InvalidFilePathSnapshot rawPathExample ] 148 | , [ InvalidSnapshot rawSnapshotLocation someExceptionExample 149 | | rawSnapshotLocation <- rawSnapshotLocationExamples 150 | ] 151 | , [ InvalidGlobalHintsLocation pathAbsDirExample rawPathExample ] 152 | , [ InvalidFilePathGlobalHints rawPathExample ] 153 | , [ MismatchedPackageMetadata rawPackageLocationImmutable rawPackageMetadata treeKey packageIdentifierExample 154 | | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples 155 | , rawPackageMetadata <- rawPackageMetadataExamples 156 | , treeKey <- [Nothing, Just treeKeyExample] 157 | ] 158 | , [ Non200ResponseStatus statusExample ] 159 | , [ InvalidBlobKey (Mismatch blobKeyExample blobKeyExample) ] 160 | , [ Couldn'tParseSnapshot rawSnapshotLocation errorMessageExample 161 | | rawSnapshotLocation <- rawSnapshotLocationExamples 162 | ] 163 | , [ WrongCabalFileName rawPackageLocationImmutable safeFilePathExample packageNameExample 164 | | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples 165 | ] 166 | , [ DownloadInvalidSHA256 urlExample (Mismatch sha256Example sha256Example) ] 167 | , [ DownloadInvalidSize urlExample (Mismatch fileSizeExample fileSizeExample) ] 168 | , [ DownloadTooLarge urlExample (Mismatch fileSizeExample fileSizeExample) ] 169 | , [ LocalNoArchiveFileFound pathAbsFileExample ] 170 | , [ LocalInvalidSHA256 pathAbsFileExample (Mismatch sha256Example sha256Example) ] 171 | , [ LocalInvalidSize pathAbsFileExample (Mismatch fileSizeExample fileSizeExample) ] 172 | , [ UnknownArchiveType archiveLocation 173 | | archiveLocation <- archiveLocationExamples 174 | ] 175 | , [ InvalidTarFileType archiveLocation filePathExample fileTypeExample 176 | | archiveLocation <- archiveLocationExamples 177 | ] 178 | , [ UnsupportedTarball archiveLocation (T.pack errorMessageExample) 179 | | archiveLocation <- archiveLocationExamples 180 | ] 181 | , [ NoHackageCryptographicHash packageIdentifierExample ] 182 | , [ FailedToCloneRepo simpleRepoExample ] 183 | , [ TreeReferencesMissingBlob rawPackageLocationImmutable safeFilePathExample blobKeyExample 184 | | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples 185 | ] 186 | , [ CompletePackageMetadataMismatch rawPackageLocationImmutable packageMetadataExample 187 | | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples 188 | ] 189 | , [ CRC32Mismatch archiveLocation filePathExample (Mismatch 1024 1024 ) 190 | | archiveLocation <- archiveLocationExamples 191 | ] 192 | , [ UnknownHackagePackage packageIdentifierRevisionExample fuzzyResults 193 | | packageIdentifierRevisionExample <- packageIdentifierRevisionExamples 194 | , fuzzyResults <- fuzzyResultsExamples 195 | ] 196 | , [ CannotCompleteRepoNonSHA1 repoExample ] 197 | , [ MutablePackageLocationFromUrl urlExample ] 198 | , [ MismatchedCabalFileForHackage packageIdentifierRevision (Mismatch packageIdentifierExample packageIdentifierExample) 199 | | packageIdentifierRevision <- packageIdentifierRevisionExamples 200 | ] 201 | , [ PackageNameParseFail rawPackageName ] 202 | , [ PackageVersionParseFail rawPackageVersion ] 203 | , [ InvalidCabalFilePath pathAbsFileExample ] 204 | , [ DuplicatePackageNames sourceMsgExample duplicatePackageNamesExamples ] 205 | , [ MigrationFailure descriptionExample pathAbsFileExample someExceptionExample ] 206 | , [ NoCasaConfig ] 207 | , [ InvalidTreeFromCasa blobKeyExample blobExample ] 208 | , [ ParseSnapNameException rawSnapNameExample ] 209 | , [ HpackLibraryException pathAbsFileExample errorMessageExample ] 210 | , [ HpackExeException hpackCommandExample pathAbsDirExample someExceptionExample ] 211 | ] 212 | 213 | hackageMsg :: Text 214 | hackageMsg = "" 215 | 216 | pErrorExamples :: [C.PError] 217 | pErrorExamples = 218 | [ C.PError (C.Position 10 20) "" 219 | , C.PError (C.Position 12 10) "" 220 | , C.PError (C.Position 14 30) "" 221 | ] 222 | 223 | pWarningExamples :: [C.PWarning] 224 | pWarningExamples = 225 | [ C.PWarning C.PWTOther (C.Position 10 20) "" 226 | , C.PWarning C.PWTOther (C.Position 12 10) "" 227 | , C.PWarning C.PWTOther (C.Position 14 30) "" 228 | ] 229 | 230 | packageNameExample :: PackageName 231 | packageNameExample = C.mkPackageName "my-package" 232 | 233 | versionExample :: Version 234 | versionExample = C.mkVersion [1, 0, 0] 235 | 236 | sha256Example :: SHA256 237 | sha256Example = hashBytes "example" 238 | 239 | fileSizeExample :: FileSize 240 | fileSizeExample = FileSize 1234 241 | 242 | revisionExample :: Revision 243 | revisionExample = Revision 1 244 | 245 | cabalFileInfoExamples :: [CabalFileInfo] 246 | cabalFileInfoExamples = concat 247 | [ [CFILatest] 248 | , [ CFIHash sha256Example fileSize 249 | | fileSize <- [Nothing, Just fileSizeExample] 250 | ] 251 | , [CFIRevision revisionExample] 252 | ] 253 | 254 | packageIdentifierRevisionExamples :: [PackageIdentifierRevision] 255 | packageIdentifierRevisionExamples = 256 | [ PackageIdentifierRevision packageNameExample versionExample cabalFileInfo 257 | | cabalFileInfo <- cabalFileInfoExamples 258 | ] 259 | 260 | blobKeyExample :: BlobKey 261 | blobKeyExample = BlobKey sha256Example fileSizeExample 262 | 263 | treeKeyExample :: TreeKey 264 | treeKeyExample = TreeKey blobKeyExample 265 | 266 | rawPackageLocationImmutableExamples :: [RawPackageLocationImmutable] 267 | rawPackageLocationImmutableExamples = 268 | [ RPLIHackage packageIdentifierRevision treeKey 269 | | packageIdentifierRevision <- packageIdentifierRevisionExamples 270 | , treeKey <- [Nothing, Just treeKeyExample] 271 | ] 272 | --, RPLIArchive 273 | <> [ RPLIRepo repoExample rawPackageMetadata 274 | | rawPackageMetadata <- rawPackageMetadataExamples 275 | ] 276 | 277 | safeFilePathExamples :: [SafeFilePath] 278 | safeFilePathExamples = 279 | [ fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example1.ext" 280 | , fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example2.ext" 281 | , fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example3.ext" 282 | ] 283 | 284 | rawPathExample :: Text 285 | rawPathExample = "" 286 | 287 | wantedCompilerExamples :: [WantedCompiler] 288 | wantedCompilerExamples = 289 | [ WCGhc versionExample 290 | , WCGhcGit "" "" 291 | , WCGhcjs versionExample versionExample 292 | ] 293 | 294 | newtype ExceptionExample 295 | = ExceptionExample Text 296 | deriving (Show, Typeable) 297 | 298 | instance Exception ExceptionExample where 299 | displayException (ExceptionExample t) = T.unpack t 300 | 301 | errorMessageExample :: String 302 | errorMessageExample = 303 | "This is the first line of some example text for the message in an exception \ 304 | \example. This is example text for an exception example.\n\ 305 | \This is the second line of some example text for the message in an exception \ 306 | \example. This is example text for an exception example." 307 | 308 | someExceptionExample :: SomeException 309 | someExceptionExample = 310 | SomeException (ExceptionExample $ T.pack errorMessageExample) 311 | 312 | urlExample :: Text 313 | urlExample = "https://example.com" 314 | 315 | relFilePathExample :: RelFilePath 316 | relFilePathExample = RelFilePath "jane/my-project-dir" 317 | 318 | resolvedPathFileExample :: ResolvedPath File 319 | resolvedPathFileExample = ResolvedPath relFilePathExample pathAbsFileExample 320 | 321 | snapNameExamples :: [SnapName] 322 | snapNameExamples = 323 | [ LTS 20 17 324 | , Nightly $ fromGregorian 2023 4 5 325 | ] 326 | 327 | rawSnapshotLocationExamples :: [RawSnapshotLocation] 328 | rawSnapshotLocationExamples = concat 329 | [ [ RSLCompiler wantedCompiler 330 | | wantedCompiler <- wantedCompilerExamples 331 | ] 332 | , [ RSLUrl urlExample blobKey 333 | | blobKey <- [Nothing, Just blobKeyExample] 334 | ] 335 | , [ RSLFilePath resolvedPathFileExample ] 336 | , [ RSLSynonym snapNameExample 337 | | snapNameExample <- snapNameExamples 338 | ] 339 | ] 340 | 341 | rawPackageMetadataExamples :: [RawPackageMetadata] 342 | rawPackageMetadataExamples = 343 | [ RawPackageMetadata name version treeKey 344 | | name <- [ Nothing, Just packageNameExample] 345 | , version <- [ Nothing, Just versionExample ] 346 | , treeKey <- [Nothing, Just treeKeyExample] 347 | ] 348 | 349 | statusExample :: Status 350 | statusExample = mkStatus 100 "" 351 | 352 | safeFilePathExample :: SafeFilePath 353 | safeFilePathExample = 354 | fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example.ext" 355 | 356 | archiveLocationExamples :: [ArchiveLocation] 357 | archiveLocationExamples = 358 | [ ALUrl urlExample 359 | , ALFilePath resolvedPathFileExample 360 | ] 361 | 362 | filePathExample :: FilePath 363 | filePathExample = "" 364 | 365 | fileTypeExample :: Tar.FileType 366 | fileTypeExample = Tar.FTNormal 367 | 368 | commitExample :: Text 369 | commitExample = "b8b34bf5571de75909d97f687e3d37909b1dc9f7" 370 | 371 | simpleRepoExample :: SimpleRepo 372 | simpleRepoExample = SimpleRepo urlExample commitExample RepoGit 373 | 374 | packageIdentifierExample :: PackageIdentifier 375 | packageIdentifierExample = PackageIdentifier packageNameExample versionExample 376 | 377 | packageMetadataExample :: PackageMetadata 378 | packageMetadataExample = PackageMetadata packageIdentifierExample treeKeyExample 379 | 380 | fuzzyResultsExamples :: [FuzzyResults] 381 | fuzzyResultsExamples = 382 | [ FRNameNotFound packageNameExamples 383 | , FRVersionNotFound $ fromJust $ nonEmpty packageIdentifierRevisionExamples 384 | , FRRevisionNotFound $ fromJust $ nonEmpty packageIdentifierRevisionExamples 385 | ] 386 | 387 | repoExample :: Repo 388 | repoExample = Repo urlExample commitExample RepoGit "my-subdirectory" 389 | 390 | rawPackageName :: Text 391 | rawPackageName = "" 392 | 393 | rawPackageVersion :: Text 394 | rawPackageVersion = "" 395 | 396 | sourceMsgExample :: Utf8Builder 397 | sourceMsgExample = "" 398 | 399 | packageNameExamples :: [PackageName] 400 | packageNameExamples = 401 | [ C.mkPackageName "my-package1" 402 | , C.mkPackageName "my-package2" 403 | , C.mkPackageName "my-package3" 404 | ] 405 | 406 | duplicatePackageNamesExamples :: [(PackageName, [RawPackageLocationImmutable])] 407 | duplicatePackageNamesExamples = map 408 | (, rawPackageLocationImmutableExamples) 409 | packageNameExamples 410 | 411 | descriptionExample :: Text 412 | descriptionExample = "" 413 | 414 | blobExample :: ByteString 415 | blobExample = "b8b34bf5571de75909d97f687e3d37909b1dc9f7" 416 | 417 | rawSnapNameExample :: Text 418 | rawSnapNameExample = "" 419 | 420 | hpackCommandExample :: FilePath 421 | hpackCommandExample = "/hpack" 422 | 423 | jsonWarningsExample :: [JSONWarning] 424 | jsonWarningsExample = 425 | [ jsonUnrecognizedFieldsExample 426 | , jsonGeneralWarningExample 427 | ] 428 | 429 | jsonUnrecognizedFieldsExample :: JSONWarning 430 | jsonUnrecognizedFieldsExample = JSONUnrecognizedFields 431 | "UnresolvedPackageLocationImmutable.UPLIHackage" 432 | ["field1", "field2", "field3"] 433 | 434 | jsonGeneralWarningExample :: JSONWarning 435 | jsonGeneralWarningExample = JSONGeneralWarning "A general JSON warning." 436 | -------------------------------------------------------------------------------- /app/test-pretty-exceptions/unix/PathAbsExamples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | -- | The module of this name differs as between Windows and non-Windows builds. 4 | -- This is the non-Windows version. 5 | module PathAbsExamples 6 | ( pathAbsDirExample 7 | , pathAbsFileExample 8 | , pathAbsFileExamples 9 | ) where 10 | 11 | import Path ( Abs, Dir, File, Path, absdir, absfile ) 12 | 13 | pathAbsDirExample :: Path Abs Dir 14 | pathAbsDirExample = [absdir|/home/jane/my-project-dir|] 15 | 16 | pathAbsFileExample :: Path Abs File 17 | pathAbsFileExample = [absfile|/home/jane/my-project-dir/example.ext|] 18 | 19 | pathAbsFileExamples :: [Path Abs File] 20 | pathAbsFileExamples = 21 | [ [absfile|/home/jane/my-project-dir/example1.ext|] 22 | , [absfile|/home/jane/my-project-dir/example2.ext|] 23 | , [absfile|/home/jane/my-project-dir/example3.ext|] 24 | ] 25 | -------------------------------------------------------------------------------- /app/test-pretty-exceptions/unix/System/Terminal.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | 3 | -- | The module of this name differs as between Windows and non-Windows builds. 4 | -- This is the non-Windows version. 5 | module System.Terminal 6 | ( getTerminalWidth 7 | , hIsTerminalDeviceOrMinTTY 8 | ) where 9 | 10 | import Foreign 11 | import Foreign.C.Types 12 | import RIO (MonadIO, Handle, hIsTerminalDevice) 13 | 14 | #include 15 | #include 16 | 17 | 18 | newtype WindowWidth = WindowWidth CUShort 19 | deriving (Eq, Ord, Show) 20 | 21 | instance Storable WindowWidth where 22 | sizeOf _ = (#size struct winsize) 23 | alignment _ = (#alignment struct winsize) 24 | peek p = WindowWidth <$> (#peek struct winsize, ws_col) p 25 | poke p (WindowWidth w) = do 26 | (#poke struct winsize, ws_col) p w 27 | 28 | -- `ioctl` is variadic, so `capi` is needed, see: 29 | -- https://www.haskell.org/ghc/blog/20210709-capi-usage.html 30 | foreign import capi "sys/ioctl.h ioctl" 31 | ioctl :: CInt -> CInt -> Ptr WindowWidth -> IO CInt 32 | 33 | getTerminalWidth :: IO (Maybe Int) 34 | getTerminalWidth = 35 | alloca $ \p -> do 36 | errno <- ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) p 37 | if errno < 0 38 | then pure Nothing 39 | else do 40 | WindowWidth w <- peek p 41 | pure . Just . fromIntegral $ w 42 | 43 | -- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal 44 | -- devices, but isMinTTYHandle does. 45 | hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool 46 | hIsTerminalDeviceOrMinTTY = hIsTerminalDevice 47 | -------------------------------------------------------------------------------- /app/test-pretty-exceptions/windows/PathAbsExamples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | -- | The module of this name differs as between Windows and non-Windows builds. 4 | -- This is the Windows version. 5 | module PathAbsExamples 6 | ( pathAbsDirExample 7 | , pathAbsFileExample 8 | , pathAbsFileExamples 9 | ) where 10 | 11 | import Path ( Abs, Dir, File, Path, absdir, absfile ) 12 | 13 | pathAbsDirExample :: Path Abs Dir 14 | pathAbsDirExample = [absdir|C:/Users/jane/my-project-dir|] 15 | 16 | pathAbsFileExample :: Path Abs File 17 | pathAbsFileExample = [absfile|C:/Users/jane/my-project-dir/example.ext|] 18 | 19 | pathAbsFileExamples :: [Path Abs File] 20 | pathAbsFileExamples = 21 | [ [absfile|C:/Users/jane/my-project-dir/example1.ext|] 22 | , [absfile|C:/Users/jane/my-project-dir/example2.ext|] 23 | , [absfile|C:/Users/jane/my-project-dir/example3.ext|] 24 | ] 25 | -------------------------------------------------------------------------------- /app/test-pretty-exceptions/windows/System/Terminal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | The module of this name differs as between Windows and non-Windows builds. 5 | -- This is the Windows version. 6 | module System.Terminal 7 | ( getTerminalWidth 8 | , hIsTerminalDeviceOrMinTTY 9 | ) where 10 | 11 | import Foreign.Marshal.Alloc ( allocaBytes ) 12 | import Foreign.Ptr ( Ptr ) 13 | import Foreign.Storable ( peekByteOff ) 14 | import RIO 15 | import RIO.Partial ( read ) 16 | import System.IO hiding ( hIsTerminalDevice ) 17 | import System.Process 18 | ( StdStream (..), createProcess, shell, std_err, std_in 19 | , std_out, waitForProcess 20 | ) 21 | import System.Win32 ( isMinTTYHandle, withHandleToHANDLE ) 22 | 23 | type HANDLE = Ptr () 24 | 25 | data CONSOLE_SCREEN_BUFFER_INFO 26 | 27 | sizeCONSOLE_SCREEN_BUFFER_INFO :: Int 28 | sizeCONSOLE_SCREEN_BUFFER_INFO = 22 29 | 30 | posCONSOLE_SCREEN_BUFFER_INFO_srWindow :: Int 31 | posCONSOLE_SCREEN_BUFFER_INFO_srWindow = 10 -- 4 x Word16 Left,Top,Right,Bottom 32 | 33 | c_STD_OUTPUT_HANDLE :: Int 34 | c_STD_OUTPUT_HANDLE = -11 35 | 36 | foreign import ccall unsafe "windows.h GetConsoleScreenBufferInfo" 37 | c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO Bool 38 | 39 | foreign import ccall unsafe "windows.h GetStdHandle" 40 | c_GetStdHandle :: Int -> IO HANDLE 41 | 42 | 43 | getTerminalWidth :: IO (Maybe Int) 44 | getTerminalWidth = do 45 | hdl <- c_GetStdHandle c_STD_OUTPUT_HANDLE 46 | allocaBytes sizeCONSOLE_SCREEN_BUFFER_INFO $ \p -> do 47 | b <- c_GetConsoleScreenBufferInfo hdl p 48 | if not b 49 | then do -- This could happen on Cygwin or MSYS 50 | let stty = (shell "stty size") { 51 | std_in = UseHandle stdin 52 | , std_out = CreatePipe 53 | , std_err = CreatePipe 54 | } 55 | (_, mbStdout, _, rStty) <- createProcess stty 56 | exStty <- waitForProcess rStty 57 | case exStty of 58 | ExitFailure _ -> pure Nothing 59 | ExitSuccess -> 60 | maybe (pure Nothing) 61 | (\hSize -> do 62 | sizeStr <- hGetContents hSize 63 | case map read $ words sizeStr :: [Int] of 64 | [_r, c] -> pure $ Just c 65 | _ -> pure Nothing 66 | ) 67 | mbStdout 68 | else do 69 | [left,_top,right,_bottom] <- forM [0..3] $ \i -> do 70 | v <- peekByteOff p (i * 2 + posCONSOLE_SCREEN_BUFFER_INFO_srWindow) 71 | pure $ fromIntegral (v :: Word16) 72 | pure $ Just (1 + right - left) 73 | 74 | -- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal 75 | -- devices, but isMinTTYHandle does. 76 | hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool 77 | hIsTerminalDeviceOrMinTTY h = do 78 | isTD <- hIsTerminalDevice h 79 | if isTD 80 | then pure True 81 | else liftIO $ withHandleToHANDLE h isMinTTYHandle 82 | -------------------------------------------------------------------------------- /attic/hpack-0.1.2.3.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/commercialhaskell/pantry/2b685f3f094ad3ca470e96045c7f51267c39a161/attic/hpack-0.1.2.3.tar.gz -------------------------------------------------------------------------------- /attic/package-0.1.2.3.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/commercialhaskell/pantry/2b685f3f094ad3ca470e96045c7f51267c39a161/attic/package-0.1.2.3.tar.gz -------------------------------------------------------------------------------- /attic/symlink-to-dir.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/commercialhaskell/pantry/2b685f3f094ad3ca470e96045c7f51267c39a161/attic/symlink-to-dir.tar.gz -------------------------------------------------------------------------------- /int/Pantry/HPack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Pantry.HPack 7 | ( hpack 8 | , hpackVersion 9 | ) where 10 | 11 | import qualified Data.ByteString.Lazy.Char8 as BL 12 | import Data.Char ( isDigit, isSpace ) 13 | import qualified Hpack 14 | import qualified Hpack.Config as Hpack 15 | import Pantry.Types 16 | ( HasPantryConfig, HpackExecutable (..), PantryConfig (..) 17 | , Version, pantryConfigL, parseVersionThrowing 18 | ) 19 | import Path 20 | ( Abs, Dir, Path, (), filename, parseRelFile, toFilePath ) 21 | import Path.IO ( doesFileExist ) 22 | import RIO 23 | import RIO.Process 24 | ( HasProcessContext, proc, readProcessStdout_, runProcess_ 25 | , withWorkingDir 26 | ) 27 | 28 | hpackVersion :: 29 | (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 30 | => RIO env Version 31 | hpackVersion = do 32 | he <- view $ pantryConfigL.to pcHpackExecutable 33 | case he of 34 | HpackBundled -> do 35 | let bundledHpackVersion :: String = VERSION_hpack 36 | parseVersionThrowing bundledHpackVersion 37 | HpackCommand command -> do 38 | version <- BL.unpack <$> proc command ["--version"] readProcessStdout_ 39 | let version' = dropWhile (not . isDigit) version 40 | version'' = filter (not . isSpace) version' 41 | parseVersionThrowing version'' 42 | 43 | -- | Generate .cabal file from package.yaml, if necessary. 44 | hpack :: 45 | (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 46 | => Path Abs Dir 47 | -> RIO env () 48 | hpack pkgDir = do 49 | packageConfigRelFile <- parseRelFile Hpack.packageConfig 50 | let hpackFile = pkgDir Path. packageConfigRelFile 51 | whenM (doesFileExist hpackFile) $ do 52 | logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) 53 | he <- view $ pantryConfigL.to pcHpackExecutable 54 | hpackForce <- view $ pantryConfigL.to pcHpackForce 55 | case he of 56 | HpackBundled -> do 57 | r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ 58 | Hpack.setTarget 59 | (toFilePath hpackFile) 60 | Hpack.defaultOptions { Hpack.optionsForce = hpackForce } 61 | forM_ (Hpack.resultWarnings r) (logWarn . fromString) 62 | let cabalFile = fromString . Hpack.resultCabalFile $ r 63 | case Hpack.resultStatus r of 64 | Hpack.Generated -> logDebug $ 65 | "hpack generated a modified version of " 66 | <> cabalFile 67 | Hpack.OutputUnchanged -> logDebug $ 68 | "hpack output unchanged in " 69 | <> cabalFile 70 | Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ 71 | cabalFile 72 | <> " was generated with a newer version of hpack. Ignoring " 73 | <> fromString (toFilePath hpackFile) 74 | <> " in favor of the Cabal file.\n" 75 | <> "Either please upgrade and try again or, if you want to use the " 76 | <> fromString (toFilePath (filename hpackFile)) 77 | <> " file instead of the Cabal file,\n" 78 | <> "then please delete the Cabal file." 79 | Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ 80 | cabalFile 81 | <> " was modified manually. Ignoring " 82 | <> fromString (toFilePath hpackFile) 83 | <> " in favor of the Cabal file.\n" 84 | <> "If you want to use the " 85 | <> fromString (toFilePath (filename hpackFile)) 86 | <> " file instead of the Cabal file,\n" 87 | <> "then please delete the Cabal file." 88 | HpackCommand command -> do 89 | let hpackArgs = case hpackForce of 90 | Hpack.Force -> ["--force"] 91 | Hpack.NoForce -> [] 92 | withWorkingDir (toFilePath pkgDir) $ proc command hpackArgs runProcess_ 93 | -------------------------------------------------------------------------------- /int/Pantry/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Pantry.Internal 4 | ( normalizeParents 5 | , makeTarRelative 6 | ) where 7 | 8 | import Control.Exception ( assert ) 9 | import Data.Maybe ( fromMaybe ) 10 | import qualified Data.Text as T 11 | 12 | -- | Like @System.FilePath.normalise@, however: 13 | -- 14 | -- * Only works on relative paths, absolute paths fail 15 | -- 16 | -- * Strips trailing slashes 17 | -- 18 | -- * Only works on forward slashes, even on Windows 19 | -- 20 | -- * Normalizes parent dirs @foo/../@ get stripped 21 | -- 22 | -- * Cannot begin with a parent directory (@../@) 23 | -- 24 | -- * Spelled like an American, sorry 25 | normalizeParents :: 26 | FilePath 27 | -> Either String FilePath 28 | normalizeParents "" = Left "empty file path" 29 | normalizeParents ('/':_) = Left "absolute path" 30 | normalizeParents ('.':'.':'/':_) = Left "absolute path" 31 | normalizeParents fp = do 32 | -- Strip a single trailing, but not multiple 33 | let t0 = T.pack fp 34 | t = fromMaybe t0 $ T.stripSuffix "/" t0 35 | case T.unsnoc t of 36 | Just (_, '/') -> Left "multiple trailing slashes" 37 | _ -> Right () 38 | 39 | let c1 = T.split (== '/') t 40 | 41 | case reverse c1 of 42 | ".":_ -> Left "last component is a single dot" 43 | _ -> Right () 44 | 45 | let c2 = filter (\x -> not (T.null x || x == ".")) c1 46 | 47 | let loop [] routput = reverse routput 48 | loop ("..":rest) (_:routput) = loop rest routput 49 | loop (x:xs) routput = loop xs (x:routput) 50 | 51 | case loop c2 [] of 52 | [] -> Left "no non-empty components" 53 | c' -> Right $ T.unpack $ T.intercalate "/" c' 54 | 55 | -- | Following tar file rules (Unix file paths only), make the second file 56 | -- relative to the first file. 57 | makeTarRelative :: 58 | FilePath -- ^ base file 59 | -> FilePath -- ^ relative part 60 | -> Either String FilePath 61 | makeTarRelative _ ('/':_) = Left "absolute path found" 62 | makeTarRelative base rel = 63 | case reverse base of 64 | [] -> Left "cannot have empty base" 65 | '/':_ -> Left "base cannot be a directory" 66 | _:rest -> Right $ 67 | case dropWhile (/= '/') rest of 68 | '/':rest' -> reverse rest' ++ '/' : rel 69 | rest' -> assert (null rest') rel 70 | -------------------------------------------------------------------------------- /int/Pantry/SHA256.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | -- | Provides a data type ('SHA256') for efficient memory representation of a 8 | -- sha-256 hash value, together with helper functions for converting to and from 9 | -- that value. This module is intended to be imported qualified as @SHA256@. 10 | -- 11 | -- Some nomenclature: 12 | -- 13 | -- * Hashing calculates a new hash value from some input. @from@ takes a value 14 | -- that represents an existing hash. 15 | -- 16 | -- * Raw means a raw binary representation of the hash value, without any hex 17 | -- encoding. 18 | -- 19 | -- * Text always uses lower case hex encoding 20 | -- 21 | -- @since 0.1.0.0 22 | module Pantry.SHA256 23 | ( -- * Types 24 | SHA256 25 | , SHA256Exception (..) 26 | -- * Hashing 27 | , hashFile 28 | , hashBytes 29 | , hashLazyBytes 30 | , sinkHash 31 | -- * Convert from a hash representation 32 | , fromHexText 33 | , fromHexBytes 34 | , fromDigest 35 | , fromRaw 36 | -- * Convert to a hash representation 37 | , toHexText 38 | , toHexBytes 39 | , toRaw 40 | ) where 41 | 42 | import Conduit ( ConduitT ) 43 | import qualified Crypto.Hash as Hash ( Digest, SHA256, hash, hashlazy ) 44 | import qualified Crypto.Hash.Conduit as Hash ( hashFile, sinkHash ) 45 | import Data.Aeson ( FromJSON (..), ToJSON (..), withText ) 46 | import qualified Data.ByteArray 47 | import qualified Data.ByteArray.Encoding as Mem 48 | import Data.StaticBytes 49 | ( Bytes32, StaticBytesException, toStaticExact ) 50 | import Database.Persist.Class.PersistField ( PersistField (..) ) 51 | import Database.Persist.PersistValue ( PersistValue (..) ) 52 | import Database.Persist.Sql ( PersistFieldSql (..) ) 53 | import Database.Persist.Types ( SqlType (..) ) 54 | import RIO 55 | import qualified RIO.Text as T 56 | 57 | -- | A SHA256 hash, stored in a static size for more efficient 58 | -- memory representation. 59 | -- 60 | -- @since 0.1.0.0 61 | newtype SHA256 = SHA256 Bytes32 62 | deriving (Generic, Eq, NFData, Data, Typeable, Ord, Hashable) 63 | 64 | -- | Exceptions which can occur in this module 65 | -- 66 | -- @since 0.1.0.0 67 | data SHA256Exception 68 | = InvalidByteCount !ByteString !StaticBytesException 69 | | InvalidHexBytes !ByteString !Text 70 | deriving (Typeable) 71 | 72 | -- | Generate a 'SHA256' value by hashing the contents of a file. 73 | -- 74 | -- @since 0.1.0.0 75 | hashFile :: MonadIO m => FilePath -> m SHA256 76 | hashFile fp = fromDigest <$> Hash.hashFile fp 77 | 78 | -- | Generate a 'SHA256' value by hashing a @ByteString@. 79 | -- 80 | -- @since 0.1.0.0 81 | hashBytes :: ByteString -> SHA256 82 | hashBytes = fromDigest . Hash.hash 83 | 84 | -- | Generate a 'SHA256' value by hashing a lazy @ByteString@. 85 | -- 86 | -- @since 0.1.0.0 87 | hashLazyBytes :: LByteString -> SHA256 88 | hashLazyBytes = fromDigest . Hash.hashlazy 89 | 90 | -- | Generate a 'SHA256' value by hashing the contents of a stream. 91 | -- 92 | -- @since 0.1.0.0 93 | sinkHash :: Monad m => ConduitT ByteString o m SHA256 94 | sinkHash = fromDigest <$> Hash.sinkHash 95 | 96 | -- | Convert a base16-encoded 'Text' value containing a hash into a 'SHA256'. 97 | -- 98 | -- @since 0.1.0.0 99 | fromHexText :: Text -> Either SHA256Exception SHA256 100 | fromHexText = fromHexBytes . encodeUtf8 101 | 102 | -- | Convert a base16-encoded 'ByteString' value containing a hash into a 103 | -- 'SHA256'. 104 | -- 105 | -- @since 0.1.0.0 106 | fromHexBytes :: ByteString -> Either SHA256Exception SHA256 107 | fromHexBytes hexBS = do 108 | mapLeft (InvalidHexBytes hexBS . T.pack) (Mem.convertFromBase Mem.Base16 hexBS) >>= fromRaw 109 | 110 | -- | Convert a 'Hash.Digest' into a 'SHA256' 111 | -- 112 | -- @since 0.1.0.0 113 | fromDigest :: Hash.Digest Hash.SHA256 -> SHA256 114 | fromDigest digest = 115 | case toStaticExact (Data.ByteArray.convert digest :: ByteString) of 116 | Left e -> error $ "Impossible failure in fromDigest: " ++ show (digest, e) 117 | Right x -> SHA256 x 118 | 119 | -- | Convert a raw representation of a hash into a 'SHA256'. 120 | -- 121 | -- @since 0.1.0.0 122 | fromRaw :: ByteString -> Either SHA256Exception SHA256 123 | fromRaw bs = 124 | either (Left . InvalidByteCount bs) (Right . SHA256) (toStaticExact bs) 125 | 126 | -- | Convert a 'SHA256' into a base16-encoded SHA256 hash. 127 | -- 128 | -- @since 0.1.0.0 129 | toHexText :: SHA256 -> Text 130 | toHexText ss = 131 | case decodeUtf8' $ toHexBytes ss of 132 | Left e -> 133 | error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e) 134 | Right t -> t 135 | 136 | -- | Convert a 'SHA256' into a base16-encoded SHA256 hash. 137 | -- 138 | -- @since 0.1.0.0 139 | toHexBytes :: SHA256 -> ByteString 140 | toHexBytes (SHA256 x) = Mem.convertToBase Mem.Base16 x 141 | 142 | -- | Convert a 'SHA256' into a raw binary representation. 143 | -- 144 | -- @since 0.1.0.0 145 | toRaw :: SHA256 -> ByteString 146 | toRaw (SHA256 x) = Data.ByteArray.convert x 147 | 148 | -- Instances 149 | 150 | instance Show SHA256 where 151 | show s = "SHA256 " ++ show (toHexText s) 152 | 153 | instance PersistField SHA256 where 154 | toPersistValue = PersistByteString . toRaw 155 | fromPersistValue (PersistByteString bs) = 156 | case toStaticExact bs of 157 | Left e -> Left $ tshow e 158 | Right ss -> pure $ SHA256 ss 159 | fromPersistValue x = Left $ "Unexpected value: " <> tshow x 160 | 161 | instance PersistFieldSql SHA256 where 162 | sqlType _ = SqlBlob 163 | 164 | instance Display SHA256 where 165 | display = displayBytesUtf8 . toHexBytes 166 | 167 | instance ToJSON SHA256 where 168 | toJSON = toJSON . toHexText 169 | instance FromJSON SHA256 where 170 | parseJSON = withText "SHA256" $ \t -> 171 | case fromHexText t of 172 | Right x -> pure x 173 | Left e -> fail $ concat 174 | [ "Invalid SHA256 " 175 | , show t 176 | , ": " 177 | , show e 178 | ] 179 | 180 | instance Exception SHA256Exception 181 | instance Show SHA256Exception where 182 | show = T.unpack . utf8BuilderToText . display 183 | 184 | -- To support the Haskell Foundation's 185 | -- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry 186 | -- error messages generated by Pantry itself begin with an unique code in the 187 | -- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999. 188 | -- The numbers are selected at random, not in sequence. 189 | instance Display SHA256Exception where 190 | display (InvalidByteCount bs sbe) = 191 | "Error: [S-161]\n" 192 | <> "Invalid byte count creating a SHA256 from " 193 | <> displayShow bs 194 | <> ": " 195 | <> displayShow sbe 196 | display (InvalidHexBytes bs t) = 197 | "Error: [S-165]\n" 198 | <> "Invalid hex bytes creating a SHA256: " 199 | <> displayShow bs 200 | <> ": " 201 | <> display t 202 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: pantry 2 | version: 0.10.1 3 | synopsis: Content addressable Haskell package management 4 | description: Please see the README on GitHub at 5 | category: Development 6 | author: Michael Snoyman 7 | maintainer: michael@snoyman.com 8 | copyright: 2018-2022 FP Complete 9 | license: BSD3 10 | github: commercialhaskell/pantry 11 | 12 | extra-source-files: 13 | - CONTRIBUTING.md 14 | - README.md 15 | - ChangeLog.md 16 | - attic/hpack-0.1.2.3.tar.gz 17 | - attic/package-0.1.2.3.tar.gz 18 | - attic/symlink-to-dir.tar.gz 19 | 20 | flags: 21 | test-pretty-exceptions: 22 | description: Build an executable to test pretty exceptions 23 | default: false 24 | manual: false 25 | 26 | dependencies: 27 | - base >= 4.13 && < 5 28 | - aeson 29 | - aeson-warning-parser >= 0.1.1 30 | - ansi-terminal 31 | - bytestring 32 | - Cabal >= 3 && < 3.15 33 | - casa-client >= 0.0.2 34 | - casa-types 35 | - companion 36 | - conduit 37 | - conduit-extra 38 | - containers 39 | - crypton 40 | - crypton-conduit 41 | - digest 42 | - filelock 43 | - generic-deriving 44 | - hackage-security 45 | - hpack >= 0.35.3 46 | - http-client 47 | - http-client-tls >= 0.3.6.2 48 | - http-conduit 49 | - http-download >= 0.2.1.0 50 | - http-types 51 | - memory 52 | - mtl 53 | - network-uri 54 | - path 55 | - path-io 56 | - persistent 57 | - persistent-sqlite >= 2.9.3 58 | - persistent-template 59 | - primitive 60 | - resourcet 61 | - rio 62 | - rio-orphans 63 | - rio-prettyprint >= 0.1.7.0 64 | - static-bytes >= 0.1.1 65 | - tar-conduit >= 0.4.1 66 | - text 67 | - text-metrics 68 | - time 69 | - transformers 70 | - unix-compat 71 | - unliftio 72 | - unordered-containers 73 | - vector 74 | - yaml 75 | - zip-archive 76 | 77 | # See https://github.com/haskell/network/pull/552. 78 | when: 79 | condition: impl(ghc >= 9.4.5) && os(windows) 80 | dependencies: network >= 3.1.2.9 81 | 82 | ghc-options: 83 | - -fwrite-ide-info 84 | - -hiedir=.hie 85 | - -Wall 86 | 87 | # For testing 88 | internal-libraries: 89 | internal: 90 | source-dirs: int/ 91 | 92 | library: 93 | source-dirs: src/ 94 | when: 95 | - condition: 'os(windows)' 96 | then: 97 | source-dirs: src/windows/ 98 | else: 99 | source-dirs: src/unix/ 100 | dependencies: 101 | - internal 102 | 103 | exposed-modules: 104 | - Pantry 105 | - Pantry.SQLite 106 | 107 | # For stackage-server, and stack testing 108 | - Pantry.Internal.Stackage 109 | 110 | reexported-modules: 111 | - Pantry.SHA256 112 | 113 | other-modules: 114 | - Hackage.Security.Client.Repository.HttpLib.HttpClient 115 | - Pantry.Archive 116 | - Pantry.HTTP 117 | - Pantry.Hackage 118 | - Pantry.Repo 119 | - Pantry.Storage 120 | - Pantry.Casa 121 | - Pantry.Tree 122 | 123 | executables: 124 | test-pretty-exceptions: 125 | when: 126 | - condition: "!flag(test-pretty-exceptions)" 127 | buildable: false 128 | - condition: 'os(windows)' 129 | then: 130 | source-dirs: app/test-pretty-exceptions/windows/ 131 | dependencies: 132 | - process 133 | - Win32 134 | else: 135 | source-dirs: app/test-pretty-exceptions/unix/ 136 | main: Main.hs 137 | source-dirs: app/test-pretty-exceptions 138 | dependencies: 139 | - pantry 140 | - optparse-applicative 141 | 142 | tests: 143 | spec: 144 | build-tools: hspec-discover 145 | source-dirs: test 146 | main: Spec.hs 147 | dependencies: 148 | - pantry 149 | - exceptions 150 | - hedgehog 151 | - hspec 152 | - QuickCheck 153 | - raw-strings-qq 154 | - internal 155 | -------------------------------------------------------------------------------- /pantry.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.38.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: pantry 8 | version: 0.10.1 9 | synopsis: Content addressable Haskell package management 10 | description: Please see the README on GitHub at 11 | category: Development 12 | homepage: https://github.com/commercialhaskell/pantry#readme 13 | bug-reports: https://github.com/commercialhaskell/pantry/issues 14 | author: Michael Snoyman 15 | maintainer: michael@snoyman.com 16 | copyright: 2018-2022 FP Complete 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | CONTRIBUTING.md 22 | README.md 23 | ChangeLog.md 24 | attic/hpack-0.1.2.3.tar.gz 25 | attic/package-0.1.2.3.tar.gz 26 | attic/symlink-to-dir.tar.gz 27 | 28 | source-repository head 29 | type: git 30 | location: https://github.com/commercialhaskell/pantry 31 | 32 | flag test-pretty-exceptions 33 | description: Build an executable to test pretty exceptions 34 | manual: False 35 | default: False 36 | 37 | library 38 | exposed-modules: 39 | Pantry 40 | Pantry.SQLite 41 | Pantry.Internal.Stackage 42 | other-modules: 43 | Hackage.Security.Client.Repository.HttpLib.HttpClient 44 | Pantry.Archive 45 | Pantry.HTTP 46 | Pantry.Hackage 47 | Pantry.Repo 48 | Pantry.Storage 49 | Pantry.Casa 50 | Pantry.Tree 51 | reexported-modules: 52 | Pantry.SHA256 53 | hs-source-dirs: 54 | src/ 55 | ghc-options: -fwrite-ide-info -hiedir=.hie -Wall 56 | build-depends: 57 | Cabal >=3 && <3.15 58 | , aeson 59 | , aeson-warning-parser >=0.1.1 60 | , ansi-terminal 61 | , base >=4.13 && <5 62 | , bytestring 63 | , casa-client >=0.0.2 64 | , casa-types 65 | , companion 66 | , conduit 67 | , conduit-extra 68 | , containers 69 | , crypton 70 | , crypton-conduit 71 | , digest 72 | , filelock 73 | , generic-deriving 74 | , hackage-security 75 | , hpack >=0.35.3 76 | , http-client 77 | , http-client-tls >=0.3.6.2 78 | , http-conduit 79 | , http-download >=0.2.1.0 80 | , http-types 81 | , internal 82 | , memory 83 | , mtl 84 | , network-uri 85 | , path 86 | , path-io 87 | , persistent 88 | , persistent-sqlite >=2.9.3 89 | , persistent-template 90 | , primitive 91 | , resourcet 92 | , rio 93 | , rio-orphans 94 | , rio-prettyprint >=0.1.7.0 95 | , static-bytes >=0.1.1 96 | , tar-conduit >=0.4.1 97 | , text 98 | , text-metrics 99 | , time 100 | , transformers 101 | , unix-compat 102 | , unliftio 103 | , unordered-containers 104 | , vector 105 | , yaml 106 | , zip-archive 107 | default-language: Haskell2010 108 | if impl(ghc >= 9.4.5) && os(windows) 109 | build-depends: 110 | network >=3.1.2.9 111 | if os(windows) 112 | other-modules: 113 | System.IsWindows 114 | hs-source-dirs: 115 | src/windows/ 116 | else 117 | other-modules: 118 | System.IsWindows 119 | hs-source-dirs: 120 | src/unix/ 121 | 122 | library internal 123 | exposed-modules: 124 | Pantry.HPack 125 | Pantry.Internal 126 | Pantry.SHA256 127 | Pantry.Types 128 | other-modules: 129 | Paths_pantry 130 | autogen-modules: 131 | Paths_pantry 132 | hs-source-dirs: 133 | int/ 134 | ghc-options: -fwrite-ide-info -hiedir=.hie -Wall 135 | build-depends: 136 | Cabal >=3 && <3.15 137 | , aeson 138 | , aeson-warning-parser >=0.1.1 139 | , ansi-terminal 140 | , base >=4.13 && <5 141 | , bytestring 142 | , casa-client >=0.0.2 143 | , casa-types 144 | , companion 145 | , conduit 146 | , conduit-extra 147 | , containers 148 | , crypton 149 | , crypton-conduit 150 | , digest 151 | , filelock 152 | , generic-deriving 153 | , hackage-security 154 | , hpack >=0.35.3 155 | , http-client 156 | , http-client-tls >=0.3.6.2 157 | , http-conduit 158 | , http-download >=0.2.1.0 159 | , http-types 160 | , memory 161 | , mtl 162 | , network-uri 163 | , path 164 | , path-io 165 | , persistent 166 | , persistent-sqlite >=2.9.3 167 | , persistent-template 168 | , primitive 169 | , resourcet 170 | , rio 171 | , rio-orphans 172 | , rio-prettyprint >=0.1.7.0 173 | , static-bytes >=0.1.1 174 | , tar-conduit >=0.4.1 175 | , text 176 | , text-metrics 177 | , time 178 | , transformers 179 | , unix-compat 180 | , unliftio 181 | , unordered-containers 182 | , vector 183 | , yaml 184 | , zip-archive 185 | default-language: Haskell2010 186 | if impl(ghc >= 9.4.5) && os(windows) 187 | build-depends: 188 | network >=3.1.2.9 189 | 190 | executable test-pretty-exceptions 191 | main-is: Main.hs 192 | other-modules: 193 | Paths_pantry 194 | autogen-modules: 195 | Paths_pantry 196 | hs-source-dirs: 197 | app/test-pretty-exceptions 198 | ghc-options: -fwrite-ide-info -hiedir=.hie -Wall 199 | build-depends: 200 | Cabal >=3 && <3.15 201 | , aeson 202 | , aeson-warning-parser >=0.1.1 203 | , ansi-terminal 204 | , base >=4.13 && <5 205 | , bytestring 206 | , casa-client >=0.0.2 207 | , casa-types 208 | , companion 209 | , conduit 210 | , conduit-extra 211 | , containers 212 | , crypton 213 | , crypton-conduit 214 | , digest 215 | , filelock 216 | , generic-deriving 217 | , hackage-security 218 | , hpack >=0.35.3 219 | , http-client 220 | , http-client-tls >=0.3.6.2 221 | , http-conduit 222 | , http-download >=0.2.1.0 223 | , http-types 224 | , memory 225 | , mtl 226 | , network-uri 227 | , optparse-applicative 228 | , pantry 229 | , path 230 | , path-io 231 | , persistent 232 | , persistent-sqlite >=2.9.3 233 | , persistent-template 234 | , primitive 235 | , resourcet 236 | , rio 237 | , rio-orphans 238 | , rio-prettyprint >=0.1.7.0 239 | , static-bytes >=0.1.1 240 | , tar-conduit >=0.4.1 241 | , text 242 | , text-metrics 243 | , time 244 | , transformers 245 | , unix-compat 246 | , unliftio 247 | , unordered-containers 248 | , vector 249 | , yaml 250 | , zip-archive 251 | default-language: Haskell2010 252 | if impl(ghc >= 9.4.5) && os(windows) 253 | build-depends: 254 | network >=3.1.2.9 255 | if !flag(test-pretty-exceptions) 256 | buildable: False 257 | if os(windows) 258 | other-modules: 259 | PathAbsExamples 260 | System.Terminal 261 | hs-source-dirs: 262 | app/test-pretty-exceptions/windows/ 263 | build-depends: 264 | Win32 265 | , process 266 | else 267 | other-modules: 268 | PathAbsExamples 269 | System.Terminal 270 | hs-source-dirs: 271 | app/test-pretty-exceptions/unix/ 272 | 273 | test-suite spec 274 | type: exitcode-stdio-1.0 275 | main-is: Spec.hs 276 | other-modules: 277 | Pantry.ArchiveSpec 278 | Pantry.BuildPlanSpec 279 | Pantry.CabalSpec 280 | Pantry.CasaSpec 281 | Pantry.FileSpec 282 | Pantry.GlobalHintsSpec 283 | Pantry.HackageSpec 284 | Pantry.InternalSpec 285 | Pantry.TreeSpec 286 | Pantry.TypesSpec 287 | Paths_pantry 288 | autogen-modules: 289 | Paths_pantry 290 | hs-source-dirs: 291 | test 292 | ghc-options: -fwrite-ide-info -hiedir=.hie -Wall 293 | build-tool-depends: 294 | hspec-discover:hspec-discover 295 | build-depends: 296 | Cabal >=3 && <3.15 297 | , QuickCheck 298 | , aeson 299 | , aeson-warning-parser >=0.1.1 300 | , ansi-terminal 301 | , base >=4.13 && <5 302 | , bytestring 303 | , casa-client >=0.0.2 304 | , casa-types 305 | , companion 306 | , conduit 307 | , conduit-extra 308 | , containers 309 | , crypton 310 | , crypton-conduit 311 | , digest 312 | , exceptions 313 | , filelock 314 | , generic-deriving 315 | , hackage-security 316 | , hedgehog 317 | , hpack >=0.35.3 318 | , hspec 319 | , http-client 320 | , http-client-tls >=0.3.6.2 321 | , http-conduit 322 | , http-download >=0.2.1.0 323 | , http-types 324 | , internal 325 | , memory 326 | , mtl 327 | , network-uri 328 | , pantry 329 | , path 330 | , path-io 331 | , persistent 332 | , persistent-sqlite >=2.9.3 333 | , persistent-template 334 | , primitive 335 | , raw-strings-qq 336 | , resourcet 337 | , rio 338 | , rio-orphans 339 | , rio-prettyprint >=0.1.7.0 340 | , static-bytes >=0.1.1 341 | , tar-conduit >=0.4.1 342 | , text 343 | , text-metrics 344 | , time 345 | , transformers 346 | , unix-compat 347 | , unliftio 348 | , unordered-containers 349 | , vector 350 | , yaml 351 | , zip-archive 352 | default-language: Haskell2010 353 | if impl(ghc >= 9.4.5) && os(windows) 354 | build-depends: 355 | network >=3.1.2.9 356 | -------------------------------------------------------------------------------- /src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs: -------------------------------------------------------------------------------- 1 | -- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | -- Adapted from `hackage-security-http-client` to use our own 8 | -- `Pantry.HTTP` implementation 9 | module Hackage.Security.Client.Repository.HttpLib.HttpClient 10 | ( httpLib 11 | ) where 12 | 13 | import Control.Exception ( handle ) 14 | import Control.Monad ( void ) 15 | import Data.ByteString ( ByteString ) 16 | import qualified Data.ByteString as BS 17 | import qualified Data.ByteString.Char8 as BS.C8 18 | import Hackage.Security.Client ( SomeRemoteError (..) ) 19 | import Hackage.Security.Client.Repository.HttpLib 20 | ( BodyReader, HttpLib (..), HttpRequestHeader (..) 21 | , HttpResponseHeader (..), HttpStatus (..) 22 | ) 23 | import Hackage.Security.Util.Checked 24 | ( Throws, handleChecked, throwChecked ) 25 | import Network.URI ( URI ) 26 | import qualified Pantry.HTTP as HTTP 27 | 28 | {------------------------------------------------------------------------------- 29 | Top-level API 30 | -------------------------------------------------------------------------------} 31 | 32 | -- | An 'HttpLib' value using the default global manager 33 | httpLib :: HttpLib 34 | httpLib = HttpLib 35 | { httpGet = get 36 | , httpGetRange = getRange 37 | } 38 | 39 | {------------------------------------------------------------------------------- 40 | Individual methods 41 | -------------------------------------------------------------------------------} 42 | 43 | get :: 44 | Throws SomeRemoteError 45 | => [HttpRequestHeader] -> URI 46 | -> ([HttpResponseHeader] -> BodyReader -> IO a) 47 | -> IO a 48 | get reqHeaders uri callback = wrapCustomEx $ do 49 | -- TODO: setUri fails under certain circumstances; in particular, when 50 | -- the URI contains URL auth. Not sure if this is a concern. 51 | request' <- HTTP.setUri HTTP.defaultRequest uri 52 | let request = setRequestHeaders reqHeaders request' 53 | checkHttpException $ HTTP.withResponse request $ \response -> do 54 | let br = wrapCustomEx $ HTTP.getResponseBody response 55 | callback (getResponseHeaders response) br 56 | 57 | getRange :: 58 | Throws SomeRemoteError 59 | => [HttpRequestHeader] 60 | -> URI 61 | -> (Int, Int) 62 | -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) 63 | -> IO a 64 | getRange reqHeaders uri (from, to) callback = wrapCustomEx $ do 65 | request' <- HTTP.setUri HTTP.defaultRequest uri 66 | let request = setRange from to 67 | $ setRequestHeaders reqHeaders request' 68 | checkHttpException $ HTTP.withResponse request $ \response -> do 69 | let br = wrapCustomEx $ HTTP.getResponseBody response 70 | case () of 71 | () | HTTP.getResponseStatus response == HTTP.partialContent206 -> 72 | callback HttpStatus206PartialContent (getResponseHeaders response) br 73 | () | HTTP.getResponseStatus response == HTTP.ok200 -> 74 | callback HttpStatus200OK (getResponseHeaders response) br 75 | _otherwise -> 76 | throwChecked $ HTTP.HttpExceptionRequest request 77 | $ HTTP.StatusCodeException (void response) "" 78 | 79 | -- | Wrap custom exceptions 80 | -- 81 | -- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@ 82 | -- but it is currently disabled 83 | wrapCustomEx :: 84 | (Throws HTTP.HttpException => IO a) 85 | -> (Throws SomeRemoteError => IO a) 86 | wrapCustomEx = handleChecked (\(ex :: HTTP.HttpException) -> go ex) 87 | where 88 | go ex = throwChecked (SomeRemoteError ex) 89 | 90 | checkHttpException :: Throws HTTP.HttpException => IO a -> IO a 91 | checkHttpException = handle $ \(ex :: HTTP.HttpException) -> 92 | throwChecked ex 93 | 94 | {------------------------------------------------------------------------------- 95 | http-client auxiliary 96 | -------------------------------------------------------------------------------} 97 | 98 | hAcceptRanges :: HTTP.HeaderName 99 | hAcceptRanges = "Accept-Ranges" 100 | 101 | hAcceptEncoding :: HTTP.HeaderName 102 | hAcceptEncoding = "Accept-Encoding" 103 | 104 | setRange :: 105 | Int 106 | -> Int 107 | -> HTTP.Request 108 | -> HTTP.Request 109 | setRange from to = 110 | HTTP.addRequestHeader HTTP.hRange rangeHeader 111 | where 112 | -- Content-Range header uses inclusive rather than exclusive bounds 113 | -- See 114 | rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1) 115 | 116 | -- | Set request headers 117 | setRequestHeaders :: 118 | [HttpRequestHeader] 119 | -> HTTP.Request 120 | -> HTTP.Request 121 | setRequestHeaders opts = 122 | setRequestHeaders' (trOpt disallowCompressionByDefault opts) 123 | where 124 | setRequestHeaders' :: [HTTP.Header] -> HTTP.Request -> HTTP.Request 125 | setRequestHeaders' = 126 | foldr (\(name, val) f -> f . HTTP.setRequestHeader name [val]) id 127 | 128 | trOpt :: 129 | [(HTTP.HeaderName, [ByteString])] 130 | -> [HttpRequestHeader] 131 | -> [HTTP.Header] 132 | trOpt acc [] = 133 | map finalizeHeader acc 134 | trOpt acc (HttpRequestMaxAge0:os) = 135 | trOpt (insert HTTP.hCacheControl ["max-age=0"] acc) os 136 | trOpt acc (HttpRequestNoTransform:os) = 137 | trOpt (insert HTTP.hCacheControl ["no-transform"] acc) os 138 | 139 | -- disable content compression (potential security issue) 140 | disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])] 141 | disallowCompressionByDefault = [(hAcceptEncoding, [])] 142 | 143 | -- Some headers are comma-separated, others need multiple headers for 144 | -- multiple options. 145 | -- 146 | -- TODO: Right we we just comma-separate all of them. 147 | finalizeHeader :: 148 | (HTTP.HeaderName, [ByteString]) 149 | -> HTTP.Header 150 | finalizeHeader (name, strs) = (name, BS.intercalate ", " (reverse strs)) 151 | 152 | insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] 153 | insert _ _ [] = [] 154 | insert x y ((k, v):pairs) 155 | | x == k = (k, v ++ y) : insert x y pairs 156 | | otherwise = (k, v) : insert x y pairs 157 | 158 | -- | Extract the response headers 159 | getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader] 160 | getResponseHeaders response = 161 | [ HttpResponseAcceptRangesBytes | (hAcceptRanges, "bytes") `elem` headers ] 162 | where 163 | headers = HTTP.getResponseHeaders response 164 | -------------------------------------------------------------------------------- /src/Pantry/Archive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TupleSections #-} 5 | 6 | -- | Logic for loading up trees from HTTPS archives. 7 | module Pantry.Archive 8 | ( getArchivePackage 9 | , getArchive 10 | , getArchiveKey 11 | , fetchArchivesRaw 12 | , fetchArchives 13 | , findCabalOrHpackFile 14 | ) where 15 | 16 | import qualified Codec.Archive.Zip as Zip 17 | import Conduit 18 | ( ConduitT, (.|), runConduit, sinkHandle, sinkList 19 | , sourceHandle, sourceLazy, withSourceFile 20 | ) 21 | import Data.Bits ( (.&.), shiftR ) 22 | import qualified Data.Conduit.Tar as Tar 23 | import Data.Conduit.Zlib ( ungzip ) 24 | import qualified Data.Digest.CRC32 as CRC32 25 | import Distribution.PackageDescription ( package, packageDescription ) 26 | import qualified Hpack.Config as Hpack 27 | import Pantry.HPack ( hpackVersion ) 28 | import Pantry.HTTP ( httpSinkChecked ) 29 | import Pantry.Internal ( makeTarRelative, normalizeParents ) 30 | import qualified Pantry.SHA256 as SHA256 31 | import Pantry.Storage 32 | ( BlobId, CachedTree (..), TreeId, hpackToCabal 33 | , loadArchiveCache, loadBlob, loadCabalBlobKey 34 | , loadCachedTree, loadPackageById, storeArchiveCache 35 | , storeBlob, storeHPack, storeTree, unCachedTree, withStorage 36 | ) 37 | import Pantry.Tree ( rawParseGPD ) 38 | import Pantry.Types 39 | ( Archive, ArchiveLocation (..), BlobKey, BuildFile (..) 40 | , FileSize (..), FileType (..), HasPantryConfig 41 | , Mismatch (..), Package (..), PackageCabal (..) 42 | , PackageIdentifier (..), PackageMetadata (..) 43 | , PantryException (..), PHpack (..), RawArchive (..) 44 | , RawPackageLocationImmutable (..), RawPackageMetadata (..) 45 | , ResolvedPath (..), SHA256, Tree (..), TreeEntry (..) 46 | , TreeKey, cabalFileName, hpackSafeFilePath, mkSafeFilePath 47 | , toRawArchive, toRawPM, unSafeFilePath 48 | ) 49 | import Path ( toFilePath ) 50 | import Path.IO ( doesFileExist ) 51 | import RIO 52 | import qualified RIO.ByteString.Lazy as BL 53 | import qualified RIO.List as List 54 | import qualified RIO.Map as Map 55 | import RIO.Process ( HasProcessContext ) 56 | import qualified RIO.Set as Set 57 | import qualified RIO.Text as T 58 | import qualified RIO.Text.Partial as T 59 | 60 | fetchArchivesRaw :: 61 | (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 62 | => [(RawArchive, RawPackageMetadata)] 63 | -> RIO env () 64 | fetchArchivesRaw pairs = 65 | for_ pairs $ \(ra, rpm) -> 66 | getArchive (RPLIArchive ra rpm) ra rpm 67 | 68 | fetchArchives :: 69 | (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 70 | => [(Archive, PackageMetadata)] 71 | -> RIO env () 72 | fetchArchives pairs = 73 | -- TODO be more efficient, group together shared archives 74 | fetchArchivesRaw [(toRawArchive a, toRawPM pm) | (a, pm) <- pairs] 75 | 76 | getArchiveKey :: 77 | forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 78 | => RawPackageLocationImmutable -- ^ for exceptions 79 | -> RawArchive 80 | -> RawPackageMetadata 81 | -> RIO env TreeKey 82 | getArchiveKey rpli archive rpm = 83 | packageTreeKey <$> getArchivePackage rpli archive rpm -- potential optimization 84 | 85 | thd4 :: (a, b, c, d) -> c 86 | thd4 (_, _, z, _) = z 87 | 88 | getArchivePackage :: 89 | forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) 90 | => RawPackageLocationImmutable -- ^ for exceptions 91 | -> RawArchive 92 | -> RawPackageMetadata 93 | -> RIO env Package 94 | getArchivePackage rpli archive rpm = thd4 <$> getArchive rpli archive rpm 95 | 96 | getArchive :: 97 | forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) 98 | => RawPackageLocationImmutable -- ^ for exceptions 99 | -> RawArchive 100 | -> RawPackageMetadata 101 | -> RIO env (SHA256, FileSize, Package, CachedTree) 102 | getArchive rpli archive rpm = do 103 | -- Check if the value is in the cache, and use it if possible 104 | mcached <- loadCache rpli archive 105 | -- Ensure that all of the blobs referenced exist in the cache 106 | -- See: https://github.com/commercialhaskell/pantry/issues/27 107 | mtree <- 108 | case mcached of 109 | Nothing -> pure Nothing 110 | Just (_, _, pa) -> do 111 | etree <- withStorage $ loadCachedTree $ packageTree pa 112 | case etree of 113 | Left e -> do 114 | logDebug $ 115 | "getArchive of " 116 | <> displayShow rpli 117 | <> ": loadCachedTree failed: " 118 | <> displayShow e 119 | pure Nothing 120 | Right x -> pure $ Just x 121 | cached@(_, _, pa, _) <- 122 | case (mcached, mtree) of 123 | (Just (a, b, c), Just d) -> pure (a, b, c, d) 124 | -- Not in the archive. Load the archive. Completely ignore the 125 | -- PackageMetadata for now, we'll check that the Package info matches 126 | -- next. 127 | _ -> withArchiveLoc archive $ \fp sha size -> do 128 | (pa, tree) <- parseArchive rpli archive fp 129 | -- Storing in the cache exclusively uses information we have about the 130 | -- archive itself, not metadata from the user. 131 | storeCache archive sha size pa 132 | pure (sha, size, pa, tree) 133 | 134 | either throwIO (\_ -> pure cached) $ checkPackageMetadata rpli rpm pa 135 | 136 | storeCache :: 137 | forall env. (HasPantryConfig env, HasLogFunc env) 138 | => RawArchive 139 | -> SHA256 140 | -> FileSize 141 | -> Package 142 | -> RIO env () 143 | storeCache archive sha size pa = 144 | case raLocation archive of 145 | ALUrl url -> withStorage $ 146 | storeArchiveCache url (raSubdir archive) sha size (packageTreeKey pa) 147 | ALFilePath _ -> pure () -- TODO cache local as well 148 | 149 | loadCache :: 150 | forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 151 | => RawPackageLocationImmutable 152 | -> RawArchive 153 | -> RIO env (Maybe (SHA256, FileSize, Package)) 154 | loadCache rpli archive = 155 | case loc of 156 | ALFilePath _ -> pure Nothing -- TODO can we do something intelligent here? 157 | ALUrl url -> withStorage (loadArchiveCache url (raSubdir archive)) >>= loop 158 | where 159 | loc = raLocation archive 160 | msha = raHash archive 161 | msize = raSize archive 162 | 163 | loadFromCache :: TreeId -> RIO env (Maybe Package) 164 | loadFromCache tid = fmap Just $ withStorage $ loadPackageById rpli tid 165 | 166 | loop [] = pure Nothing 167 | loop ((sha, size, tid):rest) = 168 | case msha of 169 | Nothing -> do 170 | case msize of 171 | Just size' | size /= size' -> loop rest 172 | _ -> do 173 | case loc of 174 | ALUrl url -> do 175 | -- Only debug level, let lock files solve this 176 | logDebug $ 177 | "Using archive from " 178 | <> display url 179 | <> " without a specified cryptographic hash" 180 | logDebug $ 181 | "Cached hash is " 182 | <> display sha 183 | <> ", file size " 184 | <> display size 185 | ALFilePath _ -> pure () 186 | fmap (sha, size,) <$> loadFromCache tid 187 | Just sha' 188 | | sha == sha' -> 189 | case msize of 190 | Nothing -> do 191 | case loc of 192 | -- Only debug level, let lock files solve this 193 | ALUrl url -> logDebug $ 194 | "Archive from " 195 | <> display url 196 | <> " does not specify a size" 197 | ALFilePath _ -> pure () 198 | fmap (sha, size,) <$> loadFromCache tid 199 | Just size' 200 | | size == size' -> fmap (sha, size,) <$> loadFromCache tid 201 | | otherwise -> do 202 | -- This is an actual warning, since we have a concrete 203 | -- mismatch 204 | logWarn $ 205 | "Archive from " 206 | <> display loc 207 | <> " has a matching hash but mismatched size" 208 | logWarn "Please verify that your configuration provides \ 209 | \the correct size" 210 | loop rest 211 | | otherwise -> loop rest 212 | 213 | -- ensure name, version, etc are correct 214 | checkPackageMetadata :: 215 | RawPackageLocationImmutable 216 | -> RawPackageMetadata 217 | -> Package 218 | -> Either PantryException Package 219 | checkPackageMetadata pl pm pa = do 220 | let 221 | err = MismatchedPackageMetadata 222 | pl 223 | pm 224 | (Just (packageTreeKey pa)) 225 | (packageIdent pa) 226 | 227 | test :: Eq a => Maybe a -> a -> Bool 228 | test (Just x) y = x == y 229 | test Nothing _ = True 230 | 231 | tests = 232 | [ test (rpmTreeKey pm) (packageTreeKey pa) 233 | , test (rpmName pm) (pkgName $ packageIdent pa) 234 | , test (rpmVersion pm) (pkgVersion $ packageIdent pa) 235 | ] 236 | 237 | in if and tests then Right pa else Left err 238 | 239 | -- | Provide a local file with the contents of the archive, regardless of where 240 | -- it comes from. If not downloading, checks that the archive file exists. 241 | -- Performs SHA256 and file size validation. 242 | withArchiveLoc :: 243 | HasLogFunc env 244 | => RawArchive 245 | -> (FilePath -> SHA256 -> FileSize -> RIO env a) 246 | -> RIO env a 247 | withArchiveLoc (RawArchive (ALFilePath resolved) msha msize _subdir) f = do 248 | let abs' = resolvedAbsolute resolved 249 | fp = toFilePath abs' 250 | archiveExists <- doesFileExist abs' 251 | unless archiveExists $ 252 | throwIO $ LocalNoArchiveFileFound abs' 253 | (sha, size) <- withBinaryFile fp ReadMode $ \h -> do 254 | size <- FileSize . fromIntegral <$> hFileSize h 255 | for_ msize $ \size' -> 256 | when (size /= size') $ 257 | throwIO $ LocalInvalidSize abs' Mismatch 258 | { mismatchExpected = size' 259 | , mismatchActual = size 260 | } 261 | 262 | sha <- runConduit (sourceHandle h .| SHA256.sinkHash) 263 | for_ msha $ \sha' -> 264 | when (sha /= sha') $ 265 | throwIO $ LocalInvalidSHA256 abs' Mismatch 266 | { mismatchExpected = sha' 267 | , mismatchActual = sha 268 | } 269 | 270 | pure (sha, size) 271 | f fp sha size 272 | withArchiveLoc (RawArchive (ALUrl url) msha msize _subdir) f = 273 | withSystemTempFile "archive" $ \fp hout -> do 274 | logDebug $ "Downloading archive from " <> display url 275 | (sha, size, ()) <- httpSinkChecked url msha msize (sinkHandle hout) 276 | hClose hout 277 | f fp sha size 278 | 279 | data ArchiveType = ATTarGz | ATTar | ATZip 280 | deriving (Enum, Bounded) 281 | 282 | instance Display ArchiveType where 283 | display ATTarGz = "GZIP-ed tar file" 284 | display ATTar = "Uncompressed tar file" 285 | display ATZip = "Zip file" 286 | 287 | data METype 288 | = METNormal 289 | | METExecutable 290 | | METLink !FilePath 291 | deriving Show 292 | 293 | data MetaEntry = MetaEntry 294 | { mePath :: !FilePath 295 | , meType :: !METype 296 | } 297 | deriving Show 298 | 299 | foldArchive :: 300 | (HasPantryConfig env, HasLogFunc env) 301 | => ArchiveLocation -- ^ for error reporting 302 | -> FilePath 303 | -> ArchiveType 304 | -> a 305 | -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a) 306 | -> RIO env a 307 | foldArchive loc fp ATTarGz accum f = 308 | withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar loc accum f 309 | foldArchive loc fp ATTar accum f = 310 | withSourceFile fp $ \src -> runConduit $ src .| foldTar loc accum f 311 | foldArchive loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do 312 | let go accum entry = do 313 | let normalizedRelPath = removeInitialDotSlash $ Zip.eRelativePath entry 314 | me = MetaEntry normalizedRelPath met 315 | met = fromMaybe METNormal $ do 316 | let modes = shiftR (Zip.eExternalFileAttributes entry) 16 317 | guard $ Zip.eVersionMadeBy entry .&. 0xFF00 == 0x0300 318 | guard $ modes /= 0 319 | Just $ 320 | if (modes .&. 0o100) == 0 321 | then METNormal 322 | else METExecutable 323 | lbs = Zip.fromEntry entry 324 | let crcExpected = Zip.eCRC32 entry 325 | crcActual = CRC32.crc32 lbs 326 | when (crcExpected /= crcActual) 327 | $ throwIO $ CRC32Mismatch loc (Zip.eRelativePath entry) Mismatch 328 | { mismatchExpected = crcExpected 329 | , mismatchActual = crcActual 330 | } 331 | runConduit $ sourceLazy lbs .| f accum me 332 | isDir entry = 333 | case reverse $ Zip.eRelativePath entry of 334 | '/':_ -> True 335 | _ -> False 336 | -- We're entering lazy I/O land thanks to zip-archive. 337 | lbs <- BL.hGetContents h 338 | foldM go accum0 (filter (not . isDir) $ Zip.zEntries $ Zip.toArchive lbs) 339 | 340 | foldTar :: 341 | (HasPantryConfig env, HasLogFunc env) 342 | => ArchiveLocation -- ^ for exceptions 343 | -> a 344 | -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a) 345 | -> ConduitT ByteString o (RIO env) a 346 | foldTar loc accum0 f = do 347 | ref <- newIORef accum0 348 | Tar.untar $ toME >=> traverse_ (\me -> do 349 | accum <- readIORef ref 350 | accum' <- f accum me 351 | writeIORef ref $! accum') 352 | readIORef ref 353 | where 354 | toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry) 355 | toME fi = do 356 | let exc = InvalidTarFileType loc (Tar.getFileInfoPath fi) (Tar.fileType fi) 357 | mmet <- 358 | case Tar.fileType fi of 359 | Tar.FTSymbolicLink bs -> 360 | case decodeUtf8' bs of 361 | Left _ -> throwIO exc 362 | Right text -> pure $ Just $ METLink $ T.unpack text 363 | Tar.FTNormal -> pure $ Just $ 364 | if Tar.fileMode fi .&. 0o100 /= 0 365 | then METExecutable 366 | else METNormal 367 | Tar.FTDirectory -> pure Nothing 368 | _ -> throwIO exc 369 | pure $ 370 | (\met -> MetaEntry 371 | { mePath = removeInitialDotSlash . Tar.getFileInfoPath $ fi 372 | , meType = met 373 | }) 374 | <$> mmet 375 | 376 | data SimpleEntry = SimpleEntry 377 | { seSource :: !FilePath 378 | , seType :: !FileType 379 | } 380 | deriving Show 381 | 382 | removeInitialDotSlash :: FilePath -> FilePath 383 | removeInitialDotSlash filename = 384 | fromMaybe filename $ List.stripPrefix "./" filename 385 | 386 | -- | Attempt to parse the contents of the given archive in the given subdir into 387 | -- a 'Tree'. This will not consult any caches. It will ensure that: 388 | -- 389 | -- * The cabal file exists 390 | -- 391 | -- * The cabal file can be parsed 392 | -- 393 | -- * The name inside the cabal file matches the name of the cabal file itself 394 | parseArchive :: 395 | forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 396 | => RawPackageLocationImmutable 397 | -> RawArchive 398 | -> FilePath -- ^ file holding the archive 399 | -> RIO env (Package, CachedTree) 400 | parseArchive rpli archive fp = do 401 | let loc = raLocation archive 402 | archiveTypes :: [ArchiveType] 403 | archiveTypes = [minBound .. maxBound] 404 | getFiles :: [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry) 405 | getFiles [] = throwIO $ UnknownArchiveType loc 406 | getFiles (at:ats) = do 407 | eres <- tryAny $ 408 | -- foldArchive normalises filepaths in archives that begin with ./ 409 | foldArchive loc fp at id $ \m me -> pure $ m . (me:) 410 | case eres of 411 | Left e -> do 412 | logDebug $ "parseArchive of " <> display at <> ": " <> displayShow e 413 | getFiles ats 414 | Right files -> 415 | pure (at, Map.fromList $ map (mePath &&& id) $ files []) 416 | (at, files) <- getFiles archiveTypes 417 | let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry) 418 | toSimple key me = 419 | case meType me of 420 | METNormal -> 421 | Right $ Map.singleton key $ SimpleEntry (mePath me) FTNormal 422 | METExecutable -> 423 | Right $ Map.singleton key $ SimpleEntry (mePath me) FTExecutable 424 | METLink relDest -> do 425 | case relDest of 426 | '/':_ -> Left $ concat 427 | [ "File located at " 428 | , show $ mePath me 429 | , " is a symbolic link to absolute path " 430 | , relDest 431 | ] 432 | _ -> Right () 433 | dest0 <- 434 | case makeTarRelative (mePath me) relDest of 435 | Left e -> Left $ concat 436 | [ "Error resolving relative path " 437 | , relDest 438 | , " from symlink at " 439 | , mePath me 440 | , ": " 441 | , e 442 | ] 443 | Right x -> Right x 444 | dest <- 445 | case normalizeParents dest0 of 446 | Left e -> Left $ concat 447 | [ "Invalid symbolic link from " 448 | , mePath me 449 | , " to " 450 | , relDest 451 | , ", tried parsing " 452 | , dest0 453 | , ": " 454 | , e 455 | ] 456 | Right x -> Right x 457 | -- Check if it's a symlink to a file 458 | case Map.lookup dest files of 459 | Nothing -> 460 | -- Check if it's a symlink to a directory 461 | case findWithPrefix dest files of 462 | [] -> Left $ 463 | "Symbolic link dest not found from " 464 | ++ mePath me 465 | ++ " to " 466 | ++ relDest 467 | ++ ", looking for " 468 | ++ dest 469 | ++ ".\n" 470 | ++ "This may indicate that the source is a git \ 471 | \archive which uses git-annex.\n" 472 | ++ "See https://github.com/commercialhaskell/stack/issues/4579 \ 473 | \for further information." 474 | pairs -> 475 | fmap fold $ for pairs $ \(suffix, me') -> 476 | toSimple (key ++ '/' : suffix) me' 477 | Just me' -> 478 | case meType me' of 479 | METNormal -> 480 | Right $ Map.singleton key $ SimpleEntry dest FTNormal 481 | METExecutable -> 482 | Right $ Map.singleton key $ SimpleEntry dest FTExecutable 483 | METLink _ -> 484 | Left $ 485 | "Symbolic link dest cannot be a symbolic link, from " 486 | ++ mePath me 487 | ++ " to " 488 | ++ relDest 489 | 490 | case fold <$> Map.traverseWithKey toSimple files of 491 | Left e -> throwIO $ UnsupportedTarball loc $ T.pack e 492 | Right files1 -> do 493 | let files2 = stripCommonPrefix $ Map.toList files1 494 | files3 = takeSubdir (raSubdir archive) files2 495 | toSafe (fp', a) = 496 | case mkSafeFilePath fp' of 497 | Nothing -> Left $ "Not a safe file path: " ++ show fp' 498 | Just sfp -> Right (sfp, a) 499 | case traverse toSafe files3 of 500 | Left e -> throwIO $ UnsupportedTarball loc $ T.pack e 501 | Right safeFiles -> do 502 | let toSave = Set.fromList $ map (seSource . snd) safeFiles 503 | (blobs :: Map FilePath (BlobKey, BlobId)) <- 504 | foldArchive loc fp at mempty $ \m me -> 505 | if mePath me `Set.member` toSave 506 | then do 507 | bs <- mconcat <$> sinkList 508 | (blobId, blobKey) <- lift $ withStorage $ storeBlob bs 509 | pure $ Map.insert (mePath me) (blobKey, blobId) m 510 | else pure m 511 | tree :: CachedTree <- 512 | fmap (CachedTreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) -> 513 | case Map.lookup (removeInitialDotSlash . seSource $ se) blobs of 514 | Nothing -> 515 | error $ "Impossible: blob not found for: " ++ seSource se 516 | Just (blobKey, blobId) -> 517 | pure (sfp, (TreeEntry blobKey (seType se), blobId)) 518 | -- parse the cabal file and ensure it has the right name 519 | buildFile <- findCabalOrHpackFile rpli $ unCachedTree tree 520 | (buildFilePath, buildFileBlobKey, buildFileEntry) <- case buildFile of 521 | BFCabal fpath te@(TreeEntry key _) -> pure (fpath, key, te) 522 | BFHpack te@(TreeEntry key _) -> pure (hpackSafeFilePath, key, te) 523 | mbs <- withStorage $ loadBlob buildFileBlobKey 524 | bs <- case mbs of 525 | Nothing -> throwIO $ 526 | TreeReferencesMissingBlob rpli buildFilePath buildFileBlobKey 527 | Just bs -> pure bs 528 | cabalBs <- case buildFile of 529 | BFCabal _ _ -> pure bs 530 | BFHpack _ -> snd <$> hpackToCabal rpli (unCachedTree tree) 531 | (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBs 532 | let ident@(PackageIdentifier name _) = package $ packageDescription gpd 533 | case buildFile of 534 | BFCabal _ _ -> 535 | when (buildFilePath /= cabalFileName name) $ 536 | throwIO $ WrongCabalFileName rpli buildFilePath name 537 | _ -> pure () 538 | -- It's good! Store the tree, let's bounce 539 | (tid, treeKey') <- withStorage $ storeTree rpli ident tree buildFile 540 | packageCabal <- case buildFile of 541 | BFCabal _ _ -> pure $ PCCabalFile buildFileEntry 542 | BFHpack _ -> do 543 | cabalKey <- withStorage $ do 544 | hpackId <- storeHPack rpli tid 545 | loadCabalBlobKey hpackId 546 | hpackSoftwareVersion <- hpackVersion 547 | let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) 548 | pure 549 | $ PCHpack 550 | $ PHpack 551 | { phOriginal = buildFileEntry 552 | , phGenerated = cabalTreeEntry 553 | , phVersion = hpackSoftwareVersion 554 | } 555 | pure (Package 556 | { packageTreeKey = treeKey' 557 | , packageTree = unCachedTree tree 558 | , packageCabalEntry = packageCabal 559 | , packageIdent = ident 560 | }, tree) 561 | 562 | -- | Find all of the files in the Map with the given directory as a prefix. 563 | -- Directory is given without trailing slash. Returns the suffix after stripping 564 | -- the given prefix. 565 | findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)] 566 | findWithPrefix dir = mapMaybe go . Map.toList 567 | where 568 | prefix = dir ++ "/" 569 | go (x, y) = (, y) <$> List.stripPrefix prefix x 570 | 571 | findCabalOrHpackFile :: 572 | MonadThrow m 573 | => RawPackageLocationImmutable -- ^ for exceptions 574 | -> Tree 575 | -> m BuildFile 576 | findCabalOrHpackFile loc (TreeMap m) = do 577 | let isCabalFile (sfp, _) = 578 | let txt = unSafeFilePath sfp 579 | in not ("/" `T.isInfixOf` txt) && (".cabal" `T.isSuffixOf` txt) 580 | isHpackFile (sfp, _) = 581 | let txt = unSafeFilePath sfp 582 | in T.pack Hpack.packageConfig == txt 583 | isBFCabal (BFCabal _ _) = True 584 | isBFCabal _ = False 585 | sfpBuildFile (BFCabal sfp _) = sfp 586 | sfpBuildFile (BFHpack _) = hpackSafeFilePath 587 | toBuildFile xs@(sfp, te) = let cbFile = if isCabalFile xs 588 | then Just $ BFCabal sfp te 589 | else Nothing 590 | hpFile = if isHpackFile xs 591 | then Just $ BFHpack te 592 | else Nothing 593 | in cbFile <|> hpFile 594 | case mapMaybe toBuildFile $ Map.toList m of 595 | [] -> throwM $ TreeWithoutCabalFile loc 596 | [bfile] -> pure bfile 597 | xs -> case filter isBFCabal xs of 598 | [] -> throwM $ TreeWithoutCabalFile loc 599 | [bfile] -> pure bfile 600 | xs' -> throwM $ TreeWithMultipleCabalFiles loc $ map sfpBuildFile xs' 601 | 602 | -- | If all files have a shared prefix, strip it off 603 | stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)] 604 | stripCommonPrefix [] = [] 605 | stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do 606 | let firstDir = takeWhile (/= '/') firstFP 607 | guard $ not $ null firstDir 608 | let strip (fp, a) = (, a) <$> List.stripPrefix (firstDir ++ "/") fp 609 | stripCommonPrefix <$> traverse strip pairs 610 | 611 | -- | Take us down to the specified subdirectory 612 | takeSubdir :: 613 | Text -- ^ subdir 614 | -> [(FilePath, a)] -- ^ files after stripping common prefix 615 | -> [(Text, a)] 616 | takeSubdir subdir = mapMaybe $ \(fp, a) -> do 617 | stripped <- List.stripPrefix subdirs $ splitDirs $ T.pack fp 618 | Just (T.intercalate "/" stripped, a) 619 | where 620 | splitDirs = List.dropWhile (== ".") . filter (/= "") . T.splitOn "/" 621 | subdirs = splitDirs subdir 622 | -------------------------------------------------------------------------------- /src/Pantry/Casa.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DisambiguateRecordFields #-} 2 | 3 | -- | Integration with the Casa server. 4 | 5 | module Pantry.Casa where 6 | 7 | import Database.Persist.Sql ( SqlBackend ) 8 | import qualified Casa.Client as Casa 9 | import qualified Casa.Types as Casa 10 | import Conduit 11 | ( ConduitT, ResourceT, (.|), await, mapMC, runConduitRes ) 12 | import qualified Data.HashMap.Strict as HM 13 | import qualified Pantry.SHA256 as SHA256 14 | import Pantry.Storage ( storeBlob, withStorage ) 15 | import Pantry.Types as P 16 | ( BlobKey (..), FileSize (..), HasPantryConfig (..) 17 | , PantryConfig (..), PantryException (..), Tree, TreeKey (..) 18 | , parseTreeM 19 | ) 20 | import RIO 21 | import qualified RIO.ByteString as B 22 | 23 | -- | Lookup a tree. 24 | casaLookupTree :: 25 | (HasPantryConfig env, HasLogFunc env) 26 | => TreeKey 27 | -> RIO env (Maybe (TreeKey, P.Tree)) 28 | casaLookupTree (P.TreeKey key) = 29 | handleAny (const (pure Nothing)) 30 | (withStorage 31 | (runConduitRes (casaBlobSource (Identity key) .| mapMC parseTreeM .| await))) 32 | 33 | -- | Lookup a single blob. If possible, prefer 'casaBlobSource', and query a 34 | -- group of keys at once, rather than one at a time. This will have better 35 | -- network performance. 36 | casaLookupKey :: 37 | (HasPantryConfig env, HasLogFunc env) 38 | => BlobKey 39 | -> RIO env (Maybe ByteString) 40 | casaLookupKey key = 41 | handleAny (const (pure Nothing)) 42 | (fmap 43 | (fmap snd) 44 | (withStorage (runConduitRes (casaBlobSource (Identity key) .| await)))) 45 | 46 | -- | A source of blobs given a set of keys. All blobs are automatically stored 47 | -- in the local pantry database. 48 | casaBlobSource :: 49 | (Foldable f, HasPantryConfig env, HasLogFunc env) 50 | => f BlobKey 51 | -> ConduitT 52 | i 53 | (BlobKey, ByteString) 54 | (ResourceT (ReaderT SqlBackend (RIO env))) 55 | () 56 | casaBlobSource keys = source .| convert .| store 57 | where 58 | source = do 59 | mCasaConfig <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaConfig 60 | case mCasaConfig of 61 | Just (pullUrl, maxPerRequest) -> do 62 | Casa.blobsSource 63 | ( Casa.SourceConfig 64 | { sourceConfigUrl = pullUrl 65 | , sourceConfigBlobs = toBlobKeyMap keys 66 | , sourceConfigMaxBlobsPerRequest = maxPerRequest 67 | } 68 | ) 69 | Nothing -> throwM NoCasaConfig 70 | where 71 | toBlobKeyMap :: Foldable f => f BlobKey -> HashMap Casa.BlobKey Int 72 | toBlobKeyMap = HM.fromList . map unpackBlobKey . toList 73 | unpackBlobKey (P.BlobKey sha256 (FileSize fileSize)) = 74 | (Casa.BlobKey (SHA256.toRaw sha256), fromIntegral fileSize) 75 | convert = mapMC toBlobKeyAndBlob 76 | where 77 | toBlobKeyAndBlob :: 78 | MonadThrow m 79 | => (Casa.BlobKey, ByteString) 80 | -> m (BlobKey, ByteString) 81 | toBlobKeyAndBlob (Casa.BlobKey keyBytes, blob) = do 82 | sha256 <- 83 | case SHA256.fromRaw keyBytes of 84 | Left e -> throwM e 85 | Right sha -> pure sha 86 | pure (BlobKey sha256 (FileSize (fromIntegral (B.length blob))), blob) 87 | store = mapMC insertBlob 88 | where 89 | insertBlob original@(_key, binary) = do 90 | _ <- lift (storeBlob binary) 91 | pure original 92 | -------------------------------------------------------------------------------- /src/Pantry/HTTP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Pantry.HTTP 5 | ( module Export 6 | , withResponse 7 | , httpSink 8 | , httpSinkChecked 9 | ) where 10 | 11 | import Conduit ( ConduitT, ZipSink (..), await, getZipSink ) 12 | import Network.HTTP.Client as Export 13 | ( BodyReader, HttpExceptionContent (StatusCodeException) 14 | , parseRequest, parseUrlThrow 15 | ) 16 | import qualified Network.HTTP.Client as HTTP ( withResponse ) 17 | import Network.HTTP.Client.Internal as Export ( setUri ) 18 | import Network.HTTP.Client.TLS ( getGlobalManager ) 19 | import Network.HTTP.Simple as Export 20 | ( HttpException (..), Request, Response, addRequestHeader 21 | , defaultRequest, getResponseBody, getResponseHeaders 22 | , getResponseStatus, setRequestHeader 23 | ) 24 | import qualified Network.HTTP.Simple as HTTP hiding ( withResponse ) 25 | import Network.HTTP.Types as Export 26 | ( Header, HeaderName, Status, hCacheControl, hRange, ok200 27 | , partialContent206, statusCode 28 | ) 29 | import qualified Pantry.SHA256 as SHA256 30 | import Pantry.Types 31 | ( FileSize (..), Mismatch (..), PantryException (..), SHA256 32 | ) 33 | import RIO 34 | import qualified RIO.ByteString as B 35 | import qualified RIO.Text as T 36 | 37 | setUserAgent :: Request -> Request 38 | setUserAgent = setRequestHeader "User-Agent" ["Haskell pantry package"] 39 | 40 | withResponse :: 41 | MonadUnliftIO m 42 | => HTTP.Request 43 | -> (Response BodyReader -> m a) 44 | -> m a 45 | withResponse req inner = withRunInIO $ \run -> do 46 | manager <- getGlobalManager 47 | HTTP.withResponse (setUserAgent req) manager (run . inner) 48 | 49 | httpSink :: 50 | MonadUnliftIO m 51 | => Request 52 | -> (Response () -> ConduitT ByteString Void m a) 53 | -> m a 54 | httpSink req = HTTP.httpSink (setUserAgent req) 55 | 56 | httpSinkChecked :: 57 | MonadUnliftIO m 58 | => Text 59 | -> Maybe SHA256 60 | -> Maybe FileSize 61 | -> ConduitT ByteString Void m a 62 | -> m (SHA256, FileSize, a) 63 | httpSinkChecked url msha msize sink = do 64 | req <- liftIO $ parseUrlThrow $ T.unpack url 65 | httpSink req $ const $ getZipSink $ (,,) 66 | <$> ZipSink (checkSha msha) 67 | <*> ZipSink (checkSize msize) 68 | <*> ZipSink sink 69 | where 70 | checkSha mexpected = do 71 | actual <- SHA256.sinkHash 72 | for_ mexpected $ \expected -> unless (actual == expected) $ 73 | throwIO $ DownloadInvalidSHA256 url Mismatch 74 | { mismatchExpected = expected 75 | , mismatchActual = actual 76 | } 77 | pure actual 78 | checkSize mexpected = 79 | loop 0 80 | where 81 | loop accum = do 82 | mbs <- await 83 | case mbs of 84 | Nothing -> 85 | case mexpected of 86 | Just (FileSize expected) | expected /= accum -> 87 | throwIO $ DownloadInvalidSize url Mismatch 88 | { mismatchExpected = FileSize expected 89 | , mismatchActual = FileSize accum 90 | } 91 | _ -> pure (FileSize accum) 92 | Just bs -> do 93 | let accum' = accum + fromIntegral (B.length bs) 94 | case mexpected of 95 | Just (FileSize expected) 96 | | accum' > expected -> 97 | throwIO $ DownloadTooLarge url Mismatch 98 | { mismatchExpected = FileSize expected 99 | , mismatchActual = FileSize accum' 100 | } 101 | _ -> loop accum' 102 | -------------------------------------------------------------------------------- /src/Pantry/Hackage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TupleSections #-} 7 | 8 | module Pantry.Hackage 9 | ( updateHackageIndex 10 | , forceUpdateHackageIndex 11 | , DidUpdateOccur (..) 12 | , RequireHackageIndex (..) 13 | , hackageIndexTarballL 14 | , getHackageTarball 15 | , getHackageTarballKey 16 | , getHackageCabalFile 17 | , getHackagePackageVersions 18 | , getHackagePackageVersionRevisions 19 | , getHackageTypoCorrections 20 | , UsePreferredVersions (..) 21 | , HackageTarballResult(..) 22 | ) where 23 | 24 | import Conduit 25 | ( ZipSink (..), (.|), getZipSink, runConduit, sinkLazy 26 | , sinkList, sourceHandle, takeC, takeCE 27 | ) 28 | import Data.Aeson 29 | ( FromJSON (..), Value (..), (.:), eitherDecode' 30 | , withObject 31 | ) 32 | import Data.Conduit.Tar 33 | ( FileInfo (..), FileType (..), untar ) 34 | import qualified Data.List.NonEmpty as NE 35 | import Data.Text.Metrics (damerauLevenshtein) 36 | import Data.Text.Unsafe ( unsafeTail ) 37 | import Data.Time ( getCurrentTime ) 38 | import Database.Persist.Sql ( SqlBackend ) 39 | import Distribution.PackageDescription ( GenericPackageDescription ) 40 | import qualified Distribution.PackageDescription as Cabal 41 | import qualified Distribution.Text 42 | import Distribution.Types.Version (versionNumbers) 43 | import Distribution.Types.VersionRange (withinRange) 44 | import qualified Hackage.Security.Client as HS 45 | import qualified Hackage.Security.Client.Repository.Cache as HS 46 | import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS 47 | import qualified Hackage.Security.Client.Repository.Remote as HS 48 | import qualified Hackage.Security.Util.Path as HS 49 | import qualified Hackage.Security.Util.Pretty as HS 50 | import Network.URI ( parseURI ) 51 | import Pantry.Archive ( getArchive ) 52 | import Pantry.Casa ( casaLookupKey ) 53 | import qualified Pantry.SHA256 as SHA256 54 | import Pantry.Storage 55 | ( CachedTree (..), TreeId, BlobId, clearHackageRevisions 56 | , countHackageCabals, getBlobKey, loadBlobById, loadBlobBySHA 57 | , loadHackagePackageVersion, loadHackagePackageVersions 58 | , loadHackageTarballInfo, loadHackageTree, loadHackageTreeKey 59 | , loadLatestCacheUpdate, loadPreferredVersion 60 | , sinkHackagePackageNames, storeBlob, storeCacheUpdate 61 | , storeHackageRevision, storeHackageTarballInfo 62 | , storeHackageTree, storePreferredVersion, storeTree 63 | , unCachedTree, withStorage 64 | ) 65 | import Pantry.Tree ( rawParseGPD ) 66 | import Pantry.Types 67 | ( ArchiveLocation (..), BlobKey (..), BuildFile (..) 68 | , CabalFileInfo (..), FileSize (..), FuzzyResults (..) 69 | , HackageSecurityConfig (..), HasPantryConfig (..) 70 | , Mismatch (..), Package (..), PackageCabal (..) 71 | , PackageIdentifier (..), PackageIdentifierRevision (..) 72 | , PackageIndexConfig (..), PackageName, PantryConfig (..) 73 | , PantryException (..), RawArchive (..) 74 | , RawPackageLocationImmutable (..), RawPackageMetadata (..) 75 | , Revision, SHA256, Storage (..), TreeEntry (..), TreeKey 76 | , Version, cabalFileName, packageNameString, parsePackageName 77 | , unSafeFilePath 78 | ) 79 | import Path 80 | ( Abs, Dir, File, Path, Rel, (), parseRelDir, parseRelFile 81 | , toFilePath 82 | ) 83 | import RIO 84 | import qualified RIO.ByteString as B 85 | import qualified RIO.ByteString.Lazy as BL 86 | import qualified RIO.Map as Map 87 | import RIO.Process ( HasProcessContext ) 88 | import qualified RIO.Text as T 89 | #if !MIN_VERSION_rio(0,1,16) 90 | -- Now provided by RIO from the rio package. Resolvers before lts-15.16 91 | -- (GHC 8.8.3) had rio < 0.1.16. 92 | import System.IO ( SeekMode (..) ) 93 | #endif 94 | 95 | hackageRelDir :: Path Rel Dir 96 | hackageRelDir = either impureThrow id $ parseRelDir "hackage" 97 | 98 | hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir) 99 | hackageDirL = pantryConfigL.to (( hackageRelDir) . pcRootDir) 100 | 101 | -- | The name of the tar file that is part of the local cache of the package 102 | -- index is determined by this package's use of 'HS.cabalCacheLayout' as the 103 | -- layout of the local cache. 104 | indexRelFile :: Path Rel File 105 | indexRelFile = either impureThrow id $ parseRelFile indexTar 106 | where 107 | indexTar' = HS.cacheLayoutIndexTar HS.cabalCacheLayout 108 | indexTar = HS.toUnrootedFilePath $ HS.unrootPath indexTar' 109 | 110 | -- | Where does pantry download its 01-index.tar file from Hackage? 111 | -- 112 | -- @since 0.1.0.0 113 | hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File) 114 | hackageIndexTarballL = hackageDirL.to ( indexRelFile) 115 | 116 | -- | Did an update occur when running 'updateHackageIndex'? 117 | -- 118 | -- @since 0.1.0.0 119 | data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred 120 | 121 | 122 | -- | Information returned by `getHackageTarball` 123 | -- 124 | -- @since 0.1.0.0 125 | data HackageTarballResult = HackageTarballResult 126 | { htrPackage :: !Package 127 | -- ^ Package that was loaded from Hackage tarball 128 | , htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId)) 129 | -- ^ This information is only available whenever package was just loaded 130 | -- into pantry. 131 | } 132 | 133 | -- | Download the most recent 01-index.tar file from Hackage and update the 134 | -- database tables. 135 | -- 136 | -- This function will only perform an update once per 'PantryConfig' for user 137 | -- sanity. See the return value to find out if it happened. 138 | -- 139 | -- @since 0.1.0.0 140 | updateHackageIndex :: 141 | (HasPantryConfig env, HasLogFunc env) 142 | => Maybe Utf8Builder -- ^ reason for updating, if any 143 | -> RIO env DidUpdateOccur 144 | updateHackageIndex = updateHackageIndexInternal False 145 | 146 | -- | Same as `updateHackageIndex`, but force the database update even if hackage 147 | -- security tells that there is no change. This can be useful in order to make 148 | -- sure the database is in sync with the locally downloaded tarball 149 | -- 150 | -- @since 0.1.0.0 151 | forceUpdateHackageIndex :: 152 | (HasPantryConfig env, HasLogFunc env) 153 | => Maybe Utf8Builder 154 | -> RIO env DidUpdateOccur 155 | forceUpdateHackageIndex = updateHackageIndexInternal True 156 | 157 | 158 | updateHackageIndexInternal :: 159 | (HasPantryConfig env, HasLogFunc env) 160 | => Bool -- ^ Force the database update. 161 | -> Maybe Utf8Builder -- ^ reason for updating, if any 162 | -> RIO env DidUpdateOccur 163 | updateHackageIndexInternal forceUpdate mreason = do 164 | storage <- view $ pantryConfigL.to pcStorage 165 | gateUpdate $ withWriteLock_ storage $ do 166 | for_ mreason logInfo 167 | pc <- view pantryConfigL 168 | let PackageIndexConfig url (HackageSecurityConfig keyIds threshold ignoreExpiry) = pcPackageIndex pc 169 | root <- view hackageDirL 170 | tarball <- view hackageIndexTarballL 171 | baseURI <- 172 | case parseURI $ T.unpack url of 173 | Nothing -> 174 | throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url 175 | Just x -> pure x 176 | run <- askRunInIO 177 | let logTUF = run . logInfo . fromString . HS.pretty 178 | withRepo = HS.withRepository 179 | HS.httpLib 180 | [baseURI] 181 | HS.defaultRepoOpts 182 | HS.Cache 183 | { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root 184 | , HS.cacheLayout = HS.cabalCacheLayout 185 | } 186 | HS.hackageRepoLayout 187 | HS.hackageIndexLayout 188 | logTUF 189 | didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do 190 | needBootstrap <- HS.requiresBootstrap repo 191 | when needBootstrap $ do 192 | HS.bootstrap 193 | repo 194 | (map (HS.KeyId . T.unpack) keyIds) 195 | (HS.KeyThreshold $ fromIntegral threshold) 196 | maybeNow <- if ignoreExpiry 197 | then pure Nothing 198 | else Just <$> getCurrentTime 199 | HS.checkForUpdates repo maybeNow 200 | 201 | case didUpdate of 202 | _ | forceUpdate -> do 203 | logInfo "Forced package update is initialized" 204 | updateCache tarball 205 | HS.NoUpdates -> do 206 | x <- needsCacheUpdate tarball 207 | if x 208 | then do 209 | logInfo "No package index update available, but didn't update cache last time, running now" 210 | updateCache tarball 211 | else logInfo "No package index update available and cache up to date" 212 | HS.HasUpdates -> do 213 | logInfo "Updated package index downloaded" 214 | updateCache tarball 215 | logStickyDone "Package index cache populated" 216 | where 217 | -- The size of the new index tarball, ignoring the required (by the tar spec) 218 | -- 1024 null bytes at the end, which will be mutated in the future by other 219 | -- updates. 220 | getTarballSize :: MonadIO m => Handle -> m Word 221 | getTarballSize h = fromIntegral . max 0 . subtract 1024 <$> hFileSize h 222 | 223 | -- Check if the size of the tarball on the disk matches the value in 224 | -- CacheUpdate. If not, we need to perform a cache update, even if we didn't 225 | -- download any new information. This can be caused by canceling an 226 | -- updateCache call. 227 | needsCacheUpdate tarball = do 228 | mres <- withStorage loadLatestCacheUpdate 229 | case mres of 230 | Nothing -> pure True 231 | Just (FileSize cachedSize, _sha256) -> do 232 | actualSize <- withBinaryFile (toFilePath tarball) ReadMode getTarballSize 233 | pure $ cachedSize /= actualSize 234 | 235 | -- This is the one action in the Pantry codebase known to hold a write lock on 236 | -- the database for an extended period of time. To avoid failures due to 237 | -- SQLite locks failing, we take our own lock outside of SQLite for this 238 | -- action. 239 | -- 240 | -- See https://github.com/commercialhaskell/stack/issues/4471 241 | updateCache tarball = withStorage $ do 242 | -- Alright, here's the story. In theory, we only ever append to a tarball. 243 | -- Therefore, we can store the last place we populated our cache from, and 244 | -- fast forward to that point. But there are two issues with that: 245 | -- 246 | -- 1. Hackage may rebase, in which case we need to recalculate everything 247 | -- from the beginning. Unfortunately, hackage-security doesn't let us know 248 | -- when that happens. 249 | -- 250 | -- 2. Some paranoia about files on the filesystem getting modified out from 251 | -- under us. 252 | -- 253 | -- Therefore, we store both the last read-to index, _and_ the SHA256 of all 254 | -- of the contents until that point. When updating the cache, we calculate 255 | -- the new SHA256 of the whole file, and the SHA256 of the previous read-to 256 | -- point. If the old hashes match, we can do an efficient fast forward. 257 | -- Otherwise, we clear the old cache and repopulate. 258 | minfo <- loadLatestCacheUpdate 259 | (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do 260 | logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" 261 | 262 | newSize <- getTarballSize h 263 | let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash 264 | 265 | case minfo of 266 | Nothing -> do 267 | logInfo "No old cache found, populating cache from scratch" 268 | newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize 269 | pure (0, newHash, newSize) 270 | Just (FileSize oldSize, oldHash) -> do 271 | -- oldSize and oldHash come from the database, and tell 272 | -- us what we cached already. Compare against 273 | -- oldHashCheck, which assuming the tarball has not been 274 | -- rebased will be the same as oldHash. At the same 275 | -- time, calculate newHash, which is the hash of the new 276 | -- content as well. 277 | (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) 278 | <$> ZipSink (sinkSHA256 oldSize) 279 | <*> ZipSink (sinkSHA256 newSize) 280 | ) 281 | offset <- 282 | if oldHash == oldHashCheck 283 | then oldSize <$ logInfo "Updating preexisting cache, should be quick" 284 | else 0 <$ do 285 | logWarn $ mconcat [ 286 | "Package index change detected, that's pretty unusual: " 287 | , "\n Old size: " <> display oldSize 288 | , "\n Old hash (orig) : " <> display oldHash 289 | , "\n New hash (check): " <> display oldHashCheck 290 | , "\n Forcing a recache" 291 | ] 292 | pure (offset, newHash, newSize) 293 | 294 | lift $ logInfo $ 295 | "Populating cache from file size " 296 | <> display newSize 297 | <> ", hash " 298 | <> display newHash 299 | when (offset == 0) clearHackageRevisions 300 | populateCache tarball (fromIntegral offset) `onException` 301 | lift (logStickyDone "Failed populating package index cache") 302 | storeCacheUpdate (FileSize newSize) newHash 303 | gateUpdate inner = do 304 | pc <- view pantryConfigL 305 | join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ 306 | if toUpdate 307 | then (False, UpdateOccurred <$ inner) 308 | else (False, pure NoUpdateOccurred) 309 | 310 | -- | Populate the SQLite tables with Hackage index information. 311 | populateCache :: 312 | (HasPantryConfig env, HasLogFunc env) 313 | => Path Abs File -- ^ tarball 314 | -> Integer -- ^ where to start processing from 315 | -> ReaderT SqlBackend (RIO env) () 316 | populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do 317 | lift $ logInfo "Populating package index cache ..." 318 | counter <- newIORef (0 :: Int) 319 | hSeek h AbsoluteSeek offset 320 | runConduit $ sourceHandle h .| untar (perFile counter) 321 | where 322 | perFile counter fi 323 | | FTNormal <- fileType fi 324 | , Right path <- decodeUtf8' $ filePath fi 325 | , Just (name, version, filename) <- parseNameVersionSuffix path = 326 | if 327 | | filename == "package.json" -> 328 | sinkLazy >>= lift . addJSON name version 329 | | filename == unSafeFilePath (cabalFileName name) -> do 330 | sinkLazy >>= (lift . addCabal name version) . BL.toStrict 331 | count <- readIORef counter 332 | let count' = count + 1 333 | writeIORef counter count' 334 | when (count' `mod` 400 == 0) $ 335 | lift $ lift $ 336 | logSticky $ "Processed " <> display count' <> " cabal files" 337 | | otherwise -> pure () 338 | | FTNormal <- fileType fi 339 | , Right path <- decodeUtf8' $ filePath fi 340 | , (nameT, "/preferred-versions") <- T.break (== '/') path 341 | , Just name <- parsePackageName $ T.unpack nameT = do 342 | lbs <- sinkLazy 343 | case decodeUtf8' $ BL.toStrict lbs of 344 | Left _ -> pure () -- maybe warning 345 | Right p -> lift $ storePreferredVersion name p 346 | | otherwise = pure () 347 | 348 | addJSON name version lbs = 349 | case eitherDecode' lbs of 350 | Left e -> lift $ logError $ 351 | "Error: [S-563]\n" 352 | <> "Error processing Hackage security metadata for " 353 | <> fromString (Distribution.Text.display name) <> "-" 354 | <> fromString (Distribution.Text.display version) <> ": " 355 | <> fromString e 356 | Right (PackageDownload sha size) -> 357 | storeHackageTarballInfo name version sha $ FileSize size 358 | 359 | addCabal name version bs = do 360 | (blobTableId, _blobKey) <- storeBlob bs 361 | 362 | storeHackageRevision name version blobTableId 363 | 364 | breakSlash x 365 | | T.null z = Nothing 366 | | otherwise = Just (y, unsafeTail z) 367 | where 368 | (y, z) = T.break (== '/') x 369 | 370 | parseNameVersionSuffix t1 = do 371 | (name, t2) <- breakSlash t1 372 | (version, filename) <- breakSlash t2 373 | 374 | name' <- Distribution.Text.simpleParse $ T.unpack name 375 | version' <- Distribution.Text.simpleParse $ T.unpack version 376 | 377 | Just (name', version', filename) 378 | 379 | -- | Package download info from Hackage 380 | data PackageDownload = PackageDownload !SHA256 !Word 381 | 382 | instance FromJSON PackageDownload where 383 | parseJSON = withObject "PackageDownload" $ \o1 -> do 384 | o2 <- o1 .: "signed" 385 | Object o3 <- o2 .: "targets" 386 | Object o4:_ <- pure $ toList o3 387 | len <- o4 .: "length" 388 | hashes <- o4 .: "hashes" 389 | sha256' <- hashes .: "sha256" 390 | sha256 <- 391 | case SHA256.fromHexText sha256' of 392 | Left e -> fail $ "Invalid sha256: " ++ show e 393 | Right x -> pure x 394 | pure $ PackageDownload sha256 len 395 | 396 | getHackageCabalFile :: 397 | (HasPantryConfig env, HasLogFunc env) 398 | => PackageIdentifierRevision 399 | -> RIO env ByteString 400 | getHackageCabalFile pir@(PackageIdentifierRevision _ _ cfi) = do 401 | bid <- resolveCabalFileInfo pir 402 | bs <- withStorage $ loadBlobById bid 403 | case cfi of 404 | CFIHash sha msize -> do 405 | let sizeMismatch = 406 | case msize of 407 | Nothing -> False 408 | Just size -> FileSize (fromIntegral (B.length bs)) /= size 409 | shaMismatch = sha /= SHA256.hashBytes bs 410 | when (sizeMismatch || shaMismatch) 411 | $ error $ "getHackageCabalFile: size or SHA mismatch for " ++ show (pir, bs) 412 | _ -> pure () 413 | pure bs 414 | 415 | resolveCabalFileInfo :: 416 | (HasPantryConfig env, HasLogFunc env) 417 | => PackageIdentifierRevision 418 | -> RIO env BlobId 419 | resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do 420 | mres <- inner 421 | case mres of 422 | Just res -> pure res 423 | Nothing -> do 424 | updated <- updateHackageIndex $ Just 425 | $ "Cabal file info not found for " 426 | <> display pir 427 | <> ", updating" 428 | mres' <- 429 | case updated of 430 | UpdateOccurred -> inner 431 | NoUpdateOccurred -> pure Nothing 432 | case mres' of 433 | Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir 434 | Just res -> pure res 435 | where 436 | inner = 437 | case cfi of 438 | CFIHash sha msize -> loadOrDownloadBlobBySHA pir sha msize 439 | CFIRevision rev -> 440 | fmap fst . Map.lookup rev <$> withStorage (loadHackagePackageVersion name ver) 441 | CFILatest -> 442 | fmap (fst . fst) . Map.maxView <$> withStorage (loadHackagePackageVersion name ver) 443 | 444 | -- | Load or download a blob by its SHA. 445 | loadOrDownloadBlobBySHA :: 446 | (Display a, HasPantryConfig env, HasLogFunc env) 447 | => a 448 | -> SHA256 449 | -> Maybe FileSize 450 | -> RIO env (Maybe BlobId) 451 | loadOrDownloadBlobBySHA label sha256 msize = do 452 | mresult <- byDB 453 | case mresult of 454 | Nothing -> do 455 | case msize of 456 | Nothing -> do 457 | pure Nothing 458 | Just size -> do 459 | mblob <- casaLookupKey (BlobKey sha256 size) 460 | case mblob of 461 | Nothing -> do 462 | pure Nothing 463 | Just {} -> do 464 | result <- byDB 465 | case result of 466 | Just blobId -> do 467 | logDebug ("Pulled blob from Casa for " <> display label) 468 | pure (Just blobId) 469 | Nothing -> do 470 | logWarn 471 | ("Bug? Blob pulled from Casa not in database for " <> 472 | display label) 473 | pure Nothing 474 | Just blobId -> do 475 | logDebug ("Got blob from Pantry database for " <> display label) 476 | pure (Just blobId) 477 | where 478 | byDB = withStorage $ loadBlobBySHA sha256 479 | 480 | -- | Given package identifier and package caches, return list of packages with 481 | -- the same name and the same two first version number components found in the 482 | -- caches. 483 | fuzzyLookupCandidates :: 484 | (HasPantryConfig env, HasLogFunc env) 485 | => PackageName 486 | -> Version 487 | -> RIO env FuzzyResults 488 | fuzzyLookupCandidates name ver0 = do 489 | m <- getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions name 490 | if Map.null m 491 | then FRNameNotFound <$> getHackageTypoCorrections name 492 | else 493 | case Map.lookup ver0 m of 494 | Nothing -> do 495 | let withVers vers = pure $ FRVersionNotFound $ flip NE.map vers $ \(ver, revs) -> 496 | case Map.maxView revs of 497 | Nothing -> error "fuzzyLookupCandidates: no revisions" 498 | Just (BlobKey sha size, _) -> 499 | PackageIdentifierRevision name ver (CFIHash sha (Just size)) 500 | case NE.nonEmpty $ filter (sameMajor . fst) $ Map.toList m of 501 | Just vers -> withVers vers 502 | Nothing -> 503 | case NE.nonEmpty $ Map.toList m of 504 | Nothing -> error "fuzzyLookupCandidates: no versions" 505 | Just vers -> withVers vers 506 | Just revisions -> 507 | let pirs = map 508 | (\(BlobKey sha size) -> 509 | PackageIdentifierRevision name ver0 (CFIHash sha (Just size))) 510 | (Map.elems revisions) 511 | in case NE.nonEmpty pirs of 512 | Nothing -> error "fuzzyLookupCandidates: no revisions" 513 | Just pirs' -> pure $ FRRevisionNotFound pirs' 514 | where 515 | sameMajor v = toMajorVersion v == toMajorVersion ver0 516 | 517 | toMajorVersion :: Version -> [Int] 518 | toMajorVersion v = 519 | case versionNumbers v of 520 | [] -> [0, 0] 521 | [a] -> [a, 0] 522 | a:b:_ -> [a, b] 523 | 524 | -- | Try to come up with typo corrections for given package identifier using 525 | -- Hackage package names. This can provide more user-friendly information in 526 | -- error messages. 527 | -- 528 | -- @since 0.1.0.0 529 | getHackageTypoCorrections :: 530 | (HasPantryConfig env, HasLogFunc env) 531 | => PackageName 532 | -> RIO env [PackageName] 533 | getHackageTypoCorrections name1 = 534 | withStorage $ sinkHackagePackageNames 535 | (\name2 -> name1 `distance` name2 < 4) 536 | (takeC 10 .| sinkList) 537 | where 538 | distance = damerauLevenshtein `on` (T.pack . packageNameString) 539 | 540 | -- | Should we pay attention to Hackage's preferred versions? 541 | -- 542 | -- @since 0.1.0.0 543 | data UsePreferredVersions 544 | = UsePreferredVersions 545 | | IgnorePreferredVersions 546 | deriving Show 547 | 548 | -- | Require that the Hackage index is populated. 549 | -- 550 | -- @since 0.1.0.0 551 | data RequireHackageIndex 552 | = YesRequireHackageIndex 553 | -- ^ If there is nothing in the Hackage index, then perform an update 554 | | NoRequireHackageIndex 555 | -- ^ Do not perform an update 556 | deriving Show 557 | 558 | initializeIndex :: 559 | (HasPantryConfig env, HasLogFunc env) 560 | => RequireHackageIndex 561 | -> RIO env () 562 | initializeIndex NoRequireHackageIndex = pure () 563 | initializeIndex YesRequireHackageIndex = do 564 | cabalCount <- withStorage countHackageCabals 565 | when (cabalCount == 0) $ void $ 566 | updateHackageIndex $ Just "No information from Hackage index, updating" 567 | 568 | -- | Returns the versions of the package available on Hackage. 569 | -- 570 | -- @since 0.1.0.0 571 | getHackagePackageVersions :: 572 | (HasPantryConfig env, HasLogFunc env) 573 | => RequireHackageIndex 574 | -> UsePreferredVersions 575 | -> PackageName -- ^ package name 576 | -> RIO env (Map Version (Map Revision BlobKey)) 577 | getHackagePackageVersions req usePreferred name = do 578 | initializeIndex req 579 | withStorage $ do 580 | mpreferred <- 581 | case usePreferred of 582 | UsePreferredVersions -> loadPreferredVersion name 583 | IgnorePreferredVersions -> pure Nothing 584 | let predicate :: Version -> Map Revision BlobKey -> Bool 585 | predicate = fromMaybe (\_ _ -> True) $ do 586 | preferredT1 <- mpreferred 587 | preferredT2 <- T.stripPrefix (T.pack $ packageNameString name) preferredT1 588 | vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 589 | Just $ \v _ -> withinRange v vr 590 | Map.filterWithKey predicate <$> loadHackagePackageVersions name 591 | 592 | -- | Returns the versions of the package available on Hackage. 593 | -- 594 | -- @since 0.1.0.0 595 | getHackagePackageVersionRevisions :: 596 | (HasPantryConfig env, HasLogFunc env) 597 | => RequireHackageIndex 598 | -> PackageName -- ^ package name 599 | -> Version -- ^ package version 600 | -> RIO env (Map Revision BlobKey) 601 | getHackagePackageVersionRevisions req name version = do 602 | initializeIndex req 603 | withStorage $ 604 | Map.map snd <$> loadHackagePackageVersion name version 605 | 606 | withCachedTree :: 607 | (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 608 | => RawPackageLocationImmutable 609 | -> PackageName 610 | -> Version 611 | -> BlobId -- ^ cabal file contents 612 | -> RIO env HackageTarballResult 613 | -> RIO env HackageTarballResult 614 | withCachedTree rpli name ver bid inner = do 615 | mres <- withStorage $ loadHackageTree rpli name ver bid 616 | case mres of 617 | Just package -> pure $ HackageTarballResult package Nothing 618 | Nothing -> do 619 | htr <- inner 620 | withStorage $ 621 | storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr 622 | pure htr 623 | 624 | getHackageTarballKey :: 625 | (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 626 | => PackageIdentifierRevision 627 | -> RIO env TreeKey 628 | getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do 629 | mres <- withStorage $ loadHackageTreeKey name ver sha 630 | case mres of 631 | Nothing -> packageTreeKey . htrPackage <$> getHackageTarball pir Nothing 632 | Just key -> pure key 633 | getHackageTarballKey pir = 634 | packageTreeKey . htrPackage <$> getHackageTarball pir Nothing 635 | 636 | getHackageTarball :: 637 | (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 638 | => PackageIdentifierRevision 639 | -> Maybe TreeKey 640 | -> RIO env HackageTarballResult 641 | getHackageTarball pir mtreeKey = do 642 | let PackageIdentifierRevision name ver _cfi = pir 643 | cabalFile <- resolveCabalFileInfo pir 644 | let rpli = RPLIHackage pir mtreeKey 645 | withCachedTree rpli name ver cabalFile $ do 646 | cabalFileKey <- withStorage $ getBlobKey cabalFile 647 | mpair <- withStorage $ loadHackageTarballInfo name ver 648 | (sha, size) <- 649 | case mpair of 650 | Just pair -> pure pair 651 | Nothing -> do 652 | let exc = NoHackageCryptographicHash $ PackageIdentifier name ver 653 | updated <- updateHackageIndex $ Just $ display exc <> ", updating" 654 | mpair2 <- 655 | case updated of 656 | UpdateOccurred -> withStorage $ loadHackageTarballInfo name ver 657 | NoUpdateOccurred -> pure Nothing 658 | case mpair2 of 659 | Nothing -> throwIO exc 660 | Just pair2 -> pure pair2 661 | pc <- view pantryConfigL 662 | let urlPrefix = picDownloadPrefix $ pcPackageIndex pc 663 | url = 664 | mconcat 665 | [ urlPrefix 666 | , "package/" 667 | , T.pack $ Distribution.Text.display name 668 | , "-" 669 | , T.pack $ Distribution.Text.display ver 670 | , ".tar.gz" 671 | ] 672 | (_, _, package, cachedTree) <- 673 | getArchive 674 | rpli 675 | RawArchive 676 | { raLocation = ALUrl url 677 | , raHash = Just sha 678 | , raSize = Just size 679 | , raSubdir = T.empty -- no subdirs on Hackage 680 | } 681 | RawPackageMetadata 682 | { rpmName = Just name 683 | , rpmVersion = Just ver 684 | , rpmTreeKey = Nothing -- with a revision cabal file will differ 685 | -- giving a different tree 686 | } 687 | case cachedTree of 688 | CachedTreeMap m -> do 689 | let ft = 690 | case packageCabalEntry package of 691 | PCCabalFile (TreeEntry _ ft') -> ft' 692 | _ -> error "Impossible: Hackage does not support hpack" 693 | cabalEntry = TreeEntry cabalFileKey ft 694 | (cabalBS, cabalBlobId) <- 695 | withStorage $ do 696 | let BlobKey sha' _ = cabalFileKey 697 | mcabalBS <- loadBlobBySHA sha' 698 | case mcabalBS of 699 | Nothing -> 700 | error $ 701 | "Invariant violated, cabal file key: " ++ show cabalFileKey 702 | Just bid -> (, bid) <$> loadBlobById bid 703 | let tree' = CachedTreeMap $ 704 | Map.insert (cabalFileName name) (cabalEntry, cabalBlobId) m 705 | ident = PackageIdentifier name ver 706 | (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS 707 | let gpdIdent = Cabal.package $ Cabal.packageDescription gpd 708 | when (ident /= gpdIdent) $ 709 | throwIO $ 710 | MismatchedCabalFileForHackage 711 | pir 712 | Mismatch {mismatchExpected = ident, mismatchActual = gpdIdent} 713 | (tid, treeKey') <- 714 | withStorage $ 715 | storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) 716 | pure 717 | HackageTarballResult 718 | { htrPackage = 719 | Package 720 | { packageTreeKey = treeKey' 721 | , packageTree = unCachedTree tree' 722 | , packageIdent = ident 723 | , packageCabalEntry = PCCabalFile cabalEntry 724 | } 725 | , htrFreshPackageInfo = Just (gpd, tid) 726 | } 727 | -------------------------------------------------------------------------------- /src/Pantry/Internal/Stackage.hs: -------------------------------------------------------------------------------- 1 | -- | All types and functions exported from this module are for advanced usage 2 | -- only. They are needed for stackage-server integration with pantry and some 3 | -- are needed for stack testing. 4 | module Pantry.Internal.Stackage 5 | ( module X 6 | ) where 7 | 8 | import Pantry.Hackage as X 9 | ( HackageTarballResult (..), forceUpdateHackageIndex 10 | , getHackageTarball 11 | ) 12 | import Pantry.Storage as X 13 | ( BlobId, EntityField (..), HackageCabalId, Key (unBlobKey) 14 | , ModuleNameId, PackageName, PackageNameId, Tree (..) 15 | , TreeEntryId, TreeId, Unique (..), Version, VersionId 16 | , allBlobsCount, allBlobsSource, allHackageCabalCount 17 | , allHackageCabalRawPackageLocations, getBlobKey 18 | , getPackageNameById, getPackageNameId, getTreeForKey 19 | , getVersionId, loadBlobById, migrateAll, storeBlob 20 | , versionVersion 21 | ) 22 | import Pantry.Types as X 23 | ( ModuleNameP (..), PackageNameP (..), PantryConfig (..) 24 | , SafeFilePath, Storage (..), VersionP (..), mkSafeFilePath 25 | , packageTreeKey, unSafeFilePath 26 | ) 27 | -------------------------------------------------------------------------------- /src/Pantry/Repo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TupleSections #-} 8 | 9 | module Pantry.Repo 10 | ( fetchReposRaw 11 | , fetchRepos 12 | , getRepo 13 | , getRepoKey 14 | , createRepoArchive 15 | , withRepoArchive 16 | , withRepo 17 | ) where 18 | 19 | import Database.Persist.Class.PersistEntity ( Entity (..) ) 20 | import Pantry.Archive ( getArchivePackage ) 21 | import Pantry.Storage 22 | ( getTreeForKey, loadPackageById, loadRepoCache 23 | , storeRepoCache, withStorage 24 | ) 25 | import Pantry.Types 26 | ( AggregateRepo (..), ArchiveLocation (..), HasPantryConfig 27 | , Package (..), PackageMetadata (..), PantryException (..) 28 | , RawArchive (..), RawPackageLocationImmutable (..) 29 | , RawPackageMetadata (..), RelFilePath (..), Repo (..) 30 | , RepoType (..), ResolvedPath (..), SimpleRepo (..) 31 | , TreeKey (..), arToSimpleRepo, rToSimpleRepo 32 | , toAggregateRepos, toRawPM 33 | ) 34 | import Path.IO ( resolveFile' ) 35 | import RIO 36 | import RIO.ByteString ( isInfixOf ) 37 | import RIO.ByteString.Lazy ( toStrict ) 38 | import RIO.Directory ( doesDirectoryExist ) 39 | import RIO.FilePath ( () ) 40 | import qualified RIO.Map as Map 41 | import RIO.Process 42 | ( ExitCodeException (..), HasProcessContext, proc 43 | , readProcess, readProcess_, withModifyEnvVars 44 | , withWorkingDir 45 | ) 46 | import qualified RIO.Text as T 47 | #if MIN_VERSION_ansi_terminal(1, 0, 2) 48 | import System.Console.ANSI ( hNowSupportsANSI ) 49 | #else 50 | import System.Console.ANSI ( hSupportsANSIWithoutEmulation ) 51 | #endif 52 | import System.IsWindows ( osIsWindows ) 53 | 54 | data TarType = Gnu | Bsd 55 | 56 | getGitTarType :: (HasProcessContext env, HasLogFunc env) => RIO env TarType 57 | getGitTarType = if osIsWindows 58 | then do 59 | (_, stdoutBS, _) <- proc "git" ["--version"] readProcess 60 | let bs = toStrict stdoutBS 61 | -- If using Git for Windows, then assume that the tar type within 62 | -- `git submodule foreach ` is the Git-supplied\MSYS2-supplied 63 | -- GNU tar 64 | if "windows" `isInfixOf` bs then pure Gnu else getTarType 65 | else getTarType 66 | 67 | getTarType :: (HasProcessContext env, HasLogFunc env) => RIO env TarType 68 | getTarType = do 69 | (_, stdoutBS, _) <- proc "tar" ["--version"] readProcess 70 | let bs = toStrict stdoutBS 71 | pure $ if "GNU" `isInfixOf` bs then Gnu else Bsd 72 | 73 | -- | Like 'fetchRepos', except with 'RawPackageMetadata' instead of 74 | -- 'PackageMetadata'. 75 | -- 76 | -- @since 0.5.3 77 | fetchReposRaw :: 78 | (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 79 | => [(Repo, RawPackageMetadata)] 80 | -> RIO env () 81 | fetchReposRaw pairs = do 82 | let repos = toAggregateRepos pairs 83 | logDebug (displayShow repos) 84 | for_ repos getRepos 85 | 86 | -- | Fetch the given repositories at once and populate the pantry database. 87 | -- 88 | -- @since 0.5.3 89 | fetchRepos :: 90 | (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 91 | => [(Repo, PackageMetadata)] 92 | -> RIO env () 93 | fetchRepos pairs = do 94 | -- TODO be more efficient, group together shared archives 95 | fetchReposRaw $ map (second toRawPM) pairs 96 | 97 | getRepoKey :: 98 | forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 99 | => Repo 100 | -> RawPackageMetadata 101 | -> RIO env TreeKey 102 | getRepoKey repo rpm = packageTreeKey <$> getRepo repo rpm -- potential optimization 103 | 104 | getRepo :: 105 | forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 106 | => Repo 107 | -> RawPackageMetadata 108 | -> RIO env Package 109 | getRepo repo pm = do 110 | withCache $ getRepo' repo pm 111 | where 112 | withCache :: RIO env Package -> RIO env Package 113 | withCache inner = do 114 | mtid <- withStorage (loadRepoCache repo) 115 | case mtid of 116 | Just tid -> withStorage $ loadPackageById (RPLIRepo repo pm) tid 117 | Nothing -> do 118 | package <- inner 119 | withStorage $ do 120 | ment <- getTreeForKey $ packageTreeKey package 121 | case ment of 122 | Nothing -> error $ 123 | "invariant violated, Tree not found: " 124 | ++ show (packageTreeKey package) 125 | Just (Entity tid _) -> storeRepoCache repo (repoSubdir repo) tid 126 | pure package 127 | 128 | getRepo' :: 129 | forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 130 | => Repo 131 | -> RawPackageMetadata 132 | -> RIO env Package 133 | getRepo' repo@Repo{..} rpm = do 134 | withRepoArchive (rToSimpleRepo repo) $ \tarball -> do 135 | abs' <- resolveFile' tarball 136 | getArchivePackage 137 | (RPLIRepo repo rpm) 138 | RawArchive 139 | { raLocation = ALFilePath $ ResolvedPath 140 | { resolvedRelative = RelFilePath $ T.pack tarball 141 | , resolvedAbsolute = abs' 142 | } 143 | , raHash = Nothing 144 | , raSize = Nothing 145 | , raSubdir = repoSubdir 146 | } 147 | rpm 148 | 149 | getRepos :: 150 | forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 151 | => AggregateRepo 152 | -> RIO env [Package] 153 | getRepos repo@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = withCache getRepos' 154 | where 155 | withCache inner = do 156 | pkgs <- forM repoSubdirs $ \(subdir, rpm) -> withStorage $ do 157 | loadRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) >>= \case 158 | Just tid -> 159 | fmap Right $ (, subdir) <$> loadPackageById (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) tid 160 | Nothing -> pure $ Left (subdir, rpm) 161 | let (missingPkgs, cachedPkgs) = partitionEithers pkgs 162 | newPkgs <- 163 | if null missingPkgs 164 | then pure [] 165 | else do 166 | packages <- inner repo { aRepoSubdirs = missingPkgs } 167 | forM packages $ \(package, subdir) -> do 168 | withStorage $ do 169 | ment <- getTreeForKey $ packageTreeKey package 170 | case ment of 171 | Nothing -> error $ 172 | "invariant violated, Tree not found: " 173 | ++ show (packageTreeKey package) 174 | Just (Entity tid _) -> 175 | storeRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) subdir tid 176 | pure package 177 | pure (nubOrd ((fst <$> cachedPkgs) ++ newPkgs)) 178 | 179 | getRepos' :: 180 | forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 181 | => AggregateRepo 182 | -> RIO env [(Package, Text)] -- ^ [(package, subdir)] 183 | getRepos' ar@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = do 184 | withRepoArchive (arToSimpleRepo ar) $ \tarball -> do 185 | abs' <- resolveFile' tarball 186 | forM repoSubdirs $ \(subdir, rpm) -> do 187 | (,subdir) <$> getArchivePackage 188 | (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) 189 | RawArchive 190 | { raLocation = ALFilePath $ ResolvedPath 191 | { resolvedRelative = RelFilePath $ T.pack tarball 192 | , resolvedAbsolute = abs' 193 | } 194 | , raHash = Nothing 195 | , raSize = Nothing 196 | , raSubdir = subdir 197 | } 198 | rpm 199 | 200 | -- | Fetch a repository and create a (temporary) tar archive from it. Pass the 201 | -- path of the generated tarball to the given action. 202 | withRepoArchive :: 203 | forall env a. (HasLogFunc env, HasProcessContext env) 204 | => SimpleRepo 205 | -> (FilePath -> RIO env a) 206 | -> RIO env a 207 | withRepoArchive sr action = 208 | withSystemTempDirectory "with-repo-archive" $ \tmpdirArchive -> do 209 | let tarball = tmpdirArchive "foo.tar" 210 | createRepoArchive sr tarball 211 | action tarball 212 | 213 | -- | Run a git command, setting appropriate environment variable settings. See 214 | -- . 215 | runGitCommand :: 216 | (HasLogFunc env, HasProcessContext env) 217 | => [String] -- ^ args 218 | -> RIO env () 219 | runGitCommand args = 220 | withModifyEnvVars go $ 221 | void $ proc "git" args readProcess_ 222 | where 223 | go = Map.delete "GIT_DIR" 224 | . Map.delete "GIT_CEILING_DIRECTORIES" 225 | . Map.delete "GIT_WORK_TREE" 226 | . Map.delete "GIT_INDEX_FILE" 227 | . Map.delete "GIT_OBJECT_DIRECTORY" -- possible optimization: set this to something Pantry controls 228 | . Map.delete "GIT_ALTERNATE_OBJECT_DIRECTORIES" 229 | 230 | -- Include submodules files into the archive: use `git submodule foreach` to 231 | -- execute `git archive` in each submodule and generate tar archive. With bsd 232 | -- tar, the generated archive is extracted to a temporary folder and the files 233 | -- in them are added to the tarball referenced by the variable tarball in the 234 | -- haskell code. This is done in GNU tar with -A option. 235 | archiveSubmodules :: 236 | (HasLogFunc env, HasProcessContext env) 237 | => FilePath 238 | -> RIO env () 239 | archiveSubmodules tarball = do 240 | tarType <- getGitTarType 241 | let forceLocal = 242 | if osIsWindows 243 | then " --force-local " 244 | else mempty 245 | case tarType of 246 | Gnu -> do 247 | -- Single quotation marks are required around tarball because otherwise, 248 | -- in the foreach environment, the \ character in absolute paths on 249 | -- Windows will be interpreted as escaping the following character. 250 | let foreachCommand = 251 | "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; " 252 | <> "tar" <> forceLocal <> " -Af '" <> tarball <> "' bar.tar" 253 | runGitCommand 254 | [ "submodule" 255 | , "foreach" 256 | , "--recursive" 257 | , foreachCommand 258 | ] 259 | Bsd -> runGitCommand 260 | [ "submodule" 261 | , "foreach" 262 | , "--recursive" 263 | , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; " 264 | <> "rm -rf temp; mkdir temp; mv bar.tar temp/; " 265 | <> "tar -C temp -xf temp/bar.tar; " 266 | <> "rm temp/bar.tar; " 267 | <> "tar -C temp -rf " <> tarball <> " . ;" 268 | ] 269 | 270 | -- | Run an hg command 271 | runHgCommand :: 272 | (HasLogFunc env, HasProcessContext env) 273 | => [String] -- ^ args 274 | -> RIO env () 275 | runHgCommand args = void $ proc "hg" args readProcess_ 276 | 277 | -- | Create a tarball containing files from a repository 278 | createRepoArchive :: 279 | forall env. (HasLogFunc env, HasProcessContext env) 280 | => SimpleRepo 281 | -> FilePath -- ^ Output tar archive filename 282 | -> RIO env () 283 | createRepoArchive sr tarball = do 284 | withRepo sr $ 285 | case sRepoType sr of 286 | RepoGit -> do 287 | runGitCommand 288 | ["-c", "core.autocrlf=false", "archive", "-o", tarball, "HEAD"] 289 | archiveSubmodules tarball 290 | RepoHg -> runHgCommand ["archive", tarball, "-X", ".hg_archival.txt"] 291 | 292 | 293 | -- | Clone the repository (and, in the case of Git and if necessary, fetch the 294 | -- specific commit) and execute the action with the working directory set to the 295 | -- repository root. 296 | -- 297 | -- @since 0.1.0.0 298 | withRepo :: 299 | forall env a. (HasLogFunc env, HasProcessContext env) 300 | => SimpleRepo 301 | -> RIO env a 302 | -> RIO env a 303 | withRepo sr@SimpleRepo{..} action = 304 | withSystemTempDirectory "with-repo" $ \tmpDir -> do 305 | let repoUrl = T.unpack sRepoUrl 306 | repoCommit = T.unpack sRepoCommit 307 | dir = tmpDir "cloned" 308 | (runCommand, resetArgs) = 309 | case sRepoType of 310 | RepoGit -> 311 | ( runGitCommand 312 | , ["reset", "--hard", repoCommit] 313 | ) 314 | RepoHg -> 315 | ( runHgCommand 316 | , ["update", "-C", repoCommit] 317 | ) 318 | fetchCommit = ["fetch", repoUrl, repoCommit] 319 | submoduleArgs = ["submodule", "update", "--init", "--recursive"] 320 | fixANSIForWindows = 321 | -- On Windows 10, an upstream issue with the `git clone` command means 322 | -- that command clears, but does not then restore, the 323 | -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The 324 | -- following hack re-enables the lost ANSI-capability. 325 | when osIsWindows $ void $ liftIO $ 326 | #if MIN_VERSION_ansi_terminal(1, 0, 2) 327 | hNowSupportsANSI stdout 328 | #else 329 | hSupportsANSIWithoutEmulation stdout 330 | #endif 331 | logInfo $ "Cloning " <> display sRepoCommit <> " from " <> display sRepoUrl 332 | runCommand ["clone", repoUrl, dir] 333 | fixANSIForWindows 334 | created <- doesDirectoryExist dir 335 | unless created $ throwIO $ FailedToCloneRepo sr 336 | 337 | -- Note we do not immediately change directories into the new temporary 338 | -- directory, but instead wait until we have finished cloning the repo. This 339 | -- is because the repo URL may be a relative path on the local filesystem, 340 | -- and we should interpret it as relative to the current directory, not the 341 | -- temporary directory. 342 | withWorkingDir dir $ do 343 | case sRepoType of 344 | RepoGit -> do 345 | catch 346 | -- This will result in a failure exit code if the specified commit 347 | -- is not in the clone of the repository. 348 | (runCommand resetArgs) 349 | ( \(_ :: ExitCodeException) -> do 350 | -- Perhaps the specified commit is not one that is brought across 351 | -- by `git clone`. For example, in the case of a GitHub 352 | -- repository, it may be a commit from a different repository 353 | -- that is the subject of an unmerged pull request. Try to fetch 354 | -- the specific commit and then try again. 355 | runCommand fetchCommit 356 | runCommand resetArgs 357 | ) 358 | runCommand submoduleArgs 359 | fixANSIForWindows 360 | RepoHg -> runCommand resetArgs 361 | action 362 | -------------------------------------------------------------------------------- /src/Pantry/SQLite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Pantry.SQLite 7 | ( Storage (..) 8 | , initStorage 9 | ) where 10 | 11 | import Control.Concurrent.Companion 12 | ( Companion, onCompanionDone, withCompanion ) 13 | import Database.Persist.Sql ( runSqlConn ) 14 | import Database.Persist.Sql.Migration 15 | ( Migration, runMigrationSilent ) 16 | import Database.Persist.Sqlite 17 | ( extraPragmas, fkEnabled, mkSqliteConnectionInfo 18 | , walEnabled, withSqliteConnInfo 19 | ) 20 | import Pantry.Types ( PantryException (..), Storage (..) ) 21 | import Path ( Abs, File, Path, parent, toFilePath ) 22 | import Path.IO ( ensureDir ) 23 | import RIO hiding ( FilePath ) 24 | import RIO.Orphans () 25 | import System.FileLock 26 | ( SharedExclusive (..), withFileLock, withTryFileLock ) 27 | 28 | initStorage :: 29 | HasLogFunc env 30 | => Text -- ^ Database description, for lock messages. 31 | -> Migration -- ^ Initial migration. 32 | -> Path Abs File -- ^ SQLite database file. 33 | -> (Storage -> RIO env a) -- ^ What to do with the initialised 'Storage'. 34 | -> RIO env a 35 | initStorage description migration fp inner = do 36 | ensureDir $ parent fp 37 | 38 | migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $ 39 | withSqliteConnInfo (sqinfo True) $ runSqlConn $ 40 | runMigrationSilent migration 41 | forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig 42 | 43 | -- Make a single connection to the SQLite database and wrap it in an MVar for 44 | -- the entire execution context. Previously we used a resource pool of size 45 | -- 1, but (1) there's no advantage to that, and (2) it had a _very_ weird 46 | -- interaction with Docker on OS X where when resource-pool's reaper would 47 | -- trigger, it would somehow cause the Stack process inside the container to 48 | -- die with a SIGBUS. Definitely an interesting thing worth following up 49 | -- on... 50 | withSqliteConnInfo (sqinfo False) $ \conn0 -> do 51 | connVar <- newMVar conn0 52 | inner $ Storage 53 | -- NOTE: Currently, we take a write lock on every action. This is 54 | -- a bit heavyweight, but it avoids the SQLITE_BUSY errors 55 | -- reported in 56 | -- 57 | -- completely. We can investigate more elegant solutions in the 58 | -- future, such as separate read and write actions or introducing 59 | -- smarter retry logic. 60 | { withStorage_ = \action -> withMVar connVar $ \conn -> 61 | withWriteLock (display description) fp $ 62 | runSqlConn action conn 63 | , withWriteLock_ = id 64 | } 65 | where 66 | wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp) 67 | 68 | sqinfo isMigration 69 | = set extraPragmas ["PRAGMA busy_timeout=2000;"] 70 | $ set walEnabled False 71 | 72 | -- When doing a migration, we want to disable foreign key checking, since 73 | -- the order in which tables are created by the migration scripts may not 74 | -- respect foreign keys. The rest of the time: enforce those foreign keys. 75 | $ set fkEnabled (not isMigration) 76 | 77 | $ mkSqliteConnectionInfo (fromString $ toFilePath fp) 78 | 79 | -- | Ensure that only one process is trying to write to the database at a time. 80 | -- See https://github.com/commercialhaskell/stack/issues/4471 and comments 81 | -- above. 82 | withWriteLock :: 83 | HasLogFunc env 84 | => Utf8Builder -- ^ Database description, for lock messages 85 | -> Path Abs File -- ^ SQLite database file 86 | -> RIO env a 87 | -> RIO env a 88 | withWriteLock desc dbFile inner = do 89 | let lockFile = toFilePath dbFile ++ ".pantry-write-lock" 90 | withRunInIO $ \run -> do 91 | mres <- withTryFileLock lockFile Exclusive $ const $ run inner 92 | case mres of 93 | Just res -> pure res 94 | Nothing -> do 95 | let complainer :: Companion IO 96 | complainer delay = run $ do 97 | -- Wait five seconds before giving the first message to 98 | -- avoid spamming the user for uninteresting file locks 99 | delay $ 5 * 1000 * 1000 -- 5 seconds 100 | logInfo $ 101 | "Unable to get a write lock on the " 102 | <> desc 103 | <> " database, waiting..." 104 | 105 | -- Now loop printing a message every 1 minute 106 | forever $ do 107 | delay (60 * 1000 * 1000) -- 1 minute 108 | `onCompanionDone` logInfo 109 | ( "Acquired the " 110 | <> desc 111 | <> " database write lock" 112 | ) 113 | logWarn 114 | ( "Still waiting on the " 115 | <> desc 116 | <> " database write lock..." 117 | ) 118 | withCompanion complainer $ \stopComplaining -> 119 | withFileLock lockFile Exclusive $ const $ do 120 | stopComplaining 121 | run inner 122 | -------------------------------------------------------------------------------- /src/Pantry/Tree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | 4 | module Pantry.Tree 5 | ( unpackTree 6 | , rawParseGPD 7 | ) where 8 | 9 | import Distribution.PackageDescription ( GenericPackageDescription ) 10 | import Distribution.PackageDescription.Parsec 11 | ( parseGenericPackageDescription, runParseResult ) 12 | import Distribution.Parsec ( PWarning (..) ) 13 | import Pantry.Storage ( loadBlob, withStorage ) 14 | import Pantry.Types 15 | ( FileType (..), HasPantryConfig, PantryException (..) 16 | , RawPackageLocationImmutable, Tree (..), TreeEntry (..) 17 | , unSafeFilePath 18 | ) 19 | import Path ( Abs, Dir, File, Path, toFilePath ) 20 | import RIO 21 | import qualified RIO.ByteString as B 22 | import RIO.Directory 23 | ( createDirectoryIfMissing, getPermissions 24 | , setOwnerExecutable, setPermissions 25 | ) 26 | import RIO.FilePath ((), takeDirectory) 27 | import qualified RIO.Map as Map 28 | import qualified RIO.Text as T 29 | 30 | unpackTree :: 31 | (HasPantryConfig env, HasLogFunc env) 32 | => RawPackageLocationImmutable -- for exceptions 33 | -> Path Abs Dir -- ^ dest dir, will be created if necessary 34 | -> Tree 35 | -> RIO env () 36 | unpackTree rpli (toFilePath -> dir) (TreeMap m) = do 37 | withStorage $ for_ (Map.toList m) $ \(sfp, TreeEntry blobKey ft) -> do 38 | let dest = dir T.unpack (unSafeFilePath sfp) 39 | createDirectoryIfMissing True $ takeDirectory dest 40 | mbs <- loadBlob blobKey 41 | case mbs of 42 | Nothing -> do 43 | -- TODO when we have pantry wire stuff, try downloading 44 | throwIO $ TreeReferencesMissingBlob rpli sfp blobKey 45 | Just bs -> do 46 | B.writeFile dest bs 47 | case ft of 48 | FTNormal -> pure () 49 | FTExecutable -> liftIO $ do 50 | perms <- getPermissions dest 51 | setPermissions dest $ setOwnerExecutable True perms 52 | 53 | -- | A helper function that performs the basic character encoding necessary. 54 | rawParseGPD :: 55 | MonadThrow m 56 | => Either RawPackageLocationImmutable (Path Abs File) 57 | -> ByteString 58 | -> m ([PWarning], GenericPackageDescription) 59 | rawParseGPD loc bs = 60 | case eres of 61 | Left (mversion, errs) -> 62 | throwM $ InvalidCabalFile loc mversion (toList errs) warnings 63 | Right gpkg -> pure (warnings, gpkg) 64 | where 65 | (warnings, eres) = runParseResult $ parseGenericPackageDescription bs 66 | -------------------------------------------------------------------------------- /src/unix/System/IsWindows.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module System.IsWindows 4 | ( osIsWindows 5 | ) where 6 | 7 | import RIO ( Bool (..) ) 8 | 9 | -- | False if not using Windows OS. 10 | osIsWindows :: Bool 11 | osIsWindows = False 12 | -------------------------------------------------------------------------------- /src/windows/System/IsWindows.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module System.IsWindows 4 | ( osIsWindows 5 | ) where 6 | 7 | import RIO ( Bool (..) ) 8 | 9 | -- | True if using Windows OS. 10 | osIsWindows :: Bool 11 | osIsWindows = True 12 | -------------------------------------------------------------------------------- /stack-ghc-9.10.1.yaml: -------------------------------------------------------------------------------- 1 | # Snapshot specification for GHC 9.10.1. 2 | snapshot: nightly-2025-02-15 # GHC 9.10.1 3 | 4 | flags: 5 | path: 6 | os-string: true 7 | -------------------------------------------------------------------------------- /stack-ghc-9.12.2.yaml: -------------------------------------------------------------------------------- 1 | # Snapshot specification for GHC 9.12.2. 2 | snapshot: nightly-2025-03-27 # GHC 9.10.1 3 | compiler: ghc-9.12.2 4 | 5 | flags: 6 | path: 7 | os-string: true 8 | -------------------------------------------------------------------------------- /stack-ghc-9.2.8.yaml: -------------------------------------------------------------------------------- 1 | # Snapshot specification for GHC 9.2.8. 2 | snapshot: lts-20.26 # GHC 9.2.8 3 | 4 | packages: 5 | - aeson-warning-parser-0.1.1@sha256:e5b81492d39bfe5de99fdc838e54e0fc0f2e290eb9fcfd4531cabf24baeada76,1353 6 | # lts-20.26 provides casa-client-0.0.1 7 | - casa-client-0.0.2@sha256:1e27a6678c511b3372c4e97ab1a4a9eca4eca8a0a090eac103a1806ce7c8584d,888 8 | - companion-0.1.0@sha256:99f6de52c832d433639232a6d77d33abbca3b3037e49b7db6242fb9f569a8a2b,1093 9 | - crypton-0.33@sha256:5e92f29b9b7104d91fcdda1dec9400c9ad1f1791c231cc41ceebd783fb517dee,18202 10 | - crypton-conduit-0.2.3@sha256:31f44243b42f344c65be6cd2c39c07994d9186d19d15988656620d1de85aca37,1946 11 | - crypton-connection-0.3.1@sha256:4d0958537197956b536ea91718b1749949757022532f50b8f683290056a19021,1581 12 | - crypton-x509-1.7.6@sha256:c567657a705b6d6521f9dd2de999bf530d618ec00f3b939df76a41fb0fe94281,2339 13 | - crypton-x509-store-1.6.9@sha256:422b9b9f87a7382c66385d047615b16fc86a68c08ea22b1e0117c143a2d44050,1750 14 | - crypton-x509-system-1.6.7@sha256:023ed573d82983bc473a37a89e0434a085b413be9f68d07e085361056afd4637,1532 15 | - crypton-x509-validation-1.6.12@sha256:85989721b64be4b90de9f66ef641c26f57575cffed1a50d707065fb60176f386,2227 16 | # lts-20.26 provides hpack-0.35.2 17 | - hpack-0.35.5@sha256:22b46f28b53ec6fb2d05517b569a74b8b3e5e8c2e89c6b7ca25b345af62f22fa,5119 18 | # lts-20.26 provides http-client-tls-0.3.6.1 19 | - http-client-tls-0.3.6.3@sha256:a5909ce412ee65c141b8547f8fe22236f175186c95c708e86a46b5547394f910,2046 20 | # lts-20.26 provides http-download-0.2.0.0 21 | - http-download-0.2.1.0@sha256:a97863e96f7d44efc3d0e3061db7fe2540b8374ca44ae90d0b56040140cb7506,1716 22 | # lts-20.26 provides rio-prettyprint-0.1.3.0 23 | - rio-prettyprint-0.1.7.0@sha256:4f0f2dabcbc3be1f9871de7c2ff3d090b82462ca5924afa24f7b2540c5511d84,1428 24 | - static-bytes-0.1.1@sha256:e090886a4752a816cfff7ccb2c51c533cc8e39ec2d27e485427577fc92d9e9f9,1627 25 | # lts-20.26 provides tar-conduit-0.3.2 26 | - tar-conduit-0.4.1@sha256:112d28118eb71901ea9e224e1b174c648b378256729669c2739b8b803d25b43a,3126 27 | # crypton-connection-0.3.1 requires tls >= 1.7. lts-20.26 provides tls-1.5.8 28 | - tls-1.8.0@sha256:0ea435fb1969384c76e6b6ba49c509cec55eec29f60dd2c335151d9c8a4e8b4f,5571 29 | 30 | flags: 31 | ansi-terminal: 32 | win32-2-13-1: false 33 | -------------------------------------------------------------------------------- /stack-ghc-9.4.8.yaml: -------------------------------------------------------------------------------- 1 | # Snapshot specification for GHC 9.4.8. 2 | snapshot: lts-21.25 # GHC 9.4.8 3 | 4 | packages: 5 | - aeson-warning-parser-0.1.1@sha256:e5b81492d39bfe5de99fdc838e54e0fc0f2e290eb9fcfd4531cabf24baeada76,1353 6 | - companion-0.1.0@sha256:99f6de52c832d433639232a6d77d33abbca3b3037e49b7db6242fb9f569a8a2b,1093 7 | - crypton-connection-0.3.1@sha256:4d0958537197956b536ea91718b1749949757022532f50b8f683290056a19021,1581 8 | - crypton-x509-1.7.6@sha256:c567657a705b6d6521f9dd2de999bf530d618ec00f3b939df76a41fb0fe94281,2339 9 | - crypton-x509-store-1.6.9@sha256:422b9b9f87a7382c66385d047615b16fc86a68c08ea22b1e0117c143a2d44050,1750 10 | - crypton-x509-system-1.6.7@sha256:023ed573d82983bc473a37a89e0434a085b413be9f68d07e085361056afd4637,1532 11 | - crypton-x509-validation-1.6.12@sha256:85989721b64be4b90de9f66ef641c26f57575cffed1a50d707065fb60176f386,2227 12 | # lts-21.25 provides hpack-0.35.2 13 | - hpack-0.36.0@sha256:c2daa6556afc57367a5d1dbd878bf515d442d201e24b27473051359abd47ed08,5187 14 | # lts-21.25 provides http-client-tls-0.3.6.1 15 | - http-client-tls-0.3.6.3@sha256:a5909ce412ee65c141b8547f8fe22236f175186c95c708e86a46b5547394f910,2046 16 | # lts-21.25 provides http-download-0.2.0.0 17 | - http-download-0.2.1.0@sha256:a97863e96f7d44efc3d0e3061db7fe2540b8374ca44ae90d0b56040140cb7506,1716 18 | - static-bytes-0.1.1@sha256:e090886a4752a816cfff7ccb2c51c533cc8e39ec2d27e485427577fc92d9e9f9,1627 19 | # lts-21.25 provides tar-conduit-0.3.2.1 20 | - tar-conduit-0.4.1@sha256:112d28118eb71901ea9e224e1b174c648b378256729669c2739b8b803d25b43a,3126 21 | # crypton-connection-0.3.1 requires tls >= 1.7. lts-21.25 provides tls-1.6.0 22 | - tls-1.8.0@sha256:0ea435fb1969384c76e6b6ba49c509cec55eec29f60dd2c335151d9c8a4e8b4f,5571 23 | -------------------------------------------------------------------------------- /stack-ghc-9.6.7.yaml: -------------------------------------------------------------------------------- 1 | # Snapshot specification for GHC 9.6.7. 2 | snapshot: lts-22.43 # GHC 9.6.6 3 | compiler: ghc-9.6.7 4 | -------------------------------------------------------------------------------- /stack-ghc-9.8.4.yaml: -------------------------------------------------------------------------------- 1 | # Snapshot specification for GHC 9.8.4. 2 | snapshot: lts-23.8 # GHC 9.8.4 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | snapshot: stack-ghc-9.8.4.yaml 2 | 3 | # Added to allow testing of snapshot: stack-ghc-9.12.2.yaml: 4 | allow-newer: true 5 | -------------------------------------------------------------------------------- /test/Pantry/ArchiveSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Pantry.ArchiveSpec 6 | ( spec 7 | ) where 8 | 9 | import Data.Maybe ( fromJust ) 10 | import Pantry 11 | import Path.IO ( resolveFile' ) 12 | import RIO 13 | import RIO.Text as T 14 | import Test.Hspec 15 | 16 | data TestLocation 17 | = TLFilePath String 18 | | TLUrl Text 19 | 20 | data TestArchive = TestArchive 21 | { testLocation :: !TestLocation 22 | , testSubdir :: !Text 23 | } 24 | 25 | getRawPackageLocationIdent' :: TestArchive -> IO PackageIdentifier 26 | getRawPackageLocationIdent' TestArchive{..} = do 27 | testLocation' <- case testLocation of 28 | TLFilePath relPath -> do 29 | absPath <- resolveFile' relPath 30 | pure $ ALFilePath $ ResolvedPath 31 | { resolvedRelative = RelFilePath $ fromString relPath 32 | , resolvedAbsolute = absPath 33 | } 34 | TLUrl url -> pure $ ALUrl url 35 | let archive = RawArchive 36 | { raLocation = testLocation' 37 | , raHash = Nothing 38 | , raSize = Nothing 39 | , raSubdir = testSubdir 40 | } 41 | runPantryApp $ getRawPackageLocationIdent $ RPLIArchive archive metadata 42 | where 43 | metadata = RawPackageMetadata 44 | { rpmName = Nothing 45 | , rpmVersion = Nothing 46 | , rpmTreeKey = Nothing 47 | } 48 | 49 | parsePackageIdentifier' :: String -> PackageIdentifier 50 | parsePackageIdentifier' = fromJust . parsePackageIdentifier 51 | 52 | urlToStackCommit :: Text -> TestLocation 53 | urlToStackCommit commit = TLUrl $ T.concat 54 | [ "https://github.com/commercialhaskell/stack/archive/" 55 | , commit 56 | , ".tar.gz" 57 | ] 58 | 59 | treeWithoutCabalFile :: Selector PantryException 60 | treeWithoutCabalFile (TreeWithoutCabalFile _) = True 61 | treeWithoutCabalFile _ = False 62 | 63 | spec :: Spec 64 | spec = do 65 | it "finds cabal file from tarball" $ do 66 | ident <- getRawPackageLocationIdent' TestArchive 67 | { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" 68 | , testSubdir = "" 69 | } 70 | ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" 71 | it "finds cabal file from tarball with subdir '.'" $ do 72 | ident <- getRawPackageLocationIdent' TestArchive 73 | { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" 74 | , testSubdir = "." 75 | } 76 | ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" 77 | it "finds cabal file from tarball with a package.yaml" $ do 78 | ident <- getRawPackageLocationIdent' TestArchive 79 | { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" 80 | , testSubdir = "" 81 | } 82 | ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" 83 | it "finds cabal file from tarball with subdir '.' with a package.yaml" $ do 84 | ident <- getRawPackageLocationIdent' TestArchive 85 | { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" 86 | , testSubdir = "." 87 | } 88 | ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" 89 | it "finds cabal file from tarball with subdir 'subs/pantry/'" $ do 90 | ident <- getRawPackageLocationIdent' TestArchive 91 | { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" 92 | , testSubdir = "subs/pantry/" 93 | } 94 | ident `shouldBe` parsePackageIdentifier' "pantry-0.1.0.0" 95 | it "matches whole directory name" $ 96 | getRawPackageLocationIdent' TestArchive 97 | { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" 98 | , testSubdir = "subs/pant" 99 | } 100 | `shouldThrow` treeWithoutCabalFile 101 | it "follows symlinks to directories" $ do 102 | ident <- getRawPackageLocationIdent' TestArchive 103 | { testLocation = TLFilePath "attic/symlink-to-dir.tar.gz" 104 | , testSubdir = "symlink" 105 | } 106 | ident `shouldBe` parsePackageIdentifier' "foo-1.2.3" 107 | -------------------------------------------------------------------------------- /test/Pantry/BuildPlanSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Pantry.BuildPlanSpec where 5 | 6 | import Data.Aeson.WarningParser ( WithJSONWarnings(..) ) 7 | import qualified Data.ByteString.Char8 as S8 8 | import Data.Yaml ( decodeThrow ) 9 | import Pantry 10 | import RIO 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = 15 | describe "PackageLocation" $ do 16 | describe "Archive" $ do 17 | describe "github" $ do 18 | let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) 19 | decode' = decodeThrow 20 | 21 | decode'' :: HasCallStack => ByteString -> IO (NonEmpty RawPackageLocationImmutable) 22 | decode'' bs = do 23 | WithJSONWarnings unresolved warnings <- decode' bs 24 | unless (null warnings) $ error $ show warnings 25 | resolvePaths Nothing unresolved 26 | 27 | it "'github' and 'commit' keys" $ do 28 | let contents :: ByteString 29 | contents = 30 | S8.pack 31 | (unlines 32 | [ "github: oink/town" 33 | , "commit: abc123" 34 | ]) 35 | let expected :: RawPackageLocationImmutable 36 | expected = 37 | RPLIArchive 38 | RawArchive 39 | { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" 40 | , raHash = Nothing 41 | , raSize = Nothing 42 | , raSubdir = "" 43 | } 44 | RawPackageMetadata 45 | { rpmName = Nothing 46 | , rpmVersion = Nothing 47 | , rpmTreeKey = Nothing 48 | } 49 | actual <- decode'' contents 50 | actual `shouldBe` pure expected 51 | 52 | it "'github', 'commit', and 'subdirs' keys" $ do 53 | let contents :: ByteString 54 | contents = 55 | S8.pack 56 | (unlines 57 | [ "github: oink/town" 58 | , "commit: abc123" 59 | , "subdirs:" 60 | , " - foo" 61 | ]) 62 | let expected :: RawPackageLocationImmutable 63 | expected = 64 | RPLIArchive 65 | RawArchive 66 | { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" 67 | , raHash = Nothing 68 | , raSize = Nothing 69 | , raSubdir = "foo" 70 | } 71 | RawPackageMetadata 72 | { rpmName = Nothing 73 | , rpmVersion = Nothing 74 | , rpmTreeKey = Nothing 75 | } 76 | actual <- decode'' contents 77 | actual `shouldBe` pure expected 78 | 79 | it "does not parse GitHub repo with no slash" $ do 80 | let contents :: ByteString 81 | contents = 82 | S8.pack 83 | (unlines 84 | [ "github: oink" 85 | , "commit: abc123" 86 | ]) 87 | void (decode' contents) `shouldBe` Nothing 88 | 89 | it "does not parse GitHub repo with leading slash" $ do 90 | let contents :: ByteString 91 | contents = 92 | S8.pack 93 | (unlines 94 | [ "github: /oink" 95 | , "commit: abc123" 96 | ]) 97 | void (decode' contents) `shouldBe` Nothing 98 | 99 | it "does not parse GitHub repo with trailing slash" $ do 100 | let contents :: ByteString 101 | contents = 102 | S8.pack 103 | (unlines 104 | [ "github: oink/" 105 | , "commit: abc123" 106 | ]) 107 | void (decode' contents) `shouldBe` Nothing 108 | 109 | it "does not parse GitHub repo with more than one slash" $ do 110 | let contents :: ByteString 111 | contents = 112 | S8.pack 113 | (unlines 114 | [ "github: oink/town/here" 115 | , "commit: abc123" 116 | ]) 117 | void (decode' contents) `shouldBe` Nothing 118 | -------------------------------------------------------------------------------- /test/Pantry/CabalSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Pantry.CabalSpec 6 | ( spec 7 | ) where 8 | 9 | import Distribution.Types.PackageName ( mkPackageName ) 10 | import Distribution.Types.Version ( mkVersion ) 11 | import Pantry 12 | import qualified Pantry.SHA256 as SHA256 13 | import RIO 14 | import Test.Hspec 15 | 16 | spec :: Spec 17 | spec = describe "wrong cabal file" $ do 18 | let test :: HasCallStack => String -> RIO PantryApp () -> Spec 19 | test name action = it name (runPantryApp action :: IO ()) 20 | shouldThrow' x y = withRunInIO $ \run -> run x `shouldThrow` y 21 | test "Hackage" $ do 22 | sha <- either throwIO pure 23 | $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" 24 | let rpli = 25 | RPLIHackage 26 | (PackageIdentifierRevision 27 | name 28 | version3 29 | (CFIHash sha (Just size))) 30 | Nothing 31 | go = loadCabalFileRawImmutable rpli 32 | name = mkPackageName "acme-missiles" 33 | version2 = mkVersion [0, 2] 34 | version3 = mkVersion [0, 3] 35 | size = FileSize 597 36 | go `shouldThrow'` \case 37 | MismatchedPackageMetadata rpli' rpm _tree ident -> 38 | rpli == rpli' && 39 | rpm == RawPackageMetadata 40 | { rpmName = Just name 41 | , rpmVersion = Just version3 42 | , rpmTreeKey = Nothing 43 | } && 44 | ident == PackageIdentifier name version2 45 | _ -> False 46 | 47 | test "tarball with wrong ident" $ do 48 | archiveHash' <- either throwIO pure 49 | $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" 50 | let rpli = RPLIArchive archive rpm 51 | archive = 52 | RawArchive 53 | { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" 54 | , raHash = Just archiveHash' 55 | , raSize = Just $ FileSize 309199 56 | , raSubdir = "yesod-auth" 57 | } 58 | rpm = 59 | RawPackageMetadata 60 | { rpmName = Just acmeMissiles 61 | , rpmVersion = Just version2 62 | , rpmTreeKey = Nothing 63 | } 64 | go = loadCabalFileRawImmutable rpli 65 | acmeMissiles = mkPackageName "acme-missiles" 66 | version2 = mkVersion [0, 2] 67 | go `shouldThrow'` \case 68 | MismatchedPackageMetadata rpli' rpm' _treeKey ident -> 69 | rpli == rpli' && 70 | rpm == rpm' && 71 | ident == PackageIdentifier 72 | (mkPackageName "yesod-auth") 73 | (mkVersion [1, 6, 4, 1]) 74 | _ -> False 75 | 76 | test "tarball with wrong cabal file" $ do 77 | let rpli = RPLIArchive archive rpm 78 | archive = 79 | RawArchive 80 | { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" 81 | , raHash = either impureThrow Just 82 | $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" 83 | , raSize = Just $ FileSize 309199 84 | , raSubdir = "yesod-auth" 85 | } 86 | rpm = 87 | RawPackageMetadata 88 | { rpmName = Just yesodAuth 89 | , rpmVersion = Just badVersion 90 | , rpmTreeKey = Nothing 91 | } 92 | go = loadCabalFileRawImmutable rpli 93 | yesodAuth = mkPackageName "yesod-auth" 94 | version = mkVersion [1, 6, 4, 1] 95 | badVersion = mkVersion [1, 6, 4, 0] 96 | go `shouldThrow'` \case 97 | MismatchedPackageMetadata rpli' rpm' _treeKey ident -> 98 | rpli == rpli' && 99 | rpm == rpm' && 100 | ident == PackageIdentifier yesodAuth version 101 | _ -> False 102 | -------------------------------------------------------------------------------- /test/Pantry/CasaSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Pantry.CasaSpec 4 | ( spec 5 | ) where 6 | 7 | import Distribution.Types.Version ( mkVersion ) 8 | import Pantry 9 | import Pantry.SHA256 10 | import Test.Hspec 11 | 12 | spec :: Spec 13 | spec = do 14 | loadHackagePackageSpec 15 | completeSpec 16 | 17 | completeSpec :: Spec 18 | completeSpec = 19 | it 20 | "completePackageLocation: unliftio_0_2_12" 21 | (shouldReturn 22 | (runPantryAppClean 23 | (cplComplete <$> completePackageLocation (argsRlpi unliftio_0_2_12))) 24 | ( PLIHackage 25 | (PackageIdentifier 26 | { pkgName = "unliftio" 27 | , pkgVersion = mkVersion [0, 2, 12] 28 | }) 29 | (argsCabalKey unliftio_0_2_12) 30 | (argsTreeKey unliftio_0_2_12))) 31 | 32 | loadHackagePackageSpec :: Spec 33 | loadHackagePackageSpec = do 34 | it 35 | "loadPackageRaw Exact hackage lookup" 36 | (shouldReturn 37 | (fmap 38 | packageTreeKey 39 | (runPantryAppClean (loadPackageRaw (argsRlpi unliftio_0_2_12)))) 40 | (argsTreeKey unliftio_0_2_12)) 41 | it 42 | "loadHackagePackageRaw Exact hackage lookup" 43 | (shouldReturn 44 | (fmap 45 | packageTreeKey 46 | (runPantryAppClean (loadPackageRaw (argsRlpi unliftio_0_2_12)))) 47 | (argsTreeKey unliftio_0_2_12)) 48 | it 49 | "loadHackagePackageRawViaCasa Exact hackage lookup" 50 | (shouldReturn 51 | (fmap 52 | (fmap packageTreeKey) 53 | (runPantryAppClean 54 | (tryLoadPackageRawViaCasa 55 | (argsRlpi unliftio_0_2_12) 56 | (argsTreeKey unliftio_0_2_12)))) 57 | (Just (argsTreeKey unliftio_0_2_12))) 58 | 59 | data Args = 60 | Args 61 | { argsRlpi :: !RawPackageLocationImmutable 62 | , argsTreeKey :: !TreeKey 63 | , argsRevision :: !PackageIdentifierRevision 64 | , argsCabalKey :: !BlobKey 65 | } 66 | 67 | unliftio_0_2_12 :: Args 68 | unliftio_0_2_12 = 69 | let cabalHash = either 70 | (error . show) 71 | id 72 | (fromHexText 73 | "b089fbc2ff2628a963c2c4b12143f2020874e3e5144ffd6c62b25639a0ca1483") 74 | cabalLen = FileSize 3325 75 | cabalFileHash = 76 | CFIHash 77 | cabalHash 78 | (Just cabalLen) 79 | casaTreeKey = 80 | TreeKey 81 | (BlobKey 82 | (either 83 | (error . show) 84 | id 85 | (fromHexText 86 | "4971b43f3d473eff868eb1a0c359729b49f1779e78c462ba45ef0d1eda677699")) 87 | (FileSize 2229)) 88 | pir = 89 | PackageIdentifierRevision 90 | "unliftio" 91 | (mkVersion [0, 2, 12]) 92 | cabalFileHash 93 | in Args 94 | { argsRevision = pir 95 | , argsRlpi = RPLIHackage pir (Just casaTreeKey) 96 | , argsTreeKey = casaTreeKey 97 | , argsCabalKey = BlobKey cabalHash cabalLen 98 | } 99 | -------------------------------------------------------------------------------- /test/Pantry/FileSpec.hs: -------------------------------------------------------------------------------- 1 | module Pantry.FileSpec 2 | ( spec 3 | ) where 4 | 5 | import Control.Monad ( void ) 6 | import Pantry 7 | import Path 8 | import Path.IO 9 | import Test.Hspec 10 | 11 | spec :: Spec 12 | spec = describe "loadCabalFilePath" $ do 13 | it "sanity" $ do 14 | abs' <- resolveDir' "." 15 | (f, name, cabalfp) <- runPantryApp $ loadCabalFilePath Nothing abs' 16 | suffix <- parseRelFile "pantry.cabal" 17 | cabalfp `shouldBe` abs' suffix 18 | name' <- parsePackageNameThrowing "pantry" 19 | name `shouldBe` name' 20 | void $ f NoPrintWarnings 21 | -------------------------------------------------------------------------------- /test/Pantry/GlobalHintsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Pantry.GlobalHintsSpec 6 | ( spec 7 | ) where 8 | 9 | import Distribution.Types.PackageName ( mkPackageName ) 10 | import Distribution.Version ( mkVersion ) 11 | import Pantry ( WantedCompiler (..), loadGlobalHints, runPantryAppClean ) 12 | import Pantry.Types ( getGlobalHintsFile ) 13 | import Path ( toFilePath ) 14 | import RIO 15 | import qualified RIO.Map as Map 16 | import Test.Hspec 17 | 18 | spec :: Spec 19 | spec = do 20 | let it' name inner = it name $ example $ runPantryAppClean $ do 21 | file <- getGlobalHintsFile 22 | writeFileBinary (toFilePath file) "this should be ignored" 23 | inner 24 | it' "unknown compiler" $ do 25 | mmap <- loadGlobalHints $ WCGhc (mkVersion [0, 0, 0, 0, 0, 0, 0]) 26 | liftIO $ mmap `shouldBe` Nothing 27 | it' "known compiler" $ do 28 | mmap <- loadGlobalHints $ WCGhc (mkVersion [8, 4, 3]) 29 | case mmap of 30 | Nothing -> error "not found" 31 | Just m -> liftIO $ do 32 | Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [8, 4, 3]) 33 | Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 11, 1, 0]) 34 | Map.lookup (mkPackageName "bytestring") m `shouldBe` Just (mkVersion [0, 10, 8, 2]) 35 | Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing 36 | it' "older known compiler" $ do 37 | mmap <- loadGlobalHints $ WCGhc (mkVersion [7, 8, 4]) 38 | case mmap of 39 | Nothing -> error "not found" 40 | Just m -> liftIO $ do 41 | Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [7, 8, 4]) 42 | Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 7, 0, 2]) 43 | Map.lookup (mkPackageName "Cabal") m `shouldBe` Just (mkVersion [1, 18, 1, 5]) 44 | Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing 45 | -------------------------------------------------------------------------------- /test/Pantry/HackageSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Pantry.HackageSpec 6 | ( spec 7 | ) where 8 | 9 | import Distribution.Types.Version ( mkVersion ) 10 | import Pantry 11 | import RIO 12 | import Test.Hspec 13 | 14 | spec :: Spec 15 | spec = do 16 | it "update works" $ asIO $ void $ runPantryApp $ updateHackageIndex Nothing 17 | it "fuzzy lookup kicks in" $ do 18 | let pir = PackageIdentifierRevision "thisisnot-tobe-foundon-hackage-please" (mkVersion [1..3]) CFILatest 19 | runPantryApp (loadPackageRaw (RPLIHackage pir Nothing)) 20 | `shouldThrow` \case 21 | UnknownHackagePackage pir' _ -> pir == pir' 22 | _ -> False 23 | -- Flaky test, can be broken by new packages on Hackage. 24 | it "finds acme-missiles" $ do 25 | x <- runPantryApp (getHackageTypoCorrections "acme-missile") 26 | x `shouldSatisfy` ("acme-missiles" `elem`) 27 | -------------------------------------------------------------------------------- /test/Pantry/InternalSpec.hs: -------------------------------------------------------------------------------- 1 | module Pantry.InternalSpec 2 | ( spec 3 | ) where 4 | 5 | import Pantry ( runPantryApp ) 6 | import Pantry.HPack ( hpackVersion ) 7 | import Pantry.Internal ( makeTarRelative, normalizeParents ) 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "normalizeParents" $ do 13 | let (!) :: HasCallStack => String -> Maybe String -> Spec 14 | input ! output = 15 | it input $ 16 | let x = normalizeParents input 17 | y = either (const Nothing) Just x 18 | in y `shouldBe` output 19 | 20 | "/file/\\test" ! Nothing 21 | "file/\\test" ! Just "file/\\test" 22 | "/file/////\\test" ! Nothing 23 | "file/////\\test" ! Just "file/\\test" 24 | "file/test/" ! Just "file/test" 25 | "/file/\\test////" ! Nothing 26 | "/file/./test" ! Nothing 27 | "file/./test" ! Just "file/test" 28 | "/test/file/../bob/fred/" ! Nothing 29 | "/test/file/../bob/fred" ! Nothing 30 | "test/file/../bob/fred/" ! Just "test/bob/fred" 31 | "test/file/../bob/fred" ! Just "test/bob/fred" 32 | "test0/test1/file/../../bob/fred" ! Just "test0/bob/fred" 33 | "../bob/fred" ! Nothing 34 | "../bob/fred/" ! Nothing 35 | "./bob/fred/" ! Just "bob/fred" 36 | "./bob/fred" ! Just "bob/fred" 37 | "./" ! Nothing 38 | "./." ! Nothing 39 | "/./" ! Nothing 40 | "/" ! Nothing 41 | "bob/fred/." ! Nothing 42 | "//home" ! Nothing 43 | "foobarbaz\\bin" ! Just "foobarbaz\\bin" 44 | 45 | describe "makeTarRelative" $ do 46 | let test :: HasCallStack => FilePath -> FilePath -> Maybe FilePath -> Spec 47 | test base rel expected = 48 | it (show (base, rel)) $ 49 | either (const Nothing) Just (makeTarRelative base rel) 50 | `shouldBe` expected 51 | 52 | test "foo/bar" "baz" $ Just "foo/baz" 53 | test "foo" "bar" $ Just "bar" 54 | test "foo" "/bar" Nothing 55 | test "foo/" "bar" Nothing 56 | 57 | -- MSS 2018-08-23: Arguable whether this should be Nothing 58 | -- instead, since we don't want any absolute paths. However, 59 | -- that's really a concern for normalizeParents. Point being: if 60 | -- you refactor in the future, and this turns into Nothing, that's 61 | -- fine. 62 | test "/foo" "bar" $ Just "/bar" 63 | 64 | describe "Parse HPack version" $ do 65 | {- 66 | let isVersion :: Version -> Bool 67 | isVersion _ = True 68 | -} 69 | 70 | it "Shipped hpack version" $ example $ do 71 | _version <- runPantryApp hpackVersion 72 | -- version `shouldSatisfy` isVersion 73 | pure () 74 | 75 | -- it "External hpack version" $ do 76 | -- version <- runPantryApp $ customHpack "/home/sibi/.local/bin/hpack" hpackVersion 77 | -- version `shouldSatisfy` isVersion 78 | -------------------------------------------------------------------------------- /test/Pantry/TreeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Pantry.TreeSpec 5 | ( spec 6 | ) where 7 | 8 | import Distribution.Types.PackageName ( mkPackageName ) 9 | import Distribution.Types.Version ( mkVersion ) 10 | import Pantry 11 | import qualified Pantry.SHA256 as SHA256 12 | import RIO 13 | import Test.Hspec 14 | 15 | spec :: Spec 16 | spec = do 17 | let tarURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.tar.gz" 18 | zipURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.zip" 19 | emptyPM = RawPackageMetadata 20 | { rpmName = Nothing 21 | , rpmVersion = Nothing 22 | , rpmTreeKey = Nothing 23 | } 24 | mkArchive url = 25 | RPLIArchive 26 | RawArchive 27 | { raLocation = ALUrl url 28 | , raHash = Nothing 29 | , raSize = Nothing 30 | , raSubdir = "" 31 | } 32 | emptyPM 33 | tarPL = mkArchive tarURL 34 | zipPL = mkArchive zipURL 35 | gitPL = 36 | RPLIRepo 37 | Repo 38 | { repoUrl = "https://github.com/snoyberg/file-embed.git" 39 | , repoCommit = "47b499c3c58ca465c56ee0295d0a76782a66751d" 40 | , repoType = RepoGit 41 | , repoSubdir = "" 42 | } 43 | emptyPM 44 | hgPL = 45 | RPLIRepo 46 | Repo 47 | { repoUrl = "https://bitbucket.org/snoyberg/file-embed" 48 | , repoCommit = "6d8126e7a4821788a0275fa7c2c4a0083e14d690" 49 | , repoType = RepoHg 50 | , repoSubdir = "" 51 | } 52 | emptyPM 53 | 54 | it "zip and tar.gz archives match" $ asIO $ runPantryAppClean $ do 55 | pair1 <- loadPackageRaw tarPL 56 | pair2 <- loadPackageRaw zipPL 57 | liftIO $ pair2 `shouldBe` pair1 58 | it "archive and Git repo match" $ asIO $ runPantryAppClean $ do 59 | pair1 <- loadPackageRaw tarPL 60 | pair2 <- loadPackageRaw gitPL 61 | liftIO $ pair2 `shouldBe` pair1 62 | -- https://github.com/commercialhaskell/pantry/issues/26 63 | xit "archive and Hg repo match" $ asIO $ runPantryAppClean $ do 64 | pair1 <- loadPackageRaw tarPL 65 | pair2 <- loadPackageRaw hgPL 66 | liftIO $ pair2 `shouldBe` pair1 67 | 68 | it "5045 no cabal file" $ asIO $ runPantryAppClean $ do 69 | let rpli = RPLIArchive archive rpm 70 | packageName = mkPackageName "yaml" 71 | version = mkVersion [0, 11, 1, 2] 72 | archive = 73 | RawArchive 74 | { raLocation = ALUrl "https://github.com/snoyberg/yaml/archive/yaml-0.11.1.2.tar.gz" 75 | , raHash = either impureThrow Just 76 | $ SHA256.fromHexBytes "b8564e99c555e670ee487bbf92d03800d955f0e6e16333610ef46534548e0a3d" 77 | , raSize = Just $ FileSize 94198 78 | , raSubdir = "yaml" 79 | } 80 | rpm = 81 | RawPackageMetadata 82 | { rpmName = Just packageName 83 | , rpmVersion = Just version 84 | , rpmTreeKey = Nothing 85 | } 86 | void $ loadCabalFileRawImmutable rpli 87 | -------------------------------------------------------------------------------- /test/Pantry/TypesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | 9 | module Pantry.TypesSpec 10 | ( spec 11 | ) where 12 | 13 | import Data.Aeson.WarningParser ( WithJSONWarnings (..) ) 14 | import qualified Data.ByteString.Char8 as S8 15 | import qualified Data.Yaml as Yaml 16 | import Distribution.Types.PackageName ( mkPackageName ) 17 | import Distribution.Types.Version ( mkVersion ) 18 | import Hedgehog 19 | import qualified Hedgehog.Gen as Gen 20 | import qualified Hedgehog.Range as Range 21 | import Pantry 22 | import qualified Pantry.SHA256 as SHA256 23 | import Pantry.Types 24 | ( Tree (..), TreeEntry (..), parseTree, renderTree ) 25 | import RIO 26 | import qualified RIO.Text as T 27 | import RIO.Time ( Day (..), fromGregorian ) 28 | import Test.Hspec 29 | import Text.RawString.QQ 30 | 31 | hh :: HasCallStack => String -> Property -> Spec 32 | hh name p = it name $ do 33 | result <- check p 34 | unless result $ throwString "Hedgehog property failed" :: IO () 35 | 36 | genBlobKey :: Gen BlobKey 37 | genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> Gen.word (Range.linear 1 10000)) 38 | 39 | genSha256 :: Gen SHA256 40 | genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500) 41 | 42 | samplePLIRepo :: ByteString 43 | samplePLIRepo = 44 | [r| 45 | subdir: wai 46 | cabal-file: 47 | # This is ignored, only included to make sure we get no warnings 48 | size: 1765 49 | sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 50 | name: wai 51 | version: 3.2.1.2 52 | git: https://github.com/yesodweb/wai.git 53 | pantry-tree: 54 | size: 714 55 | sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 56 | commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 57 | |] 58 | 59 | samplePLIRepo2 :: ByteString 60 | samplePLIRepo2 = 61 | [r| 62 | name: merkle-log 63 | version: 0.1.0.0 64 | git: https://github.com/kadena-io/merkle-log.git 65 | pantry-tree: 66 | size: 615 67 | sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d 68 | commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376 69 | |] 70 | 71 | spec :: Spec 72 | spec = do 73 | describe "WantedCompiler" $ do 74 | hh "parse/render works" $ property $ do 75 | wc <- forAll $ 76 | let ghc = WCGhc <$> genVersion 77 | ghcjs = WCGhcjs <$> genVersion <*> genVersion 78 | genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100)) 79 | in Gen.choice [ghc, ghcjs] 80 | let text = utf8BuilderToText $ display wc 81 | case parseWantedCompiler text of 82 | Left e -> throwIO e 83 | Right actual -> liftIO $ actual `shouldBe` wc 84 | 85 | describe "Tree" $ do 86 | hh "parse/render works" $ property $ do 87 | tree <- forAll $ 88 | let sfp = do 89 | pieces <- Gen.list (Range.linear 1 10) sfpComponent 90 | let combined = T.intercalate "/" pieces 91 | case mkSafeFilePath combined of 92 | Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces 93 | Just sfp' -> pure sfp' 94 | sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum 95 | entry = TreeEntry 96 | <$> genBlobKey 97 | <*> Gen.choice (map pure [minBound..maxBound]) 98 | in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry) 99 | let bs = renderTree tree 100 | liftIO $ parseTree bs `shouldBe` Just tree 101 | 102 | describe "(Raw)SnapshotLayer" $ do 103 | let parseSl :: String -> IO RawSnapshotLayer 104 | parseSl str = case Yaml.decodeThrow . S8.pack $ str of 105 | (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x 106 | Nothing -> fail "Can't parse RawSnapshotLayer" 107 | 108 | it "parses snapshot using 'resolver'" $ do 109 | RawSnapshotLayer{..} <- parseSl $ 110 | "name: 'test'\n" ++ 111 | "resolver: lts-22.9\n" 112 | rslParent `shouldBe` RSLSynonym (LTS 22 9) 113 | 114 | it "parses snapshot using 'snapshot'" $ do 115 | RawSnapshotLayer{..} <- parseSl $ 116 | "name: 'test'\n" ++ 117 | "snapshot: lts-22.9\n" 118 | rslParent `shouldBe` RSLSynonym (LTS 22 9) 119 | 120 | it "throws if both 'resolver' and 'snapshot' are present" $ do 121 | let go = parseSl $ 122 | "name: 'test'\n" ++ 123 | "resolver: lts-22.9\n" ++ 124 | "snapshot: lts-22.9\n" 125 | go `shouldThrow` anyException 126 | 127 | it "throws if both 'snapshot' and 'compiler' are not present" $ do 128 | let go = parseSl "name: 'test'\n" 129 | go `shouldThrow` anyException 130 | 131 | it "works if no 'snapshot' specified" $ do 132 | RawSnapshotLayer{..} <- parseSl $ 133 | "name: 'test'\n" ++ 134 | "compiler: ghc-9.6.4\n" 135 | rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [9, 6, 4])) 136 | 137 | hh "rendering the name of an LTS to JSON" $ property $ do 138 | (major, minor) <- forAll $ (,) 139 | <$> Gen.integral (Range.linear 1 10000) 140 | <*> Gen.integral (Range.linear 1 10000) 141 | liftIO $ 142 | Yaml.toJSON (RSLSynonym $ LTS major minor) `shouldBe` 143 | Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor]) 144 | 145 | hh "rendering the name of a nightly to JSON" $ property $ do 146 | days <- forAll $ Gen.integral $ Range.linear 1 10000000 147 | let day = ModifiedJulianDay days 148 | liftIO $ 149 | Yaml.toJSON (RSLSynonym $ Nightly day) `shouldBe` 150 | Yaml.String (T.pack $ "nightly-" ++ show day) 151 | it "FromJSON instance for PLIRepo" $ do 152 | WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo 153 | warnings `shouldBe` [] 154 | pli <- resolvePaths Nothing unresolvedPli 155 | let repoValue = 156 | Repo 157 | { repoSubdir = "wai" 158 | , repoType = RepoGit 159 | , repoCommit = 160 | "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" 161 | , repoUrl = "https://github.com/yesodweb/wai.git" 162 | } 163 | pantrySha = 164 | SHA256.fromHexBytes 165 | "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2" 166 | psha <- case pantrySha of 167 | Right psha -> pure psha 168 | _ -> fail "Failed decoding sha256" 169 | let pkgValue = 170 | PackageMetadata 171 | { pmIdent = 172 | PackageIdentifier 173 | (mkPackageName "wai") 174 | (mkVersion [3, 2, 1, 2]) 175 | , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) 176 | } 177 | pli `shouldBe` PLIRepo repoValue pkgValue 178 | 179 | WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli 180 | warnings2 `shouldBe` [] 181 | reparsed' <- resolvePaths Nothing reparsed 182 | reparsed' `shouldBe` pli 183 | it "parseHackageText parses" $ do 184 | let txt = 185 | "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" 186 | hsha = 187 | SHA256.fromHexBytes 188 | "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" 189 | sha <- case hsha of 190 | Right sha' -> pure sha' 191 | _ -> fail "parseHackagetext: failed decoding the sha256" 192 | let Right (pkgIdentifier, blobKey) = parseHackageText txt 193 | blobKey `shouldBe` BlobKey sha (FileSize 5058) 194 | pkgIdentifier `shouldBe` 195 | PackageIdentifier 196 | (mkPackageName "persistent") 197 | (mkVersion [2, 8, 2]) 198 | it "roundtripping a PLIRepo" $ do 199 | WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2 200 | warnings `shouldBe` [] 201 | pli <- resolvePaths Nothing unresolvedPli 202 | WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli 203 | warnings2 `shouldBe` [] 204 | pli2 <- resolvePaths Nothing unresolvedPli2 205 | pli2 `shouldBe` (pli :: PackageLocationImmutable) 206 | 207 | describe "completeSnapshotLocation" $ do 208 | let sameUrl (SLUrl txt _) (RSLUrl txt' _) txt'' = 209 | do 210 | txt `shouldBe` txt' 211 | txt `shouldBe` txt'' 212 | sameUrl _ _ _ = liftIO $ error "Snapshot synonym did not complete as expected" 213 | 214 | it "default location for nightly-2024-02-04" $ do 215 | let sn = Nightly $ fromGregorian 2024 2 4 216 | loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn 217 | sameUrl loc (defaultSnapshotLocation sn) 218 | "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2024/2/4.yaml" 219 | 220 | it "default location for lts-22.9" $ do 221 | let sn = LTS 22 9 222 | loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn 223 | sameUrl loc (defaultSnapshotLocation sn) 224 | "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/9.yaml" 225 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------