module Sqel.Migration.Metadata where import qualified Data.Map.Strict as Map import Exon (exon) import Prettyprinter (Pretty, pretty, vsep, (<+>)) import qualified Sqel.Class.MigrationEffect as MigrationEffect import Sqel.Class.MigrationEffect (MigrationEffect) import qualified Sqel.Data.PgType as PgType import Sqel.Data.PgType ( ColumnType, PgColumn (PgColumn), PgColumnName (PgColumnName), PgPrimName (PgPrimName), PgTypeRef (PgTypeRef), ) import Sqel.Data.PgTypeName (PgTableName, pattern PgTypeName, PgTypeName) import Sqel.Data.Sql (Sql) import qualified Sqel.Statement as Statement import Sqel.Statement (tableColumnsSql) newtype DbCols = DbCols { DbCols -> Map PgColumnName (Either PgTypeRef PgPrimName) unDbCols :: Map PgColumnName (Either PgTypeRef PgPrimName) } deriving stock (DbCols -> DbCols -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: DbCols -> DbCols -> Bool $c/= :: DbCols -> DbCols -> Bool == :: DbCols -> DbCols -> Bool $c== :: DbCols -> DbCols -> Bool Eq, Int -> DbCols -> ShowS [DbCols] -> ShowS DbCols -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [DbCols] -> ShowS $cshowList :: [DbCols] -> ShowS show :: DbCols -> String $cshow :: DbCols -> String showsPrec :: Int -> DbCols -> ShowS $cshowsPrec :: Int -> DbCols -> ShowS Show, forall x. Rep DbCols x -> DbCols forall x. DbCols -> Rep DbCols x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep DbCols x -> DbCols $cfrom :: forall x. DbCols -> Rep DbCols x Generic) newtype PrettyColMap = PrettyColMap { PrettyColMap -> DbCols unPrettyColMap :: DbCols } deriving stock (PrettyColMap -> PrettyColMap -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: PrettyColMap -> PrettyColMap -> Bool $c/= :: PrettyColMap -> PrettyColMap -> Bool == :: PrettyColMap -> PrettyColMap -> Bool $c== :: PrettyColMap -> PrettyColMap -> Bool Eq, Int -> PrettyColMap -> ShowS [PrettyColMap] -> ShowS PrettyColMap -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [PrettyColMap] -> ShowS $cshowList :: [PrettyColMap] -> ShowS show :: PrettyColMap -> String $cshow :: PrettyColMap -> String showsPrec :: Int -> PrettyColMap -> ShowS $cshowsPrec :: Int -> PrettyColMap -> ShowS Show, forall x. Rep PrettyColMap x -> PrettyColMap forall x. PrettyColMap -> Rep PrettyColMap x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep PrettyColMap x -> PrettyColMap $cfrom :: forall x. PrettyColMap -> Rep PrettyColMap x Generic) instance Pretty PrettyColMap where pretty :: forall ann. PrettyColMap -> Doc ann pretty (PrettyColMap (DbCols Map PgColumnName (Either PgTypeRef PgPrimName) cols)) = forall ann. [Doc ann] -> Doc ann vsep (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry forall {a} {a} {a} {ann}. (Pretty a, Pretty a, Pretty a) => a -> Either a a -> Doc ann col forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall k a. Map k a -> [(k, a)] Map.toList Map PgColumnName (Either PgTypeRef PgPrimName) cols) where col :: a -> Either a a -> Doc ann col a name = \case Right a tpe -> Doc ann "*" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty a name forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty a tpe Left a ref -> Doc ann "+" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty a name forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty a ref typeColumns :: Monad m => MigrationEffect m => Sql -> PgTypeName table -> m DbCols typeColumns :: forall (m :: * -> *) (table :: Bool). (Monad m, MigrationEffect m) => Sql -> PgTypeName table -> m DbCols typeColumns Sql code (PgTypeName Text name) = do [(PgColumnName, Either PgTypeRef PgPrimName)] cols <- forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (Text, Text, Text, Maybe Text) -> m (PgColumnName, Either PgTypeRef PgPrimName) mktype forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *) q a. MigrationEffect m => q -> Statement q [a] -> m [a] MigrationEffect.runStatement Text name (Sql -> Statement Text [(Text, Text, Text, Maybe Text)] Statement.dbColumns Sql code) pure (Map PgColumnName (Either PgTypeRef PgPrimName) -> DbCols DbCols (forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [(PgColumnName, Either PgTypeRef PgPrimName)] cols)) where mktype :: (Text, Text, Text, Maybe Text) -> m (PgColumnName, Either PgTypeRef PgPrimName) mktype = \case (Text col, Text "USER-DEFINED", Text n, Maybe Text _) -> forall (f :: * -> *) a. Applicative f => a -> f a pure (Text -> PgColumnName PgColumnName Text col, forall a b. a -> Either a b Left (Text -> PgTypeRef PgTypeRef Text n)) (Text col, Text "ARRAY", Text _, Just Text n) -> forall (f :: * -> *) a. Applicative f => a -> f a pure (Text -> PgColumnName PgColumnName Text col, forall a b. b -> Either a b Right (Text -> PgPrimName PgPrimName [exon|#{n}[]|])) (Text col, Text n, Text _, Maybe Text Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a pure (Text -> PgColumnName PgColumnName Text col, forall a b. b -> Either a b Right (Text -> PgPrimName PgPrimName Text n)) (Text col, Text n, Text _, Just Text e) -> do forall (m :: * -> *). MigrationEffect m => Text -> m () MigrationEffect.error [exon|Error: non-array column with element type: ##{n} | ##{e}|] pure (Text -> PgColumnName PgColumnName Text col, forall a b. b -> Either a b Right (Text -> PgPrimName PgPrimName Text n)) tableColumns :: Monad m => MigrationEffect m => PgTableName -> m DbCols tableColumns :: forall (m :: * -> *). (Monad m, MigrationEffect m) => PgTableName -> m DbCols tableColumns = forall (m :: * -> *) (table :: Bool). (Monad m, MigrationEffect m) => Sql -> PgTypeName table -> m DbCols typeColumns Sql tableColumnsSql columnMap :: [PgColumn] -> Map PgColumnName ColumnType columnMap :: [PgColumn] -> Map PgColumnName ColumnType columnMap = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap \ PgColumn {PgColumnName $sel:name:PgColumn :: PgColumn -> PgColumnName name :: PgColumnName name, ColumnType $sel:pgType:PgColumn :: PgColumn -> ColumnType pgType :: ColumnType pgType} -> (PgColumnName name, ColumnType pgType) logType :: MigrationEffect m => Text -> DbCols -> DbCols -> m () logType :: forall (m :: * -> *). MigrationEffect m => Text -> DbCols -> DbCols -> m () logType Text desc DbCols dbCols DbCols colsByName = forall (m :: * -> *). MigrationEffect m => Text -> m () MigrationEffect.log [exon|Trying #{desc} with: #{show (pretty (PrettyColMap colsByName))} for existing #{desc} with #{show (pretty (PrettyColMap dbCols))}|] data TypeStatus = Absent | Mismatch | Match deriving stock (TypeStatus -> TypeStatus -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: TypeStatus -> TypeStatus -> Bool $c/= :: TypeStatus -> TypeStatus -> Bool == :: TypeStatus -> TypeStatus -> Bool $c== :: TypeStatus -> TypeStatus -> Bool Eq, Int -> TypeStatus -> ShowS [TypeStatus] -> ShowS TypeStatus -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TypeStatus] -> ShowS $cshowList :: [TypeStatus] -> ShowS show :: TypeStatus -> String $cshow :: TypeStatus -> String showsPrec :: Int -> TypeStatus -> ShowS $cshowsPrec :: Int -> TypeStatus -> ShowS Show, forall x. Rep TypeStatus x -> TypeStatus forall x. TypeStatus -> Rep TypeStatus x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep TypeStatus x -> TypeStatus $cfrom :: forall x. TypeStatus -> Rep TypeStatus x Generic) typeStatus :: DbCols -> DbCols -> TypeStatus typeStatus :: DbCols -> DbCols -> TypeStatus typeStatus (DbCols Map PgColumnName (Either PgTypeRef PgPrimName) dbCols) (DbCols Map PgColumnName (Either PgTypeRef PgPrimName) colByName) | forall k a. Map k a -> Bool Map.null Map PgColumnName (Either PgTypeRef PgPrimName) dbCols = TypeStatus Absent | Map PgColumnName (Either PgTypeRef PgPrimName) dbCols forall a. Eq a => a -> a -> Bool == Map PgColumnName (Either PgTypeRef PgPrimName) colByName = TypeStatus Match | Bool otherwise = TypeStatus Mismatch