packages feed

rds-data 0.0.0.5 → 0.0.0.6

raw patch · 4 files changed

+272/−31 lines, 4 files

Files

integration/Test/Data/RdsData/Migration/ConnectionSpec.hs view
@@ -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
polysemy/Data/RdsData/Polysemy/Migration.hs view
@@ -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")))
rds-data.cabal view
@@ -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
src/Data/RdsData/Migration/Types.hs view
@@ -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