cabal-cache 1.1.0.2 → 1.2.0.0
raw patch · 38 files changed
+1465/−836 lines, 38 filesdep +effectfuldep +effectful-coredep +effectful-plugindep −mtldep −oopsdep −unliftio
Dependencies added: effectful, effectful-core, effectful-plugin, effectful-zoo, resourcet-effectful
Dependencies removed: mtl, oops, unliftio
Files
- CHANGELOG.md +511/−0
- app/App/Amazonka.hs +23/−0
- app/App/Commands/Debug/S3/Cp.hs +24/−37
- app/App/Commands/Options/Types.hs +0/−3
- app/App/Commands/Plan.hs +65/−67
- app/App/Commands/SyncFromArchive.hs +93/−97
- app/App/Commands/SyncToArchive.hs +102/−103
- app/App/Commands/Version.hs +0/−4
- app/App/Run.hs +62/−0
- app/App/Static.hs +0/−2
- app/App/Static/Posix.hs +20/−1
- cabal-cache.cabal +97/−18
- src/HaskellWorks/CabalCache/AWS/Env.hs +2/−22
- src/HaskellWorks/CabalCache/AWS/Error.hs +14/−15
- src/HaskellWorks/CabalCache/AWS/S3.hs +88/−72
- src/HaskellWorks/CabalCache/AWS/S3/URI.hs +1/−8
- src/HaskellWorks/CabalCache/AppError.hs +9/−13
- src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs +13/−17
- src/HaskellWorks/CabalCache/Concurrent/Fork.hs +17/−11
- src/HaskellWorks/CabalCache/Concurrent/Type.hs +0/−3
- src/HaskellWorks/CabalCache/Core.hs +42/−56
- src/HaskellWorks/CabalCache/Error.hs +2/−6
- src/HaskellWorks/CabalCache/Exit.hs +23/−0
- src/HaskellWorks/CabalCache/GhcPkg.hs +1/−5
- src/HaskellWorks/CabalCache/IO/File.hs +14/−15
- src/HaskellWorks/CabalCache/IO/Lazy.hs +150/−158
- src/HaskellWorks/CabalCache/IO/Tar.hs +13/−21
- src/HaskellWorks/CabalCache/Location.hs +5/−12
- src/HaskellWorks/CabalCache/Metadata.hs +2/−4
- src/HaskellWorks/CabalCache/Store.hs +4/−5
- src/HaskellWorks/CabalCache/Topology.hs +4/−7
- src/HaskellWorks/CabalCache/Types.hs +0/−6
- src/HaskellWorks/CabalCache/URI.hs +0/−3
- src/HaskellWorks/CabalCache/Version.hs +0/−2
- test/HaskellWorks/CabalCache/AwsSpec.hs +61/−29
- test/HaskellWorks/CabalCache/IntegrationSpec.hs +1/−6
- test/HaskellWorks/CabalCache/LocationSpec.hs +2/−4
- test/HaskellWorks/CabalCache/QuerySpec.hs +0/−4
+ CHANGELOG.md view
@@ -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)*
+ app/App/Amazonka.hs view
@@ -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
app/App/Commands/Debug/S3/Cp.hs view
@@ -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
app/App/Commands/Options/Types.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-}- module App.Commands.Options.Types ( CpOptions(..), PlanOptions(..),
app/App/Commands/Plan.hs view
@@ -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 ())
app/App/Commands/SyncFromArchive.hs view
@@ -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
app/App/Commands/SyncToArchive.hs view
@@ -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"
app/App/Commands/Version.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}- module App.Commands.Version ( cmdVersion, ) where
+ app/App/Run.hs view
@@ -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
app/App/Static.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}- module App.Static ( cabalStoreDirectory, buildPath,
app/App/Static/Posix.hs view
@@ -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"
cabal-cache.cabal view
@@ -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
src/HaskellWorks/CabalCache/AWS/Env.hs view
@@ -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
src/HaskellWorks/CabalCache/AWS/Error.hs view
@@ -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
src/HaskellWorks/CabalCache/AWS/S3.hs view
@@ -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
src/HaskellWorks/CabalCache/AWS/S3/URI.hs view
@@ -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)
src/HaskellWorks/CabalCache/AppError.hs view
@@ -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
src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs view
@@ -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
src/HaskellWorks/CabalCache/Concurrent/Fork.hs view
@@ -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
src/HaskellWorks/CabalCache/Concurrent/Type.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-}- module HaskellWorks.CabalCache.Concurrent.Type ( DownloadQueue(..), ConsumerId,
src/HaskellWorks/CabalCache/Core.hs view
@@ -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
src/HaskellWorks/CabalCache/Error.hs view
@@ -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
+ src/HaskellWorks/CabalCache/Exit.hs view
@@ -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
src/HaskellWorks/CabalCache/GhcPkg.hs view
@@ -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
src/HaskellWorks/CabalCache/IO/File.hs view
@@ -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
src/HaskellWorks/CabalCache/IO/Lazy.hs view
@@ -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)
src/HaskellWorks/CabalCache/IO/Tar.hs view
@@ -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
src/HaskellWorks/CabalCache/Location.hs view
@@ -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
src/HaskellWorks/CabalCache/Metadata.hs view
@@ -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
src/HaskellWorks/CabalCache/Store.hs view
@@ -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
src/HaskellWorks/CabalCache/Topology.hs view
@@ -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 -------------------------------------------------------------------------------
src/HaskellWorks/CabalCache/Types.hs view
@@ -1,9 +1,3 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}- module HaskellWorks.CabalCache.Types ( CompilerId, PackageId,
src/HaskellWorks/CabalCache/URI.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}- module HaskellWorks.CabalCache.URI ( reslashUri, ) where
src/HaskellWorks/CabalCache/Version.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module HaskellWorks.CabalCache.Version ( archiveVersion, ) where
test/HaskellWorks/CabalCache/AwsSpec.hs view
@@ -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
test/HaskellWorks/CabalCache/IntegrationSpec.hs view
@@ -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"
test/HaskellWorks/CabalCache/LocationSpec.hs view
@@ -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)
test/HaskellWorks/CabalCache/QuerySpec.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}- module HaskellWorks.CabalCache.QuerySpec ( spec, ) where