diff --git a/app/App/Commands.hs b/app/App/Commands.hs --- a/app/App/Commands.hs +++ b/app/App/Commands.hs @@ -5,6 +5,7 @@ import App.Commands.SyncFromArchive (cmdSyncFromArchive) import App.Commands.SyncToArchive (cmdSyncToArchive) import App.Commands.Version (cmdVersion) +import HaskellWorks.Prelude import Options.Applicative (Parser) import qualified Options.Applicative as OA diff --git a/app/App/Commands/Debug.hs b/app/App/Commands/Debug.hs --- a/app/App/Commands/Debug.hs +++ b/app/App/Commands/Debug.hs @@ -3,6 +3,7 @@ ) where import App.Commands.Debug.S3 (cmdS3) +import HaskellWorks.Prelude import qualified Options.Applicative as OA diff --git a/app/App/Commands/Debug/S3.hs b/app/App/Commands/Debug/S3.hs --- a/app/App/Commands/Debug/S3.hs +++ b/app/App/Commands/Debug/S3.hs @@ -3,6 +3,7 @@ ) where import App.Commands.Debug.S3.Cp (cmdCp) +import HaskellWorks.Prelude import qualified Options.Applicative as OA diff --git a/app/App/Commands/Debug/S3/Cp.hs b/app/App/Commands/Debug/S3/Cp.hs --- a/app/App/Commands/Debug/S3/Cp.hs +++ b/app/App/Commands/Debug/S3/Cp.hs @@ -9,26 +9,21 @@ import App.Commands.Options.Parser (text) import App.Commands.Options.Types (CpOptions (CpOptions)) -import Control.Applicative (Alternative(..), optional) -import Control.Lens ((.~), (<&>), (&), (^.)) -import Control.Monad.Except (MonadIO(..)) -import Control.Monad.Trans.AWS (envOverride, setEndpoint) -import Data.ByteString (ByteString) import Data.Generics.Product.Any (the) -import Data.Monoid (Dual(Dual), Endo(Endo)) import HaskellWorks.CabalCache.AppError (AwsError(..), displayAwsError) import HaskellWorks.CabalCache.Error (CopyFailed(..), ExitFailure(..), UnsupportedUri) -import HaskellWorks.CabalCache.Show (tshow) +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 Network.AWS as AWS -import qualified Network.AWS.Data as AWS import qualified Options.Applicative as OA import qualified System.IO as IO import qualified System.IO.Unsafe as IO @@ -39,16 +34,25 @@ runCp :: Z.CpOptions -> IO () runCp opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do - let srcUri = opts ^. the @"srcUri" - let dstUri = opts ^. the @"dstUri" - let hostEndpoint = opts ^. the @"hostEndpoint" - let awsLogLevel = opts ^. the @"awsLogLevel" + 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 $ (<&> envOverride .~ Dual (Endo $ \s -> case hostEndpoint of - Just (hostname, port, ssl) -> setEndpoint ssl hostname port s - Nothing -> s)) - $ AWS.mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel) + 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 AWS.copyS3Uri envAws srcUri dstUri & do OO.catch @AwsError \e -> do diff --git a/app/App/Commands/Options/Parser.hs b/app/App/Commands/Options/Parser.hs --- a/app/App/Commands/Options/Parser.hs +++ b/app/App/Commands/Options/Parser.hs @@ -5,17 +5,15 @@ ) where import App.Commands.Options.Types (VersionOptions (..)) -import Control.Applicative (Alternative(..)) -import Control.Monad (join) import Data.Set (Set) -import Data.Text (Text) +import HaskellWorks.Prelude import Options.Applicative (Parser, ReadM) +import qualified Amazonka.Data as AWS import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text as Text import qualified HaskellWorks.CabalCache.Types as Z -import qualified Network.AWS.Data as AWS import qualified Options.Applicative as OA optsVersion :: Parser VersionOptions diff --git a/app/App/Commands/Options/Types.hs b/app/App/Commands/Options/Types.hs --- a/app/App/Commands/Options/Types.hs +++ b/app/App/Commands/Options/Types.hs @@ -9,15 +9,14 @@ VersionOptions(..), ) where -import Data.ByteString (ByteString) import Data.Set (Set) -import GHC.Generics (Generic) import HaskellWorks.CabalCache.Location (Location) import HaskellWorks.CabalCache.Types (PackageId) +import HaskellWorks.Prelude import Network.URI (URI) -import qualified Data.List.NonEmpty as NEL -import qualified Network.AWS as AWS +import qualified Amazonka as AWS +import qualified Data.List.NonEmpty as NEL data CpOptions = CpOptions { region :: AWS.Region diff --git a/app/App/Commands/Plan.hs b/app/App/Commands/Plan.hs --- a/app/App/Commands/Plan.hs +++ b/app/App/Commands/Plan.hs @@ -8,18 +8,15 @@ ) where import App.Commands.Options.Types (PlanOptions (PlanOptions)) -import Control.Applicative (optional) -import Control.Lens ((<&>), (&), (^.), (%~), Each(each)) -import Control.Monad (forM) -import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Lens ((^.), (%~), Each(each)) import Data.Generics.Product.Any (the) -import Data.Maybe (fromMaybe) import HaskellWorks.CabalCache.Error (DecodeError, ExitFailure(..)) import HaskellWorks.CabalCache.Location (Location (..), (<.>), ()) -import HaskellWorks.CabalCache.Show (tshow) 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 @@ -29,7 +26,6 @@ import qualified HaskellWorks.CabalCache.Core as Z import qualified HaskellWorks.CabalCache.Hash as H import qualified HaskellWorks.CabalCache.IO.Console as CIO -import qualified Network.AWS.Data as AWS import qualified Options.Applicative as OA import qualified System.IO as IO diff --git a/app/App/Commands/SyncFromArchive.hs b/app/App/Commands/SyncFromArchive.hs --- a/app/App/Commands/SyncFromArchive.hs +++ b/app/App/Commands/SyncFromArchive.hs @@ -9,35 +9,27 @@ import App.Commands.Options.Parser (optsPackageIds, text) import App.Commands.Options.Types (SyncFromArchiveOptions (SyncFromArchiveOptions)) -import Control.Applicative (optional, Alternative(..)) -import Control.Lens ((^..), (.~), (<&>), (%~), (&), (^.), Each(each)) +import Control.Lens ((^..), (%~), (^.), (.~), Each(each)) import Control.Lens.Combinators (traverse1) -import Control.Monad (when, unless, forM_) import Control.Monad.Catch (MonadCatch) -import Control.Monad.Except (ExceptT) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.AWS (envOverride, setEndpoint) import Control.Monad.Trans.Resource (runResourceT) -import Data.ByteString (ByteString) import Data.ByteString.Lazy.Search (replace) import Data.Generics.Product.Any (the) import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (fromMaybe) -import Data.Monoid (Dual(Dual), Endo(Endo)) -import Data.Semigroup (Semigroup(..)) -import Data.Text (Text) import HaskellWorks.CabalCache.AppError (AwsError, HttpError (..), displayAwsError, displayHttpError) import HaskellWorks.CabalCache.Error (DecodeError(..), ExitFailure(..), InvalidUrl(..), NotFound, UnsupportedUri(..)) import HaskellWorks.CabalCache.IO.Lazy (readFirstAvailableResource) import HaskellWorks.CabalCache.IO.Tar (ArchiveError(..)) import HaskellWorks.CabalCache.Location (toLocation, (<.>), (), Location) import HaskellWorks.CabalCache.Metadata (loadMetadata) -import HaskellWorks.CabalCache.Show (tshow) import HaskellWorks.CabalCache.Version (archiveVersion) +import HaskellWorks.Prelude import Options.Applicative (CommandFields, Mod, Parser) import Options.Applicative.NonEmpty (some1) import System.Directory (createDirectoryIfMissing, doesDirectoryExist) +import qualified Amazonka as AWS +import qualified Amazonka.Data as AWS import qualified App.Commands.Options.Types as Z import qualified App.Static as AS import qualified Control.Concurrent.STM as STM @@ -60,8 +52,6 @@ import qualified HaskellWorks.CabalCache.IO.Tar as IO import qualified HaskellWorks.CabalCache.Store as M import qualified HaskellWorks.CabalCache.Types as Z -import qualified Network.AWS as AWS -import qualified Network.AWS.Data as AWS import qualified Options.Applicative as OA import qualified System.Directory as IO import qualified System.IO as IO @@ -77,7 +67,7 @@ runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO () runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do - let hostEndpoint = opts ^. the @"hostEndpoint" + let mHostEndpoint = opts ^. the @"hostEndpoint" let storePath = opts ^. the @"storePath" let archiveUris = opts ^. the @"archiveUris" :: NonEmpty Location let threads = opts ^. the @"threads" @@ -109,10 +99,19 @@ liftIO $ GhcPkg.testAvailability compilerContext - envAws <- liftIO $ IO.unsafeInterleaveIO $ (<&> envOverride .~ Dual (Endo $ \s -> case hostEndpoint of - Just (hostname, port, ssl) -> setEndpoint ssl hostname port s - Nothing -> s)) - $ AWS.mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel) + 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" @@ -127,7 +126,7 @@ unless storeCompilerPackageDbPathExists do CIO.putStrLn "Package DB missing. Creating Package DB" - liftIO $ GhcPkg.init compilerContext storeCompilerPackageDbPath + liftIO $ GhcPkg.contextInit compilerContext storeCompilerPackageDbPath packages <- liftIO $ Z.getPackages storePath planJson @@ -153,7 +152,7 @@ pInfo <- pure (M.lookup packageId pInfos) & do OO.onNothing do CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId - DQ.succeed + DQ.downloadSucceed let archiveBaseName = Z.packageDir pInfo <.> ".tar.gz" let archiveFiles = versionedArchiveUris & traverse1 %~ ( T.pack archiveBaseName) @@ -166,17 +165,17 @@ package <- pure (M.lookup packageId planPackages) & do OO.onNothing do CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageName - DQ.succeed + DQ.downloadSucceed when (skippable package) do CIO.putStrLn $ "Skipping: " <> packageName - DQ.succeed + DQ.downloadSucceed when (packageName `S.member` ignorePackages) do CIO.putStrLn $ "Ignoring: " <> packageName - DQ.fail + DQ.downloadFail - when storeDirectoryExists DQ.succeed + when storeDirectoryExists DQ.downloadSucceed OO.suspend runResourceT $ ensureStorePathCleanup packageStorePath do let locations = sconcat $ fmap L.tuple2ToNel (NEL.zip archiveFiles scopedArchiveFiles) @@ -184,19 +183,19 @@ (existingArchiveFileContents, existingArchiveFile) <- readFirstAvailableResource envAws locations maxRetries & do OO.catch @AwsError \e -> do CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayAwsError e - DQ.fail + DQ.downloadFail & do OO.catch @HttpError \e -> do CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayHttpError e - DQ.fail + DQ.downloadFail & do OO.catch @NotFound \_ -> do CIO.putStrLn $ "Not found: " <> tshow locations - DQ.fail + DQ.downloadFail & do OO.catch @InvalidUrl \(InvalidUrl url' reason') -> do CIO.hPutStrLn IO.stderr $ "Invalid URL: " <> tshow url' <> ", " <> reason' - DQ.fail + DQ.downloadFail & do OO.catch @UnsupportedUri \e -> do CIO.hPutStrLn IO.stderr $ tshow e - DQ.fail + DQ.downloadFail CIO.putStrLn $ "Extracting: " <> AWS.toText existingArchiveFile @@ -206,13 +205,13 @@ IO.extractTar tempArchiveFile storePath & do OO.catch @ArchiveError \(ArchiveError reason') -> do CIO.putStrLn $ "Unable to extract tar at " <> tshow tempArchiveFile <> " because: " <> reason' - DQ.fail + DQ.downloadFail meta <- loadMetadata packageStorePath oldStorePath <- pure (Map.lookup "store-path" meta) & do OO.onNothing do CIO.putStrLn "store-path is missing from Metadata" - DQ.fail + DQ.downloadFail let Z.Tagged conf _ = Z.confPath pInfo @@ -224,7 +223,7 @@ liftIO $ LBS.writeFile tempConfPath (replace (LBS.toStrict oldStorePath) (C8.pack storePath) confContents) liftIO $ IO.copyFile tempConfPath theConfPath >> IO.removeFile tempConfPath - DQ.succeed + DQ.downloadSucceed CIO.putStrLn "Recaching package database" diff --git a/app/App/Commands/SyncToArchive.hs b/app/App/Commands/SyncToArchive.hs --- a/app/App/Commands/SyncToArchive.hs +++ b/app/App/Commands/SyncToArchive.hs @@ -8,31 +8,24 @@ import App.Commands.Options.Parser (optsPackageIds, text) import App.Commands.Options.Types (SyncToArchiveOptions (SyncToArchiveOptions)) -import Control.Applicative (Alternative(..), optional) import Control.Concurrent.STM (TVar) -import Control.Lens ((<&>), (&), (^..), (^.), (.~), Each(each)) -import Control.Monad (filterM, when, unless) -import Control.Monad.Except (ExceptT) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.AWS (envOverride, setEndpoint) -import Data.ByteString (ByteString) +import Control.Lens ((^..), (^.), (.~), (%~), Each(each)) import Data.Generics.Product.Any (the) import Data.List ((\\)) -import Data.Maybe (fromMaybe) -import Data.Monoid (Dual(Dual), Endo(Endo)) -import Data.Text (Text) import HaskellWorks.CabalCache.AppError (AwsError, HttpError (..), displayAwsError, 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.Metadata (createMetadata) -import HaskellWorks.CabalCache.Show (tshow) import HaskellWorks.CabalCache.Topology (buildPlanData, canShare) import HaskellWorks.CabalCache.Version (archiveVersion) +import HaskellWorks.Prelude import Options.Applicative (Parser, Mod, CommandFields) import System.Directory (doesDirectoryExist) import System.FilePath (takeDirectory) +import qualified Amazonka as AWS +import qualified Amazonka.Data as AWS import qualified App.Commands.Options.Types as Z import qualified App.Static as AS import qualified Control.Concurrent.STM as STM @@ -50,8 +43,6 @@ import qualified HaskellWorks.CabalCache.IO.File as IO import qualified HaskellWorks.CabalCache.IO.Lazy as IO import qualified HaskellWorks.CabalCache.IO.Tar as IO -import qualified Network.AWS as AWS -import qualified Network.AWS.Data as AWS import qualified Options.Applicative as OA import qualified System.Directory as IO import qualified System.IO as IO @@ -71,7 +62,7 @@ tEarlyExit <- STM.newTVarIO False OO.runOops $ OO.catchAndExitFailure @ExitFailure do - let hostEndpoint = opts ^. the @"hostEndpoint" + let mHostEndpoint = opts ^. the @"hostEndpoint" let storePath = opts ^. the @"storePath" let archiveUri = opts ^. the @"archiveUri" let threads = opts ^. the @"threads" @@ -101,10 +92,19 @@ let compilerId = planJson ^. the @"compilerId" - envAws <- liftIO $ IO.unsafeInterleaveIO $ (<&> envOverride .~ Dual (Endo $ \s -> case hostEndpoint of - Just (hostname, port, ssl) -> setEndpoint ssl hostname port s - Nothing -> s)) - $ AWS.mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel) + 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 archivePath = versionedArchiveUri compilerId let scopedArchivePath = scopedArchiveUri compilerId @@ -124,7 +124,7 @@ storeCompilerPackageDbPathExists <- liftIO $ doesDirectoryExist storeCompilerPackageDbPath unless storeCompilerPackageDbPathExists $ - liftIO $ GhcPkg.init compilerContext storeCompilerPackageDbPath + liftIO $ GhcPkg.contextInit compilerContext storeCompilerPackageDbPath CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages" diff --git a/app/App/Commands/Version.hs b/app/App/Commands/Version.hs --- a/app/App/Commands/Version.hs +++ b/app/App/Commands/Version.hs @@ -7,6 +7,7 @@ ) where import App.Commands.Options.Parser (optsVersion) +import HaskellWorks.Prelude import Options.Applicative (Mod, CommandFields) import qualified App.Commands.Options.Types as Z diff --git a/app/App/Static.hs b/app/App/Static.hs --- a/app/App/Static.hs +++ b/app/App/Static.hs @@ -7,8 +7,7 @@ ) where import Control.Monad.Catch (handle) -import Control.Exception (IOException) -import Control.Monad.Identity (Identity(..)) +import HaskellWorks.Prelude import qualified App.Static.Base as S import qualified App.Static.Posix as P diff --git a/app/App/Static/Base.hs b/app/App/Static/Base.hs --- a/app/App/Static/Base.hs +++ b/app/App/Static/Base.hs @@ -3,6 +3,8 @@ isPosix, ) where +import HaskellWorks.Prelude + import qualified System.Directory as IO import qualified System.IO.Unsafe as IO import qualified System.Info as I diff --git a/app/App/Static/Posix.hs b/app/App/Static/Posix.hs --- a/app/App/Static/Posix.hs +++ b/app/App/Static/Posix.hs @@ -3,6 +3,7 @@ ) where import HaskellWorks.CabalCache.Location (()) +import HaskellWorks.Prelude import qualified App.Static.Base as S diff --git a/app/App/Static/Windows.hs b/app/App/Static/Windows.hs --- a/app/App/Static/Windows.hs +++ b/app/App/Static/Windows.hs @@ -3,8 +3,8 @@ cabalDirectory, ) where -import Data.Maybe (fromMaybe) import HaskellWorks.CabalCache.Location (()) +import HaskellWorks.Prelude import qualified App.Static.Base as S import qualified System.Environment as IO diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,8 +1,7 @@ module Main where import App.Commands (commands) -import Control.Applicative ((<**>)) -import Control.Monad (join) +import HaskellWorks.Prelude import qualified Options.Applicative as OA diff --git a/cabal-cache.cabal b/cabal-cache.cabal --- a/cabal-cache.cabal +++ b/cabal-cache.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: cabal-cache -version: 1.0.6.0 +version: 1.1.0.2 synopsis: CI Assistant for Haskell projects description: CI Assistant for Haskell projects. Implements package caching. homepage: https://github.com/haskell-works/cabal-cache @@ -11,6 +11,7 @@ maintainer: newhoggy@gmail.com 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 source-repository head @@ -19,50 +20,52 @@ common base { build-depends: base >= 4.7 && < 5 } -common aeson { build-depends: aeson >= 1.4.2.0 && < 2.2 } -common amazonka { build-depends: amazonka >= 1.6.1 && < 1.7 } -common amazonka-core { build-depends: amazonka-core >= 1.6.1 && < 1.7 } -common amazonka-s3 { build-depends: amazonka-s3 >= 1.6.1 && < 1.7 } +common aeson { build-depends: aeson >= 2 && < 2.3 } +common amazonka { build-depends: amazonka >= 2 && < 3 } +common amazonka-core { build-depends: amazonka-core >= 2 && < 3 } +common amazonka-s3 { build-depends: amazonka-s3 >= 2 && < 3 } common attoparsec { build-depends: attoparsec >= 0.14 && < 0.15 } -common bytestring { build-depends: bytestring >= 0.10.8.2 && < 0.12 } -common cabal-install-parsers { build-depends: cabal-install-parsers >= 0.4 && < 0.6 } +common bytestring { build-depends: bytestring >= 0.10.8.2 && < 0.13 } +common cabal-install-parsers { build-depends: cabal-install-parsers >= 0.6.1 && < 0.7 } common conduit-extra { build-depends: conduit-extra >= 1.3.1.1 && < 1.4 } common containers { build-depends: containers >= 0.6.0.1 && < 0.7 } common cryptonite { build-depends: cryptonite >= 0.25 && < 1 } -common deepseq { build-depends: deepseq >= 1.4.4.0 && < 1.5 } +common deepseq { build-depends: deepseq >= 1.4.4.0 && < 1.6 } common directory { build-depends: directory >= 1.3.3.0 && < 1.4 } common exceptions { build-depends: exceptions >= 0.10.1 && < 0.11 } -common filepath { build-depends: filepath >= 1.3 && < 1.5 } +common filepath { build-depends: filepath >= 1.3 && < 1.6 } common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 2.3 } common Glob { build-depends: Glob >= 0.10.2 && < 0.11 } -common hedgehog { build-depends: hedgehog >= 1.0 && < 1.3 } -common hedgehog-extras { build-depends: hedgehog-extras >= 0.3 && < 0.4 } +common hedgehog { build-depends: hedgehog >= 1.5 && < 1.6 } +common hedgehog-extras { build-depends: hedgehog-extras >= 0.4 && < 0.7 } common hspec { build-depends: hspec >= 2.4 && < 3 } common http-client { build-depends: http-client >= 0.5.14 && < 0.8 } common http-client-tls { build-depends: http-client-tls >= 0.3 && < 0.4 } common http-types { build-depends: http-types >= 0.12.3 && < 0.13 } common hw-hedgehog { build-depends: hw-hedgehog >= 0.1.0.3 && < 0.2 } common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1.0.4 && < 0.2 } +common hw-prelude { build-depends: hw-prelude >= 0.0.4.0 && < 0.1 } 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.18 } +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 selective { build-depends: selective >= 0.1.0 && < 0.6 } +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 } -common tar { build-depends: tar >= 0.5.1.0 && < 0.6 } +common tar { build-depends: tar >= 0.5.1.0 && < 0.7 } common temporary { build-depends: temporary >= 1.3 && < 1.4 } -common text { build-depends: text >= 1.2.3.1 && < 2.1 } +common text { build-depends: text >= 1.2.3.1 && < 2.2 } common time { build-depends: time >= 1.4 && < 1.13 } common topograph { build-depends: topograph >= 1 && < 2 } common transformers { build-depends: transformers >= 0.5.6.2 && < 0.7 } common unliftio { build-depends: unliftio >= 0.2.10 && < 0.3 } -common zlib { build-depends: zlib >= 0.6.2 && < 0.7 } +common zlib { build-depends: zlib >= 0.6.2 && < 0.8 } common project-config default-language: Haskell2010 @@ -71,11 +74,13 @@ FlexibleContexts LambdaCase MonoLocalBinds + NoImplicitPrelude TypeOperators ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -Wtabs + -Wunused-packages if impl(ghc >= 8.10.1) ghc-options: -Wunused-packages @@ -99,7 +104,8 @@ http-client, http-client-tls, http-types, - lens, + hw-prelude, + microlens, mtl, network-uri, oops, @@ -110,7 +116,6 @@ stm, text, topograph, - transformers, other-modules: Paths_cabal_cache autogen-modules: Paths_cabal_cache hs-source-dirs: src @@ -134,7 +139,6 @@ HaskellWorks.CabalCache.Location HaskellWorks.CabalCache.Metadata HaskellWorks.CabalCache.Options - HaskellWorks.CabalCache.Show HaskellWorks.CabalCache.Store HaskellWorks.CabalCache.Text HaskellWorks.CabalCache.Topology @@ -154,8 +158,9 @@ exceptions, filepath, generic-lens, + hw-prelude, + microlens, lens, - mtl, network-uri, oops, optparse-applicative, @@ -200,8 +205,7 @@ hspec, http-types, hw-hspec-hedgehog, - lens, - mtl, + hw-prelude, network-uri, oops, raw-strings-qq, diff --git a/src/HaskellWorks/CabalCache/AWS/Env.hs b/src/HaskellWorks/CabalCache/AWS/Env.hs --- a/src/HaskellWorks/CabalCache/AWS/Env.hs +++ b/src/HaskellWorks/CabalCache/AWS/Env.hs @@ -1,33 +1,53 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module HaskellWorks.CabalCache.AWS.Env ( awsLogger , mkEnv + , setEnvEndpoint ) where import Control.Concurrent (myThreadId) -import Control.Lens ((<&>), (.~)) -import Control.Monad (when, forM_) import Data.ByteString.Builder (toLazyByteString) -import HaskellWorks.CabalCache.Show (tshow) +import Data.Generics.Product.Any (the) +import HaskellWorks.Prelude +import Lens.Micro import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..)) +import qualified Amazonka as AWS import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LC8 import qualified Data.Text.Encoding as T import qualified HaskellWorks.CabalCache.IO.Console as CIO -import qualified Network.AWS as AWS 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 region lg = do lgr <- newAwsLogger lg - AWS.newEnv AWS.Discover - <&> AWS.envLogger .~ lgr - <&> AWS.envRegion .~ region - <&> AWS.envRetryCheck .~ retryPolicy 5 + discoveredEnv <- AWS.newEnv AWS.discover + + pure discoveredEnv + { AWS.logger = lgr + , AWS.region = region + , AWS.retryCheck = retryPolicy 5 + } newAwsLogger :: Monad m => (AWS.LogLevel -> LBS.ByteString -> IO ()) -> m AWS.Logger newAwsLogger lg = return $ \y b -> diff --git a/src/HaskellWorks/CabalCache/AWS/Error.hs b/src/HaskellWorks/CabalCache/AWS/Error.hs --- a/src/HaskellWorks/CabalCache/AWS/Error.hs +++ b/src/HaskellWorks/CabalCache/AWS/Error.hs @@ -7,9 +7,10 @@ import Control.Monad.Catch (MonadCatch(..), MonadThrow(throwM)) import Control.Monad.Except (MonadError) import HaskellWorks.CabalCache.AppError (AwsError(..)) +import HaskellWorks.Prelude +import qualified Amazonka as AWS import qualified Control.Monad.Oops as OO -import qualified Network.AWS as AWS import qualified Network.HTTP.Types as HTTP {- HLINT ignore "Redundant do" -} diff --git a/src/HaskellWorks/CabalCache/AWS/S3.hs b/src/HaskellWorks/CabalCache/AWS/S3.hs --- a/src/HaskellWorks/CabalCache/AWS/S3.hs +++ b/src/HaskellWorks/CabalCache/AWS/S3.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module HaskellWorks.CabalCache.AWS.S3 ( uriToS3Uri, @@ -10,49 +14,52 @@ ) where -import Control.Lens ((^.)) -import Control.Monad (void, unless) +import Amazonka (ResponseBody) +import Amazonka.Data (ToText(..), fromText) import Control.Monad.Catch (MonadCatch(..)) import Control.Monad.Except (MonadError) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.AWS (RsBody) -import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Resource (MonadResource, MonadUnliftIO, liftResourceT, runResourceT) import Data.Conduit.Lazy (lazyConsume) +import Data.Generics.Product.Any (the) import HaskellWorks.CabalCache.AppError (AwsError(..)) import HaskellWorks.CabalCache.Error (CopyFailed(..), UnsupportedUri(..)) -import HaskellWorks.CabalCache.Show (tshow) -import Network.AWS (MonadAWS, HasEnv) -import Network.AWS.Data (ToText(..), fromText) +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.IO.Console as CIO import qualified HaskellWorks.CabalCache.AWS.Error as AWS import qualified HaskellWorks.CabalCache.AWS.S3.URI as AWS +import qualified HaskellWorks.CabalCache.IO.Console as CIO import qualified HaskellWorks.CabalCache.URI as URI -import qualified Network.AWS as AWS -import qualified Network.AWS.Data.Body as AWS -import qualified Network.AWS.S3 as AWS import qualified System.IO as IO --- | Access the response body as a lazy bytestring -lazyByteString :: MonadResource m => RsBody -> m LBS.ByteString -lazyByteString rsBody = liftResourceT $ LBS.fromChunks <$> lazyConsume (AWS._streamBody rsBody) +--- | Access the response body as a lazy bytestring +lazyByteString :: MonadResource m => ResponseBody -> m LBS.ByteString +lazyByteString rsBody = liftResourceT $ LBS.fromChunks <$> lazyConsume (rsBody ^. the @"body") -unsafeDownloadRequest :: (MonadAWS m, MonadResource m) - => AWS.GetObject +unsafeDownloadRequest :: () + => Monad m + => MonadResource m + => AWS.Env + -> AWS.GetObject -> m LBS.ByteString -unsafeDownloadRequest req = do - resp <- AWS.send req - lazyByteString (resp ^. AWS.gorsBody) +unsafeDownloadRequest awsEnv req = do + resp <- AWS.send awsEnv req + lazyByteString (resp ^. the @"body") -unsafeDownload :: (MonadAWS m, MonadResource m) - => AWS.BucketName +unsafeDownload :: () + => Monad m + => MonadResource m + => AWS.Env + -> AWS.BucketName -> AWS.ObjectKey -> m LBS.ByteString -unsafeDownload bucketName objectKey = unsafeDownloadRequest (AWS.getObject bucketName objectKey) +unsafeDownload env bucketName objectKey = unsafeDownloadRequest env (AWS.newGetObject bucketName objectKey) uriToS3Uri :: URI -> Either UnsupportedUri AWS.S3Uri uriToS3Uri uri = case fromText @AWS.S3Uri (tshow uri) of @@ -65,30 +72,28 @@ => e `OO.CouldBe` UnsupportedUri => MonadCatch m => MonadResource m - => HasEnv r - => r + => AWS.Env -> URI -> m AWS.HeadObjectResponse headS3Uri envAws uri = do AWS.S3Uri b k <- OO.hoistEither $ uriToS3Uri (URI.reslashUri uri) - AWS.handleAwsError $ AWS.runAWS envAws $ AWS.send $ AWS.headObject b k + AWS.handleAwsError $ AWS.send envAws $ AWS.newHeadObject b k putObject :: () => e `OO.CouldBe` AwsError => e `OO.CouldBe` UnsupportedUri => MonadCatch m => MonadUnliftIO m - => HasEnv r => AWS.ToBody a - => r + => AWS.Env -> URI -> a -> ExceptT (OO.Variant e) m () putObject envAws uri lbs = do AWS.S3Uri b k <- OO.hoistEither $ uriToS3Uri (URI.reslashUri uri) let req = AWS.toBody lbs - let po = AWS.putObject b k req - AWS.handleAwsError $ void $ OO.suspend runResourceT $ AWS.runAWS envAws $ AWS.send po + let po = AWS.newPutObject b k req + AWS.handleAwsError $ void $ OO.suspend runResourceT $ AWS.send envAws po getS3Uri :: () => MonadError (OO.Variant e) m @@ -96,30 +101,28 @@ => e `OO.CouldBe` UnsupportedUri => MonadCatch m => MonadResource m - => HasEnv r - => r + => AWS.Env -> URI -> m LBS.ByteString getS3Uri envAws uri = do AWS.S3Uri b k <- OO.hoistEither $ uriToS3Uri (URI.reslashUri uri) - AWS.handleAwsError $ AWS.runAWS envAws $ unsafeDownload b k + AWS.handleAwsError $ unsafeDownload envAws b k copyS3Uri :: () - => HasEnv r => MonadUnliftIO m => e `OO.CouldBe` AwsError => e `OO.CouldBe` CopyFailed => e `OO.CouldBe` UnsupportedUri - => r + => AWS.Env -> 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) - let copyObjectRequest = AWS.copyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey - response <- OO.suspend runResourceT (AWS.runAWS envAws $ AWS.send copyObjectRequest) - let responseCode = response ^. AWS.corsResponseStatus + let copyObjectRequest = AWS.newCopyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey + response <- OO.suspend runResourceT $ AWS.send envAws 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 diff --git a/src/HaskellWorks/CabalCache/AWS/S3/URI.hs b/src/HaskellWorks/CabalCache/AWS/S3/URI.hs --- a/src/HaskellWorks/CabalCache/AWS/S3/URI.hs +++ b/src/HaskellWorks/CabalCache/AWS/S3/URI.hs @@ -7,20 +7,18 @@ ( S3Uri(..) ) where -import Control.Applicative (Alternative(many), optional) import Control.DeepSeq (NFData) -import Control.Lens ((^.)) import Data.Generics.Product.Any (HasAny(the)) -import Data.Text (Text) -import GHC.Generics (Generic) +import HaskellWorks.Prelude +import Lens.Micro +import qualified Amazonka.Data.Text as AWS +import qualified Amazonka.S3 as AWS import qualified Data.Aeson as J import qualified Data.Aeson.Types as J import qualified Data.Attoparsec.Combinator as DAC import qualified Data.Attoparsec.Text as DAT import qualified Data.Text as T -import qualified Network.AWS.Data as AWS -import qualified Network.AWS.S3 as AWS data S3Uri = S3Uri { bucket :: AWS.BucketName @@ -28,7 +26,7 @@ } deriving (Show, Eq, Ord, Generic, NFData) instance AWS.FromText S3Uri where - parser = do + fromText = DAT.parseOnly $ do _ <- DAT.string "s3://" bn <- AWS.BucketName . T.pack <$> DAC.many1 (DAT.satisfy (\c -> c /= '/' && c /= ' ')) _ <- optional (DAT.char '/') diff --git a/src/HaskellWorks/CabalCache/AppError.hs b/src/HaskellWorks/CabalCache/AppError.hs --- a/src/HaskellWorks/CabalCache/AppError.hs +++ b/src/HaskellWorks/CabalCache/AppError.hs @@ -11,9 +11,7 @@ displayHttpError, ) where -import Data.Text (Text) -import GHC.Generics (Generic) -import HaskellWorks.CabalCache.Show (tshow) +import HaskellWorks.Prelude import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Types as HTTP diff --git a/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs b/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs --- a/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs +++ b/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs @@ -7,17 +7,15 @@ ( DownloadStatus(..), createDownloadQueue, runQueue, - succeed, - fail, + downloadSucceed, + downloadFail, ) where import Control.Monad.Catch (MonadMask(..)) import Control.Monad.Except (MonadError) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.Function ((&)) import Data.Set ((\\)) -import HaskellWorks.CabalCache.Show (tshow) import Prelude hiding (fail) +import HaskellWorks.Prelude import qualified Control.Concurrent.STM as STM import qualified Control.Monad.Catch as CMC @@ -30,17 +28,17 @@ data DownloadStatus = DownloadSuccess | DownloadFailure deriving (Eq, Show) -succeed :: forall e a m. () +downloadSucceed :: forall e a m. () => MonadError (OO.Variant e) m => e `OO.CouldBe` DownloadStatus => m a -succeed = OO.throw DownloadSuccess +downloadSucceed = OO.throw DownloadSuccess -fail :: forall e a m. () +downloadFail :: forall e a m. () => MonadError (OO.Variant e) m => e `OO.CouldBe` DownloadStatus => m a -fail = OO.throw DownloadFailure +downloadFail = OO.throw DownloadFailure createDownloadQueue :: [(Z.ProviderId, Z.ConsumerId)] -> STM.STM Z.DownloadQueue createDownloadQueue dependencies = do diff --git a/src/HaskellWorks/CabalCache/Concurrent/Fork.hs b/src/HaskellWorks/CabalCache/Concurrent/Fork.hs --- a/src/HaskellWorks/CabalCache/Concurrent/Fork.hs +++ b/src/HaskellWorks/CabalCache/Concurrent/Fork.hs @@ -3,7 +3,7 @@ ) where import Control.Exception (finally) -import Control.Monad (when, forM_) +import HaskellWorks.Prelude import qualified Control.Concurrent as IO import qualified Control.Concurrent.STM as STM diff --git a/src/HaskellWorks/CabalCache/Core.hs b/src/HaskellWorks/CabalCache/Core.hs --- a/src/HaskellWorks/CabalCache/Core.hs +++ b/src/HaskellWorks/CabalCache/Core.hs @@ -17,17 +17,13 @@ ) where import Control.DeepSeq (NFData) -import Control.Lens ((<&>), (&), (^.)) import Control.Monad.Catch (MonadCatch(..)) -import Control.Monad.Except (ExceptT, forM, MonadIO(..), MonadError(..)) +import Control.Monad.Except (MonadError(..)) import Data.Aeson (eitherDecode) -import Data.Bifunctor (first) -import Data.Bool (bool) import Data.Generics.Product.Any (the) -import Data.Text (Text) -import GHC.Generics (Generic) import HaskellWorks.CabalCache.Error (DecodeError(..)) -import HaskellWorks.CabalCache.Show (tshow) +import HaskellWorks.Prelude +import Lens.Micro import System.FilePath ((<.>), ()) import qualified Control.Monad.Oops as OO @@ -135,7 +131,7 @@ <> (pInfo ^. the @"libs") <> [packageDir pInfo] , IO.TarGroup basePath $ mempty - <> ([pInfo ^. the @"confPath"] & filter ((== Present) . (^. the @"tag")) <&> (^. the @"value")) + <> ([pInfo ^. the @"confPath"] & L.filter ((== Present) . (^. the @"tag")) <&> (^. the @"value")) ] getPackages :: FilePath -> Z.PlanJson -> IO [PackageInfo] @@ -181,5 +177,5 @@ getLibFiles relativeLibPath libPath libPrefix = do libExists <- IO.doesDirectoryExist libPath if libExists - then fmap (relativeLibPath ) . filter (L.isPrefixOf (T.unpack libPrefix)) <$> IO.listDirectory libPath + then fmap (relativeLibPath ) . L.filter (L.isPrefixOf (T.unpack libPrefix)) <$> IO.listDirectory libPath else pure [] diff --git a/src/HaskellWorks/CabalCache/Data/List.hs b/src/HaskellWorks/CabalCache/Data/List.hs --- a/src/HaskellWorks/CabalCache/Data/List.hs +++ b/src/HaskellWorks/CabalCache/Data/List.hs @@ -5,6 +5,7 @@ ) where import Data.List.NonEmpty (NonEmpty(..)) +import HaskellWorks.Prelude tuple2ToDL :: (a, a) -> [a] -> [a] tuple2ToDL (a, b) = (a:) . (b:) diff --git a/src/HaskellWorks/CabalCache/Error.hs b/src/HaskellWorks/CabalCache/Error.hs --- a/src/HaskellWorks/CabalCache/Error.hs +++ b/src/HaskellWorks/CabalCache/Error.hs @@ -12,8 +12,7 @@ UnsupportedUri(UnsupportedUri), ) where -import Data.Text (Text) -import GHC.Generics (Generic) +import HaskellWorks.Prelude import Network.URI (URI) data DecodeError = DecodeError Text deriving (Eq, Show, Generic) diff --git a/src/HaskellWorks/CabalCache/GhcPkg.hs b/src/HaskellWorks/CabalCache/GhcPkg.hs --- a/src/HaskellWorks/CabalCache/GhcPkg.hs +++ b/src/HaskellWorks/CabalCache/GhcPkg.hs @@ -5,13 +5,13 @@ runGhcPkg, testAvailability, recache, - init, + contextInit, ) where -import Prelude hiding (init) - -import Control.Lens ((^.)) 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) @@ -39,5 +39,5 @@ recache :: Z.CompilerContext -> FilePath -> IO () recache cc packageDb = runGhcPkg cc ["recache", "--package-db", packageDb] -init :: Z.CompilerContext -> FilePath -> IO () -init cc packageDb = runGhcPkg cc ["init", packageDb] +contextInit :: Z.CompilerContext -> FilePath -> IO () +contextInit cc packageDb = runGhcPkg cc ["init", packageDb] diff --git a/src/HaskellWorks/CabalCache/Hash.hs b/src/HaskellWorks/CabalCache/Hash.hs --- a/src/HaskellWorks/CabalCache/Hash.hs +++ b/src/HaskellWorks/CabalCache/Hash.hs @@ -2,9 +2,12 @@ ( hashStorePath ) where +import HaskellWorks.Prelude + import qualified Crypto.Hash as CH +import qualified Data.List as L import qualified Data.Text as T import qualified Data.Text.Encoding as T hashStorePath :: String -> String -hashStorePath = take 10 . show . CH.hashWith CH.SHA256 . T.encodeUtf8 . T.pack +hashStorePath = L.take 10 . show . CH.hashWith CH.SHA256 . T.encodeUtf8 . T.pack diff --git a/src/HaskellWorks/CabalCache/IO/File.hs b/src/HaskellWorks/CabalCache/IO/File.hs --- a/src/HaskellWorks/CabalCache/IO/File.hs +++ b/src/HaskellWorks/CabalCache/IO/File.hs @@ -6,7 +6,7 @@ ) where import Control.Monad.Except (MonadError) -import Control.Monad.IO.Class (MonadIO(..)) +import HaskellWorks.Prelude import qualified Control.Monad.Oops as OO import qualified Data.Text as T diff --git a/src/HaskellWorks/CabalCache/IO/Lazy.hs b/src/HaskellWorks/CabalCache/IO/Lazy.hs --- a/src/HaskellWorks/CabalCache/IO/Lazy.hs +++ b/src/HaskellWorks/CabalCache/IO/Lazy.hs @@ -17,22 +17,19 @@ retryOnE, ) where -import Control.Lens ((&), (^.)) -import Control.Monad (unless) import Control.Monad.Catch (MonadCatch(..)) -import Control.Monad.Except (ExceptT, MonadError) -import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Except (MonadError) import Control.Monad.Trans.Resource (MonadResource, runResourceT, MonadUnliftIO) -import Data.Functor.Identity (Identity(..)) import Data.Generics.Product.Any (HasAny(the)) import Data.List.NonEmpty (NonEmpty ((:|))) import HaskellWorks.CabalCache.AppError (AwsError(..), HttpError(..), statusCodeOf) import HaskellWorks.CabalCache.Error (CopyFailed(..), InvalidUrl(..), NotFound(..), NotImplemented(..), UnsupportedUri(..)) import HaskellWorks.CabalCache.Location (Location (..)) -import HaskellWorks.CabalCache.Show (tshow) -import Network.AWS (HasEnv) +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 @@ -68,7 +65,6 @@ HTTP.InvalidUrlException url' reason' -> OO.throw $ InvalidUrl (tshow url') (tshow reason') readResource :: () - => HasEnv r => MonadResource m => MonadCatch m => e `OO.CouldBe` AwsError @@ -76,7 +72,7 @@ => e `OO.CouldBe` HttpError => e `OO.CouldBe` InvalidUrl => e `OO.CouldBe` NotFound - => r + => AWS.Env -> Int -> Location -> ExceptT (OO.Variant e) m LBS.ByteString @@ -93,7 +89,6 @@ scheme -> OO.throw $ UnsupportedUri uri $ "Unrecognised uri scheme: " <> T.pack scheme readFirstAvailableResource :: () - => HasEnv t => MonadResource m => MonadCatch m => e `OO.CouldBe` AwsError @@ -101,12 +96,16 @@ => e `OO.CouldBe` InvalidUrl => e `OO.CouldBe` NotFound => e `OO.CouldBe` UnsupportedUri - => t + => AWS.Env -> 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 + case NEL.nonEmpty as of + Nothing -> OO.throwF (Identity e) + Just nas -> readFirstAvailableResource envAws nas maxRetries & do OO.catch @AwsError \e -> do case NEL.nonEmpty as of Nothing -> OO.throwF (Identity e) @@ -126,10 +125,9 @@ resourceExists :: () => MonadUnliftIO m => MonadCatch m - => HasEnv r => e `OO.CouldBe` InvalidUrl => e `OO.CouldBe` UnsupportedUri - => r + => AWS.Env -> Location -> ExceptT (OO.Variant e) m Bool resourceExists envAws = \case @@ -163,8 +161,7 @@ => MonadIO m => MonadCatch m => MonadUnliftIO m - => HasEnv r - => r + => AWS.Env -> Location -> Int -> LBS.ByteString @@ -243,13 +240,12 @@ retryableHTTPStatuses = [408, 409, 425, 426, 502, 503, 504] linkOrCopyResource :: () - => HasEnv r => MonadUnliftIO m => e `OO.CouldBe` AwsError => e `OO.CouldBe` CopyFailed => e `OO.CouldBe` NotImplemented => e `OO.CouldBe` UnsupportedUri - => r + => AWS.Env -> Location -> Location -> ExceptT (OO.Variant e) m () diff --git a/src/HaskellWorks/CabalCache/IO/Tar.hs b/src/HaskellWorks/CabalCache/IO/Tar.hs --- a/src/HaskellWorks/CabalCache/IO/Tar.hs +++ b/src/HaskellWorks/CabalCache/IO/Tar.hs @@ -11,13 +11,10 @@ ) where import Control.DeepSeq (NFData) -import Control.Lens ((^.)) import Control.Monad.Except (MonadError) -import Control.Monad.IO.Class (MonadIO(..)) import Data.Generics.Product.Any (HasAny(the)) -import Data.Text (Text) -import GHC.Generics (Generic) -import HaskellWorks.CabalCache.Show (tshow) +import HaskellWorks.Prelude +import Lens.Micro import qualified Control.Monad.Oops as OO import qualified System.Exit as IO diff --git a/src/HaskellWorks/CabalCache/Location.hs b/src/HaskellWorks/CabalCache/Location.hs --- a/src/HaskellWorks/CabalCache/Location.hs +++ b/src/HaskellWorks/CabalCache/Location.hs @@ -12,18 +12,15 @@ ) where -import Control.Lens ((&), (%~)) import Data.Generics.Product.Any (HasAny(the)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import GHC.Generics (Generic) import HaskellWorks.CabalCache.AWS.S3.URI (S3Uri (..)) -import HaskellWorks.CabalCache.Show (tshow) +import HaskellWorks.Prelude +import Lens.Micro import Network.URI (URI) +import qualified Amazonka.Data as AWS +import qualified Amazonka.S3 as AWS import qualified Data.Text as T -import qualified Network.AWS.Data as AWS -import qualified Network.AWS.S3 as AWS import qualified Network.URI as URI import qualified System.FilePath as FP diff --git a/src/HaskellWorks/CabalCache/Metadata.hs b/src/HaskellWorks/CabalCache/Metadata.hs --- a/src/HaskellWorks/CabalCache/Metadata.hs +++ b/src/HaskellWorks/CabalCache/Metadata.hs @@ -7,11 +7,9 @@ deleteMetadata, ) where -import Control.Lens ((<&>)) -import Control.Monad (forM_) -import Control.Monad.IO.Class (MonadIO, liftIO) import HaskellWorks.CabalCache.Core (PackageInfo (..)) import HaskellWorks.CabalCache.IO.Tar (TarGroup (..)) +import HaskellWorks.Prelude import System.FilePath (takeFileName, ()) import qualified Data.ByteString.Lazy as LBS diff --git a/src/HaskellWorks/CabalCache/Options.hs b/src/HaskellWorks/CabalCache/Options.hs --- a/src/HaskellWorks/CabalCache/Options.hs +++ b/src/HaskellWorks/CabalCache/Options.hs @@ -2,15 +2,18 @@ ( readOrFromTextOption, ) where -import Control.Applicative (Alternative(..)) -import Network.AWS.Data.Text (FromText (..), fromText) +import Amazonka.Data.Text (FromText (..), fromText) +import HaskellWorks.Prelude import Options.Applicative (Parser, Mod, OptionFields) -import Text.Read (readEither) import qualified Data.Text as T import qualified Options.Applicative as OA +orElse :: Either e a -> Either e a -> Either e a +orElse a b = + either (const b) Right a + readOrFromTextOption :: (Read a, FromText a) => Mod OptionFields a -> Parser a readOrFromTextOption = - let fromStr s = readEither s <|> fromText (T.pack s) + let fromStr s = readEither s `orElse` fromText (T.pack s) in OA.option $ OA.eitherReader fromStr diff --git a/src/HaskellWorks/CabalCache/Show.hs b/src/HaskellWorks/CabalCache/Show.hs deleted file mode 100644 --- a/src/HaskellWorks/CabalCache/Show.hs +++ /dev/null @@ -1,10 +0,0 @@ -module HaskellWorks.CabalCache.Show - ( tshow, - ) where - -import Data.Text (Text) - -import qualified Data.Text as T - -tshow :: Show a => a -> Text -tshow = T.pack . show diff --git a/src/HaskellWorks/CabalCache/Store.hs b/src/HaskellWorks/CabalCache/Store.hs --- a/src/HaskellWorks/CabalCache/Store.hs +++ b/src/HaskellWorks/CabalCache/Store.hs @@ -2,10 +2,8 @@ ( cleanupStorePath, ) where -import Control.Monad (when, void) import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Except (ExceptT) +import HaskellWorks.Prelude import qualified Control.Monad.Oops as OO import qualified HaskellWorks.CabalCache.IO.Lazy as IO diff --git a/src/HaskellWorks/CabalCache/Topology.hs b/src/HaskellWorks/CabalCache/Topology.hs --- a/src/HaskellWorks/CabalCache/Topology.hs +++ b/src/HaskellWorks/CabalCache/Topology.hs @@ -9,16 +9,16 @@ ) where import Control.Arrow ((&&&)) -import Control.Lens (view, (&), (<&>), (^.)) -import Control.Monad (join) -import Data.Either (fromRight) import Data.Generics.Product.Any (the) import Data.Map.Strict (Map) -import Data.Maybe (fromMaybe) import Data.Set (Set) -import GHC.Generics (Generic) import HaskellWorks.CabalCache.Types (Package, PackageId, PlanJson) +import HaskellWorks.Prelude +import HaskellWorks.Unsafe +import Lens.Micro +import Lens.Micro.Extras (view) +import qualified Data.List as L import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Topograph as TG @@ -51,7 +51,7 @@ fromRight (error "Could not process dependencies") $ TG.runG plan $ \g -> let tg = TG.transpose g - nsPaths = concatMap (fromMaybe [] . paths tg) knownNonShareable + nsPaths = L.concatMap (fromMaybe [] . paths tg) knownNonShareable nsAll = S.fromList (join nsPaths) in PlanData { nonShareable = nsAll } where paths g x = (fmap . fmap . fmap) (TG.gFromVertex g) $ TG.dfs g <$> TG.gToVertex g x diff --git a/src/HaskellWorks/CabalCache/URI.hs b/src/HaskellWorks/CabalCache/URI.hs --- a/src/HaskellWorks/CabalCache/URI.hs +++ b/src/HaskellWorks/CabalCache/URI.hs @@ -5,8 +5,9 @@ ( reslashUri, ) where -import Control.Lens ((&), (%~)) import Data.Generics.Product.Any (HasAny(the)) +import HaskellWorks.Prelude +import Lens.Micro import Network.URI (URI) reslashUri :: URI -> URI diff --git a/test/HaskellWorks/CabalCache/AwsSpec.hs b/test/HaskellWorks/CabalCache/AwsSpec.hs --- a/test/HaskellWorks/CabalCache/AwsSpec.hs +++ b/test/HaskellWorks/CabalCache/AwsSpec.hs @@ -8,24 +8,20 @@ ( spec ) where -import Control.Lens -import Control.Monad -import Control.Monad.Except (runExceptT) -import Control.Monad.IO.Class -import Data.Maybe (isJust) import HaskellWorks.CabalCache.AppError (AwsError(..)) import HaskellWorks.CabalCache.Error (UnsupportedUri) import HaskellWorks.Hspec.Hedgehog +import HaskellWorks.Prelude import Hedgehog 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.AWS as AWS import qualified Network.HTTP.Types as HTTP import qualified Network.URI as URI import qualified System.Environment as IO @@ -40,7 +36,7 @@ ci <- liftIO $ IO.lookupEnv "CI" <&> isJust unless ci do envAws <- liftIO $ AWS.mkEnv AWS.Oregon (const LBSC.putStrLn) - let Just uri = URI.parseURI "s3://jky-mayhem/hjddhd" + 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) diff --git a/test/HaskellWorks/CabalCache/IntegrationSpec.hs b/test/HaskellWorks/CabalCache/IntegrationSpec.hs --- a/test/HaskellWorks/CabalCache/IntegrationSpec.hs +++ b/test/HaskellWorks/CabalCache/IntegrationSpec.hs @@ -7,7 +7,7 @@ ( spec ) where -import Control.Monad (forM_) +import HaskellWorks.Prelude import System.FilePath (()) import Test.Hspec (Spec, describe, it) diff --git a/test/HaskellWorks/CabalCache/LocationSpec.hs b/test/HaskellWorks/CabalCache/LocationSpec.hs --- a/test/HaskellWorks/CabalCache/LocationSpec.hs +++ b/test/HaskellWorks/CabalCache/LocationSpec.hs @@ -7,16 +7,17 @@ import Data.Maybe (fromJust) import HaskellWorks.CabalCache.Location import HaskellWorks.Hspec.Hedgehog +import HaskellWorks.Prelude import Hedgehog import Network.URI (URI) import Test.Hspec +import qualified Amazonka.Data as AWS import qualified Data.List as L import qualified Data.List as List import qualified Data.Text as Text import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import qualified Network.AWS.Data as AWS import qualified Network.URI as URI import qualified System.FilePath as FP diff --git a/test/HaskellWorks/CabalCache/QuerySpec.hs b/test/HaskellWorks/CabalCache/QuerySpec.hs --- a/test/HaskellWorks/CabalCache/QuerySpec.hs +++ b/test/HaskellWorks/CabalCache/QuerySpec.hs @@ -7,6 +7,7 @@ ) where import HaskellWorks.Hspec.Hedgehog +import HaskellWorks.Prelude import Hedgehog import Test.Hspec import Text.RawString.QQ diff --git a/test/Test/Base.hs b/test/Test/Base.hs --- a/test/Test/Base.hs +++ b/test/Test/Base.hs @@ -5,10 +5,8 @@ , integration ) where -import Control.Monad (void) import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO) -import GHC.Stack (HasCallStack) +import HaskellWorks.Prelude import Hedgehog (MonadTest) import Hedgehog.Extras.Test.Process (ExecConfig)