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 @@ -27,6 +27,7 @@ import Data.Acquire (ReleaseType (ReleaseNormal)) import Data.Generics.Product.Any import Data.RdsData.Aws +import Data.RdsData.Default import Data.RdsData.Polysemy.Test.Cluster import Data.RdsData.Polysemy.Test.Env import GHC.IORef (IORef) @@ -85,7 +86,7 @@ -> IO (TC.Container, IO.InternalState) startContainers tcConfig = TC.runTestContainer tcConfig do - result <- setupContainers + result <- setupContainers' projectDefaultLocalStack releaseMap <- IO.liftResourceT IO.getInternalState -- N.B. runResourceT runs the finalizers on every resource. We don't want it to! We want to run 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 @@ -18,6 +18,7 @@ import Data.Function import Data.Generics.Product.Any import qualified Data.List as L +import Data.RdsData.Default import Data.RdsData.Polysemy.Core import Data.RdsData.Polysemy.Error import Data.RdsData.Polysemy.Migration @@ -37,7 +38,7 @@ -- cabal test rds-data-test --test-options "--pattern \"/RDS integration test/\"" tasty_rds_integration_test :: Tasty.TestTree tasty_rds_integration_test = - TC.withContainers (setupContainers' "localstack/localstack-pro:3.7.2") $ \getContainer -> + TC.withContainers (setupContainers' projectDefaultLocalStack) $ \getContainer -> H.testProperty "RDS integration test" $ propertyOnce $ localWorkspace "rds-data" $ runLocalTestEnv getContainer $ do rdsClusterDetails <- createRdsDbCluster "rds_data_migration" getContainer 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 @@ -52,6 +52,7 @@ & the @"database" .~ (context ^? the @"database" . _Just . the @1) executeStatement :: () + => HasCallStack => Member (DataLog AwsLogEntry) r => Member (Embed m) r => Member (Error AWS.Error) r @@ -63,7 +64,7 @@ => MonadIO m => Text -> Sem r AWS.ExecuteStatementResponse -executeStatement sql = do +executeStatement sql = withFrozenCallStack do res <- newExecuteStatement sql >>= sendAws case res ^. the @"httpStatus" of @@ -73,6 +74,7 @@ _ -> throw $ RdsDataError $ "Failed to initialise database: " <> tshow res executeStatement_ :: () + => HasCallStack => Member (DataLog AwsLogEntry) r => Member (Embed m) r => Member (Error AWS.Error) r @@ -84,9 +86,11 @@ => MonadIO m => Text -> Sem r () -executeStatement_ = void . executeStatement +executeStatement_ f = withFrozenCallStack do + void $ executeStatement f initialiseDb :: () + => HasCallStack => Member (DataLog AwsLogEntry) r => Member (Embed m) r => Member (Error AWS.Error) r @@ -97,7 +101,7 @@ => Member Resource r => MonadIO m => Sem r () -initialiseDb = do +initialiseDb = withFrozenCallStack do executeStatement_ $ mconcat [ "CREATE TABLE IF NOT EXISTS migration (" , " ulid CHAR(26) NOT NULL PRIMARY KEY," 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 @@ -113,12 +113,15 @@ columnClauses <- pure $ createTableStatement ^.. the @"createTable" . the @"columns" . each . to columnToText + primaryKeyClause <- pure $ + createTableStatement ^.. the @"createTable" . the @"primaryKey" . _Just . to primaryKeyToText + constraintClauses <- pure $ createTableStatement ^.. the @"createTable" . the @"constraints" . _Just . each . to constraintToText statement <- pure $ mconcat [ "CREATE TABLE " <> createTableStatement ^. the @"createTable" . the @"name" <> " (" - , mconcat $ L.intersperse ", " (columnClauses <> constraintClauses) + , mconcat $ L.intersperse ", " (columnClauses <> primaryKeyClause <> constraintClauses) , ");\n" ] @@ -169,6 +172,15 @@ ] & T.intercalate " " | Just fk <- [c ^. the @"references"] ] + ] + +primaryKeyToText :: [Text] -> Text +primaryKeyToText cs = + T.intercalate " " + [ "PRIMARY KEY" + , "(" + , T.intercalate ", " cs + , ")" ] constraintToText :: Constraint -> Text 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.7 +version: 0.0.0.8 synopsis: Codecs for use with AWS rds-data description: Codecs for use with AWS rds-data. category: Data @@ -39,10 +39,10 @@ common hedgehog { build-depends: hedgehog >= 1.4 && < 2 } common hedgehog-extras { build-depends: hedgehog-extras >= 0.6.0.2 && < 0.7 } common http-client { build-depends: http-client >= 0.5.14 && < 0.8 } -common hw-polysemy-amazonka { build-depends: hw-polysemy:amazonka >= 0.2.14.5 && < 0.3 } -common hw-polysemy-core { build-depends: hw-polysemy:core >= 0.2.14.5 && < 0.3 } -common hw-polysemy-hedgehog { build-depends: hw-polysemy:hedgehog >= 0.2.14.5 && < 0.3 } -common hw-polysemy-testcontainers-localstack { build-depends: hw-polysemy:testcontainers-localstack >= 0.2.14.5 && < 0.3 } +common hw-polysemy-amazonka { build-depends: hw-polysemy:amazonka >= 0.2.14.6 && < 0.3 } +common hw-polysemy-core { build-depends: hw-polysemy:core >= 0.2.14.6 && < 0.3 } +common hw-polysemy-hedgehog { build-depends: hw-polysemy:hedgehog >= 0.2.14.6 && < 0.3 } +common hw-polysemy-testcontainers-localstack { build-depends: hw-polysemy:testcontainers-localstack >= 0.2.14.6 && < 0.3 } common microlens { build-depends: microlens >= 0.4.13 && < 0.5 } common mtl { build-depends: mtl >= 2 && < 3 } common optparse-applicative { build-depends: optparse-applicative >= 0.18.1.0 && < 0.19 } @@ -103,6 +103,7 @@ Data.RdsData.Decode.Array Data.RdsData.Decode.Row Data.RdsData.Decode.Value + Data.RdsData.Default Data.RdsData.Encode.Array Data.RdsData.Encode.Param Data.RdsData.Encode.Params diff --git a/src/Data/RdsData/Default.hs b/src/Data/RdsData/Default.hs new file mode 100644 --- /dev/null +++ b/src/Data/RdsData/Default.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.RdsData.Default + ( projectDefaultLocalStack + ) where + +import Data.Text + +projectDefaultLocalStack :: Text +projectDefaultLocalStack = "localstack/localstack-pro:3.7.2" diff --git a/src/Data/RdsData/Migration/Types.hs b/src/Data/RdsData/Migration/Types.hs --- a/src/Data/RdsData/Migration/Types.hs +++ b/src/Data/RdsData/Migration/Types.hs @@ -176,6 +176,7 @@ data TableSchema = TableSchema { name :: Text , columns :: [Column] + , primaryKey :: Maybe [Text] , constraints :: Maybe [Constraint] } deriving (Eq, Generic, Show)