rds-data 0.0.0.6 → 0.0.0.7
raw patch · 4 files changed
+109/−46 lines, 4 files
Files
- integration/Test/Data/RdsData/Migration/ConnectionSpec.hs +2/−17
- polysemy/Data/RdsData/Polysemy/Migration.hs +44/−3
- rds-data.cabal +1/−1
- src/Data/RdsData/Migration/Types.hs +62/−25
integration/Test/Data/RdsData/Migration/ConnectionSpec.hs view
@@ -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
polysemy/Data/RdsData/Polysemy/Migration.hs view
@@ -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"+ , ")"+ ]
rds-data.cabal view
@@ -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
src/Data/RdsData/Migration/Types.hs view
@@ -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