diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,511 @@ +# Changelog + +## [Unreleased](https://github.com/haskell-works/cabal-cache/tree/HEAD) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.1.0.0...HEAD) + +**Closed issues:** + +- sync-from-archive does not consider ${archive\_version}/${store\_hash} subfolder if syncing from \(local\) archive directory [\#236](https://github.com/haskell-works/cabal-cache/issues/236) +- Wrong region parsing [\#230](https://github.com/haskell-works/cabal-cache/issues/230) + +**Merged pull requests:** + +- Issue 236 make sync from archive consider store hash folder [\#238](https://github.com/haskell-works/cabal-cache/pull/238) ([newhoggy](https://github.com/newhoggy)) +- CHG: handle NotFound in readFirstAvailableResource to make sure that … [\#237](https://github.com/haskell-works/cabal-cache/pull/237) ([snetramo](https://github.com/snetramo)) +- Update upper bounds [\#234](https://github.com/haskell-works/cabal-cache/pull/234) ([newhoggy](https://github.com/newhoggy)) + +## [v1.1.0.0](https://github.com/haskell-works/cabal-cache/tree/v1.1.0.0) (2023-08-09) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.6.1...v1.1.0.0) + +**Merged pull requests:** + +- Support newer ghcs [\#233](https://github.com/haskell-works/cabal-cache/pull/233) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to `amazonka-2` [\#232](https://github.com/haskell-works/cabal-cache/pull/232) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to haskell/actions/setup@v2 [\#229](https://github.com/haskell-works/cabal-cache/pull/229) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to haskell/actions/setup@v2 [\#228](https://github.com/haskell-works/cabal-cache/pull/228) ([newhoggy](https://github.com/newhoggy)) +- Fix set-output warnings in CI [\#225](https://github.com/haskell-works/cabal-cache/pull/225) ([newhoggy](https://github.com/newhoggy)) +- Ignore packages cli option [\#224](https://github.com/haskell-works/cabal-cache/pull/224) ([newhoggy](https://github.com/newhoggy)) +- Upgrade oops [\#223](https://github.com/haskell-works/cabal-cache/pull/223) ([newhoggy](https://github.com/newhoggy)) +- Split AppError type [\#220](https://github.com/haskell-works/cabal-cache/pull/220) ([newhoggy](https://github.com/newhoggy)) +- Move S3 functions to own module. Drop antiope dependency [\#219](https://github.com/haskell-works/cabal-cache/pull/219) ([newhoggy](https://github.com/newhoggy)) +- New cp command for debugging purposes [\#218](https://github.com/haskell-works/cabal-cache/pull/218) ([newhoggy](https://github.com/newhoggy)) +- Remove Github Actions environment [\#217](https://github.com/haskell-works/cabal-cache/pull/217) ([newhoggy](https://github.com/newhoggy)) +- Break apart app error [\#216](https://github.com/haskell-works/cabal-cache/pull/216) ([newhoggy](https://github.com/newhoggy)) +- Remove project.sh [\#215](https://github.com/haskell-works/cabal-cache/pull/215) ([newhoggy](https://github.com/newhoggy)) +- Remove tasks.json from git tracking [\#214](https://github.com/haskell-works/cabal-cache/pull/214) ([newhoggy](https://github.com/newhoggy)) +- Use oops for error handling [\#213](https://github.com/haskell-works/cabal-cache/pull/213) ([newhoggy](https://github.com/newhoggy)) +- Update copyright [\#212](https://github.com/haskell-works/cabal-cache/pull/212) ([newhoggy](https://github.com/newhoggy)) +- Delete unused code [\#209](https://github.com/haskell-works/cabal-cache/pull/209) ([newhoggy](https://github.com/newhoggy)) +- Tidy up cabal file [\#208](https://github.com/haskell-works/cabal-cache/pull/208) ([newhoggy](https://github.com/newhoggy)) +- Fix sync-to-archive [\#206](https://github.com/haskell-works/cabal-cache/pull/206) ([hasufell](https://github.com/hasufell)) + +## [v1.0.6.1](https://github.com/haskell-works/cabal-cache/tree/v1.0.6.1) (2023-02-04) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.6.0...v1.0.6.1) + +## [v1.0.6.0](https://github.com/haskell-works/cabal-cache/tree/v1.0.6.0) (2023-02-04) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.5.5...v1.0.6.0) + +**Closed issues:** + +- Collaboration [\#211](https://github.com/haskell-works/cabal-cache/issues/211) + +## [v1.0.5.5](https://github.com/haskell-works/cabal-cache/tree/v1.0.5.5) (2022-12-30) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.5.4...v1.0.5.5) + +**Closed issues:** + +- cabal-cache exits with "thread blocked indefinitely" [\#76](https://github.com/haskell-works/cabal-cache/issues/76) + +**Merged pull requests:** + +- Restrictive retry [\#205](https://github.com/haskell-works/cabal-cache/pull/205) ([hasufell](https://github.com/hasufell)) + +## [v1.0.5.4](https://github.com/haskell-works/cabal-cache/tree/v1.0.5.4) (2022-12-21) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.5.2...v1.0.5.4) + +## [v1.0.5.2](https://github.com/haskell-works/cabal-cache/tree/v1.0.5.2) (2022-12-21) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.5.1...v1.0.5.2) + +**Closed issues:** + +- Should cabal-cache retry failed downloads/uploads? [\#191](https://github.com/haskell-works/cabal-cache/issues/191) +- Trying to use root of the S3 bucket results in `/` key. [\#152](https://github.com/haskell-works/cabal-cache/issues/152) + +**Merged pull requests:** + +- Catch log and rethrow exceptions during download. [\#198](https://github.com/haskell-works/cabal-cache/pull/198) ([newhoggy](https://github.com/newhoggy)) +- Try to fix STM bug wrt \#76 [\#196](https://github.com/haskell-works/cabal-cache/pull/196) ([newhoggy](https://github.com/newhoggy)) +- Fix versioned compiler detection on windows [\#195](https://github.com/haskell-works/cabal-cache/pull/195) ([hasufell](https://github.com/hasufell)) +- More robust store dir detection [\#194](https://github.com/haskell-works/cabal-cache/pull/194) ([hasufell](https://github.com/hasufell)) +- Retry s3 upload/download, fixes \#191 [\#193](https://github.com/haskell-works/cabal-cache/pull/193) ([hasufell](https://github.com/hasufell)) +- Bump upper bounds [\#185](https://github.com/haskell-works/cabal-cache/pull/185) ([newhoggy](https://github.com/newhoggy)) +- Fix typos [\#184](https://github.com/haskell-works/cabal-cache/pull/184) ([newhoggy](https://github.com/newhoggy)) +- New CI to sync with Backblaze s3 provider [\#183](https://github.com/haskell-works/cabal-cache/pull/183) ([newhoggy](https://github.com/newhoggy)) +- Remove unused function anchor [\#106](https://github.com/haskell-works/cabal-cache/pull/106) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.5.1](https://github.com/haskell-works/cabal-cache/tree/v1.0.5.1) (2022-12-01) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.5.0...v1.0.5.1) + +**Merged pull requests:** + +- Fix bug with build-path [\#182](https://github.com/haskell-works/cabal-cache/pull/182) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.5.0](https://github.com/haskell-works/cabal-cache/tree/v1.0.5.0) (2022-12-01) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.4.0...v1.0.5.0) + +**Merged pull requests:** + +- New --path CLI option [\#181](https://github.com/haskell-works/cabal-cache/pull/181) ([newhoggy](https://github.com/newhoggy)) +- More concrete types [\#178](https://github.com/haskell-works/cabal-cache/pull/178) ([newhoggy](https://github.com/newhoggy)) +- Replace boolean [\#177](https://github.com/haskell-works/cabal-cache/pull/177) ([newhoggy](https://github.com/newhoggy)) +- Update dependencies [\#175](https://github.com/haskell-works/cabal-cache/pull/175) ([newhoggy](https://github.com/newhoggy)) +- Remove failing tests [\#172](https://github.com/haskell-works/cabal-cache/pull/172) ([newhoggy](https://github.com/newhoggy)) +- Switch to use cabal-cache-s3 [\#170](https://github.com/haskell-works/cabal-cache/pull/170) ([newhoggy](https://github.com/newhoggy)) +- Remove CircleCI support [\#146](https://github.com/haskell-works/cabal-cache/pull/146) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.4.0](https://github.com/haskell-works/cabal-cache/tree/v1.0.4.0) (2022-03-15) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.3.0...v1.0.4.0) + +**Closed issues:** + +- support multicloud [\#162](https://github.com/haskell-works/cabal-cache/issues/162) + +**Merged pull requests:** + +- Add support for https [\#169](https://github.com/haskell-works/cabal-cache/pull/169) ([newhoggy](https://github.com/newhoggy)) +- Fix syncing from archive with multicloud [\#168](https://github.com/haskell-works/cabal-cache/pull/168) ([newhoggy](https://github.com/newhoggy)) +- Fix syncing from archive with multicloud [\#167](https://github.com/haskell-works/cabal-cache/pull/167) ([hasufell](https://github.com/hasufell)) +- Support multicloud, fixes \#162 [\#165](https://github.com/haskell-works/cabal-cache/pull/165) ([newhoggy](https://github.com/newhoggy)) +- Support multicloud, fixes \#162 [\#163](https://github.com/haskell-works/cabal-cache/pull/163) ([hasufell](https://github.com/hasufell)) +- Upgrade to ghc-8.10.7 and ghc-9.0.1 [\#161](https://github.com/haskell-works/cabal-cache/pull/161) ([newhoggy](https://github.com/newhoggy)) +- Support ghc-8.10.4 [\#160](https://github.com/haskell-works/cabal-cache/pull/160) ([newhoggy](https://github.com/newhoggy)) +- Fix warnings [\#159](https://github.com/haskell-works/cabal-cache/pull/159) ([newhoggy](https://github.com/newhoggy)) +- Unify URI types [\#157](https://github.com/haskell-works/cabal-cache/pull/157) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.3.0](https://github.com/haskell-works/cabal-cache/tree/v1.0.3.0) (2021-03-14) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.2.2...v1.0.3.0) + +**Merged pull requests:** + +- New plan command [\#156](https://github.com/haskell-works/cabal-cache/pull/156) ([newhoggy](https://github.com/newhoggy)) +- Avoid set-env in Github Actions [\#154](https://github.com/haskell-works/cabal-cache/pull/154) ([newhoggy](https://github.com/newhoggy)) +- Publish releases [\#150](https://github.com/haskell-works/cabal-cache/pull/150) ([newhoggy](https://github.com/newhoggy)) +- Fix warnings [\#148](https://github.com/haskell-works/cabal-cache/pull/148) ([newhoggy](https://github.com/newhoggy)) +- Tweak caching [\#145](https://github.com/haskell-works/cabal-cache/pull/145) ([newhoggy](https://github.com/newhoggy)) +- Remove unnecessary dependencies [\#142](https://github.com/haskell-works/cabal-cache/pull/142) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.2.2](https://github.com/haskell-works/cabal-cache/tree/v1.0.2.2) (2020-10-25) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.2.1...v1.0.2.2) + +## [v1.0.2.1](https://github.com/haskell-works/cabal-cache/tree/v1.0.2.1) (2020-09-29) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.2.0...v1.0.2.1) + +**Merged pull requests:** + +- Fix slash handling on Windows [\#141](https://github.com/haskell-works/cabal-cache/pull/141) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.2.0](https://github.com/haskell-works/cabal-cache/tree/v1.0.2.0) (2020-09-29) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.9...v1.0.2.0) + +**Merged pull requests:** + +- Fix macos builds [\#138](https://github.com/haskell-works/cabal-cache/pull/138) ([newhoggy](https://github.com/newhoggy)) +- Add --build-path [\#137](https://github.com/haskell-works/cabal-cache/pull/137) ([newhoggy](https://github.com/newhoggy)) +- Use cabal cache [\#136](https://github.com/haskell-works/cabal-cache/pull/136) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.1.9](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.9) (2020-09-19) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.8...v1.0.1.9) + +**Closed issues:** + +- Windows Builds [\#129](https://github.com/haskell-works/cabal-cache/issues/129) + +**Merged pull requests:** + +- Upgrade macos executor [\#134](https://github.com/haskell-works/cabal-cache/pull/134) ([newhoggy](https://github.com/newhoggy)) +- Implement GitHub actions [\#133](https://github.com/haskell-works/cabal-cache/pull/133) ([newhoggy](https://github.com/newhoggy)) +- Implement Github Actions [\#132](https://github.com/haskell-works/cabal-cache/pull/132) ([hazelweakly](https://github.com/hazelweakly)) +- Win32 support [\#130](https://github.com/haskell-works/cabal-cache/pull/130) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to haskell-build@4.1.8 [\#128](https://github.com/haskell-works/cabal-cache/pull/128) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to optparse-applicative-0.16 [\#127](https://github.com/haskell-works/cabal-cache/pull/127) ([newhoggy](https://github.com/newhoggy)) +- Fix macos builds [\#125](https://github.com/haskell-works/cabal-cache/pull/125) ([newhoggy](https://github.com/newhoggy)) +- Use official cache http end-point [\#124](https://github.com/haskell-works/cabal-cache/pull/124) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to orb hackage@1.4.2 [\#123](https://github.com/haskell-works/cabal-cache/pull/123) ([newhoggy](https://github.com/newhoggy)) +- Fix build [\#122](https://github.com/haskell-works/cabal-cache/pull/122) ([newhoggy](https://github.com/newhoggy)) +- Fix hlint [\#121](https://github.com/haskell-works/cabal-cache/pull/121) ([newhoggy](https://github.com/newhoggy)) +- Upgrade generic-lens [\#120](https://github.com/haskell-works/cabal-cache/pull/120) ([newhoggy](https://github.com/newhoggy)) +- Disable parallel garbage colllector in CCI tests [\#119](https://github.com/haskell-works/cabal-cache/pull/119) ([newhoggy](https://github.com/newhoggy)) +- Remove unused imports [\#118](https://github.com/haskell-works/cabal-cache/pull/118) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to hackage@1.4.1 [\#117](https://github.com/haskell-works/cabal-cache/pull/117) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to github-release@1.3.3 [\#116](https://github.com/haskell-works/cabal-cache/pull/116) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to haskell-build-4.1.7 [\#115](https://github.com/haskell-works/cabal-cache/pull/115) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.1.8](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.8) (2020-03-24) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.7...v1.0.1.8) + +**Merged pull requests:** + +- Use token [\#113](https://github.com/haskell-works/cabal-cache/pull/113) ([newhoggy](https://github.com/newhoggy)) +- Convert i386 build to use binary cache [\#112](https://github.com/haskell-works/cabal-cache/pull/112) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.1.7](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.7) (2020-03-24) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.6...v1.0.1.7) + +## [v1.0.1.6](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.6) (2020-03-24) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.5.a...v1.0.1.6) + +**Merged pull requests:** + +- i386 build [\#111](https://github.com/haskell-works/cabal-cache/pull/111) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.1.5.a](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.5.a) (2020-01-25) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.5...v1.0.1.5.a) + +## [v1.0.1.5](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.5) (2020-01-25) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.4...v1.0.1.5) + +**Merged pull requests:** + +- Upgrade to haskell-build@4.0.6 [\#105](https://github.com/haskell-works/cabal-cache/pull/105) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to haskell-build@4.0.6 [\#104](https://github.com/haskell-works/cabal-cache/pull/104) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.1.4](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.4) (2020-01-25) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.3...v1.0.1.4) + +**Closed issues:** + +- ghc-pkg invocation doesn't honour current compiler [\#94](https://github.com/haskell-works/cabal-cache/issues/94) + +**Merged pull requests:** + +- Fix macos build [\#103](https://github.com/haskell-works/cabal-cache/pull/103) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to ghc-8.8.2 in CI [\#102](https://github.com/haskell-works/cabal-cache/pull/102) ([newhoggy](https://github.com/newhoggy)) +- Support multiple archive-uris [\#101](https://github.com/haskell-works/cabal-cache/pull/101) ([newhoggy](https://github.com/newhoggy)) +- Jky azure [\#100](https://github.com/haskell-works/cabal-cache/pull/100) ([newhoggy](https://github.com/newhoggy)) +- Fix development build files [\#99](https://github.com/haskell-works/cabal-cache/pull/99) ([newhoggy](https://github.com/newhoggy)) +- Tidy up cabal file [\#98](https://github.com/haskell-works/cabal-cache/pull/98) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.1.3](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.3) (2019-12-06) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.2...v1.0.1.3) + +**Merged pull requests:** + +- Use same ghc-pkg version as specified by GHC version in plan.json [\#97](https://github.com/haskell-works/cabal-cache/pull/97) ([newhoggy](https://github.com/newhoggy)) +- Move command parsers to command modules [\#96](https://github.com/haskell-works/cabal-cache/pull/96) ([newhoggy](https://github.com/newhoggy)) +- Direct test output and generate environment files [\#93](https://github.com/haskell-works/cabal-cache/pull/93) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.1.2](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.2) (2019-10-26) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.1...v1.0.1.2) + +**Closed issues:** + +- Allow use of non-AWS clouds [\#83](https://github.com/haskell-works/cabal-cache/issues/83) + +**Merged pull requests:** + +- Additional brew update to avoid ruby syntax issues [\#91](https://github.com/haskell-works/cabal-cache/pull/91) ([newhoggy](https://github.com/newhoggy)) +- Additional brew update to avoid ruby syntax issues [\#90](https://github.com/haskell-works/cabal-cache/pull/90) ([newhoggy](https://github.com/newhoggy)) +- CI for ghc-8.8.1 [\#88](https://github.com/haskell-works/cabal-cache/pull/88) ([newhoggy](https://github.com/newhoggy)) +- Fix for ghc-8.8.1 [\#87](https://github.com/haskell-works/cabal-cache/pull/87) ([newhoggy](https://github.com/newhoggy)) +- Upgrade generic-lens version [\#86](https://github.com/haskell-works/cabal-cache/pull/86) ([newhoggy](https://github.com/newhoggy)) +- Bump upper-bound of optparse-applicative [\#84](https://github.com/haskell-works/cabal-cache/pull/84) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to haskell-build-4.0.2 [\#82](https://github.com/haskell-works/cabal-cache/pull/82) ([newhoggy](https://github.com/newhoggy)) +- Upgrade haskell build orb version [\#81](https://github.com/haskell-works/cabal-cache/pull/81) ([newhoggy](https://github.com/newhoggy)) +- Upgrade haskell-build orb version [\#78](https://github.com/haskell-works/cabal-cache/pull/78) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.1.1](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.1) (2019-07-21) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.1.0...v1.0.1.1) + +**Closed issues:** + +- renamePath errors [\#73](https://github.com/haskell-works/cabal-cache/issues/73) +- Doesn't work [\#72](https://github.com/haskell-works/cabal-cache/issues/72) + +**Merged pull requests:** + +- Fix getLibFiles if directory does not exist wrt \#72 [\#75](https://github.com/haskell-works/cabal-cache/pull/75) ([hasufell](https://github.com/hasufell)) +- Fix renamePath errors wrt \#73 [\#74](https://github.com/haskell-works/cabal-cache/pull/74) ([hasufell](https://github.com/hasufell)) + +## [v1.0.1.0](https://github.com/haskell-works/cabal-cache/tree/v1.0.1.0) (2019-07-03) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.12...v1.0.1.0) + +**Merged pull requests:** + +- use ubuntu:16.04 for max compatibility [\#71](https://github.com/haskell-works/cabal-cache/pull/71) ([dsturnbull](https://github.com/dsturnbull)) + +## [v1.0.0.12](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.12) (2019-05-29) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.11...v1.0.0.12) + +**Merged pull requests:** + +- Check for target file existence [\#69](https://github.com/haskell-works/cabal-cache/pull/69) ([AlexeyRaga](https://github.com/AlexeyRaga)) + +## [v1.0.0.11](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.11) (2019-05-29) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.10...v1.0.0.11) + +**Merged pull requests:** + +- Upgrade archive to v2 [\#68](https://github.com/haskell-works/cabal-cache/pull/68) ([newhoggy](https://github.com/newhoggy)) +- Append metadata instead of prepend [\#67](https://github.com/haskell-works/cabal-cache/pull/67) ([newhoggy](https://github.com/newhoggy)) +- Use relation package instead [\#66](https://github.com/haskell-works/cabal-cache/pull/66) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.0.10](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.10) (2019-05-12) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.9...v1.0.0.10) + +**Merged pull requests:** + +- Smaller footprint [\#65](https://github.com/haskell-works/cabal-cache/pull/65) ([AlexeyRaga](https://github.com/AlexeyRaga)) +- Upgrade to haskell-build@2.0.2 [\#64](https://github.com/haskell-works/cabal-cache/pull/64) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to haskell-build@2.0.1 [\#63](https://github.com/haskell-works/cabal-cache/pull/63) ([newhoggy](https://github.com/newhoggy)) +- Build OSX binaries [\#62](https://github.com/haskell-works/cabal-cache/pull/62) ([AlexeyRaga](https://github.com/AlexeyRaga)) + +## [v1.0.0.9](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.9) (2019-05-12) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.8...v1.0.0.9) + +**Merged pull requests:** + +- Add missing cases in display app error [\#61](https://github.com/haskell-works/cabal-cache/pull/61) ([newhoggy](https://github.com/newhoggy)) +- Use latest cabal-cache again [\#60](https://github.com/haskell-works/cabal-cache/pull/60) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.0.8](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.8) (2019-05-12) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.7...v1.0.0.8) + +**Merged pull requests:** + +- Do not fail in cleanup [\#59](https://github.com/haskell-works/cabal-cache/pull/59) ([newhoggy](https://github.com/newhoggy)) +- Enable read for binary cache in forks [\#58](https://github.com/haskell-works/cabal-cache/pull/58) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.0.7](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.7) (2019-05-11) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.6...v1.0.0.7) + +**Merged pull requests:** + +- Reduce number of queries in download [\#57](https://github.com/haskell-works/cabal-cache/pull/57) ([newhoggy](https://github.com/newhoggy)) +- Remove duplicate download [\#56](https://github.com/haskell-works/cabal-cache/pull/56) ([newhoggy](https://github.com/newhoggy)) +- New readFirstAvailableResource function [\#55](https://github.com/haskell-works/cabal-cache/pull/55) ([newhoggy](https://github.com/newhoggy)) +- Use Either instead of Maybe during downloads [\#54](https://github.com/haskell-works/cabal-cache/pull/54) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.0.6](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.6) (2019-05-11) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.5...v1.0.0.6) + +**Merged pull requests:** + +- Upgrade to haskell-works/haskell-build@2.0.0 [\#53](https://github.com/haskell-works/cabal-cache/pull/53) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to haskell-build-2@1.6.18 [\#52](https://github.com/haskell-works/cabal-cache/pull/52) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.0.5](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.5) (2019-05-10) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.4...v1.0.0.5) + +## [v1.0.0.4](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.4) (2019-05-10) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.3...v1.0.0.4) + +**Merged pull requests:** + +- HTTP support [\#50](https://github.com/haskell-works/cabal-cache/pull/50) ([newhoggy](https://github.com/newhoggy)) +- Do not fail if no access to bucket [\#49](https://github.com/haskell-works/cabal-cache/pull/49) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.0.3](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.3) (2019-05-07) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.2...v1.0.0.3) + +**Merged pull requests:** + +- Implement safe download [\#47](https://github.com/haskell-works/cabal-cache/pull/47) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.0.2](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.2) (2019-05-03) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.1...v1.0.0.2) + +**Merged pull requests:** + +- AWS logging [\#45](https://github.com/haskell-works/cabal-cache/pull/45) ([newhoggy](https://github.com/newhoggy)) +- Log AWS errors [\#43](https://github.com/haskell-works/cabal-cache/pull/43) ([newhoggy](https://github.com/newhoggy)) +- Download queue [\#42](https://github.com/haskell-works/cabal-cache/pull/42) ([newhoggy](https://github.com/newhoggy)) +- New Relation type [\#41](https://github.com/haskell-works/cabal-cache/pull/41) ([newhoggy](https://github.com/newhoggy)) +- Fix test module names [\#40](https://github.com/haskell-works/cabal-cache/pull/40) ([newhoggy](https://github.com/newhoggy)) +- Add depends field to Package type [\#39](https://github.com/haskell-works/cabal-cache/pull/39) ([newhoggy](https://github.com/newhoggy)) +- Rename modules from Ci.Assist to CabalCache [\#38](https://github.com/haskell-works/cabal-cache/pull/38) ([newhoggy](https://github.com/newhoggy)) +- New stm dependency [\#37](https://github.com/haskell-works/cabal-cache/pull/37) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.0.1](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.1) (2019-04-30) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v1.0.0.0...v1.0.0.1) + +**Merged pull requests:** + +- Retry copy resource [\#36](https://github.com/haskell-works/cabal-cache/pull/36) ([newhoggy](https://github.com/newhoggy)) + +## [v1.0.0.0](https://github.com/haskell-works/cabal-cache/tree/v1.0.0.0) (2019-04-26) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.2.0.2...v1.0.0.0) + +**Merged pull requests:** + +- Add metadata [\#34](https://github.com/haskell-works/cabal-cache/pull/34) ([AlexeyRaga](https://github.com/AlexeyRaga)) +- Restore from matching store-path-hash preferentially [\#33](https://github.com/haskell-works/cabal-cache/pull/33) ([newhoggy](https://github.com/newhoggy)) +- Hashed store path in archived packages [\#32](https://github.com/haskell-works/cabal-cache/pull/32) ([newhoggy](https://github.com/newhoggy)) +- DRY versioning handling [\#31](https://github.com/haskell-works/cabal-cache/pull/31) ([newhoggy](https://github.com/newhoggy)) +- Add versioning to archive [\#30](https://github.com/haskell-works/cabal-cache/pull/30) ([newhoggy](https://github.com/newhoggy)) +- Upgrade to haskell-build-2@1.6.7 [\#28](https://github.com/haskell-works/cabal-cache/pull/28) ([newhoggy](https://github.com/newhoggy)) +- Typo in readme [\#27](https://github.com/haskell-works/cabal-cache/pull/27) ([ekmett](https://github.com/ekmett)) + +## [v0.2.0.2](https://github.com/haskell-works/cabal-cache/tree/v0.2.0.2) (2019-04-25) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.2.0.1...v0.2.0.2) + +## [v0.2.0.1](https://github.com/haskell-works/cabal-cache/tree/v0.2.0.1) (2019-04-20) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.2.0.0...v0.2.0.1) + +## [v0.2.0.0](https://github.com/haskell-works/cabal-cache/tree/v0.2.0.0) (2019-04-20) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.1.0.9...v0.2.0.0) + +**Merged pull requests:** + +- Create archive using tar cli [\#25](https://github.com/haskell-works/cabal-cache/pull/25) ([newhoggy](https://github.com/newhoggy)) +- Introduce new Presence and Tagged datatypes to convey richer informat… [\#21](https://github.com/haskell-works/cabal-cache/pull/21) ([newhoggy](https://github.com/newhoggy)) + +## [v0.1.0.9](https://github.com/haskell-works/cabal-cache/tree/v0.1.0.9) (2019-04-20) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.1.0.8...v0.1.0.9) + +## [v0.1.0.8](https://github.com/haskell-works/cabal-cache/tree/v0.1.0.8) (2019-04-19) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.1.0.7...v0.1.0.8) + +## [v0.1.0.7](https://github.com/haskell-works/cabal-cache/tree/v0.1.0.7) (2019-04-19) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.1.0.5...v0.1.0.7) + +## [v0.1.0.5](https://github.com/haskell-works/cabal-cache/tree/v0.1.0.5) (2019-04-15) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.1.0.4...v0.1.0.5) + +## [v0.1.0.4](https://github.com/haskell-works/cabal-cache/tree/v0.1.0.4) (2019-04-15) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.1.0.3...v0.1.0.4) + +**Merged pull requests:** + +- Make all paths platform-independent, some cleanup [\#19](https://github.com/haskell-works/cabal-cache/pull/19) ([AlexeyRaga](https://github.com/AlexeyRaga)) +- Create missing directories [\#18](https://github.com/haskell-works/cabal-cache/pull/18) ([newhoggy](https://github.com/newhoggy)) +- Cleanup paths [\#17](https://github.com/haskell-works/cabal-cache/pull/17) ([newhoggy](https://github.com/newhoggy)) +- More logging [\#16](https://github.com/haskell-works/cabal-cache/pull/16) ([newhoggy](https://github.com/newhoggy)) + +## [v0.1.0.3](https://github.com/haskell-works/cabal-cache/tree/v0.1.0.3) (2019-04-13) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.1.0.2...v0.1.0.3) + +**Merged pull requests:** + +- Auto create Package DB in sync-from-archive command [\#15](https://github.com/haskell-works/cabal-cache/pull/15) ([newhoggy](https://github.com/newhoggy)) + +## [v0.1.0.2](https://github.com/haskell-works/cabal-cache/tree/v0.1.0.2) (2019-04-13) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.1.0.1...v0.1.0.2) + +**Merged pull requests:** + +- Auto create Package DB [\#14](https://github.com/haskell-works/cabal-cache/pull/14) ([newhoggy](https://github.com/newhoggy)) + +## [v0.1.0.1](https://github.com/haskell-works/cabal-cache/tree/v0.1.0.1) (2019-04-12) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/v0.1.0.0...v0.1.0.1) + +**Merged pull requests:** + +- Add region options [\#12](https://github.com/haskell-works/cabal-cache/pull/12) ([newhoggy](https://github.com/newhoggy)) +- Threadsafe logging [\#11](https://github.com/haskell-works/cabal-cache/pull/11) ([newhoggy](https://github.com/newhoggy)) +- Add threads [\#10](https://github.com/haskell-works/cabal-cache/pull/10) ([newhoggy](https://github.com/newhoggy)) +- Recache package db after sync from archive [\#9](https://github.com/haskell-works/cabal-cache/pull/9) ([newhoggy](https://github.com/newhoggy)) +- Archive dylibs [\#8](https://github.com/haskell-works/cabal-cache/pull/8) ([newhoggy](https://github.com/newhoggy)) +- Static link [\#7](https://github.com/haskell-works/cabal-cache/pull/7) ([AlexeyRaga](https://github.com/AlexeyRaga)) +- Cleanup tar entries [\#6](https://github.com/haskell-works/cabal-cache/pull/6) ([AlexeyRaga](https://github.com/AlexeyRaga)) +- Pass more package information [\#5](https://github.com/haskell-works/cabal-cache/pull/5) ([newhoggy](https://github.com/newhoggy)) +- Fix pred [\#4](https://github.com/haskell-works/cabal-cache/pull/4) ([AlexeyRaga](https://github.com/AlexeyRaga)) +- Template conf [\#3](https://github.com/haskell-works/cabal-cache/pull/3) ([AlexeyRaga](https://github.com/AlexeyRaga)) +- Make conf files optional [\#2](https://github.com/haskell-works/cabal-cache/pull/2) ([newhoggy](https://github.com/newhoggy)) +- Include conf [\#1](https://github.com/haskell-works/cabal-cache/pull/1) ([AlexeyRaga](https://github.com/AlexeyRaga)) + +## [v0.1.0.0](https://github.com/haskell-works/cabal-cache/tree/v0.1.0.0) (2019-04-12) + +[Full Changelog](https://github.com/haskell-works/cabal-cache/compare/faf6083ca5b4d084f1e2e41d22db6a6a33b78a75...v0.1.0.0) + + + +\* *This Changelog was automatically generated by [github_changelog_generator](https://github.com/github-changelog-generator/github-changelog-generator)* diff --git a/app/App/Amazonka.hs b/app/App/Amazonka.hs new file mode 100644 --- /dev/null +++ b/app/App/Amazonka.hs @@ -0,0 +1,23 @@ +module App.Amazonka + ( mkAwsEnv + ) where + +import Effectful +import Effectful.Zoo.Amazonka.Data.AwsEnv +import Effectful.Zoo.Amazonka.Api.Discover +import Effectful.Zoo.Core +import HaskellWorks.Prelude +import HaskellWorks.Tuple + +import qualified Amazonka as AWS +import qualified HaskellWorks.CabalCache.AWS.Env as AWS + +mkAwsEnv :: () + => r <: IOE + => AWS.Region + -> Maybe (ByteString, Int, Bool) + -> Maybe AWS.LogLevel + -> Eff r AwsEnv +mkAwsEnv region mHostEndpoint awsLogLevel = + liftIO (AWS.mkEnv region (AWS.awsLogger awsLogLevel)) + <&> maybe id (uncurry3 setAwsEnvEndpointOverride) mHostEndpoint diff --git a/app/App/Commands/Debug/S3/Cp.hs b/app/App/Commands/Debug/S3/Cp.hs --- a/app/App/Commands/Debug/S3/Cp.hs +++ b/app/App/Commands/Debug/S3/Cp.hs @@ -1,66 +1,53 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - module App.Commands.Debug.S3.Cp ( cmdCp, ) where +import App.Amazonka import App.Commands.Options.Parser (text) import App.Commands.Options.Types (CpOptions (CpOptions)) -import Data.Generics.Product.Any (the) -import HaskellWorks.CabalCache.AppError (AwsError(..), displayAwsError) +import App.Run +import Effectful.Zoo.Amazonka.Data.AwsError +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.Lazy.Dynamic +import HaskellWorks.CabalCache.AppError (AwsStatusError(..), displayAwsStatusError) import HaskellWorks.CabalCache.Error (CopyFailed(..), ExitFailure(..), UnsupportedUri) import HaskellWorks.Prelude -import Lens.Micro import Network.URI (parseURI) import qualified Amazonka as AWS import qualified Amazonka.Data as AWS import qualified App.Commands.Options.Types as Z -import qualified Control.Monad.Oops as OO import qualified Data.Text as T -import qualified HaskellWorks.CabalCache.AWS.Env as AWS import qualified HaskellWorks.CabalCache.AWS.S3 as AWS import qualified HaskellWorks.CabalCache.IO.Console as CIO import qualified Options.Applicative as OA import qualified System.IO as IO -import qualified System.IO.Unsafe as IO {- HLINT ignore "Monoid law, left identity" -} {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Redundant do" -} runCp :: Z.CpOptions -> IO () -runCp opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do - let srcUri = opts ^. the @"srcUri" - let dstUri = opts ^. the @"dstUri" - let mHostEndpoint = opts ^. the @"hostEndpoint" - let awsLogLevel = opts ^. the @"awsLogLevel" - - OO.catchAndExitFailure @ExitFailure do - envAws <- - liftIO (IO.unsafeInterleaveIO (AWS.mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel))) - <&> case mHostEndpoint of - Just (host, port, ssl) -> - \env -> - env - & the @"overrides" .~ \svc -> - svc & the @"endpoint" %~ \mkEndpoint region -> - mkEndpoint region - & the @"host" .~ host - & the @"port" .~ port - & the @"secure" .~ ssl - Nothing -> id +runCp opts = runApp do + let srcUri = opts.srcUri + let dstUri = opts.dstUri + let mHostEndpoint = opts.hostEndpoint + let awsLogLevel = opts.awsLogLevel - AWS.copyS3Uri envAws srcUri dstUri - & do OO.catch @AwsError \e -> do - CIO.hPutStrLn IO.stderr $ "Copy failed: " <> displayAwsError e - & do OO.catch @CopyFailed \CopyFailed -> do - CIO.hPutStrLn IO.stderr $ "Copy failed" - & do OO.catch @UnsupportedUri \e -> do + runLazy (mkAwsEnv opts.region mHostEndpoint awsLogLevel) do + AWS.copyS3Uri srcUri dstUri + & do trap @AwsStatusError \e -> do + CIO.hPutStrLn IO.stderr $ "Copy failed: " <> displayAwsStatusError e + throw ExitFailure + & do trap @AwsError \e -> do + CIO.hPutStrLn IO.stderr $ "Copy failed: " <> tshow e + throw ExitFailure + & do trap @CopyFailed \CopyFailed -> do + CIO.hPutStrLn IO.stderr "Copy failed" + throw ExitFailure + & do trap @UnsupportedUri \e -> do CIO.hPutStrLn IO.stderr $ "Unsupported uri: " <> tshow e + throw ExitFailure optsCp :: OA.Parser CpOptions optsCp = CpOptions diff --git a/app/App/Commands/Options/Types.hs b/app/App/Commands/Options/Types.hs --- a/app/App/Commands/Options/Types.hs +++ b/app/App/Commands/Options/Types.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} - module App.Commands.Options.Types ( CpOptions(..), PlanOptions(..), diff --git a/app/App/Commands/Plan.hs b/app/App/Commands/Plan.hs --- a/app/App/Commands/Plan.hs +++ b/app/App/Commands/Plan.hs @@ -1,62 +1,59 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - module App.Commands.Plan ( cmdPlan, - ) where + ) +where -import App.Commands.Options.Types (PlanOptions (PlanOptions)) -import Control.Lens ((^.), (%~), Each(each)) -import Data.Generics.Product.Any (the) -import HaskellWorks.CabalCache.Error (DecodeError, ExitFailure(..)) +import Amazonka.Data qualified as AWS +import App.Commands.Options.Types (PlanOptions (PlanOptions)) +import App.Commands.Options.Types qualified as Z +import App.Run +import App.Static qualified as AS +import Control.Lens (Each (each), (%~)) +import Data.Aeson qualified as J +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Effectful.Zoo.Core.Error.Static +import HaskellWorks.CabalCache.Core qualified as Z +import HaskellWorks.CabalCache.Error (DecodeError, ExitFailure (..)) +import HaskellWorks.CabalCache.Hash qualified as H +import HaskellWorks.CabalCache.IO.Console qualified as CIO import HaskellWorks.CabalCache.Location (Location (..), (<.>), ()) -import HaskellWorks.CabalCache.Version (archiveVersion) +import HaskellWorks.CabalCache.Version (archiveVersion) import HaskellWorks.Prelude -import Options.Applicative (Parser, Mod, CommandFields) - -import qualified Amazonka.Data as AWS -import qualified App.Commands.Options.Types as Z -import qualified App.Static as AS -import qualified Control.Monad.Oops as OO -import qualified Data.Aeson as J -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as T -import qualified HaskellWorks.CabalCache.Core as Z -import qualified HaskellWorks.CabalCache.Hash as H -import qualified HaskellWorks.CabalCache.IO.Console as CIO -import qualified Options.Applicative as OA -import qualified System.IO as IO +import Options.Applicative (CommandFields, Mod, Parser) +import Options.Applicative qualified as OA +import System.IO qualified as IO {- HLINT ignore "Monoid law, left identity" -} {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -} runPlan :: Z.PlanOptions -> IO () -runPlan opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do - let storePath = opts ^. the @"storePath" - let archiveUris = [Local ""] - let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) - let versionedArchiveUris = archiveUris & each %~ ( archiveVersion) - let outputFile = opts ^. the @"outputFile" +runPlan opts = runApp do + let storePath = opts.storePath + let archiveUris = [LocalFile ""] + let storePathHash = opts.storePathHash & fromMaybe (H.hashStorePath storePath) + let versionedArchiveUris = archiveUris & each %~ ( archiveVersion) + let outputFile = opts.outputFile - CIO.putStrLn $ "Store path: " <> AWS.toText storePath - CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash - CIO.putStrLn $ "Archive URIs: " <> tshow archiveUris - CIO.putStrLn $ "Archive version: " <> archiveVersion + CIO.putStrLn $ "Store path: " <> AWS.toText storePath + CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash + CIO.putStrLn $ "Archive URIs: " <> tshow archiveUris + CIO.putStrLn $ "Archive version: " <> archiveVersion - planJson <- Z.loadPlan (opts ^. the @"path" opts ^. the @"buildPath") - & do OO.catch @DecodeError \e -> do + planJson <- + Z.loadPlan (opts.path opts.buildPath) + & do + trap @DecodeError \e -> do CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e - OO.throw ExitFailure + throw ExitFailure packages <- liftIO $ Z.getPackages storePath planJson plan <- forM packages $ \pInfo -> do - let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz" - let archiveFiles = versionedArchiveUris <&> ( T.pack archiveFileBasename) - let scopedArchiveFiles = versionedArchiveUris <&> ( T.pack storePathHash T.pack archiveFileBasename) + let archiveFileBasename = pInfo.packageDir <.> ".tar.gz" + let archiveFiles = versionedArchiveUris <&> ( T.pack archiveFileBasename) + let scopedArchiveFiles = versionedArchiveUris <&> ( T.pack storePathHash T.pack archiveFileBasename) return $ archiveFiles <> scopedArchiveFiles @@ -65,37 +62,38 @@ else liftIO $ LBS.writeFile outputFile $ J.encode (fmap (fmap AWS.toText) plan) optsPlan :: Parser PlanOptions -optsPlan = PlanOptions - <$> OA.strOption - ( OA.long "path" - <> OA.help "Path to cabal project. Defaults to \".\"" - <> OA.metavar "DIRECTORY" - <> OA.value AS.path +optsPlan = + PlanOptions + <$> OA.strOption + ( OA.long "path" + <> OA.help "Path to cabal project. Defaults to \".\"" + <> OA.metavar "DIRECTORY" + <> OA.value AS.path ) - <*> OA.strOption - ( OA.long "build-path" - <> OA.help ("Path to cabal build directory. Defaults to " <> show AS.buildPath) - <> OA.metavar "DIRECTORY" - <> OA.value AS.buildPath + <*> OA.strOption + ( OA.long "build-path" + <> OA.help ("Path to cabal build directory. Defaults to " <> show AS.buildPath) + <> OA.metavar "DIRECTORY" + <> OA.value AS.buildPath ) - <*> OA.strOption - ( OA.long "store-path" - <> OA.help "Path to cabal store" - <> OA.metavar "DIRECTORY" - <> OA.value AS.cabalStoreDirectory + <*> OA.strOption + ( OA.long "store-path" + <> OA.help "Path to cabal store" + <> OA.metavar "DIRECTORY" + <> OA.value AS.cabalStoreDirectory ) - <*> optional + <*> optional ( OA.strOption - ( OA.long "store-path-hash" - <> OA.help "Store path hash (do not use)" - <> OA.metavar "HASH" - ) + ( OA.long "store-path-hash" + <> OA.help "Store path hash (do not use)" + <> OA.metavar "HASH" + ) ) - <*> OA.strOption - ( OA.long "output-file" - <> OA.help "Output file" - <> OA.metavar "FILE" - <> OA.value "-" + <*> OA.strOption + ( OA.long "output-file" + <> OA.help "Output file" + <> OA.metavar "FILE" + <> OA.value "-" ) cmdPlan :: Mod CommandFields (IO ()) diff --git a/app/App/Commands/SyncFromArchive.hs b/app/App/Commands/SyncFromArchive.hs --- a/app/App/Commands/SyncFromArchive.hs +++ b/app/App/Commands/SyncFromArchive.hs @@ -1,22 +1,26 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{- HLINT ignore "Redundant id" -} module App.Commands.SyncFromArchive ( cmdSyncFromArchive, ) where +import App.Amazonka import App.Commands.Options.Parser (optsPackageIds, text) import App.Commands.Options.Types (SyncFromArchiveOptions (SyncFromArchiveOptions)) -import Control.Lens ((^..), (%~), (^.), (.~), Each(each)) +import App.Run +import Control.Lens ((^..), (%~), Each(each)) import Control.Lens.Combinators (traverse1) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString.Lazy.Search (replace) import Data.Generics.Product.Any (the) import Data.List.NonEmpty (NonEmpty) -import HaskellWorks.CabalCache.AppError (AwsError, HttpError (..), displayAwsError, displayHttpError) +import Effectful +import Effectful.Zoo.Amazonka.Data.AwsError +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.Lazy.Dynamic +import HaskellWorks.CabalCache.AppError (AwsStatusError, HttpError (..), displayAwsStatusError, displayHttpError) +import HaskellWorks.CabalCache.Concurrent.Fork +import HaskellWorks.CabalCache.Concurrent.Type import HaskellWorks.CabalCache.Error (DecodeError(..), ExitFailure(..), InvalidUrl(..), NotFound, UnsupportedUri(..)) import HaskellWorks.CabalCache.IO.Lazy (readFirstAvailableResource) import HaskellWorks.CabalCache.IO.Tar (ArchiveError(..)) @@ -33,7 +37,6 @@ import qualified App.Commands.Options.Types as Z import qualified App.Static as AS import qualified Control.Concurrent.STM as STM -import qualified Control.Monad.Oops as OO import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NEL @@ -41,9 +44,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as S import qualified Data.Text as T -import qualified HaskellWorks.CabalCache.AWS.Env as AWS import qualified HaskellWorks.CabalCache.Concurrent.DownloadQueue as DQ -import qualified HaskellWorks.CabalCache.Concurrent.Fork as IO import qualified HaskellWorks.CabalCache.Core as Z import qualified HaskellWorks.CabalCache.Data.List as L import qualified HaskellWorks.CabalCache.GhcPkg as GhcPkg @@ -56,27 +57,33 @@ import qualified System.Directory as IO import qualified System.IO as IO import qualified System.IO.Temp as IO -import qualified System.IO.Unsafe as IO {- HLINT ignore "Monoid law, left identity" -} {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Redundant do" -} skippable :: Z.Package -> Bool -skippable package = package ^. the @"packageType" == "pre-existing" +skippable package = package.packageType == "pre-existing" +recoverOrVoid :: forall x r. () + => Eff (Error x : r) Void + -> Eff r x +recoverOrVoid f = + f & fmap absurd + & trap pure + runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO () -runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do - let mHostEndpoint = opts ^. the @"hostEndpoint" - let storePath = opts ^. the @"storePath" - let archiveUris = opts ^. the @"archiveUris" :: NonEmpty Location - let threads = opts ^. the @"threads" - let awsLogLevel = opts ^. the @"awsLogLevel" +runSyncFromArchive opts = runApp do + let mHostEndpoint = opts.hostEndpoint :: Maybe (ByteString, Int, Bool) + let storePath = opts.storePath + let archiveUris = opts.archiveUris :: NonEmpty Location + let threads = opts.threads + let awsLogLevel = opts.awsLogLevel let versionedArchiveUris = archiveUris & traverse1 %~ ( archiveVersion) :: NonEmpty Location - let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) + let storePathHash = opts.storePathHash & fromMaybe (H.hashStorePath storePath) let scopedArchiveUris = versionedArchiveUris & traverse1 %~ ( T.pack storePathHash) - let maxRetries = opts ^. the @"maxRetries" - let ignorePackages = opts ^. the @"ignorePackages" + let maxRetries = opts.maxRetries + let ignorePackages = opts.ignorePackages CIO.putStrLn $ "Store path: " <> AWS.toText storePath CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash @@ -86,84 +93,71 @@ CIO.putStrLn $ "Threads: " <> tshow threads CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel - OO.catchAndExitFailure @ExitFailure do - planJson <- Z.loadPlan (opts ^. the @"path" opts ^. the @"buildPath") - & do OO.catch @DecodeError \e -> do - CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e - OO.throw ExitFailure + planJson <- Z.loadPlan (opts.path opts.buildPath) + & do trap @DecodeError \e -> do + CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e + throw ExitFailure - compilerContext <- Z.mkCompilerContext planJson - & do OO.catch @Text \e -> do - CIO.hPutStrLn IO.stderr e - OO.throw ExitFailure + compilerContext <- Z.mkCompilerContext planJson + & do trap @Text \e -> do + CIO.hPutStrLn IO.stderr e + throw ExitFailure - liftIO $ GhcPkg.testAvailability compilerContext + liftIO $ GhcPkg.testAvailability compilerContext - envAws <- - liftIO (IO.unsafeInterleaveIO (AWS.mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel))) - <&> case mHostEndpoint of - Just (host, port, ssl) -> - \env -> - env - & the @"overrides" .~ \svc -> - svc & the @"endpoint" %~ \mkEndpoint region -> - mkEndpoint region - & the @"host" .~ host - & the @"port" .~ port - & the @"secure" .~ ssl - Nothing -> id - let compilerId = planJson ^. the @"compilerId" - let storeCompilerPath = storePath T.unpack compilerId - let storeCompilerPackageDbPath = storeCompilerPath "package.db" - let storeCompilerLibPath = storeCompilerPath "lib" + let compilerId = planJson.compilerId + let storeCompilerPath = storePath T.unpack compilerId + let storeCompilerPackageDbPath = storeCompilerPath "package.db" + let storeCompilerLibPath = storeCompilerPath "lib" - CIO.putStrLn "Creating store directories" - liftIO $ createDirectoryIfMissing True storePath - liftIO $ createDirectoryIfMissing True storeCompilerPath - liftIO $ createDirectoryIfMissing True storeCompilerLibPath + CIO.putStrLn "Creating store directories" + liftIO $ createDirectoryIfMissing True storePath + liftIO $ createDirectoryIfMissing True storeCompilerPath + liftIO $ createDirectoryIfMissing True storeCompilerLibPath - storeCompilerPackageDbPathExists <- liftIO $ doesDirectoryExist storeCompilerPackageDbPath + storeCompilerPackageDbPathExists <- liftIO $ doesDirectoryExist storeCompilerPackageDbPath - unless storeCompilerPackageDbPathExists do - CIO.putStrLn "Package DB missing. Creating Package DB" - liftIO $ GhcPkg.contextInit compilerContext storeCompilerPackageDbPath + unless storeCompilerPackageDbPathExists do + CIO.putStrLn "Package DB missing. Creating Package DB" + liftIO $ GhcPkg.contextInit compilerContext storeCompilerPackageDbPath - packages <- liftIO $ Z.getPackages storePath planJson + packages <- liftIO $ Z.getPackages storePath planJson - let installPlan = planJson ^. the @"installPlan" - let planPackages = M.fromList $ fmap (\p -> (p ^. the @"id", p)) installPlan + let installPlan = planJson.installPlan + let planPackages = M.fromList $ fmap (\p -> (p.id, p)) installPlan - let planDeps0 = installPlan >>= \p -> fmap (p ^. the @"id", ) $ mempty - <> (p ^. the @"depends") - <> (p ^. the @"exeDepends") - <> (p ^.. the @"components" . each . the @"lib" . each . the @"depends" . each) - <> (p ^.. the @"components" . each . the @"lib" . each . the @"exeDepends" . each) - let planDeps = planDeps0 <> fmap (\p -> ("[universe]", p ^. the @"id")) installPlan + let planDeps0 = installPlan >>= \p -> fmap (p.id, ) $ mempty + <> p.depends + <> p.exeDepends + <> (p ^.. the @"components" . each . the @"lib" . each . the @"depends" . each) + <> (p ^.. the @"components" . each . the @"lib" . each . the @"exeDepends" . each) + let planDeps = planDeps0 <> fmap (\p -> ("[universe]", p.id)) installPlan - downloadQueue <- liftIO $ STM.atomically $ DQ.createDownloadQueue planDeps + downloadQueue <- liftIO $ STM.atomically $ DQ.createDownloadQueue planDeps - let pInfos = M.fromList $ fmap (\p -> (p ^. the @"packageId", p)) packages + let pInfos = M.fromList $ fmap (\p -> (p.packageId, p)) packages + runLazy (mkAwsEnv opts.region mHostEndpoint awsLogLevel) do IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do liftIO $ IO.createDirectoryIfMissing True (tempPath T.unpack compilerId "package.db") - liftIO $ IO.forkThreadsWait threads $ OO.runOops $ DQ.runQueue downloadQueue $ \packageId -> do - OO.recoverOrVoid @DQ.DownloadStatus do + forkThreadsWait threads $ DQ.runQueue downloadQueue $ \packageId -> do + recoverOrVoid @DQ.DownloadStatus do pInfo <- pure (M.lookup packageId pInfos) - & do OO.onNothing do + & do onNothingM do CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId DQ.downloadSucceed - let archiveBaseName = Z.packageDir pInfo <.> ".tar.gz" + let archiveBaseName = pInfo.packageDir <.> ".tar.gz" let archiveFiles = versionedArchiveUris & traverse1 %~ ( T.pack archiveBaseName) let scopedArchiveFiles = scopedArchiveUris & traverse1 %~ ( T.pack archiveBaseName) - let packageStorePath = storePath Z.packageDir pInfo - let packageName = pInfo ^. the @"packageName" + let packageStorePath = storePath pInfo.packageDir + let packageName = pInfo.packageName storeDirectoryExists <- liftIO $ doesDirectoryExist packageStorePath package <- pure (M.lookup packageId planPackages) - & do OO.onNothing do + & do onNothingM do CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageName DQ.downloadSucceed @@ -177,23 +171,26 @@ when storeDirectoryExists DQ.downloadSucceed - OO.suspend runResourceT $ ensureStorePathCleanup packageStorePath do + ensureStorePathCleanup packageStorePath do let locations = sconcat $ fmap L.tuple2ToNel (NEL.zip archiveFiles scopedArchiveFiles) - (existingArchiveFileContents, existingArchiveFile) <- readFirstAvailableResource envAws locations maxRetries - & do OO.catch @AwsError \e -> do - CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayAwsError e + (existingArchiveFileContents, existingArchiveFile) <- readFirstAvailableResource locations maxRetries + & do trap @AwsError \e -> do + CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> tshow e DQ.downloadFail - & do OO.catch @HttpError \e -> do + & do trap @AwsStatusError \e -> do + CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayAwsStatusError e + DQ.downloadFail + & do trap @HttpError \e -> do CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayHttpError e DQ.downloadFail - & do OO.catch @NotFound \_ -> do + & do trap @NotFound \_ -> do CIO.putStrLn $ "Not found: " <> tshow locations DQ.downloadFail - & do OO.catch @InvalidUrl \(InvalidUrl url' reason') -> do + & do trap @InvalidUrl \(InvalidUrl url' reason') -> do CIO.hPutStrLn IO.stderr $ "Invalid URL: " <> tshow url' <> ", " <> reason' DQ.downloadFail - & do OO.catch @UnsupportedUri \e -> do + & do trap @UnsupportedUri \e -> do CIO.hPutStrLn IO.stderr $ tshow e DQ.downloadFail @@ -203,17 +200,17 @@ liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents IO.extractTar tempArchiveFile storePath - & do OO.catch @ArchiveError \(ArchiveError reason') -> do + & do trap @ArchiveError \(ArchiveError reason') -> do CIO.putStrLn $ "Unable to extract tar at " <> tshow tempArchiveFile <> " because: " <> reason' DQ.downloadFail meta <- loadMetadata packageStorePath oldStorePath <- pure (Map.lookup "store-path" meta) - & do OO.onNothing do + & do onNothingM do CIO.putStrLn "store-path is missing from Metadata" DQ.downloadFail - let Z.Tagged conf _ = Z.confPath pInfo + let Z.Tagged conf _ = pInfo.confPath let theConfPath = storePath conf let tempConfPath = tempPath conf @@ -225,28 +222,27 @@ DQ.downloadSucceed - CIO.putStrLn "Recaching package database" + CIO.putStrLn "Recaching package database" - liftIO $ GhcPkg.recache compilerContext storeCompilerPackageDbPath + liftIO $ GhcPkg.recache compilerContext storeCompilerPackageDbPath - failures <- liftIO $ STM.atomically $ STM.readTVar $ downloadQueue ^. the @"tFailures" + failures <- liftIO $ STM.atomically $ STM.readTVar downloadQueue.tFailures - forM_ failures $ \packageId -> CIO.hPutStrLn IO.stderr $ "Failed to download: " <> packageId + forM_ failures $ \packageId -> CIO.hPutStrLn IO.stderr $ "Failed to download: " <> packageId ensureStorePathCleanup :: () - => MonadIO m - => MonadCatch m - => e `OO.CouldBe` DQ.DownloadStatus + => r <: Error DQ.DownloadStatus + => r <: IOE => FilePath - -> ExceptT (OO.Variant e) m a - -> ExceptT (OO.Variant e) m a + -> Eff r a + -> Eff r a ensureStorePathCleanup packageStorePath = - OO.snatch @DQ.DownloadStatus \downloadStatus -> do + trapIn @DQ.DownloadStatus \downloadStatus -> do case downloadStatus of DQ.DownloadFailure -> M.cleanupStorePath packageStorePath DQ.DownloadSuccess -> CIO.hPutStrLn IO.stdout $ "Successfully cleaned up store path: " <> tshow packageStorePath - OO.throw downloadStatus + throw downloadStatus optsSyncFromArchive :: Parser SyncFromArchiveOptions optsSyncFromArchive = SyncFromArchiveOptions diff --git a/app/App/Commands/SyncToArchive.hs b/app/App/Commands/SyncToArchive.hs --- a/app/App/Commands/SyncToArchive.hs +++ b/app/App/Commands/SyncToArchive.hs @@ -1,23 +1,30 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{- HLINT ignore "Functor law" -} module App.Commands.SyncToArchive ( cmdSyncToArchive, ) where +import App.Amazonka import App.Commands.Options.Parser (optsPackageIds, text) import App.Commands.Options.Types (SyncToArchiveOptions (SyncToArchiveOptions)) -import Control.Concurrent.STM (TVar) -import Control.Lens ((^..), (^.), (.~), (%~), Each(each)) +import App.Run +import Control.Lens ((^..), Each(each)) import Data.Generics.Product.Any (the) import Data.List ((\\)) -import HaskellWorks.CabalCache.AppError (AwsError, HttpError (..), displayAwsError, displayHttpError) +import Effectful +import Effectful.Concurrent.Async +import Effectful.Concurrent.STM +import Effectful.Zoo.Amazonka.Data.AwsError +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.Lazy.Dynamic +import HaskellWorks.CabalCache.AppError (AwsStatusError, HttpError (..), displayAwsStatusError, displayHttpError) import HaskellWorks.CabalCache.Error (DecodeError, ExitFailure(..), InvalidUrl(..), NotImplemented(..), UnsupportedUri(..)) -import HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), ()) import HaskellWorks.CabalCache.IO.Tar (ArchiveError) +import HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), ()) import HaskellWorks.CabalCache.Metadata (createMetadata) import HaskellWorks.CabalCache.Topology (buildPlanData, canShare) +import HaskellWorks.CabalCache.Types import HaskellWorks.CabalCache.Version (archiveVersion) import HaskellWorks.Prelude import Options.Applicative (Parser, Mod, CommandFields) @@ -29,13 +36,11 @@ import qualified App.Commands.Options.Types as Z import qualified App.Static as AS import qualified Control.Concurrent.STM as STM -import qualified Control.Monad.Oops as OO import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LC8 import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text as Text -import qualified HaskellWorks.CabalCache.AWS.Env as AWS import qualified HaskellWorks.CabalCache.Core as Z import qualified HaskellWorks.CabalCache.GhcPkg as GhcPkg import qualified HaskellWorks.CabalCache.Hash as H @@ -47,8 +52,6 @@ import qualified System.Directory as IO import qualified System.IO as IO import qualified System.IO.Temp as IO -import qualified System.IO.Unsafe as IO -import qualified UnliftIO.Async as IO {- HLINT ignore "Monoid law, left identity" -} {- HLINT ignore "Redundant do" -} @@ -58,107 +61,99 @@ deriving (Eq, Show) runSyncToArchive :: Z.SyncToArchiveOptions -> IO () -runSyncToArchive opts = do - tEarlyExit <- STM.newTVarIO False - - OO.runOops $ OO.catchAndExitFailure @ExitFailure do - let mHostEndpoint = opts ^. the @"hostEndpoint" - let storePath = opts ^. the @"storePath" - let archiveUri = opts ^. the @"archiveUri" - let threads = opts ^. the @"threads" - let awsLogLevel = opts ^. the @"awsLogLevel" - let versionedArchiveUri = archiveUri archiveVersion - let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) - let scopedArchiveUri = versionedArchiveUri T.pack storePathHash - let maxRetries = opts ^. the @"maxRetries" - let ignorePackages = opts ^. the @"ignorePackages" +runSyncToArchive opts = runApp do + tEarlyExit <- newTVarIO False - CIO.putStrLn $ "Store path: " <> AWS.toText storePath - CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash - CIO.putStrLn $ "Archive URI: " <> AWS.toText archiveUri - CIO.putStrLn $ "Archive version: " <> archiveVersion - CIO.putStrLn $ "Threads: " <> tshow threads - CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel + let mHostEndpoint = opts.hostEndpoint + let storePath = opts.storePath + let archiveUri = opts.archiveUri + let threads = opts.threads + let awsLogLevel = opts.awsLogLevel + let versionedArchiveUri = archiveUri archiveVersion + let storePathHash = opts.storePathHash & fromMaybe (H.hashStorePath storePath) + let scopedArchiveUri = versionedArchiveUri T.pack storePathHash + let maxRetries = opts.maxRetries + let ignorePackages = opts.ignorePackages - planJson <- Z.loadPlan (opts ^. the @"path" opts ^. the @"buildPath") - & do OO.catch @DecodeError \e -> do - CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e - OO.throw ExitFailure + CIO.putStrLn $ "Store path: " <> AWS.toText storePath + CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash + CIO.putStrLn $ "Archive URI: " <> AWS.toText archiveUri + CIO.putStrLn $ "Archive version: " <> archiveVersion + CIO.putStrLn $ "Threads: " <> tshow threads + CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel - compilerContext <- Z.mkCompilerContext planJson - & do OO.catch @Text \e -> do - CIO.hPutStrLn IO.stderr e - OO.throw ExitFailure + planJson <- Z.loadPlan (opts.path opts.buildPath) + & do trap @DecodeError \e -> do + CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e + throw ExitFailure - let compilerId = planJson ^. the @"compilerId" + compilerContext <- Z.mkCompilerContext planJson + & do trap @Text \e -> do + CIO.hPutStrLn IO.stderr e + throw ExitFailure - envAws <- - liftIO (IO.unsafeInterleaveIO (AWS.mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel))) - <&> case mHostEndpoint of - Just (host, port, ssl) -> - \env -> - env - & the @"overrides" .~ \svc -> - svc & the @"endpoint" %~ \mkEndpoint region -> - mkEndpoint region - & the @"host" .~ host - & the @"port" .~ port - & the @"secure" .~ ssl - Nothing -> id + let compilerId = planJson.compilerId - let archivePath = versionedArchiveUri compilerId - let scopedArchivePath = scopedArchiveUri compilerId + let archivePath = versionedArchiveUri compilerId + let scopedArchivePath = scopedArchiveUri compilerId - liftIO $ IO.createLocalDirectoryIfMissing archivePath - liftIO $ IO.createLocalDirectoryIfMissing scopedArchivePath + liftIO $ IO.createLocalDirectoryIfMissing archivePath + liftIO $ IO.createLocalDirectoryIfMissing scopedArchivePath - packages <- liftIO $ Z.getPackages storePath planJson + packages <- liftIO $ Z.getPackages storePath planJson - nonShareable <- packages & filterM (fmap not . isShareable storePath) + nonShareable <- packages & filterM (fmap not . isShareable storePath) - let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId") + let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId") - let storeCompilerPath = storePath T.unpack compilerId - let storeCompilerPackageDbPath = storeCompilerPath "package.db" + let storeCompilerPath = storePath T.unpack compilerId + let storeCompilerPackageDbPath = storeCompilerPath "package.db" - storeCompilerPackageDbPathExists <- liftIO $ doesDirectoryExist storeCompilerPackageDbPath + storeCompilerPackageDbPathExists <- liftIO $ doesDirectoryExist storeCompilerPackageDbPath - unless storeCompilerPackageDbPathExists $ - liftIO $ GhcPkg.contextInit compilerContext storeCompilerPackageDbPath + unless storeCompilerPackageDbPathExists $ + liftIO $ GhcPkg.contextInit compilerContext storeCompilerPackageDbPath - CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages" + CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages" + runLazy (mkAwsEnv opts.region mHostEndpoint awsLogLevel) do IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do CIO.putStrLn $ "Temp path: " <> tshow tempPath - liftIO $ IO.pooledForConcurrentlyN_ (opts ^. the @"threads") packages $ \pInfo -> do - OO.runOops $ workLoop tEarlyExit do - let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz" + pooledForConcurrentlyN_ opts.threads packages $ \pInfo -> do + workLoop tEarlyExit do + let archiveFileBasename = pInfo.packageDir <.> ".tar.gz" let archiveFile = versionedArchiveUri T.pack archiveFileBasename let scopedArchiveFile = versionedArchiveUri T.pack storePathHash T.pack archiveFileBasename - let packageStorePath = storePath Z.packageDir pInfo - let packageName = pInfo ^. the @"packageName" + let packageStorePath = storePath pInfo.packageDir + let packageName = pInfo.packageName when (packageName `S.member` ignorePackages) do CIO.hPutStrLn IO.stderr $ "Ignoring package: " <> packageName - OO.throw WorkSkipped + throw WorkSkipped -- either write "normal" package, or a user-specific one if the package cannot be shared - let targetFile = if canShare planData (Z.packageId pInfo) then archiveFile else scopedArchiveFile + let targetFile = if canShare planData pInfo.packageId then archiveFile else scopedArchiveFile - archiveFileExists <- IO.resourceExists envAws targetFile - & do OO.catch @InvalidUrl \(InvalidUrl url' reason') -> do + archiveFileExists <- IO.resourceExists targetFile + & do trap @InvalidUrl \(InvalidUrl url' reason') -> do CIO.hPutStrLn IO.stderr $ "Invalid URL: " <> tshow url' <> ", " <> reason' - OO.throw WorkSkipped - & do OO.catch @UnsupportedUri \e -> do + throw WorkSkipped + & do trap @UnsupportedUri \e -> do CIO.hPutStrLn IO.stderr $ "Unsupported URI: " <> tshow e - OO.throw WorkSkipped + throw WorkSkipped + & do trap @AwsError \e -> do + CIO.hPutStrLn IO.stderr $ "Unsupported URI: " <> tshow e + throw WorkSkipped + & do trap @AwsStatusError \e -> do + CIO.hPutStrLn IO.stderr $ "Unsupported URI: " <> tshow e + throw WorkSkipped unless archiveFileExists do packageStorePathExists <- liftIO $ doesDirectoryExist packageStorePath when packageStorePathExists do - let workingStorePackagePath = tempPath Z.packageDir pInfo + let workingStorePackagePath = tempPath pInfo.packageDir liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath let rp2 = Z.relativePaths storePath pInfo @@ -170,58 +165,62 @@ metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)] IO.createTar tempArchiveFile (rp2 <> [metas]) - & do OO.catch @ArchiveError \_ -> do + & do trap @ArchiveError \_ -> do CIO.hPutStrLn IO.stderr $ "Unable tar " <> tshow tempArchiveFile - OO.throw WorkSkipped + throw WorkSkipped - (liftIO (LBS.readFile tempArchiveFile) >>= IO.writeResource envAws targetFile maxRetries) - & do OO.catch @AwsError \e -> do + (liftIO (LBS.readFile tempArchiveFile) >>= IO.writeResource targetFile maxRetries) + & do trap @AwsError \e -> do CIO.hPutStrLn IO.stderr $ mempty <> "ERROR: No write access to archive uris: " <> tshow (fmap AWS.toText [scopedArchiveFile, archiveFile]) - <> " " <> displayAwsError e - OO.throw WorkFatal - & do OO.catch @HttpError \e -> do + <> " " <> tshow e + throw WorkFatal + & do trap @AwsStatusError \e -> do CIO.hPutStrLn IO.stderr $ mempty <> "ERROR: No write access to archive uris: " <> tshow (fmap AWS.toText [scopedArchiveFile, archiveFile]) + <> " " <> displayAwsStatusError e + throw WorkFatal + & do trap @HttpError \e -> do + CIO.hPutStrLn IO.stderr $ mempty + <> "ERROR: No write access to archive uris: " + <> tshow (fmap AWS.toText [scopedArchiveFile, archiveFile]) <> " " <> displayHttpError e - OO.throw WorkFatal - & do OO.catch @NotImplemented \e -> do + throw WorkFatal + & do trap @NotImplemented \e -> do CIO.hPutStrLn IO.stderr $ mempty <> "Operation not implemented: " <> tshow (fmap AWS.toText [scopedArchiveFile, archiveFile]) <> " " <> tshow e - OO.throw WorkFatal - & do OO.catch @UnsupportedUri \e -> do + throw WorkFatal + & do trap @UnsupportedUri \e -> do CIO.hPutStrLn IO.stderr $ mempty <> "Unsupported URI: " <> tshow (fmap AWS.toText [scopedArchiveFile, archiveFile]) <> ": " <> tshow e - OO.throw WorkFatal - - return () + throw WorkFatal - earlyExit <- STM.readTVarIO tEarlyExit + earlyExit <- readTVarIO tEarlyExit - when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error" + when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error" workLoop :: () - => MonadIO m + => r <: Concurrent => TVar Bool - -> ExceptT (OO.Variant (WorkResult : e')) m () - -> ExceptT (OO.Variant e') m () + -> Eff (Error WorkResult : r) () + -> Eff r () workLoop tEarlyExit f = do - earlyExit <- liftIO $ STM.readTVarIO tEarlyExit + earlyExit <- readTVarIO tEarlyExit unless earlyExit do - f & OO.catch @WorkResult \case + f & trap @WorkResult \case WorkSkipped -> pure () - WorkFatal -> liftIO $ STM.atomically $ STM.writeTVar tEarlyExit True + WorkFatal -> atomically $ STM.writeTVar tEarlyExit True isShareable :: MonadIO m => FilePath -> Z.PackageInfo -> m Bool isShareable storePath pkg = - let packageSharePath = storePath Z.packageDir pkg "share" + let packageSharePath = storePath pkg.packageDir "share" in IO.listMaybeDirectory packageSharePath <&> (\\ ["doc"]) <&> null optsSyncToArchive :: Parser SyncToArchiveOptions @@ -237,7 +236,7 @@ ( OA.long "archive-uri" <> OA.help "Archive URI to sync to" <> OA.metavar "S3_URI" - <> OA.value (Local $ takeDirectory AS.cabalStoreDirectory "archive") + <> OA.value (LocalFile $ takeDirectory AS.cabalStoreDirectory "archive") ) <*> OA.strOption ( OA.long "path" diff --git a/app/App/Commands/Version.hs b/app/App/Commands/Version.hs --- a/app/App/Commands/Version.hs +++ b/app/App/Commands/Version.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - module App.Commands.Version ( cmdVersion, ) where diff --git a/app/App/Run.hs b/app/App/Run.hs new file mode 100644 --- /dev/null +++ b/app/App/Run.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE ImpredicativeTypes #-} + +module App.Run + ( runApp, + ) where + +import HaskellWorks.CabalCache.Error +import HaskellWorks.CabalCache.Exit +import Effectful +import Effectful.Concurrent +import Effectful.Environment +import Effectful.Resource +import Effectful.Zoo.Amazonka.Api.Run +import Effectful.Zoo.Amazonka.Data.AwsLogEntry +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.DataLog.Data.LogEntry +import Effectful.Zoo.DataLog.Dynamic +import Effectful.Zoo.Log.Data.LogMessage +import Effectful.Zoo.Log.Data.Severity +import Effectful.Zoo.Log.Dynamic +import HaskellWorks.Prelude + +import qualified Data.Text as T +import qualified System.IO as IO + +{- HLINT ignore "Monoid law, left identity" -} +{- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Redundant do" -} + +writeLog :: () + => r <: IOE + => CallStack + -> Severity + -> Text + -> Eff r () +writeLog _ _ t = do + liftIO $ IO.hPutStrLn IO.stderr $ T.unpack t -- TODO write severity + +runApp :: () + => Eff + ( Error ExitFailure + : DataLog AwsLogEntry + : DataLog (LogEntry (LogMessage Text)) + : Log Text + : Environment + : Concurrent + : Resource + : IOE + : '[] + ) a + -> IO a +runApp f = + f + & catchAndExitFailure @ExitFailure + & runDataLogAwsLogEntryToLog + & runDataLog @(LogEntry (LogMessage Text)) (\_ -> pure ()) -- TODO log these properly + & runLog (ConcUnlift Persistent Unlimited) writeLog + & runEnvironment + & runConcurrent + & runResource + & runEff diff --git a/app/App/Static.hs b/app/App/Static.hs --- a/app/App/Static.hs +++ b/app/App/Static.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module App.Static ( cabalStoreDirectory, buildPath, diff --git a/app/App/Static/Posix.hs b/app/App/Static/Posix.hs --- a/app/App/Static/Posix.hs +++ b/app/App/Static/Posix.hs @@ -6,6 +6,25 @@ import HaskellWorks.Prelude import qualified App.Static.Base as S +import qualified System.Directory as IO +import qualified System.Environment as IO +import qualified System.IO as IO +import qualified System.IO.Unsafe as IO cabalDirectory :: FilePath -cabalDirectory = S.homeDirectory ".cabal" +cabalDirectory = + IO.unsafePerformIO do + IO.lookupEnv "CABAL_DIR" >>= \case + Just dir -> pure dir + Nothing -> do + let oldCabalDir = S.homeDirectory ".cabal" + let newCabaldir = S.homeDirectory ".local/state/cabal/store" + oldExists <- IO.doesDirectoryExist oldCabalDir + newExists <- IO.doesDirectoryExist newCabaldir + case (oldExists, newExists) of + (True, True) -> do + IO.hPutStrLn IO.stderr "Warning: Both ~/.cabal and ~/.local/state/cabal/store exist" + pure newCabaldir + (True, _) -> pure oldCabalDir + (_, True) -> pure newCabaldir + _ -> fail "No cabal directory found" diff --git a/cabal-cache.cabal b/cabal-cache.cabal --- a/cabal-cache.cabal +++ b/cabal-cache.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.2 +cabal-version: 3.4 name: cabal-cache -version: 1.1.0.2 +version: 1.2.0.0 synopsis: CI Assistant for Haskell projects description: CI Assistant for Haskell projects. Implements package caching. homepage: https://github.com/haskell-works/cabal-cache @@ -12,7 +12,8 @@ copyright: John Ky 2019-2023 category: Development tested-with: GHC == 9.6.6, GHC == 9.4.8, GHC == 9.2.8 -extra-source-files: README.md +extra-doc-files: CHANGELOG.md + README.md source-repository head type: git @@ -32,6 +33,17 @@ common cryptonite { build-depends: cryptonite >= 0.25 && < 1 } common deepseq { build-depends: deepseq >= 1.4.4.0 && < 1.6 } common directory { build-depends: directory >= 1.3.3.0 && < 1.4 } +common effectful { build-depends: effectful >= 2.5 && < 3 } +common effectful-core { build-depends: effectful-core >= 2.5 && < 3 } +common effectful-plugin { build-depends: effectful-plugin >= 1.1.0.4 && < 2 } +common effectful-zoo-amazonka { build-depends: effectful-zoo:amazonka >= 0.0.1.0 && < 0.1 } +common effectful-zoo-console { build-depends: effectful-zoo:console >= 0.0.1.0 && < 0.1 } +common effectful-zoo-core { build-depends: effectful-zoo:core >= 0.0.1.0 && < 0.1 } +common effectful-zoo-datalog { build-depends: effectful-zoo:datalog >= 0.0.1.0 && < 0.1 } +common effectful-zoo-hedgehog { build-depends: effectful-zoo:hedgehog >= 0.0.1.0 && < 0.1 } +common effectful-zoo-hunit { build-depends: effectful-zoo:hunit >= 0.0.1.0 && < 0.1 } +common effectful-zoo-lazy { build-depends: effectful-zoo:lazy >= 0.0.1.0 && < 0.1 } +common effectful-zoo-log { build-depends: effectful-zoo:log >= 0.0.1.0 && < 0.1 } common exceptions { build-depends: exceptions >= 0.10.1 && < 0.11 } common filepath { build-depends: filepath >= 1.3 && < 1.6 } common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 2.3 } @@ -48,13 +60,13 @@ common lens { build-depends: lens >= 4.17 && < 6 } common mtl { build-depends: mtl >= 2.2.2 && < 2.4 } common network-uri { build-depends: network-uri >= 2.6.4.1 && < 2.8 } -common oops { build-depends: oops >= 0.2 && < 0.3 } common optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.19 } common microlens { build-depends: microlens >= 0.4.13.1 && < 0.5 } common process { build-depends: process >= 1.6.5.0 && < 1.7 } common raw-strings-qq { build-depends: raw-strings-qq >= 1.1 && < 2 } common relation { build-depends: relation >= 0.5 && < 0.6 } common resourcet { build-depends: resourcet >= 1.2.2 && < 1.4 } +common resourcet-effectful { build-depends: resourcet-effectful >= 1.0.1.0 && < 1.1 } common selective { build-depends: selective >= 0.1.0 && < 0.8 } common stm { build-depends: stm >= 2.5.0.0 && < 3 } common stringsearch { build-depends: stringsearch >= 0.3.6.6 && < 0.4 } @@ -67,23 +79,63 @@ common unliftio { build-depends: unliftio >= 0.2.10 && < 0.3 } common zlib { build-depends: zlib >= 0.6.2 && < 0.8 } +flag dev + description: Enable development settings like -Werror + default: False + manual: True + common project-config default-language: Haskell2010 - default-extensions: BlockArguments + default-extensions: AllowAmbiguousTypes + ApplicativeDo + BlockArguments DataKinds + DefaultSignatures + DeriveGeneric + DeriveAnyClass + DerivingStrategies + DerivingVia + DisambiguateRecordFields + DuplicateRecordFields FlexibleContexts + FunctionalDependencies + GADTs + ImportQualifiedPost LambdaCase + LiberalTypeSynonyms + MonadComprehensions MonoLocalBinds + MultiWayIf + NoFieldSelectors NoImplicitPrelude + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + PackageImports + PartialTypeSignatures + PatternSynonyms + QuantifiedConstraints + QuasiQuotes + RecordWildCards + RecursiveDo + RoleAnnotations + ScopedTypeVariables + TupleSections + TypeFamilies + TypeFamilyDependencies + TypeApplications TypeOperators + UndecidableInstances + UnicodeSyntax + ViewPatterns ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns + -- -Wno-incomplete-patterns -Wtabs -Wunused-packages - - if impl(ghc >= 8.10.1) - ghc-options: -Wunused-packages + if flag(dev) + ghc-options: -Werror library import: base, project-config, @@ -98,6 +150,15 @@ cryptonite, deepseq, directory, + effectful, + effectful-core, + effectful-plugin, + effectful-zoo-amazonka, + effectful-zoo-console, + effectful-zoo-core, + effectful-zoo-datalog, + effectful-zoo-lazy, + effectful-zoo-log, exceptions, filepath, generic-lens, @@ -106,13 +167,12 @@ http-types, hw-prelude, microlens, - mtl, network-uri, - oops, optparse-applicative, process, relation, resourcet, + resourcet-effectful, stm, text, topograph, @@ -130,6 +190,7 @@ HaskellWorks.CabalCache.Core HaskellWorks.CabalCache.Data.List HaskellWorks.CabalCache.Error + HaskellWorks.CabalCache.Exit HaskellWorks.CabalCache.GhcPkg HaskellWorks.CabalCache.Hash HaskellWorks.CabalCache.IO.Console @@ -145,6 +206,7 @@ HaskellWorks.CabalCache.Types HaskellWorks.CabalCache.URI HaskellWorks.CabalCache.Version + ghc-options: -fplugin=Effectful.Plugin executable cabal-cache import: base, project-config, @@ -155,25 +217,31 @@ cabal-install-parsers, containers, directory, + effectful-core, + effectful-plugin, + effectful-zoo-amazonka, + effectful-zoo-core, + effectful-zoo-datalog, + effectful-zoo-lazy, + effectful-zoo-log, + effectful, exceptions, filepath, generic-lens, hw-prelude, - microlens, lens, network-uri, - oops, optparse-applicative, - resourcet, + resourcet-effectful, stm, stringsearch, temporary, text, - unliftio, build-depends: cabal-cache main-is: Main.hs hs-source-dirs: app - other-modules: App.Commands + other-modules: App.Amazonka + App.Commands App.Commands.Options.Parser App.Commands.Debug App.Commands.Debug.S3 @@ -183,6 +251,7 @@ App.Commands.SyncFromArchive App.Commands.SyncToArchive App.Commands.Version + App.Run App.Static App.Static.Base App.Static.Posix @@ -190,6 +259,7 @@ Paths_cabal_cache autogen-modules: Paths_cabal_cache ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -fplugin=Effectful.Plugin test-suite cabal-cache-test import: base, project-config, @@ -197,21 +267,29 @@ amazonka, bytestring, directory, + effectful-core, + effectful-plugin, + effectful-zoo-amazonka, + effectful-zoo-core, + effectful-zoo-hedgehog, + effectful-zoo-hunit, + effectful-zoo-lazy, + effectful, exceptions, filepath, + generic-lens, Glob, hedgehog-extras, hedgehog, hspec, - http-types, hw-hspec-hedgehog, hw-prelude, + microlens, network-uri, - oops, raw-strings-qq, + resourcet-effectful, text, time - type: exitcode-stdio-1.0 main-is: Spec.hs build-depends: cabal-cache @@ -223,3 +301,4 @@ HaskellWorks.CabalCache.LocationSpec HaskellWorks.CabalCache.QuerySpec Test.Base + ghc-options: -fplugin=Effectful.Plugin diff --git a/src/HaskellWorks/CabalCache/AWS/Env.hs b/src/HaskellWorks/CabalCache/AWS/Env.hs --- a/src/HaskellWorks/CabalCache/AWS/Env.hs +++ b/src/HaskellWorks/CabalCache/AWS/Env.hs @@ -1,18 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - module HaskellWorks.CabalCache.AWS.Env ( awsLogger , mkEnv - , setEnvEndpoint ) where import Control.Concurrent (myThreadId) import Data.ByteString.Builder (toLazyByteString) -import Data.Generics.Product.Any (the) +import Effectful.Zoo.Amazonka.Data.AwsEnv import HaskellWorks.Prelude -import Lens.Micro import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..)) import qualified Amazonka as AWS @@ -24,21 +18,7 @@ import qualified HaskellWorks.CabalCache.IO.Console as CIO import qualified System.IO as IO -setEnvEndpoint :: Maybe (ByteString, Int, Bool) -> IO AWS.Env -> IO AWS.Env -setEnvEndpoint mHostEndpoint getEnv = do - env <- getEnv - case mHostEndpoint of - Just (host, port, ssl) -> - pure $ env - & the @"overrides" .~ \svc -> do - svc & the @"endpoint" %~ \mkEndpoint region -> do - mkEndpoint region - & the @"host" .~ host - & the @"port" .~ port - & the @"secure" .~ ssl - Nothing -> pure env - -mkEnv :: AWS.Region -> (AWS.LogLevel -> LBS.ByteString -> IO ()) -> IO AWS.Env +mkEnv :: AWS.Region -> (AWS.LogLevel -> LBS.ByteString -> IO ()) -> IO AwsEnv mkEnv region lg = do lgr <- newAwsLogger lg discoveredEnv <- AWS.newEnv AWS.discover diff --git a/src/HaskellWorks/CabalCache/AWS/Error.hs b/src/HaskellWorks/CabalCache/AWS/Error.hs --- a/src/HaskellWorks/CabalCache/AWS/Error.hs +++ b/src/HaskellWorks/CabalCache/AWS/Error.hs @@ -1,27 +1,26 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module HaskellWorks.CabalCache.AWS.Error - ( handleAwsError + ( handleAwsStatusError ) where -import Control.Monad.Catch (MonadCatch(..), MonadThrow(throwM)) -import Control.Monad.Except (MonadError) -import HaskellWorks.CabalCache.AppError (AwsError(..)) +import Effectful +import Effectful.Zoo.Amazonka.Data.AwsError +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import HaskellWorks.CabalCache.AppError (AwsStatusError(..)) import HaskellWorks.Prelude import qualified Amazonka as AWS -import qualified Control.Monad.Oops as OO import qualified Network.HTTP.Types as HTTP {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Redundant bracket" -} -handleAwsError :: (MonadCatch m, - MonadError (OO.Variant e) m, - OO.CouldBeF e AwsError) => - m a -> m a -handleAwsError f = catch f $ \(e :: AWS.Error) -> - case e of - (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status _ _) _ _ _ _)) -> OO.throw $ AwsError s - _ -> throwM e +handleAwsStatusError :: () + => r <: Error AwsError + => r <: Error AwsStatusError + => Eff r a + -> Eff r a +handleAwsStatusError f = f & trapIn @AwsError \case + (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status _ _) _ _ _ _)) -> throw $ AwsStatusError s + e -> throw e diff --git a/src/HaskellWorks/CabalCache/AWS/S3.hs b/src/HaskellWorks/CabalCache/AWS/S3.hs --- a/src/HaskellWorks/CabalCache/AWS/S3.hs +++ b/src/HaskellWorks/CabalCache/AWS/S3.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - module HaskellWorks.CabalCache.AWS.S3 ( uriToS3Uri, headS3Uri, @@ -16,21 +9,25 @@ import Amazonka (ResponseBody) import Amazonka.Data (ToText(..), fromText) -import Control.Monad.Catch (MonadCatch(..)) -import Control.Monad.Except (MonadError) -import Control.Monad.Trans.Resource (MonadResource, MonadUnliftIO, liftResourceT, runResourceT) +import Control.Monad.Trans.Resource (MonadResource, liftResourceT) import Data.Conduit.Lazy (lazyConsume) import Data.Generics.Product.Any (the) -import HaskellWorks.CabalCache.AppError (AwsError(..)) +import Effectful +import Effectful.Resource +import Effectful.Zoo.Amazonka.Api.Send +import Effectful.Zoo.Amazonka.Data +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.Lazy.Dynamic +import Effectful.Zoo.DataLog.Dynamic +import HaskellWorks.CabalCache.AppError (AwsStatusError(..)) import HaskellWorks.CabalCache.Error (CopyFailed(..), UnsupportedUri(..)) import HaskellWorks.Prelude import Lens.Micro import Network.URI (URI) import qualified Amazonka as AWS --- import qualified Amazonka.Data.Body as AWS import qualified Amazonka.S3 as AWS -import qualified Control.Monad.Oops as OO import qualified Data.ByteString.Lazy as LBS import qualified HaskellWorks.CabalCache.AWS.Error as AWS import qualified HaskellWorks.CabalCache.AWS.S3.URI as AWS @@ -40,26 +37,31 @@ --- | Access the response body as a lazy bytestring lazyByteString :: MonadResource m => ResponseBody -> m LBS.ByteString -lazyByteString rsBody = liftResourceT $ LBS.fromChunks <$> lazyConsume (rsBody ^. the @"body") +lazyByteString rsBody = liftResourceT $ LBS.fromChunks <$> lazyConsume rsBody.body unsafeDownloadRequest :: () - => Monad m - => MonadResource m - => AWS.Env - -> AWS.GetObject - -> m LBS.ByteString -unsafeDownloadRequest awsEnv req = do - resp <- AWS.send awsEnv req - lazyByteString (resp ^. the @"body") + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource + => AWS.GetObject + -> Eff r LBS.ByteString +unsafeDownloadRequest req = do + resp <- lazySendAws req + lazyByteString $ resp ^. the @"body" unsafeDownload :: () - => Monad m - => MonadResource m - => AWS.Env - -> AWS.BucketName + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource + => AWS.BucketName -> AWS.ObjectKey - -> m LBS.ByteString -unsafeDownload env bucketName objectKey = unsafeDownloadRequest env (AWS.newGetObject bucketName objectKey) + -> Eff r LBS.ByteString +unsafeDownload bucketName objectKey = + unsafeDownloadRequest (AWS.newGetObject bucketName objectKey) uriToS3Uri :: URI -> Either UnsupportedUri AWS.S3Uri uriToS3Uri uri = case fromText @AWS.S3Uri (tshow uri) of @@ -67,62 +69,76 @@ Left msg -> Left $ UnsupportedUri uri $ "Unable to parse URI" <> tshow msg headS3Uri :: () - => MonadError (OO.Variant e) m - => e `OO.CouldBe` AwsError - => e `OO.CouldBe` UnsupportedUri - => MonadCatch m - => MonadResource m - => AWS.Env - -> URI - -> m AWS.HeadObjectResponse -headS3Uri envAws uri = do - AWS.S3Uri b k <- OO.hoistEither $ uriToS3Uri (URI.reslashUri uri) - AWS.handleAwsError $ AWS.send envAws $ AWS.newHeadObject b k + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: Error AwsStatusError + => r <: Error UnsupportedUri + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource + => URI + -> Eff r AWS.HeadObjectResponse +headS3Uri uri = do + AWS.S3Uri b k <- uriToS3Uri (URI.reslashUri uri) + & onLeft throw + AWS.handleAwsStatusError $ lazySendAws $ AWS.newHeadObject b k + putObject :: () - => e `OO.CouldBe` AwsError - => e `OO.CouldBe` UnsupportedUri - => MonadCatch m - => MonadUnliftIO m + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: Error AwsStatusError + => r <: Error UnsupportedUri + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource => AWS.ToBody a - => AWS.Env - -> URI + => URI -> a - -> ExceptT (OO.Variant e) m () -putObject envAws uri lbs = do - AWS.S3Uri b k <- OO.hoistEither $ uriToS3Uri (URI.reslashUri uri) + -> Eff r () +putObject uri lbs = do + AWS.S3Uri b k <- uriToS3Uri (URI.reslashUri uri) + & onLeft throw + let req = AWS.toBody lbs let po = AWS.newPutObject b k req - AWS.handleAwsError $ void $ OO.suspend runResourceT $ AWS.send envAws po + AWS.handleAwsStatusError $ void $ lazySendAws po + getS3Uri :: () - => MonadError (OO.Variant e) m - => e `OO.CouldBe` AwsError - => e `OO.CouldBe` UnsupportedUri - => MonadCatch m - => MonadResource m - => AWS.Env - -> URI - -> m LBS.ByteString -getS3Uri envAws uri = do - AWS.S3Uri b k <- OO.hoistEither $ uriToS3Uri (URI.reslashUri uri) - AWS.handleAwsError $ unsafeDownload envAws b k + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: Error AwsStatusError + => r <: Error UnsupportedUri + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource + => URI + -> Eff r LBS.ByteString +getS3Uri uri = do + AWS.S3Uri b k <- uriToS3Uri (URI.reslashUri uri) + & onLeft throw + AWS.handleAwsStatusError $ unsafeDownload b k + copyS3Uri :: () - => MonadUnliftIO m - => e `OO.CouldBe` AwsError - => e `OO.CouldBe` CopyFailed - => e `OO.CouldBe` UnsupportedUri - => AWS.Env - -> URI + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: Error AwsStatusError + => r <: Error CopyFailed + => r <: Error UnsupportedUri + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource + => URI -> URI - -> ExceptT (OO.Variant e) m () -copyS3Uri envAws source target = do - AWS.S3Uri sourceBucket sourceObjectKey <- OO.hoistEither $ uriToS3Uri (URI.reslashUri source) - AWS.S3Uri targetBucket targetObjectKey <- OO.hoistEither $ uriToS3Uri (URI.reslashUri target) + -> Eff r () +copyS3Uri source target = do + AWS.S3Uri sourceBucket sourceObjectKey <- uriToS3Uri (URI.reslashUri source) & onLeft throw + AWS.S3Uri targetBucket targetObjectKey <- uriToS3Uri (URI.reslashUri target) & onLeft throw let copyObjectRequest = AWS.newCopyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey - response <- OO.suspend runResourceT $ AWS.send envAws copyObjectRequest + response <- lazySendAws copyObjectRequest let responseCode = response ^. the @"httpStatus" unless (200 <= responseCode && responseCode < 300) do liftIO $ CIO.hPutStrLn IO.stderr $ "Error in S3 copy: " <> tshow response - OO.throw CopyFailed + throw CopyFailed diff --git a/src/HaskellWorks/CabalCache/AWS/S3/URI.hs b/src/HaskellWorks/CabalCache/AWS/S3/URI.hs --- a/src/HaskellWorks/CabalCache/AWS/S3/URI.hs +++ b/src/HaskellWorks/CabalCache/AWS/S3/URI.hs @@ -1,16 +1,9 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - module HaskellWorks.CabalCache.AWS.S3.URI ( S3Uri(..) ) where import Control.DeepSeq (NFData) -import Data.Generics.Product.Any (HasAny(the)) import HaskellWorks.Prelude -import Lens.Micro import qualified Amazonka.Data.Text as AWS import qualified Amazonka.S3 as AWS @@ -35,7 +28,7 @@ return (S3Uri bn ok) instance AWS.ToText S3Uri where - toText loc = toS3Uri (loc ^. the @"bucket") (loc ^. the @"objectKey") + toText loc = toS3Uri loc.bucket loc.objectKey instance J.ToJSON S3Uri where toJSON s3Uri = J.String (AWS.toText s3Uri) diff --git a/src/HaskellWorks/CabalCache/AppError.hs b/src/HaskellWorks/CabalCache/AppError.hs --- a/src/HaskellWorks/CabalCache/AppError.hs +++ b/src/HaskellWorks/CabalCache/AppError.hs @@ -1,13 +1,9 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - module HaskellWorks.CabalCache.AppError - ( AwsError(..), + ( AwsStatusError(..), HttpError(..), HasStatusCode(..), HasMaybeStatusCode(..), - displayAwsError, + displayAwsStatusError, displayHttpError, ) where @@ -16,7 +12,7 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Types as HTTP -newtype AwsError = AwsError +newtype AwsStatusError = AwsStatusError { status :: HTTP.Status } deriving (Eq, Show, Generic) @@ -27,8 +23,8 @@ } deriving (Show, Generic) -displayAwsError :: AwsError -> Text -displayAwsError (AwsError s) = tshow s +displayAwsStatusError :: AwsStatusError -> Text +displayAwsStatusError (AwsStatusError s) = tshow s displayHttpError :: HttpError -> Text displayHttpError (HttpError _ s) = tshow s @@ -39,11 +35,11 @@ class HasMaybeStatusCode a where maybeStatusCodeOf :: a -> Maybe Int -instance HasStatusCode AwsError where - statusCodeOf (AwsError (HTTP.Status c _)) = c +instance HasStatusCode AwsStatusError where + statusCodeOf (AwsStatusError (HTTP.Status c _)) = c -instance HasMaybeStatusCode AwsError where - maybeStatusCodeOf (AwsError (HTTP.Status c _)) = Just c +instance HasMaybeStatusCode AwsStatusError where + maybeStatusCodeOf (AwsStatusError (HTTP.Status c _)) = Just c instance HasMaybeStatusCode HttpError where maybeStatusCodeOf (HttpError _ content') = case content' of diff --git a/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs b/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs --- a/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs +++ b/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - module HaskellWorks.CabalCache.Concurrent.DownloadQueue ( DownloadStatus(..), createDownloadQueue, @@ -12,14 +7,15 @@ ) where import Control.Monad.Catch (MonadMask(..)) -import Control.Monad.Except (MonadError) import Data.Set ((\\)) +import Effectful +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static import Prelude hiding (fail) import HaskellWorks.Prelude import qualified Control.Concurrent.STM as STM import qualified Control.Monad.Catch as CMC -import qualified Control.Monad.Oops as OO import qualified Data.Relation as R import qualified Data.Set as S import qualified HaskellWorks.CabalCache.Concurrent.Type as Z @@ -28,17 +24,17 @@ data DownloadStatus = DownloadSuccess | DownloadFailure deriving (Eq, Show) -downloadSucceed :: forall e a m. () - => MonadError (OO.Variant e) m - => e `OO.CouldBe` DownloadStatus - => m a -downloadSucceed = OO.throw DownloadSuccess +downloadSucceed :: forall a r. () + => r <: Error DownloadStatus + => Eff r a +downloadSucceed = + throw DownloadSuccess -downloadFail :: forall e a m. () - => MonadError (OO.Variant e) m - => e `OO.CouldBe` DownloadStatus - => m a -downloadFail = OO.throw DownloadFailure +downloadFail :: forall a r. () + => r <: Error DownloadStatus + => Eff r a +downloadFail = + throw DownloadFailure createDownloadQueue :: [(Z.ProviderId, Z.ConsumerId)] -> STM.STM Z.DownloadQueue createDownloadQueue dependencies = do diff --git a/src/HaskellWorks/CabalCache/Concurrent/Fork.hs b/src/HaskellWorks/CabalCache/Concurrent/Fork.hs --- a/src/HaskellWorks/CabalCache/Concurrent/Fork.hs +++ b/src/HaskellWorks/CabalCache/Concurrent/Fork.hs @@ -2,18 +2,24 @@ ( forkThreadsWait, ) where -import Control.Exception (finally) +import Effectful +import Effectful.Concurrent +import Effectful.Concurrent.STM +import Effectful.Exception +import Effectful.Zoo.Core import HaskellWorks.Prelude -import qualified Control.Concurrent as IO -import qualified Control.Concurrent.STM as STM - -forkThreadsWait :: Int -> IO () -> IO () +forkThreadsWait :: () + => r <: Concurrent + => Int + -> Eff r () + -> Eff r () forkThreadsWait n f = do - tDone <- STM.atomically $ STM.newTVar (0 :: Int) - forM_ [1 .. n] $ \_ -> IO.forkIO do - f `finally` (STM.atomically $ STM.modifyTVar tDone (+1)) + tDone <- newTVarIO (0 :: Int) - STM.atomically do - done <- STM.readTVar tDone - when (done < n) STM.retry + forM_ [1 .. n] $ \_ -> forkIO do + f `finally` atomically (modifyTVar tDone (+1)) + + atomically do + done <- readTVar tDone + when (done < n) retry diff --git a/src/HaskellWorks/CabalCache/Concurrent/Type.hs b/src/HaskellWorks/CabalCache/Concurrent/Type.hs --- a/src/HaskellWorks/CabalCache/Concurrent/Type.hs +++ b/src/HaskellWorks/CabalCache/Concurrent/Type.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} - module HaskellWorks.CabalCache.Concurrent.Type ( DownloadQueue(..), ConsumerId, diff --git a/src/HaskellWorks/CabalCache/Core.hs b/src/HaskellWorks/CabalCache/Core.hs --- a/src/HaskellWorks/CabalCache/Core.hs +++ b/src/HaskellWorks/CabalCache/Core.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - module HaskellWorks.CabalCache.Core ( PackageInfo(..), Tagged(..), @@ -17,16 +9,15 @@ ) where import Control.DeepSeq (NFData) -import Control.Monad.Catch (MonadCatch(..)) -import Control.Monad.Except (MonadError(..)) import Data.Aeson (eitherDecode) -import Data.Generics.Product.Any (the) +import Effectful +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.Core.Exception import HaskellWorks.CabalCache.Error (DecodeError(..)) import HaskellWorks.Prelude -import Lens.Micro import System.FilePath ((<.>), ()) -import qualified Control.Monad.Oops as OO import qualified Data.ByteString.Lazy as LBS import qualified Data.List as L import qualified Data.Text as T @@ -58,9 +49,6 @@ , libs :: [Library] } deriving (Show, Eq, Generic, NFData) -(<||>) :: Monad m => ExceptT e m a -> ExceptT e m a -> ExceptT e m a -(<||>) f g = f `catchError` const g - isPosix :: Bool isPosix = I.os /= "mingw32" {-# NOINLINE isPosix #-} @@ -77,85 +65,83 @@ withExeExt' = T.pack . withExeExt . T.unpack findExecutable :: () - => MonadIO f - => MonadError (OO.Variant e) f - => e `OO.CouldBe` Text + => r <: Error Text + => r <: IOE => Text - -> f Text -findExecutable exe = fmap T.pack $ - liftIO (IO.findExecutable (T.unpack exe)) >>= OO.hoistMaybe (exe <> " is not in path") + -> Eff r Text +findExecutable exe = + liftIO (fmap T.pack <$> IO.findExecutable (T.unpack exe)) + & onNothingM (throw (exe <> " is not in path")) runGhcPkg :: () - => MonadCatch m - => MonadIO m - => MonadError (OO.Variant e) m - => e `OO.CouldBe` Text + => r <: Error Text + => r <: IOE => Text -> [Text] - -> m Text -runGhcPkg cmdExe args = catch (liftIO $ T.pack <$> IO.readProcess (T.unpack cmdExe) (fmap T.unpack args) "") $ - \(e :: IOError) -> OO.throw $ "Unable to run " <> cmdExe <> " " <> T.unwords args <> ": " <> tshow e + -> Eff r Text +runGhcPkg cmdExe args = catchIO (liftIO $ T.pack <$> IO.readProcess (T.unpack cmdExe) (fmap T.unpack args) "") $ + \(e :: IOError) -> throw $ "Unable to run " <> cmdExe <> " " <> T.unwords args <> ": " <> tshow e verifyGhcPkgVersion :: () - => MonadError (OO.Variant e) m - => MonadIO m - => MonadCatch m - => e `OO.CouldBe` Text + => r <: Error Text + => r <: IOE => Text -> Text - -> m Text + -> Eff r Text verifyGhcPkgVersion version cmdExe = do stdout <- runGhcPkg cmdExe ["--version"] if T.isSuffixOf (" " <> version) (mconcat (L.take 1 (T.lines stdout))) then return cmdExe - else OO.throw $ cmdExe <> " is not of version " <> version + else throw $ cmdExe <> " is not of version " <> version mkCompilerContext :: () - => MonadIO m - => MonadCatch m - => e `OO.CouldBe` Text + => r <: Error Text + => r <: IOE => Z.PlanJson - -> ExceptT (OO.Variant e) m Z.CompilerContext + -> Eff r Z.CompilerContext mkCompilerContext plan = do - compilerVersion <- T.stripPrefix "ghc-" (plan ^. the @"compilerId") - & OO.hoistMaybe @Text "No compiler version available in plan" + compilerVersion <- T.stripPrefix "ghc-" plan.compilerId + & onNothing (throw @Text "No compiler version available in plan") + let versionedGhcPkgCmd = "ghc-pkg-" <> compilerVersion - ghcPkgCmdPath <- - (findExecutable (withExeExt' versionedGhcPkgCmd) >>= verifyGhcPkgVersion compilerVersion) - <||> (findExecutable (withExeExt' "ghc-pkg" ) >>= verifyGhcPkgVersion compilerVersion) + + ghcPkgCmdPath <- (findExecutable (withExeExt' versionedGhcPkgCmd) >>= verifyGhcPkgVersion compilerVersion) + & trap_ @Text (findExecutable (withExeExt' "ghc-pkg" ) >>= verifyGhcPkgVersion compilerVersion) + return (Z.CompilerContext [T.unpack ghcPkgCmdPath]) relativePaths :: FilePath -> PackageInfo -> [IO.TarGroup] relativePaths basePath pInfo = [ IO.TarGroup basePath $ mempty - <> (pInfo ^. the @"libs") - <> [packageDir pInfo] + <> pInfo.libs + <> [pInfo.packageDir] , IO.TarGroup basePath $ mempty - <> ([pInfo ^. the @"confPath"] & L.filter ((== Present) . (^. the @"tag")) <&> (^. the @"value")) + <> ([pInfo.confPath] & L.filter (\c -> c.tag == Present) <&> (.value)) ] getPackages :: FilePath -> Z.PlanJson -> IO [PackageInfo] getPackages basePath planJson = forM packages (mkPackageInfo basePath compilerId') where compilerId' :: Text - compilerId' = planJson ^. the @"compilerId" + compilerId' = planJson.compilerId packages :: [Z.Package] - packages = planJson ^. the @"installPlan" + packages = planJson.installPlan loadPlan :: () - => MonadIO m - => MonadError (OO.Variant e) m - => e `OO.CouldBe` DecodeError + => r <: Error DecodeError + => r <: IOE => FilePath - -> m Z.PlanJson + -> Eff r Z.PlanJson loadPlan resolvedBuildPath = do lbs <- liftIO (LBS.readFile (resolvedBuildPath "cache" "plan.json")) - a <- OO.hoistEither $ first (DecodeError . T.pack) (eitherDecode lbs) + a <- eitherDecode lbs + & onLeft (throw . DecodeError . T.pack) + pure do a :: Z.PlanJson ------------------------------------------------------------------------------- mkPackageInfo :: FilePath -> Z.CompilerId -> Z.Package -> IO PackageInfo mkPackageInfo basePath cid pkg = do - let pid = pkg ^. the @"id" + let pid = pkg.id let compilerPath = basePath T.unpack cid let relativeConfPath = T.unpack cid "package.db" T.unpack pid <.> ".conf" let absoluteConfPath = basePath relativeConfPath @@ -167,7 +153,7 @@ return PackageInfo { compilerId = cid , packageId = pid - , packageName = pkg ^. the @"name" + , packageName = pkg.name , packageDir = T.unpack cid T.unpack pid , confPath = Tagged relativeConfPath (bool Absent Present absoluteConfPathExists) , libs = libFiles diff --git a/src/HaskellWorks/CabalCache/Error.hs b/src/HaskellWorks/CabalCache/Error.hs --- a/src/HaskellWorks/CabalCache/Error.hs +++ b/src/HaskellWorks/CabalCache/Error.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ScopedTypeVariables #-} - module HaskellWorks.CabalCache.Error ( DecodeError(DecodeError), ExitFailure(ExitFailure), @@ -15,7 +11,7 @@ import HaskellWorks.Prelude import Network.URI (URI) -data DecodeError = DecodeError Text deriving (Eq, Show, Generic) +newtype DecodeError = DecodeError Text deriving (Eq, Show, Generic) data ExitFailure = ExitFailure deriving (Eq, Show, Generic) @@ -28,7 +24,7 @@ data NotFound = NotFound deriving (Eq, Show, Generic) -data NotImplemented = NotImplemented Text deriving (Eq, Show, Generic) +newtype NotImplemented = NotImplemented Text deriving (Eq, Show, Generic) data UnsupportedUri = UnsupportedUri { uri :: URI diff --git a/src/HaskellWorks/CabalCache/Exit.hs b/src/HaskellWorks/CabalCache/Exit.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Exit.hs @@ -0,0 +1,23 @@ +module HaskellWorks.CabalCache.Exit + ( catchAndExitFailure, + ) where + +import Effectful +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.Log.Api +import Effectful.Zoo.Log.Dynamic +import HaskellWorks.Prelude + +import qualified System.Exit as IO + +catchAndExitFailure :: forall e a r. () + => Show e + => r <: IOE + => r <: Log Text + => Eff (Error e : r) a + -> Eff r a +catchAndExitFailure f = + f & trap @e \e -> do + crit $ "Error: " <> tshow e + liftIO IO.exitFailure diff --git a/src/HaskellWorks/CabalCache/GhcPkg.hs b/src/HaskellWorks/CabalCache/GhcPkg.hs --- a/src/HaskellWorks/CabalCache/GhcPkg.hs +++ b/src/HaskellWorks/CabalCache/GhcPkg.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TypeApplications #-} - module HaskellWorks.CabalCache.GhcPkg ( system, runGhcPkg, @@ -8,10 +6,8 @@ contextInit, ) where -import Data.Generics.Product.Any (HasAny(the)) import HaskellWorks.Prelude import HaskellWorks.Unsafe -import Lens.Micro import System.Exit (ExitCode (..), exitWith) import System.Process (waitForProcess) @@ -25,7 +21,7 @@ runGhcPkg :: Z.CompilerContext -> [String] -> IO () runGhcPkg cc params = do - hGhcPkg2 <- system ((cc ^. the @"ghcPkgCmd") <> params) + hGhcPkg2 <- system (cc.ghcPkgCmd <> params) exitCodeGhcPkg2 <- waitForProcess hGhcPkg2 case exitCodeGhcPkg2 of ExitFailure _ -> do diff --git a/src/HaskellWorks/CabalCache/IO/File.hs b/src/HaskellWorks/CabalCache/IO/File.hs --- a/src/HaskellWorks/CabalCache/IO/File.hs +++ b/src/HaskellWorks/CabalCache/IO/File.hs @@ -1,34 +1,33 @@ -{-# LANGUAGE OverloadedStrings #-} - module HaskellWorks.CabalCache.IO.File ( copyDirectoryRecursive, listMaybeDirectory, ) where -import Control.Monad.Except (MonadError) import HaskellWorks.Prelude - -import qualified Control.Monad.Oops as OO -import qualified Data.Text as T -import qualified HaskellWorks.CabalCache.IO.Console as CIO -import qualified System.Directory as IO -import qualified System.Exit as IO -import qualified System.Process as IO +import Effectful +import Effectful.Zoo.Console.Dynamic +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Data.Text qualified as T +import System.Directory qualified as IO +import System.Exit qualified as IO +import System.Process qualified as IO copyDirectoryRecursive :: () => MonadIO m - => MonadError (OO.Variant e) m - => e `OO.CouldBe` [Char] + => r <: IOE + => r <: Console Text + => r <: Error String => String -> String - -> m () + -> Eff r () copyDirectoryRecursive source target = do - CIO.putStrLn $ "Copying recursively from " <> T.pack source <> " to " <> T.pack target + print $ "Copying recursively from " <> T.pack source <> " to " <> T.pack target process <- liftIO $ IO.spawnProcess "cp" ["-r", source, target] exitCode <- liftIO $ IO.waitForProcess process case exitCode of IO.ExitSuccess -> return () - IO.ExitFailure n -> OO.throw $ "cp exited with " <> show n + IO.ExitFailure n -> throw $ "cp exited with " <> show n listMaybeDirectory :: MonadIO m => FilePath -> m [FilePath] listMaybeDirectory filepath = do diff --git a/src/HaskellWorks/CabalCache/IO/Lazy.hs b/src/HaskellWorks/CabalCache/IO/Lazy.hs --- a/src/HaskellWorks/CabalCache/IO/Lazy.hs +++ b/src/HaskellWorks/CabalCache/IO/Lazy.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} - module HaskellWorks.CabalCache.IO.Lazy ( readResource, readFirstAvailableResource, @@ -14,24 +7,28 @@ linkOrCopyResource, readHttpUri, removePathRecursive, - retryOnE, ) where -import Control.Monad.Catch (MonadCatch(..)) -import Control.Monad.Except (MonadError) -import Control.Monad.Trans.Resource (MonadResource, runResourceT, MonadUnliftIO) import Data.Generics.Product.Any (HasAny(the)) import Data.List.NonEmpty (NonEmpty ((:|))) -import HaskellWorks.CabalCache.AppError (AwsError(..), HttpError(..), statusCodeOf) +import Effectful +import Effectful.Resource +import Effectful.Zoo.Amazonka.Data.AwsEnv +import Effectful.Zoo.Amazonka.Data.AwsError +import Effectful.Zoo.Amazonka.Data.AwsLogEntry +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.Core.Exception +import Effectful.Zoo.DataLog.Dynamic +import Effectful.Zoo.Lazy.Dynamic +import HaskellWorks.CabalCache.AppError (AwsStatusError(..), HttpError(..), statusCodeOf) import HaskellWorks.CabalCache.Error (CopyFailed(..), InvalidUrl(..), NotFound(..), NotImplemented(..), UnsupportedUri(..)) import HaskellWorks.CabalCache.Location (Location (..)) import HaskellWorks.Prelude import Lens.Micro import Network.URI (URI) -import qualified Amazonka as AWS import qualified Control.Concurrent as IO -import qualified Control.Monad.Oops as OO import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NEL import qualified Data.Text as T @@ -45,163 +42,159 @@ import qualified System.IO as IO import qualified System.IO.Error as IO - {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Redundant bracket" -} handleHttpError :: () - => MonadError (OO.Variant e) m - => MonadCatch m - => e `OO.CouldBe` HttpError - => e `OO.CouldBe` InvalidUrl - => MonadIO m - => Monad m - => m a - -> m a -handleHttpError f = catch f $ \(e :: HTTP.HttpException) -> + => r <: Error HttpError + => r <: Error InvalidUrl + => Eff r a + -> Eff r a +handleHttpError f = catchIO f $ \(e :: HTTP.HttpException) -> case e of - HTTP.HttpExceptionRequest request content' -> OO.throw $ HttpError request content' - HTTP.InvalidUrlException url' reason' -> OO.throw $ InvalidUrl (tshow url') (tshow reason') + HTTP.HttpExceptionRequest request content' -> throw $ HttpError request content' + HTTP.InvalidUrlException url' reason' -> throw $ InvalidUrl (tshow url') (tshow reason') readResource :: () - => MonadResource m - => MonadCatch m - => e `OO.CouldBe` AwsError - => e `OO.CouldBe` UnsupportedUri - => e `OO.CouldBe` HttpError - => e `OO.CouldBe` InvalidUrl - => e `OO.CouldBe` NotFound - => AWS.Env - -> Int + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: Error AwsStatusError + => r <: Error HttpError + => r <: Error InvalidUrl + => r <: Error NotFound + => r <: Error UnsupportedUri + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource + => Int -> Location - -> ExceptT (OO.Variant e) m LBS.ByteString -readResource envAws maxRetries = \case - Local path -> do + -> Eff r LBS.ByteString +readResource maxRetries = \case + LocalFile path -> do fileExists <- liftIO $ IO.doesFileExist path if fileExists then liftIO $ LBS.readFile path - else OO.throw NotFound + else throw NotFound Uri uri -> retryS3 maxRetries $ case uri ^. the @"uriScheme" of - "s3:" -> S3.getS3Uri envAws (URI.reslashUri uri) + "s3:" -> S3.getS3Uri (URI.reslashUri uri) "http:" -> readHttpUri (URI.reslashUri uri) "https:" -> readHttpUri (URI.reslashUri uri) - scheme -> OO.throw $ UnsupportedUri uri $ "Unrecognised uri scheme: " <> T.pack scheme + scheme -> throw $ UnsupportedUri uri $ "Unrecognised uri scheme: " <> T.pack scheme readFirstAvailableResource :: () - => MonadResource m - => MonadCatch m - => e `OO.CouldBe` AwsError - => e `OO.CouldBe` HttpError - => e `OO.CouldBe` InvalidUrl - => e `OO.CouldBe` NotFound - => e `OO.CouldBe` UnsupportedUri - => AWS.Env - -> NonEmpty Location + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: Error AwsStatusError + => r <: Error HttpError + => r <: Error InvalidUrl + => r <: Error NotFound + => r <: Error UnsupportedUri + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource + => NonEmpty Location -> Int - -> ExceptT (OO.Variant e) m (LBS.ByteString, Location) -readFirstAvailableResource envAws (a:|as) maxRetries = do - (, a) <$> readResource envAws maxRetries a - & do OO.catch @NotFound \e -> do + -> Eff r (LBS.ByteString, Location) +readFirstAvailableResource (a:|as) maxRetries = do + (, a) <$> readResource maxRetries a + & do trap @NotFound \e -> do case NEL.nonEmpty as of - Nothing -> OO.throwF (Identity e) - Just nas -> readFirstAvailableResource envAws nas maxRetries - & do OO.catch @AwsError \e -> do + Nothing -> throw e + Just nas -> readFirstAvailableResource nas maxRetries + & do trap @AwsStatusError \e -> do case NEL.nonEmpty as of - Nothing -> OO.throwF (Identity e) - Just nas -> readFirstAvailableResource envAws nas maxRetries - & do OO.catch @HttpError \e -> do + Nothing -> throw e + Just nas -> readFirstAvailableResource nas maxRetries + & do trap @HttpError \e -> do case NEL.nonEmpty as of - Nothing -> OO.throwF (Identity e) - Just nas -> readFirstAvailableResource envAws nas maxRetries + Nothing -> throw e + Just nas -> readFirstAvailableResource nas maxRetries -safePathIsSymbolLink :: FilePath -> IO Bool -safePathIsSymbolLink filePath = catch (IO.pathIsSymbolicLink filePath) handler - where handler :: IOError -> IO Bool +safePathIsSymbolLink :: () + => r <: IOE + => FilePath + -> Eff r Bool +safePathIsSymbolLink filePath = + catchIO (liftIO $ IO.pathIsSymbolicLink filePath) handler + where handler :: IOError -> Eff r Bool handler e = if IO.isDoesNotExistError e then return False else return True resourceExists :: () - => MonadUnliftIO m - => MonadCatch m - => e `OO.CouldBe` InvalidUrl - => e `OO.CouldBe` UnsupportedUri - => AWS.Env - -> Location - -> ExceptT (OO.Variant e) m Bool -resourceExists envAws = \case - Local path -> do + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: Error AwsStatusError + => r <: Error InvalidUrl + => r <: Error UnsupportedUri + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource + => Location + -> Eff r Bool +resourceExists = \case + LocalFile path -> do fileExists <- liftIO $ IO.doesFileExist path if fileExists then return True else do - symbolicLinkExists <- liftIO $ safePathIsSymbolLink path + symbolicLinkExists <- safePathIsSymbolLink path if symbolicLinkExists then do target <- liftIO $ IO.getSymbolicLinkTarget path - resourceExists envAws (Local target) + resourceExists (LocalFile target) else return False Uri uri -> case uri ^. the @"uriScheme" of "s3:" -> do - OO.suspend runResourceT $ (True <$ S3.headS3Uri envAws (URI.reslashUri uri)) - & OO.catch @AwsError (pure . const False) - & OO.catch @HttpError (pure . const False) + (True <$ S3.headS3Uri (URI.reslashUri uri)) + & trap_ @AwsStatusError (pure False) + -- & trap_ @HttpError (pure False) "http:" -> do (True <$ headHttpUri (URI.reslashUri uri)) - & OO.catch @AwsError (pure . const False) - & OO.catch @HttpError (pure . const False) + & trap_ @HttpError (pure False) + & trap_ @AwsStatusError (pure False) _scheme -> return False writeResource :: () - => e `OO.CouldBe` AwsError - => e `OO.CouldBe` HttpError - => e `OO.CouldBe` NotImplemented - => e `OO.CouldBe` UnsupportedUri - => MonadIO m - => MonadCatch m - => MonadUnliftIO m - => AWS.Env - -> Location + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: Error AwsStatusError + => r <: Error HttpError + => r <: Error NotImplemented + => r <: Error UnsupportedUri + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource + => Location -> Int -> LBS.ByteString - -> ExceptT (OO.Variant e) m () -writeResource envAws loc maxRetries lbs = case loc of - Local path -> liftIO (LBS.writeFile path lbs) >> return () + -> Eff r () +writeResource loc maxRetries lbs = case loc of + LocalFile path -> liftIO (LBS.writeFile path lbs) Uri uri' -> retryS3 maxRetries $ case uri' ^. the @"uriScheme" of - "s3:" -> S3.putObject envAws (URI.reslashUri uri') lbs - "http:" -> OO.throw $ NotImplemented "HTTP PUT method not supported" - scheme -> OO.throw $ UnsupportedUri uri' $ "Unrecognised uri scheme: " <> T.pack scheme + "s3:" -> S3.putObject (URI.reslashUri uri') lbs + "http:" -> throw $ NotImplemented "HTTP PUT method not supported" + scheme -> throw $ UnsupportedUri uri' $ "Unrecognised uri scheme: " <> T.pack scheme -createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m () +createLocalDirectoryIfMissing :: MonadIO m => Location -> m () createLocalDirectoryIfMissing = \case - Local path -> liftIO $ IO.createDirectoryIfMissing True path + LocalFile path -> liftIO $ IO.createDirectoryIfMissing True path Uri uri -> case uri ^. the @"uriScheme" of "s3:" -> return () "http:" -> return () _scheme -> return () -retryOnE :: forall e e' m a. () - => Monad m - => Int - -> ExceptT (OO.Variant e') m a - -> ExceptT (OO.Variant (e : e')) m a - -> ExceptT (OO.Variant e') m a -retryOnE n g f = f - & do OO.catch @e \_ -> if n > 0 - then retryOnE (n - 1) g f - else g - retryWhen :: () - => MonadIO m + => r <: Error x + => r <: IOE => Show x - => e `OO.CouldBe` x => (x -> Bool) -> Int - -> ExceptT (OO.Variant e) m a - -> ExceptT (OO.Variant e) m a + -> Eff r a + -> Eff r a retryWhen p n f = f - & do OO.snatch \exception -> do + & do trapIn \exception -> do if n > 0 then do if p exception @@ -209,28 +202,28 @@ liftIO $ CIO.hPutStrLn IO.stderr $ "WARNING: " <> tshow exception <> " (retrying)" liftIO $ IO.threadDelay 1000000 retryWhen p (n - 1) f - else OO.throw exception - else OO.throw exception + else throw exception + else throw exception -retryUnless :: forall x e m a. () - => MonadIO m +retryUnless :: forall x r a. () => Show x - => e `OO.CouldBe` x + => r <: Error x + => r <: IOE => (x -> Bool) -> Int - -> ExceptT (OO.Variant e) m a - -> ExceptT (OO.Variant e) m a + -> Eff r a + -> Eff r a retryUnless p = retryWhen (not . p) retryS3 :: () - => MonadIO m - => e `OO.CouldBe` AwsError + => r <: Error AwsStatusError + => r <: IOE => Int - -> ExceptT (OO.Variant e) m a - -> ExceptT (OO.Variant e) m a + -> Eff r a + -> Eff r a retryS3 maxRetries a = do retryWhen retryPredicate maxRetries a - where retryPredicate :: AwsError -> Bool + where retryPredicate :: AwsStatusError -> Bool retryPredicate e = statusCodeOf e `elem` retryableHTTPStatuses -- https://docs.aws.amazon.com/AmazonS3/latest/API/ErrorResponses.html#ErrorCodeList @@ -240,37 +233,38 @@ retryableHTTPStatuses = [408, 409, 425, 426, 502, 503, 504] linkOrCopyResource :: () - => MonadUnliftIO m - => e `OO.CouldBe` AwsError - => e `OO.CouldBe` CopyFailed - => e `OO.CouldBe` NotImplemented - => e `OO.CouldBe` UnsupportedUri - => AWS.Env - -> Location + => r <: DataLog AwsLogEntry + => r <: Error AwsError + => r <: Error AwsStatusError + => r <: Error CopyFailed + => r <: Error NotImplemented + => r <: Error UnsupportedUri + => r <: IOE + => r <: Lazy AwsEnv + => r <: Resource + => Location -> Location - -> ExceptT (OO.Variant e) m () -linkOrCopyResource envAws source target = case source of - Local sourcePath -> case target of - Local targetPath -> do + -> Eff r () +linkOrCopyResource source target = case source of + LocalFile sourcePath -> case target of + LocalFile targetPath -> do liftIO $ IO.createDirectoryIfMissing True (FP.takeDirectory targetPath) targetPathExists <- liftIO $ IO.doesFileExist targetPath unless targetPathExists $ liftIO $ IO.createFileLink sourcePath targetPath - Uri _ -> OO.throw $ NotImplemented "Can't copy between different file backends" + Uri _ -> throw $ NotImplemented "Can't copy between different file backends" Uri sourceUri -> case target of - Local _targetPath -> OO.throw $ NotImplemented "Can't copy between different file backends" + LocalFile _targetPath -> throw $ NotImplemented "Can't copy between different file backends" Uri targetUri -> case (sourceUri ^. the @"uriScheme", targetUri ^. the @"uriScheme") of - ("s3:", "s3:") -> retryUnless @AwsError ((== 301) . statusCodeOf) 3 (S3.copyS3Uri envAws (URI.reslashUri sourceUri) (URI.reslashUri targetUri)) - ("http:", "http:") -> OO.throw $ NotImplemented "Link and copy unsupported for http backend" - (sourceScheme, targetScheme) -> OO.throw $ NotImplemented $ "Unsupported backend combination: " <> T.pack sourceScheme <> " to " <> T.pack targetScheme + ("s3:", "s3:") -> retryUnless @AwsStatusError ((== 301) . statusCodeOf) 3 (S3.copyS3Uri (URI.reslashUri sourceUri) (URI.reslashUri targetUri)) + ("http:", "http:") -> throw $ NotImplemented "Link and copy unsupported for http backend" + (sourceScheme, targetScheme) -> throw $ NotImplemented $ "Unsupported backend combination: " <> T.pack sourceScheme <> " to " <> T.pack targetScheme readHttpUri :: () - => MonadError (OO.Variant e) m - => MonadCatch m - => e `OO.CouldBe` HttpError - => e `OO.CouldBe` InvalidUrl - => MonadIO m + => r <: Error HttpError + => r <: Error InvalidUrl + => r <: IOE => URI - -> m LBS.ByteString + -> Eff r LBS.ByteString readHttpUri httpUri = handleHttpError do manager <- liftIO $ HTTP.newManager HTTPS.tlsManagerSettings request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> tshow (URI.reslashUri httpUri))) @@ -279,13 +273,11 @@ return $ HTTP.responseBody response headHttpUri :: () - => MonadError (OO.Variant e) m - => MonadCatch m - => e `OO.CouldBe` HttpError - => e `OO.CouldBe` InvalidUrl - => MonadIO m + => r <: Error HttpError + => r <: Error InvalidUrl + => r <: IOE => URI - -> m LBS.ByteString + -> Eff r LBS.ByteString headHttpUri httpUri = handleHttpError do manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("HEAD " <> tshow (URI.reslashUri httpUri))) @@ -294,8 +286,8 @@ return $ HTTP.responseBody response removePathRecursive :: () - => MonadCatch m - => MonadIO m + => r <: IOE => [Char] - -> ExceptT (OO.Variant e) m () -removePathRecursive pkgStorePath = liftIO (IO.removeDirectoryRecursive pkgStorePath) + -> Eff r () +removePathRecursive pkgStorePath = + liftIO (IO.removeDirectoryRecursive pkgStorePath) diff --git a/src/HaskellWorks/CabalCache/IO/Tar.hs b/src/HaskellWorks/CabalCache/IO/Tar.hs --- a/src/HaskellWorks/CabalCache/IO/Tar.hs +++ b/src/HaskellWorks/CabalCache/IO/Tar.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - module HaskellWorks.CabalCache.IO.Tar ( ArchiveError(..), TarGroup(..), @@ -11,16 +6,15 @@ ) where import Control.DeepSeq (NFData) -import Control.Monad.Except (MonadError) -import Data.Generics.Product.Any (HasAny(the)) +import Effectful +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.Core import HaskellWorks.Prelude -import Lens.Micro -import qualified Control.Monad.Oops as OO import qualified System.Exit as IO import qualified System.Process as IO -data ArchiveError = ArchiveError Text deriving (Eq, Show, Generic) +newtype ArchiveError = ArchiveError Text deriving (Eq, Show, Generic) data TarGroup = TarGroup { basePath :: FilePath @@ -28,34 +22,32 @@ } deriving (Show, Eq, Generic, NFData) createTar :: () - => MonadIO m - => MonadError (OO.Variant e) m - => e `OO.CouldBe` ArchiveError + => r <: Error ArchiveError + => r <: IOE => Foldable t => [Char] -> t TarGroup - -> m () + -> Eff r () createTar tarFile groups = do let args = ["-zcf", tarFile] <> foldMap tarGroupToArgs groups process <- liftIO $ IO.spawnProcess "tar" args exitCode <- liftIO $ IO.waitForProcess process case exitCode of IO.ExitSuccess -> return () - IO.ExitFailure n -> OO.throw $ ArchiveError $ "Failed to create tar. Exit code: " <> tshow n + IO.ExitFailure n -> throw $ ArchiveError $ "Failed to create tar. Exit code: " <> tshow n extractTar :: () - => MonadIO m - => MonadError (OO.Variant e) m - => e `OO.CouldBe` ArchiveError + => r <: Error ArchiveError + => r <: IOE => String -> String - -> m () + -> Eff r () extractTar tarFile targetPath = do process <- liftIO $ IO.spawnProcess "tar" ["-C", targetPath, "-zxf", tarFile] exitCode <- liftIO $ IO.waitForProcess process case exitCode of IO.ExitSuccess -> return () - IO.ExitFailure n -> OO.throw $ ArchiveError $ "Failed to extract tar. Exit code: " <> tshow n + IO.ExitFailure n -> throw $ ArchiveError $ "Failed to extract tar. Exit code: " <> tshow n tarGroupToArgs :: TarGroup -> [String] -tarGroupToArgs tarGroup = ["-C", tarGroup ^. the @"basePath"] <> tarGroup ^. the @"entryPaths" +tarGroupToArgs tarGroup = ["-C", tarGroup.basePath] <> tarGroup.entryPaths diff --git a/src/HaskellWorks/CabalCache/Location.hs b/src/HaskellWorks/CabalCache/Location.hs --- a/src/HaskellWorks/CabalCache/Location.hs +++ b/src/HaskellWorks/CabalCache/Location.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - module HaskellWorks.CabalCache.Location ( IsPath(..) , Location(..) @@ -33,19 +26,19 @@ data Location = Uri URI - | Local FilePath + | LocalFile FilePath deriving (Show, Eq, Generic) instance AWS.ToText Location where toText (Uri uri) = tshow uri - toText (Local p) = T.pack p + toText (LocalFile p) = T.pack p instance IsPath Location Text where Uri b p = Uri (b p) - Local b p = Local (b T.unpack p) + LocalFile b p = LocalFile (b T.unpack p) Uri b <.> e = Uri (b <.> e) - Local b <.> e = Local (b <.> T.unpack e) + LocalFile b <.> e = LocalFile (b <.> T.unpack e) instance IsPath Text Text where b p = T.pack (T.unpack b FP. T.unpack p) @@ -69,7 +62,7 @@ toLocation :: Text -> Maybe Location toLocation t = case URI.parseURI (T.unpack t) of Just uri -> Just (Uri uri) - Nothing -> Just (Local (T.unpack t)) + Nothing -> Just (LocalFile (T.unpack t)) ------------------------------------------------------------------------------- stripStart :: Text -> Text -> Text diff --git a/src/HaskellWorks/CabalCache/Metadata.hs b/src/HaskellWorks/CabalCache/Metadata.hs --- a/src/HaskellWorks/CabalCache/Metadata.hs +++ b/src/HaskellWorks/CabalCache/Metadata.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TupleSections #-} - module HaskellWorks.CabalCache.Metadata ( metaDir, createMetadata, @@ -22,10 +20,10 @@ createMetadata :: MonadIO m => FilePath -> PackageInfo -> [(T.Text, LBS.ByteString)] -> m TarGroup createMetadata storePath pkg values = liftIO do - let pkgMetaPath = storePath packageDir pkg metaDir + let pkgMetaPath = storePath pkg.packageDir metaDir IO.createDirectoryIfMissing True pkgMetaPath forM_ values $ \(k, v) -> LBS.writeFile (pkgMetaPath T.unpack k) v - pure $ TarGroup storePath [packageDir pkg metaDir] + pure $ TarGroup storePath [pkg.packageDir metaDir] loadMetadata :: MonadIO m => FilePath -> m (Map.Map T.Text LBS.ByteString) loadMetadata pkgStorePath = liftIO do diff --git a/src/HaskellWorks/CabalCache/Store.hs b/src/HaskellWorks/CabalCache/Store.hs --- a/src/HaskellWorks/CabalCache/Store.hs +++ b/src/HaskellWorks/CabalCache/Store.hs @@ -2,18 +2,17 @@ ( cleanupStorePath, ) where -import Control.Monad.Catch (MonadCatch) +import Effectful +import Effectful.Zoo.Core import HaskellWorks.Prelude -import qualified Control.Monad.Oops as OO import qualified HaskellWorks.CabalCache.IO.Lazy as IO import qualified System.Directory as IO cleanupStorePath :: () - => MonadIO m - => MonadCatch m + => r <: IOE => FilePath - -> ExceptT (OO.Variant e) m () + -> Eff r () cleanupStorePath packageStorePath = do pathExists <- liftIO $ IO.doesPathExist packageStorePath when pathExists $ void $ IO.removePathRecursive packageStorePath diff --git a/src/HaskellWorks/CabalCache/Topology.hs b/src/HaskellWorks/CabalCache/Topology.hs --- a/src/HaskellWorks/CabalCache/Topology.hs +++ b/src/HaskellWorks/CabalCache/Topology.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} +{- HLINT ignore "Functor law" -} module HaskellWorks.CabalCache.Topology ( PlanData(..), @@ -12,10 +10,9 @@ import Data.Generics.Product.Any (the) import Data.Map.Strict (Map) import Data.Set (Set) -import HaskellWorks.CabalCache.Types (Package, PackageId, PlanJson) +import HaskellWorks.CabalCache.Types import HaskellWorks.Prelude import HaskellWorks.Unsafe -import Lens.Micro import Lens.Micro.Extras (view) import qualified Data.List as L @@ -31,11 +28,11 @@ -> [PackageId] -- ^ Packages that are known to be non-shareable -> PlanData -- ^ Updated plan buildPlanData plan nonShareablePkgs = - let dm = dependenciesMap (plan ^. the @"installPlan") + let dm = dependenciesMap plan.installPlan in buildPlanData' dm nonShareablePkgs canShare :: PlanData -> PackageId -> Bool -canShare planData pkgId = S.notMember pkgId (nonShareable planData) +canShare planData pkgId = S.notMember pkgId planData.nonShareable ------------------------------------------------------------------------------- diff --git a/src/HaskellWorks/CabalCache/Types.hs b/src/HaskellWorks/CabalCache/Types.hs --- a/src/HaskellWorks/CabalCache/Types.hs +++ b/src/HaskellWorks/CabalCache/Types.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module HaskellWorks.CabalCache.Types ( CompilerId, PackageId, diff --git a/src/HaskellWorks/CabalCache/URI.hs b/src/HaskellWorks/CabalCache/URI.hs --- a/src/HaskellWorks/CabalCache/URI.hs +++ b/src/HaskellWorks/CabalCache/URI.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - module HaskellWorks.CabalCache.URI ( reslashUri, ) where diff --git a/src/HaskellWorks/CabalCache/Version.hs b/src/HaskellWorks/CabalCache/Version.hs --- a/src/HaskellWorks/CabalCache/Version.hs +++ b/src/HaskellWorks/CabalCache/Version.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module HaskellWorks.CabalCache.Version ( archiveVersion, ) where diff --git a/test/HaskellWorks/CabalCache/AwsSpec.hs b/test/HaskellWorks/CabalCache/AwsSpec.hs --- a/test/HaskellWorks/CabalCache/AwsSpec.hs +++ b/test/HaskellWorks/CabalCache/AwsSpec.hs @@ -1,47 +1,79 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module HaskellWorks.CabalCache.AwsSpec ( spec ) where -import HaskellWorks.CabalCache.AppError (AwsError(..)) +import Data.Generics.Product.Any +import Effectful +import Effectful.Concurrent +import Effectful.Resource +import Effectful.Environment +import Effectful.Error.Static (runError) +import Effectful.Zoo.Amazonka.Api.Discover +import Effectful.Zoo.Amazonka.Data.AwsEnv +import Effectful.Zoo.Amazonka.Data.AwsError +import Effectful.Zoo.Amazonka.Data.AwsLogEntry +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.Hedgehog.Api +import Effectful.Zoo.Hedgehog.Dynamic +import Effectful.Zoo.HUnit +import Effectful.Zoo.Lazy.Dynamic +import HaskellWorks.CabalCache.AppError (AwsStatusError(..)) import HaskellWorks.CabalCache.Error (UnsupportedUri) -import HaskellWorks.Hspec.Hedgehog import HaskellWorks.Prelude -import Hedgehog +import Lens.Micro import Test.Hspec -import qualified Amazonka as AWS -import qualified Control.Monad.Oops as OO -import qualified Data.ByteString.Lazy.Char8 as LBSC -import qualified Data.Variant as OO -import qualified HaskellWorks.CabalCache.AWS.Env as AWS import qualified HaskellWorks.CabalCache.AWS.S3 as AWS -import qualified Hedgehog as H -import qualified Network.HTTP.Types as HTTP import qualified Network.URI as URI -import qualified System.Environment as IO {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Redundant bracket" -} +data Success = Success deriving Show + +catchSuccess :: forall r. () + => r <: Hedgehog + => r <: IOE + => Eff (Error Success : r) Void + -> Eff r () +catchSuccess f = do + result <- f & runError @Success + case result of + Left (_, Success) -> pure () + Right a -> absurd a + +runTestEnv :: forall a r. () + => r <: IOE + => Eff + ( Lazy AwsEnv + : Concurrent + : Environment + : Resource + : r + ) a + -> Eff r a +runTestEnv f = + f + & runLazy discoverAwsEnv + & runConcurrent + & runEnvironment + & runResource + spec :: Spec spec = describe "HaskellWorks.CabalCache.QuerySpec" do - it "stub" $ requireTest do - ci <- liftIO $ IO.lookupEnv "CI" <&> isJust - unless ci do - envAws <- liftIO $ AWS.mkEnv AWS.Oregon (const LBSC.putStrLn) - let Just uri = URI.parseURI "s3://cache.haskellworks.io/test/cabal-cache/ci" - result :: Either (OO.Variant '[AwsError, UnsupportedUri]) () - <- liftIO $ runExceptT $ OO.suspend AWS.runResourceT $ void (AWS.headS3Uri envAws uri) + it "stub" $ requireTest $ hedgehog $ runTestEnv $ catchSuccess $ do + uri <- URI.parseURI "s3://cache.haskellworks.io/test/cabal-cache/ci" + & onNothingFail - case result of - Right _ -> H.failure - Left e -> OO.toEithers e === Left AwsError - { status = HTTP.Status { HTTP.statusCode = 404 , HTTP.statusMessage = "Not Found" } - } + void (AWS.headS3Uri uri) + & jotShowDataLog @AwsLogEntry + & do trap @AwsStatusError \e -> do + assert $ e.status ^. the @"statusCode" == 404 || e.status ^. the @"statusCode" == 301 + throw Success + & do trap_ @AwsError failure + & do trap_ @AwsStatusError failure + & do trap_ @UnsupportedUri failure + + failure diff --git a/test/HaskellWorks/CabalCache/IntegrationSpec.hs b/test/HaskellWorks/CabalCache/IntegrationSpec.hs --- a/test/HaskellWorks/CabalCache/IntegrationSpec.hs +++ b/test/HaskellWorks/CabalCache/IntegrationSpec.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module HaskellWorks.CabalCache.IntegrationSpec ( spec ) where @@ -29,7 +24,7 @@ spec :: Spec spec = describe "HaskellWorks.CabalCache.IntegrationSpec" do it "local" $ H.require . H.withTests 1 $ H.integration $ H.runFinallies . H.workspace "local" $ \tempAbsBasePath' -> do - cwd <- H.noteIO $ IO.getCurrentDirectory + cwd <- H.noteIO IO.getCurrentDirectory let archivePath = tempAbsBasePath' "archive" let storePath = tempAbsBasePath' "store" let buildPath = cwd "dist-newstyle" diff --git a/test/HaskellWorks/CabalCache/LocationSpec.hs b/test/HaskellWorks/CabalCache/LocationSpec.hs --- a/test/HaskellWorks/CabalCache/LocationSpec.hs +++ b/test/HaskellWorks/CabalCache/LocationSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module HaskellWorks.CabalCache.LocationSpec ( spec, ) where @@ -53,7 +51,7 @@ it "LocalLocation should roundtrip from and to text" $ require $ property do path <- forAll localPath - tripping (Local path) AWS.toText toLocation + tripping (LocalFile path) AWS.toText toLocation it "Should append s3 path" $ require $ property do loc <- Uri <$> forAll s3Uri @@ -62,7 +60,7 @@ AWS.toText (loc part <.> ext) === AWS.toText loc <> "/" <> part <> "." <> ext it "Should append s3 path" $ require $ property do - loc <- Local <$> forAll localPath + loc <- LocalFile <$> forAll localPath part <- forAll $ Gen.string (Range.linear 3 10) Gen.alphaNum ext <- forAll $ Gen.string (Range.linear 2 4) Gen.alphaNum AWS.toText (loc Text.pack part <.> Text.pack ext) === Text.pack ((Text.unpack $ AWS.toText loc) FP. part FP.<.> ext) diff --git a/test/HaskellWorks/CabalCache/QuerySpec.hs b/test/HaskellWorks/CabalCache/QuerySpec.hs --- a/test/HaskellWorks/CabalCache/QuerySpec.hs +++ b/test/HaskellWorks/CabalCache/QuerySpec.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - module HaskellWorks.CabalCache.QuerySpec ( spec, ) where