Merge pull request #232 from haskell-works/newhoggy/upgrade-to-amazon…

…ka-2 Upgrade to `amazonka-2`
haskell · Aug 9, 2023 · 4c96e17 · 4c96e17
2 parents f66d21b + 9013b05
commit 4c96e17
Show file tree

Hide file tree

Showing 16 changed files with 148 additions and 101 deletions.
diff --git a/app/App/Commands/Debug/S3/Cp.hs b/app/App/Commands/Debug/S3/Cp.hs
@@ -10,25 +10,24 @@ module App.Commands.Debug.S3.Cp
 import App.Commands.Options.Parser      (text)
 import App.Commands.Options.Types       (CpOptions (CpOptions))
 import Control.Applicative              (Alternative(..), optional)
-import Control.Lens                     ((.~), (<&>), (&), (^.))
+import Control.Lens                     ((&), (^.), (.~), (%~))
 import Control.Monad.Except             (MonadIO(..))
-import Control.Monad.Trans.AWS          (envOverride, setEndpoint)
 import Data.ByteString                  (ByteString)
+import Data.Functor                     ((<&>))
 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 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 +38,25 @@ import qualified System.IO.Unsafe                   as IO
 
 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
@@ -11,11 +11,11 @@ import Data.Set                   (Set)
 import Data.Text                  (Text)
 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
@@ -16,8 +16,8 @@ import HaskellWorks.CabalCache.Location (Location)
 import HaskellWorks.CabalCache.Types    (PackageId)
 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
@@ -20,6 +20,7 @@ import HaskellWorks.CabalCache.Show     (tshow)
 import HaskellWorks.CabalCache.Version  (archiveVersion)
 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 +30,6 @@ 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 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
@@ -10,20 +10,19 @@ module App.Commands.SyncFromArchive
 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.Functor                     ((<&>))
 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)
@@ -38,6 +37,8 @@ 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 +61,6 @@ import qualified HaskellWorks.CabalCache.IO.Console               as CIO
 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 +76,7 @@ skippable package = package ^. the @"packageType" == "pre-existing"
 
 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 +108,19 @@ runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do
 
     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"

diff --git a/app/App/Commands/SyncToArchive.hs b/app/App/Commands/SyncToArchive.hs
@@ -10,16 +10,14 @@ 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.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 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(..))
@@ -33,6 +31,8 @@ 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 +50,6 @@ import qualified HaskellWorks.CabalCache.IO.Console as CIO
 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 +69,7 @@ runSyncToArchive opts = do
   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 +99,19 @@ runSyncToArchive opts = do
 
     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

diff --git a/cabal-cache.cabal b/cabal-cache.cabal
@@ -20,12 +20,12 @@ source-repository head
 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 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 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      }

diff --git a/src/HaskellWorks/CabalCache/AWS/Env.hs b/src/HaskellWorks/CabalCache/AWS/Env.hs
@@ -1,33 +1,56 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 
 module HaskellWorks.CabalCache.AWS.Env
   ( awsLogger
   , mkEnv
+  , setEnvEndpoint
   ) where
 
 import Control.Concurrent           (myThreadId)
-import Control.Lens                 ((<&>), (.~))
+import Control.Lens                 ((.~), (%~))
 import Control.Monad                (when, forM_)
+import Data.ByteString              (ByteString)
 import Data.ByteString.Builder      (toLazyByteString)
 import HaskellWorks.CabalCache.Show (tshow)
 import Network.HTTP.Client          (HttpException (..), HttpExceptionContent (..))
+import Data.Generics.Product.Any    (the)
+import Data.Function                ((&))
 
+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
@@ -8,8 +8,8 @@ import Control.Monad.Catch              (MonadCatch(..), MonadThrow(throwM))
 import Control.Monad.Except             (MonadError)
 import HaskellWorks.CabalCache.AppError (AwsError(..))
 
+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"        -}