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 @@ -78,6 +78,21 @@ 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 === [] + migrateDown "db/migration.yaml" & trapFail @AWS.Error & trapFail @IOException 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 @@ -1,9 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{- HLINT ignore "Use let" -} + module Data.RdsData.Polysemy.Migration ( migrateDown, migrateUp, @@ -14,6 +17,7 @@ import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as LBS import Data.Generics.Product.Any +import qualified Data.List as L import Data.RdsData.Aws import Data.RdsData.Migration.Types hiding (id) import Data.RdsData.Polysemy.Core @@ -42,15 +46,39 @@ migrateDown migrationFp = do value :: Migration <- readYamlFile migrationFp - let statements = value ^.. the @"plan" . to reverse . each . the @"down" . each + let theSteps = value ^.. the @"plan" . to reverse . each . the @"steps" . _Just . to reverse . each - forM_ statements $ \statement -> do - info $ "Executing statement: " <> tshow statement + forM_ theSteps $ \case + StepOfDown downStep -> do + info $ "Executing statement: " <> tshow downStep - response <- executeStatement (statement ^. the @1) + let statement = downStep ^. the @"down" . the @1 - info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + response <- executeStatement statement + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + StepOfUp _ -> pure () + StepOfCreateTable createTableStatement -> do + statement <- pure $ mconcat + [ "DROP TABLE " <> createTableStatement ^. the @"createTable" . the @"name" + ] + + info $ "Executing statement: " <> statement + + response <- executeStatement statement + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + StepOfCreateIndex createIndexStatement -> do + statement <- pure $ mconcat + [ "DROP INDEX " <> createIndexStatement ^. the @"createIndex" . the @"name" + ] + + info $ "Executing statement: " <> statement + + response <- executeStatement statement + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + migrateUp :: () => Member (DataLog AwsLogEntry) r => Member (Embed IO) r @@ -68,11 +96,47 @@ migrateUp migrationFp = do value :: Migration <- readYamlFile migrationFp - let statements = value ^.. the @"plan" . each . the @"up" . each + let theSteps = value ^.. the @"plan" . each . the @"steps" . _Just . each - forM_ statements $ \statement -> do - info $ "Executing statement: " <> tshow statement + forM_ theSteps $ \case + StepOfUp upStep -> do + info $ "Executing statement: " <> tshow upStep - response <- executeStatement (statement ^. the @1) + let statement = upStep ^. the @"up" . the @1 - info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + response <- executeStatement statement + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + StepOfDown _ -> pure () + StepOfCreateTable createTableStatement -> do + columnClauses <- pure $ + createTableStatement ^.. the @"createTable" . the @"columns" . each . to \column -> + column ^. the @"name" <> " " <> column ^. the @"type_" + + statement <- pure $ mconcat + [ "CREATE TABLE " <> createTableStatement ^. the @"createTable" . the @"name" <> " (" + , mconcat $ L.intersperse ", " columnClauses + , ");\n" + ] + + info $ "Executing create table statement: " <> statement + + response <- executeStatement statement + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + StepOfCreateIndex createIndexStatement -> do + columnClauses <- pure $ + createIndexStatement ^.. the @"createIndex" . the @"columns" . each + + statement <- pure $ mconcat + [ "CREATE INDEX " <> createIndexStatement ^. the @"createIndex" . the @"name" + , " ON " <> createIndexStatement ^. the @"createIndex" . the @"table" <> " (" + , mconcat $ L.intersperse ", " columnClauses + , ");\n" + ] + + info $ "Executing create index statement: " <> statement + + response <- executeStatement statement + + 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.5 +version: 0.0.0.6 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 @@ -1,27 +1,57 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{- HLINT ignore "Use let" -} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Data.RdsData.Migration.Types ( MigrationRow(..), RdsClusterDetails(..), Migration(..), + Delta(..), Step(..), Statement(..), + CreateTableStep(..), + TableSchema(..), + Column(..), + ForeignKey(..), ) where -import Amazonka.Data (FromJSON, ToJSON) -import qualified Amazonka.RDS as AWS -import qualified Amazonka.SecretsManager as AWS -import Data.RdsData.Orphans () -import Data.Text (Text) +import Amazonka.Data (FromJSON, ToJSON, (.!=), (.:), + (.:?), (.=)) +import qualified Amazonka.RDS as AWS +import qualified Amazonka.SecretsManager as AWS +import Control.Applicative +import qualified Data.Aeson as J +import Data.Bool +import Data.Char (isAsciiUpper, toLower) +import Data.Generics.Product.Any +import Data.Maybe +import Data.RdsData.Orphans () +import Data.Text (Text) import Data.Time -import Data.ULID (ULID) +import Data.ULID (ULID) import GHC.Generics +import Lens.Micro +-- Helper to transform field names to snake_case +snakeCaseOptions :: J.Options +snakeCaseOptions = J.defaultOptions { J.fieldLabelModifier = camelToSnake } + +-- Helper function to convert camelCase to snake_case +camelToSnake :: String -> String +camelToSnake [] = [] +camelToSnake (x:xs) = toLower x : go xs + where + go [] = [] + go "_" = [] + go (y:ys) + | isAsciiUpper y = '_' : toLower y : go ys + | otherwise = y : go ys + data MigrationRow = MigrationRow { uuid :: ULID , createdBy :: UTCTime @@ -35,26 +65,158 @@ data Migration = Migration { description :: Text - , plan :: [Step] - } - deriving (Eq, Generic, Show) + , plan :: [Delta] + } deriving (Eq, Generic, Show) -instance ToJSON Migration +instance ToJSON Migration where + toJSON = J.genericToJSON snakeCaseOptions -instance FromJSON Migration +instance FromJSON Migration where + parseJSON = J.genericParseJSON snakeCaseOptions -data Step = Step +data Delta = Delta { id :: ULID , description :: Text - , up :: [Statement] - , down :: [Statement] - } - deriving (Eq, Generic, Show) + , steps :: Maybe [Step] + } deriving (Eq, Generic, Show) -instance ToJSON Step +instance ToJSON Delta where + toJSON = J.genericToJSON snakeCaseOptions -instance FromJSON Step +instance FromJSON Delta where + parseJSON = J.genericParseJSON snakeCaseOptions +data Step = + StepOfUp UpStep + | StepOfDown DownStep + | StepOfCreateTable CreateTableStep + | StepOfCreateIndex CreateIndexStep + deriving (Eq, Show) + +instance ToJSON Step where + toJSON = \case + StepOfUp step -> J.toJSON step + StepOfDown step -> J.toJSON step + StepOfCreateTable table -> J.toJSON table + StepOfCreateIndex index -> J.toJSON index + +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 + ] + +newtype UpStep = UpStep + { up :: Statement + } deriving (Eq, Generic, Show) + +instance ToJSON UpStep where + toJSON = J.genericToJSON snakeCaseOptions + +instance FromJSON UpStep where + parseJSON = J.genericParseJSON snakeCaseOptions + +newtype DownStep = DownStep + { down :: Statement + } deriving (Eq, Generic, Show) + +instance ToJSON DownStep where + toJSON = J.genericToJSON snakeCaseOptions + +instance FromJSON DownStep where + parseJSON = J.genericParseJSON snakeCaseOptions + newtype Statement = Statement Text deriving (Eq, Generic, Show) deriving newtype (ToJSON, FromJSON) + +newtype CreateTableStep = CreateTableStep + { createTable :: TableSchema + } deriving (Eq, Generic, Show) + +instance ToJSON CreateTableStep where + toJSON = J.genericToJSON snakeCaseOptions + +instance FromJSON CreateTableStep where + parseJSON = J.genericParseJSON snakeCaseOptions + +newtype CreateIndexStep = CreateIndexStep + { createIndex :: IndexSchema + } deriving (Eq, Generic, Show) + +instance ToJSON CreateIndexStep where + toJSON = J.genericToJSON snakeCaseOptions + +instance FromJSON CreateIndexStep where + parseJSON = J.genericParseJSON snakeCaseOptions + +data TableSchema = TableSchema + { name :: Text + , columns :: [Column] + } deriving (Eq, Generic, Show) + +instance ToJSON TableSchema where + toJSON = J.genericToJSON snakeCaseOptions + +instance FromJSON TableSchema where + parseJSON = J.genericParseJSON snakeCaseOptions + +data Column = Column + { name :: Text + , type_ :: Text + , nullable :: Bool + , primaryKey :: Bool + , unique :: Bool + , autoIncrement :: Bool + , references :: Maybe ForeignKey + } deriving (Eq, Generic, Show) + +instance ToJSON Column where + toJSON column = + 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 + ] + +(.=?) :: (J.KeyValue e kv, ToJSON v) => J.Key -> Maybe v -> Maybe kv +(.=?) k mv = + case mv of + Just v -> Just $ k .= v + Nothing -> Nothing + +instance FromJSON Column where + parseJSON = J.withObject "Column" $ \v -> + Column + <$> v .: "name" + <*> v .: "type" + <*> v .:? "nullable" .!= False + <*> v .:? "primary_key" .!= False + <*> v .:? "unique" .!= False + <*> v .:? "auto_increment" .!= False + <*> v .:? "references" + +data IndexSchema = IndexSchema + { name :: Text + , table :: Text + , columns :: [Text] + } deriving (Eq, Generic, Show) + +instance ToJSON IndexSchema where + toJSON = J.genericToJSON snakeCaseOptions + +instance FromJSON IndexSchema where + parseJSON = J.genericParseJSON snakeCaseOptions + + +newtype ForeignKey = ForeignKey Text + deriving newtype (Eq, Show, ToJSON, FromJSON) + deriving Generic