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 @@ -37,7 +37,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:latest") $ \getContainer -> + TC.withContainers (setupContainers' "localstack/localstack-pro:3.7.2") $ \getContainer -> H.testProperty "RDS integration test" $ propertyOnce $ localWorkspace "rds-data" $ runLocalTestEnv getContainer $ do rdsClusterDetails <- createRdsDbCluster "rds_data_migration" getContainer @@ -76,22 +76,7 @@ let upTables = upResult ^.. the @"records" . each . each . each . the @"stringValue" . _Just - L.sort upTables === ["migration", "projects", "users"] - - -- upIndexResult <- - -- ( executeStatement $ mconcat - -- [ "SELECT schemaname, indexname, tablename" - -- , " FROM pg_indexes" - -- , " ORDER BY schemaname, tablename, indexname;" - -- ] - -- ) - -- & trapFail @AWS.Error - -- & trapFail @RdsDataError - -- & jotShowDataLog - - -- let upIndexes = upIndexResult ^.. the @"records" . each . each . each . the @"stringValue" . _Just - - -- L.sort upIndexes === [] + L.sort upTables === ["examples", "migration", "projects", "users"] migrateDown "db/migration.yaml" & trapFail @AWS.Error 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 @@ -22,6 +22,7 @@ import Data.RdsData.Migration.Types hiding (id) import Data.RdsData.Polysemy.Core import Data.RdsData.Polysemy.Error +import qualified Data.Text as T import qualified Data.Text.Encoding as T import HaskellWorks.Polysemy import HaskellWorks.Polysemy.Amazonka @@ -110,12 +111,14 @@ StepOfDown _ -> pure () StepOfCreateTable createTableStatement -> do columnClauses <- pure $ - createTableStatement ^.. the @"createTable" . the @"columns" . each . to \column -> - column ^. the @"name" <> " " <> column ^. the @"type_" + createTableStatement ^.. the @"createTable" . the @"columns" . each . to columnToText + 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 + , mconcat $ L.intersperse ", " (columnClauses <> constraintClauses) , ");\n" ] @@ -140,3 +143,41 @@ response <- executeStatement statement info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + +columnToText :: Column -> Text +columnToText c = + T.intercalate " " $ concat + [ [c ^. the @"name"] + , [c ^. the @"type_"] + , [ "NOT NULL" + | c ^. the @"required" + ] + , [ "PRIMARY KEY" + | c ^. the @"primaryKey" + ] + , [ "UNIQUE" + | c ^. the @"unique" + ] + , [ "AUTO_INCREMENT" + | c ^. the @"autoIncrement" + ] + , [ [ "REFERENCES" + , fk ^. the @"table" + , "(" + , fk ^. the @"column" + , ")" + ] & T.intercalate " " + | Just fk <- [c ^. the @"references"] + ] + ] + +constraintToText :: Constraint -> Text +constraintToText c = + T.intercalate " " + [ "CONSTRAINT" + , c ^. the @"name" + , "CHECK" + , "(" + , c ^. the @"check" + , ")" + ] 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.6 +version: 0.0.0.7 synopsis: Codecs for use with AWS rds-data description: Codecs for use with AWS rds-data. category: Data 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 @@ -17,6 +17,7 @@ CreateTableStep(..), TableSchema(..), Column(..), + Constraint(..), ForeignKey(..), ) where @@ -26,8 +27,11 @@ import qualified Amazonka.SecretsManager as AWS import Control.Applicative import qualified Data.Aeson as J +import qualified Data.Aeson.Key as J +import qualified Data.Aeson.Types as J import Data.Bool import Data.Char (isAsciiUpper, toLower) +import Data.Functor import Data.Generics.Product.Any import Data.Maybe import Data.RdsData.Orphans () @@ -97,19 +101,34 @@ toJSON = \case StepOfUp step -> J.toJSON step StepOfDown step -> J.toJSON step - StepOfCreateTable table -> J.toJSON table - StepOfCreateIndex index -> J.toJSON index + StepOfCreateTable t -> J.toJSON t + StepOfCreateIndex i -> J.toJSON i instance FromJSON Step where - parseJSON v = - flip (J.withObject "Step") v $ \_ -> - asum - [ StepOfUp <$> J.parseJSON v - , StepOfDown <$> J.parseJSON v - , StepOfCreateTable <$> J.parseJSON v - , StepOfCreateIndex <$> J.parseJSON v - ] + parseJSON v = do + f <- fieldIn v + [ "up" + , "down" + , "create_table" + , "create_index" + ] + case f of + "up" -> StepOfUp <$> J.parseJSON v + "down" -> StepOfDown <$> J.parseJSON v + "create_table" -> StepOfCreateTable <$> J.parseJSON v + "create_index" -> StepOfCreateIndex <$> J.parseJSON v + _ -> fail "Invalid Step" + +fieldIn :: J.Value -> [Text] -> J.Parser Text +fieldIn v fs = + asum $ fmap (field v) fs + +field :: J.Value -> Text -> J.Parser Text +field v f = + flip (J.withObject "Step") v $ \o -> + (J..:) @J.Value o (J.fromText f) $> f + newtype UpStep = UpStep { up :: Statement } deriving (Eq, Generic, Show) @@ -155,8 +174,9 @@ parseJSON = J.genericParseJSON snakeCaseOptions data TableSchema = TableSchema - { name :: Text - , columns :: [Column] + { name :: Text + , columns :: [Column] + , constraints :: Maybe [Constraint] } deriving (Eq, Generic, Show) instance ToJSON TableSchema where @@ -168,7 +188,7 @@ data Column = Column { name :: Text , type_ :: Text - , nullable :: Bool + , required :: Bool , primaryKey :: Bool , unique :: Bool , autoIncrement :: Bool @@ -176,15 +196,15 @@ } deriving (Eq, Generic, Show) instance ToJSON Column where - toJSON column = + toJSON v = J.object $ catMaybes - [ "name" .=? do column ^. the @"name" & Just - , "type" .=? do column ^. the @"type_" & Just - , "nullable" .=? do column ^. the @"nullable" & bool Nothing (Just True) - , "primary_key" .=? do column ^. the @"primaryKey" & bool Nothing (Just True) - , "unique" .=? do column ^. the @"unique" & bool Nothing (Just True) - , "auto_increment" .=? do column ^. the @"autoIncrement" & bool Nothing (Just True) - , "references" .=? do column ^. the @"references" & Just + [ "name" .=? do v ^. the @"name" & Just + , "type" .=? do v ^. the @"type_" & Just + , "required" .=? do v ^. the @"required" & bool Nothing (Just True) + , "primary_key" .=? do v ^. the @"primaryKey" & bool Nothing (Just True) + , "unique" .=? do v ^. the @"unique" & bool Nothing (Just True) + , "auto_increment" .=? do v ^. the @"autoIncrement" & bool Nothing (Just True) + , "references" .=? do v ^. the @"references" & Just ] (.=?) :: (J.KeyValue e kv, ToJSON v) => J.Key -> Maybe v -> Maybe kv @@ -198,7 +218,7 @@ Column <$> v .: "name" <*> v .: "type" - <*> v .:? "nullable" .!= False + <*> v .:? "required" .!= False <*> v .:? "primary_key" .!= False <*> v .:? "unique" .!= False <*> v .:? "auto_increment" .!= False @@ -216,7 +236,24 @@ instance FromJSON IndexSchema where parseJSON = J.genericParseJSON snakeCaseOptions +data ForeignKey = ForeignKey + { table :: Text + , column :: Text + } deriving (Eq, Generic, Show) -newtype ForeignKey = ForeignKey Text - deriving newtype (Eq, Show, ToJSON, FromJSON) - deriving Generic +instance ToJSON ForeignKey where + toJSON = J.genericToJSON snakeCaseOptions + +instance FromJSON ForeignKey where + parseJSON = J.genericParseJSON snakeCaseOptions + +data Constraint = Constraint + { name :: Text + , check :: Text + } deriving (Eq, Generic, Show) + +instance ToJSON Constraint where + toJSON = J.genericToJSON snakeCaseOptions + +instance FromJSON Constraint where + parseJSON = J.genericParseJSON snakeCaseOptions