diff --git a/app/App/Cli/Options.hs b/app/App/Cli/Options.hs --- a/app/App/Cli/Options.hs +++ b/app/App/Cli/Options.hs @@ -10,6 +10,7 @@ import qualified Amazonka.Data as AWS import qualified App.Cli.Types as CLI +import Data.RdsData.Aws import qualified Data.Text as T import qualified Options.Applicative as OA @@ -35,9 +36,9 @@ $ OA.progDesc "Launch a local-stack RDS cluster." ] -pUpCmd :: OA.Parser CLI.UpCmd -pUpCmd = - CLI.UpCmd +pStatementContext :: OA.Parser StatementContext +pStatementContext = + StatementContext <$> do OA.strOption $ mconcat [ OA.long "resource-arn" , OA.help "Resource ARN" @@ -48,6 +49,17 @@ , OA.help "Secret ARN" , OA.metavar "ARN" ] + <*> do optional + ( OA.strOption $ mconcat + [ OA.long "database" + , OA.help "Database" + , OA.metavar "DATABASE" + ] + ) +pUpCmd :: OA.Parser CLI.UpCmd +pUpCmd = + CLI.UpCmd + <$> pStatementContext <*> do OA.strOption $ mconcat [ OA.long "migration-file" , OA.help "Migration File" @@ -57,16 +69,7 @@ pDownCmd :: OA.Parser CLI.DownCmd pDownCmd = CLI.DownCmd - <$> do OA.strOption $ mconcat - [ OA.long "resource-arn" - , OA.help "Resource ARN" - , OA.metavar "ARN" - ] - <*> do OA.strOption $ mconcat - [ OA.long "secret-arn" - , OA.help "Secret ARN" - , OA.metavar "ARN" - ] + <$> pStatementContext <*> do OA.strOption $ mconcat [ OA.long "migration-file" , OA.help "Migration File" diff --git a/app/App/Cli/Run/Down.hs b/app/App/Cli/Run/Down.hs --- a/app/App/Cli/Run/Down.hs +++ b/app/App/Cli/Run/Down.hs @@ -12,25 +12,17 @@ ( runDownCmd ) where -import Control.Monad.IO.Class import Data.Generics.Product.Any -import Data.Maybe -import Data.RdsData.Migration.Types (MigrationRow (..)) -import Data.RdsData.Types import Lens.Micro import qualified Amazonka as AWS import qualified App.Cli.Types as CLI import qualified App.Console as T -import qualified Data.Aeson as J import Data.RdsData.Aws -import qualified Data.RdsData.Decode.Row as DEC import Data.RdsData.Polysemy.Core import Data.RdsData.Polysemy.Error import Data.RdsData.Polysemy.Migration import qualified Data.Text as T -import qualified Data.Text.Lazy.Encoding as LT -import qualified Data.Text.Lazy.IO as LT import HaskellWorks.Polysemy import HaskellWorks.Polysemy.Amazonka import HaskellWorks.Polysemy.File @@ -38,7 +30,6 @@ import HaskellWorks.Prelude import Polysemy.Log import Polysemy.Time.Interpreter.Ghc -import qualified System.IO as IO newtype AppError = AppError Text @@ -47,8 +38,7 @@ runApp :: () => CLI.DownCmd -> Sem - [ Reader AwsResourceArn - , Reader AwsSecretArn + [ Reader StatementContext , Reader AWS.Env , Error AppError , DataLog AwsLogEntry @@ -61,8 +51,7 @@ ] () -> IO () runApp cmd f = f - & runReader (AwsResourceArn $ cmd ^. the @"resourceArn") - & runReader (AwsSecretArn $ cmd ^. the @"secretArn") + & runReader (cmd ^. the @"statementContext") & runReaderAwsEnvDiscover & trap @AppError reportFatal & interpretDataLogAwsLogEntryToLog @@ -93,32 +82,3 @@ & trap @JsonDecodeError (throw . AppError . T.pack . show) & trap @RdsDataError (throw . AppError . T.pack . show) & trap @YamlDecodeError (throw . AppError . T.pack . show) - - id do - res <- executeStatement - ( mconcat - [ "SELECT" - , " uuid," - , " created_at," - , " deployed_by" - , "FROM migration" - ] - ) - & trap @AWS.Error (throw . AppError . T.pack . show) - & trap @RdsDataError (throw . AppError . T.pack . show) - - liftIO . LT.putStrLn $ LT.decodeUtf8 $ J.encode res - - decodeMigrationRow <- pure $ id @(DEC.DecodeRow MigrationRow) $ - MigrationRow - <$> DEC.ulid - <*> DEC.utcTime - <*> DEC.text - - records <- pure $ id @[[Value]] $ fromMaybe [] $ mapM (mapM fromField) =<< res ^. the @"records" - - row <- pure $ DEC.decodeRows decodeMigrationRow records - - liftIO $ IO.print row - - pure () diff --git a/app/App/Cli/Run/Example.hs b/app/App/Cli/Run/Example.hs --- a/app/App/Cli/Run/Example.hs +++ b/app/App/Cli/Run/Example.hs @@ -74,8 +74,8 @@ let theAwsLogLevel = cmd ^. the @"mAwsLogLevel" let theMHostEndpoint = cmd ^. the @"mHostEndpoint" let theRegion = cmd ^. the @"region" - let theResourceArn = cmd ^. the @"resourceArn" - let theSecretArn = cmd ^. the @"secretArn" + let theResourceArn = cmd ^. the @"statementContext" . the @"resourceArn" . the @1 + let theSecretArn = cmd ^. the @"statementContext" . the @"secretArn" . the @1 envAws <- liftIO (IO.unsafeInterleaveIO (mkEnv theRegion (awsLogger theAwsLogLevel))) diff --git a/app/App/Cli/Run/ExecuteStatement.hs b/app/App/Cli/Run/ExecuteStatement.hs --- a/app/App/Cli/Run/ExecuteStatement.hs +++ b/app/App/Cli/Run/ExecuteStatement.hs @@ -27,8 +27,8 @@ let theAwsLogLevel = cmd ^. the @"mAwsLogLevel" let theMHostEndpoint = cmd ^. the @"mHostEndpoint" let theRegion = cmd ^. the @"region" - let theResourceArn = cmd ^. the @"resourceArn" - let theSecretArn = cmd ^. the @"secretArn" + let theResourceArn = cmd ^. the @"statementContext" . the @"resourceArn" . the @1 + let theSecretArn = cmd ^. the @"statementContext" . the @"secretArn" . the @1 let theSql = cmd ^. the @"sql" envAws <- diff --git a/app/App/Cli/Run/LocalStack.hs b/app/App/Cli/Run/LocalStack.hs --- a/app/App/Cli/Run/LocalStack.hs +++ b/app/App/Cli/Run/LocalStack.hs @@ -26,6 +26,7 @@ import qualified Control.Monad.Trans.Resource.Internal as IO import Data.Acquire (ReleaseType (ReleaseNormal)) import Data.Generics.Product.Any +import Data.RdsData.Aws import Data.RdsData.Polysemy.Test.Cluster import Data.RdsData.Polysemy.Test.Env import GHC.IORef (IORef) @@ -113,15 +114,14 @@ void $ runLocalTestEnv (pure container) do rdsClusterDetails <- createRdsDbCluster "rds_data_migration" (pure container) - runReaderResourceAndSecretArnsFromResponses rdsClusterDetails do + runReaderStatementContextFromClusterDetails rdsClusterDetails do lsEp <- getLocalStackEndpoint container jotShow_ lsEp -- Localstack endpoint let port = lsEp ^. the @"port" let exampleCmd = "awslocal --endpoint-url=http://localhost:" <> show port <> " s3 ls" -- Example awslocal command: jot_ exampleCmd - jotShowM_ $ ask @AwsResourceArn - jotShowM_ $ ask @AwsSecretArn + jotShowM_ $ ask @StatementContext pure () failure -- Not a failure diff --git a/app/App/Cli/Run/Up.hs b/app/App/Cli/Run/Up.hs --- a/app/App/Cli/Run/Up.hs +++ b/app/App/Cli/Run/Up.hs @@ -36,8 +36,7 @@ runApp :: () => CLI.UpCmd -> Sem - [ Reader AwsResourceArn - , Reader AwsSecretArn + [ Reader StatementContext , Reader AWS.Env , Error AppError , DataLog AwsLogEntry @@ -50,8 +49,7 @@ ] () -> IO () runApp cmd f = f - & runReader (AwsResourceArn $ cmd ^. the @"resourceArn") - & runReader (AwsSecretArn $ cmd ^. the @"secretArn") + & runReader (cmd ^. the @"statementContext") & runReaderAwsEnvDiscover & trap @AppError reportFatal & interpretDataLogAwsLogEntryToLog diff --git a/app/App/Cli/Types.hs b/app/App/Cli/Types.hs --- a/app/App/Cli/Types.hs +++ b/app/App/Cli/Types.hs @@ -20,6 +20,7 @@ import qualified Amazonka as AWS import qualified Amazonka.RDSData as AWS +import Data.RdsData.Aws data Cmd = CmdOfBatchExecuteStatementCmd BatchExecuteStatementCmd @@ -30,42 +31,37 @@ | CmdOfUpCmd UpCmd data ExecuteStatementCmd = ExecuteStatementCmd - { mAwsLogLevel :: Maybe AWS.LogLevel - , region :: AWS.Region - , mHostEndpoint :: Maybe (ByteString, Int, Bool) - , resourceArn :: Text - , secretArn :: Text - , sql :: Text + { mAwsLogLevel :: Maybe AWS.LogLevel + , region :: AWS.Region + , mHostEndpoint :: Maybe (ByteString, Int, Bool) + , statementContext :: StatementContext + , sql :: Text } deriving Generic data BatchExecuteStatementCmd = BatchExecuteStatementCmd - { mAwsLogLevel :: Maybe AWS.LogLevel - , region :: AWS.Region - , mHostEndpoint :: Maybe (ByteString, Int, Bool) - , parameterSets :: Maybe [[AWS.SqlParameter]] - , resourceArn :: Text - , secretArn :: Text - , sql :: Text + { mAwsLogLevel :: Maybe AWS.LogLevel + , region :: AWS.Region + , mHostEndpoint :: Maybe (ByteString, Int, Bool) + , parameterSets :: Maybe [[AWS.SqlParameter]] + , statementContext :: StatementContext + , sql :: Text } deriving Generic data ExampleCmd = ExampleCmd - { mAwsLogLevel :: Maybe AWS.LogLevel - , region :: AWS.Region - , mHostEndpoint :: Maybe (ByteString, Int, Bool) - , resourceArn :: Text - , secretArn :: Text + { mAwsLogLevel :: Maybe AWS.LogLevel + , region :: AWS.Region + , mHostEndpoint :: Maybe (ByteString, Int, Bool) + , statementContext :: StatementContext } deriving Generic data UpCmd = UpCmd - { resourceArn :: Text - , secretArn :: Text - , migrationFp :: FilePath + { statementContext :: StatementContext + , migrationFp :: FilePath } deriving Generic data DownCmd = DownCmd - { resourceArn :: Text - , secretArn :: Text - , migrationFp :: FilePath + { statementContext :: StatementContext + , migrationFp :: FilePath } deriving Generic data LocalStackCmd = LocalStackCmd diff --git a/integration/Test/Data/RdsData/Migration/ConnectionSpec.hs b/integration/Test/Data/RdsData/Migration/ConnectionSpec.hs --- a/integration/Test/Data/RdsData/Migration/ConnectionSpec.hs +++ b/integration/Test/Data/RdsData/Migration/ConnectionSpec.hs @@ -44,7 +44,7 @@ dbClusterArn <- rdsClusterDetails ^. the @"createDbClusterResponse" . the @"dbCluster" . _Just . the @"dbClusterArn" & nothingFail - runReaderResourceAndSecretArnsFromResponses rdsClusterDetails $ do + runReaderStatementContextFromClusterDetails rdsClusterDetails $ do waitUntilRdsDbClusterAvailable dbClusterArn & trapFail @AWS.Error & jotShowDataLog @AwsLogEntry diff --git a/polysemy/Data/RdsData/Polysemy/Core.hs b/polysemy/Data/RdsData/Polysemy/Core.hs --- a/polysemy/Data/RdsData/Polysemy/Core.hs +++ b/polysemy/Data/RdsData/Polysemy/Core.hs @@ -26,34 +26,37 @@ import Lens.Micro newExecuteStatement :: () - => Member (Reader AwsResourceArn) r - => Member (Reader AwsSecretArn) r + => Member (Reader StatementContext) r => Text -> Sem r AWS.ExecuteStatement newExecuteStatement sql = do - AwsResourceArn theResourceArn <- ask - AwsSecretArn theSecretArn <- ask + context <- ask @StatementContext + let AwsResourceArn theResourceArn = context ^. the @"resourceArn" + let AwsSecretArn theSecretArn = context ^. the @"secretArn" + pure $ AWS.newExecuteStatement theResourceArn theSecretArn sql + & the @"database" .~ (context ^? the @"database" . _Just . the @1) newBatchExecuteStatement :: () - => Member (Reader AwsResourceArn) r - => Member (Reader AwsSecretArn) r + => Member (Reader StatementContext) r => Text -> Sem r AWS.BatchExecuteStatement newBatchExecuteStatement sql = do - AwsResourceArn theResourceArn <- ask - AwsSecretArn theSecretArn <- ask + context <- ask @StatementContext + let AwsResourceArn theResourceArn = context ^. the @"resourceArn" + let AwsSecretArn theSecretArn = context ^. the @"secretArn" + pure $ AWS.newBatchExecuteStatement theResourceArn theSecretArn sql + & the @"database" .~ (context ^? the @"database" . _Just . the @1) executeStatement :: () => Member (DataLog AwsLogEntry) r => Member (Embed m) r => Member (Error AWS.Error) r => Member (Error RdsDataError) r - => Member (Reader AwsResourceArn) r - => Member (Reader AwsSecretArn) r + => Member (Reader StatementContext) r => Member (Reader Env) r => Member Log r => Member Resource r @@ -74,8 +77,7 @@ => Member (Embed m) r => Member (Error AWS.Error) r => Member (Error RdsDataError) r - => Member (Reader AwsResourceArn) r - => Member (Reader AwsSecretArn) r + => Member (Reader StatementContext) r => Member (Reader Env) r => Member Log r => Member Resource r @@ -89,8 +91,7 @@ => Member (Embed m) r => Member (Error AWS.Error) r => Member (Error RdsDataError) r - => Member (Reader AwsResourceArn) r - => Member (Reader AwsSecretArn) r + => Member (Reader StatementContext) r => Member (Reader Env) r => Member Log r => Member Resource r @@ -108,7 +109,7 @@ ] executeStatement_ - "CREATE INDEX idx_migration_created_at ON migration (created_at);" + "CREATE INDEX IF NOT EXISTS idx_migration_created_at ON migration (created_at);" executeStatement_ - "CREATE INDEX idx_migration_deployed_by ON migration (deployed_by);" + "CREATE INDEX IF NOT EXISTS idx_migration_deployed_by ON migration (deployed_by);" diff --git a/polysemy/Data/RdsData/Polysemy/Migration.hs b/polysemy/Data/RdsData/Polysemy/Migration.hs --- a/polysemy/Data/RdsData/Polysemy/Migration.hs +++ b/polysemy/Data/RdsData/Polysemy/Migration.hs @@ -11,11 +11,14 @@ import qualified Amazonka.Env as AWS import qualified Amazonka.Types as AWS +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as LBS import Data.Generics.Product.Any import Data.RdsData.Aws import Data.RdsData.Migration.Types hiding (id) import Data.RdsData.Polysemy.Core import Data.RdsData.Polysemy.Error +import qualified Data.Text.Encoding as T import HaskellWorks.Polysemy import HaskellWorks.Polysemy.Amazonka import HaskellWorks.Polysemy.File @@ -31,8 +34,7 @@ => Member (Error RdsDataError) r => Member (Error YamlDecodeError) r => Member (Reader AWS.Env) r - => Member (Reader AwsResourceArn) r - => Member (Reader AwsSecretArn) r + => Member (Reader StatementContext) r => Member Log r => Member Resource r => FilePath @@ -45,8 +47,10 @@ forM_ statements $ \statement -> do info $ "Executing statement: " <> tshow statement - executeStatement (statement ^. the @1) + response <- executeStatement (statement ^. the @1) + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + migrateUp :: () => Member (DataLog AwsLogEntry) r => Member (Embed IO) r @@ -56,8 +60,7 @@ => Member (Error RdsDataError) r => Member (Error YamlDecodeError) r => Member (Reader AWS.Env) r - => Member (Reader AwsResourceArn) r - => Member (Reader AwsSecretArn) r + => Member (Reader StatementContext) r => Member Log r => Member Resource r => FilePath @@ -70,4 +73,6 @@ forM_ statements $ \statement -> do info $ "Executing statement: " <> tshow statement - executeStatement (statement ^. the @1) + response <- executeStatement (statement ^. the @1) + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) diff --git a/rds-data.cabal b/rds-data.cabal --- a/rds-data.cabal +++ b/rds-data.cabal @@ -1,7 +1,7 @@ cabal-version: 3.6 name: rds-data -version: 0.0.0.4 +version: 0.0.0.5 synopsis: Codecs for use with AWS rds-data description: Codecs for use with AWS rds-data. category: Data diff --git a/src/Data/RdsData/Aws.hs b/src/Data/RdsData/Aws.hs --- a/src/Data/RdsData/Aws.hs +++ b/src/Data/RdsData/Aws.hs @@ -1,12 +1,33 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Data.RdsData.Aws - ( AwsResourceArn(..), - AwsSecretArn(..), + ( AwsResourceArn(AwsResourceArn), + AwsSecretArn(AwsSecretArn), + Database(Database), + StatementContext(StatementContext), + newStatementContext, ) where -import Data.Text (Text) +import Data.String (IsString) +import Data.Text (Text) +import GHC.Generics newtype AwsResourceArn = AwsResourceArn Text - deriving (Eq, Show) + deriving (Eq, Generic, IsString, Show) newtype AwsSecretArn = AwsSecretArn Text - deriving (Eq, Show) + deriving (Eq, Generic, IsString, Show) + +newtype Database = Database Text + deriving (Eq, Generic, IsString, Show) + +data StatementContext = StatementContext + { resourceArn :: AwsResourceArn + , secretArn :: AwsSecretArn + , database :: Maybe Database + } deriving (Eq, Generic, Show) + +newStatementContext :: AwsResourceArn -> AwsSecretArn -> StatementContext +newStatementContext theResourceArn theSecretArn = + StatementContext theResourceArn theSecretArn Nothing diff --git a/testlib/Data/RdsData/Polysemy/Test/Env.hs b/testlib/Data/RdsData/Polysemy/Test/Env.hs --- a/testlib/Data/RdsData/Polysemy/Test/Env.hs +++ b/testlib/Data/RdsData/Polysemy/Test/Env.hs @@ -17,7 +17,7 @@ runLocalTestEnv, runTestEnv, runReaderFromEnvOrFail, - runReaderResourceAndSecretArnsFromResponses, + runReaderStatementContextFromClusterDetails, ) where import qualified Amazonka as AWS @@ -81,17 +81,23 @@ runReader (f env) action -runReaderResourceAndSecretArnsFromResponses :: () +runReaderStatementContextFromClusterDetails :: () => Member Hedgehog r => RdsClusterDetails - -> Sem (Reader AwsResourceArn : Reader AwsSecretArn : r) a + -> Sem (Reader StatementContext : r) a -> Sem r a -runReaderResourceAndSecretArnsFromResponses details f = do +runReaderStatementContextFromClusterDetails details f = do resourceArn <- (details ^. the @"createDbClusterResponse" . the @"dbCluster" . _Just . the @"dbClusterArn") & nothingFail secretArn <- (details ^. the @"createSecretResponse" ^. the @"arn") & nothingFail - f & runReader (AwsResourceArn resourceArn) - & runReader (AwsSecretArn secretArn) + mDatabase <- pure $ (details ^? the @"createDbClusterResponse" . the @"dbCluster" . _Just . the @"databaseName" . _Just) + <&> Database + + statementContext <- pure $ newStatementContext (AwsResourceArn resourceArn) (AwsSecretArn secretArn) + & the @"database" .~ mDatabase + + + f & runReader statementContext