module Sqel.Migration.Run where

import Control.Monad (foldM)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import Exon (exon)
import Generics.SOP (All, NP (Nil, (:*)))
import Lens.Micro ((^.))
import qualified Sqel.Class.MigrationEffect as MigrationEffect
import Sqel.Class.MigrationEffect (MigrationEffect (runMigrationStatements))
import Sqel.Data.Migration (
  CompAction,
  CustomMigration (customMigration, customTypeKeys),
  MigExt,
  Migration (Migration),
  MigrationActions (AutoActions, CustomActions),
  Migrations (Migrations),
  TypeAction (AddAction),
  )
import Sqel.Data.PgType (
  ColumnType (ColumnComp, ColumnPrim),
  PgColumns (PgColumns),
  PgComposite (PgComposite),
  PgTable (PgTable),
  )
import Sqel.Data.PgTypeName (
  PgCompName,
  pattern PgOnlyTableName,
  PgTableName,
  pattern PgTableName,
  pattern PgTypeName,
  PgTypeName,
  getPgTypeName,
  )
import Sqel.Data.Sql (Sql)
import Sqel.Statement (tableColumnsSql, typeColumnsSql)

import Sqel.Migration.Init (initTable)
import Sqel.Migration.Metadata (
  DbCols (DbCols),
  TypeStatus (Absent, Match, Mismatch),
  columnMap,
  logType,
  typeColumns,
  typeStatus,
  )
import Sqel.Migration.Statement (typeStatements)

typeMatchWith ::
  Monad m =>
  MigrationEffect m =>
  Text ->
  PgTypeName table ->
  PgColumns ->
  Sql ->
  m TypeStatus
typeMatchWith :: forall (m :: * -> *) (table :: Bool).
(Monad m, MigrationEffect m) =>
Text -> PgTypeName table -> PgColumns -> Sql -> m TypeStatus
typeMatchWith Text
desc PgTypeName table
name (PgColumns [PgColumn]
cols) Sql
code = do
  DbCols
dbCols <- forall (m :: * -> *) (table :: Bool).
(Monad m, MigrationEffect m) =>
Sql -> PgTypeName table -> m DbCols
typeColumns Sql
code PgTypeName table
name
  forall (m :: * -> *).
MigrationEffect m =>
Text -> DbCols -> DbCols -> m ()
logType Text
desc DbCols
dbCols DbCols
colsByName
  pure (DbCols -> DbCols -> TypeStatus
typeStatus DbCols
dbCols DbCols
colsByName)
  where
    colsByName :: DbCols
colsByName = Map PgColumnName (Either PgTypeRef PgPrimName) -> DbCols
DbCols forall a b. (a -> b) -> a -> b
$ [PgColumn] -> Map PgColumnName ColumnType
columnMap [PgColumn]
cols forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      ColumnPrim PgPrimName
n Bool
_ [Sql]
_ -> forall a b. b -> Either a b
Right PgPrimName
n
      ColumnComp PgTypeRef
n Bool
_ [Sql]
_ -> forall a b. a -> Either a b
Left PgTypeRef
n

typeMatch ::
  Monad m =>
  MigrationEffect m =>
  PgComposite ->
  m TypeStatus
typeMatch :: forall (m :: * -> *).
(Monad m, MigrationEffect m) =>
PgComposite -> m TypeStatus
typeMatch (PgComposite PgCompName
name PgColumns
cols) =
  forall (m :: * -> *) (table :: Bool).
(Monad m, MigrationEffect m) =>
Text -> PgTypeName table -> PgColumns -> Sql -> m TypeStatus
typeMatchWith Text
"type" PgCompName
name PgColumns
cols Sql
typeColumnsSql

tableMatch ::
  Monad m =>
  MigrationEffect m =>
  TypeStatus ->
  PgTable a ->
  m TypeStatus
tableMatch :: forall {k} (m :: * -> *) (a :: k).
(Monad m, MigrationEffect m) =>
TypeStatus -> PgTable a -> m TypeStatus
tableMatch TypeStatus
Absent PgTable a
_ =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeStatus
Absent
tableMatch TypeStatus
_ (PgTable PgTableName
name PgColumns
cols Map PgTypeRef PgComposite
_ TableSelectors
_ TableValues
_ PgStructure
_) =
  forall (m :: * -> *) (table :: Bool).
(Monad m, MigrationEffect m) =>
Text -> PgTypeName table -> PgColumns -> Sql -> m TypeStatus
typeMatchWith Text
"table" PgTableName
name PgColumns
cols Sql
tableColumnsSql

matches ::
  Monad m =>
  MigrationEffect m =>
  TypeStatus ->
  PgTable from ->
  m (TypeStatus, Set PgCompName)
matches :: forall {k} (m :: * -> *) (from :: k).
(Monad m, MigrationEffect m) =>
TypeStatus -> PgTable from -> m (TypeStatus, Set PgCompName)
matches TypeStatus
initialStatus PgTable from
table = do
  TypeStatus
tbm <- forall {k} (m :: * -> *) (a :: k).
(Monad m, MigrationEffect m) =>
TypeStatus -> PgTable a -> m TypeStatus
tableMatch TypeStatus
initialStatus PgTable from
table
  Set PgCompName
tym <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {f :: * -> *}.
(MigrationEffect f, Monad f) =>
Set PgCompName -> PgComposite -> f (Set PgCompName)
folder forall a. Set a
Set.empty (PgTable from
table forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "types" a => a
#types)
  pure (TypeStatus
tbm, Set PgCompName
tym)
  where
    folder :: Set PgCompName -> PgComposite -> f (Set PgCompName)
folder Set PgCompName
acc PgComposite
t =
      forall (m :: * -> *).
(Monad m, MigrationEffect m) =>
PgComposite -> m TypeStatus
typeMatch PgComposite
t forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        TypeStatus
Match -> forall a. Ord a => a -> Set a -> Set a
Set.insert (PgComposite
t forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "name" a => a
#name) Set PgCompName
acc
        TypeStatus
_ -> Set PgCompName
acc

runAction ::
  MigrationEffect m =>
  PgTypeName table ->
  TypeAction table ->
  m ()
runAction :: forall (m :: * -> *) (table :: Bool).
MigrationEffect m =>
PgTypeName table -> TypeAction table -> m ()
runAction PgTypeName table
typeName TypeAction table
action =
  forall (m :: * -> *).
MigrationEffect m =>
[MigrationStatement] -> m ()
runMigrationStatements (forall (table :: Bool).
PgTypeName table -> TypeAction table -> [MigrationStatement]
typeStatements PgTypeName table
typeName TypeAction table
action)

-- TODO topo sort the types
runTypesMigration ::
  Monad m =>
  MigrationEffect m =>
  Set PgCompName ->
  Map PgCompName CompAction ->
  m ()
runTypesMigration :: forall (m :: * -> *).
(Monad m, MigrationEffect m) =>
Set PgCompName -> Map PgCompName CompAction -> m ()
runTypesMigration Set PgCompName
eligible Map PgCompName CompAction
actions =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [(k, a)]
Map.toList (forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map PgCompName CompAction
actions Set PgCompName
eligible)) \ (PgCompName
name, CompAction
tpe) ->
    forall (m :: * -> *) (table :: Bool).
MigrationEffect m =>
PgTypeName table -> TypeAction table -> m ()
runAction PgCompName
name CompAction
tpe

runMigration ::
  ∀ mig m .
  Monad m =>
  MigrationEffect m =>
  CustomMigration m mig =>
  TypeStatus ->
  PgTableName ->
  Set PgCompName ->
  MigrationActions (MigExt mig) ->
  m ()
runMigration :: forall (mig :: Mig) (m :: * -> *).
(Monad m, MigrationEffect m, CustomMigration m mig) =>
TypeStatus
-> PgTableName
-> Set PgCompName
-> MigrationActions (MigExt mig)
-> m ()
runMigration TypeStatus
status PgTableName
tableName Set PgCompName
eligible = \case
  AutoActions TableAction
tableAction Map PgCompName CompAction
typeActions -> do
    forall (m :: * -> *). MigrationEffect m => Text -> m ()
MigrationEffect.log [exon|Starting migration for #{getPgTypeName tableName}|]
    forall (m :: * -> *).
(Monad m, MigrationEffect m) =>
Set PgCompName -> Map PgCompName CompAction -> m ()
runTypesMigration Set PgCompName
eligible Map PgCompName CompAction
typeActions
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TypeStatus
status forall a. Eq a => a -> a -> Bool
== TypeStatus
Match) (forall (m :: * -> *) (table :: Bool).
MigrationEffect m =>
PgTypeName table -> TypeAction table -> m ()
runAction PgTableName
tableName TableAction
tableAction)
  CustomActions MigExt mig
actions ->
    forall (m :: * -> *) (mig :: Mig).
CustomMigration m mig =>
PgTableName -> Set PgCompName -> MigExt mig -> m ()
customMigration @m @mig PgTableName
tableName Set PgCompName
eligible MigExt mig
actions

tryRunMigration ::
  ∀ mig m .
  Monad m =>
  MigrationEffect m =>
  CustomMigration m mig =>
  TypeStatus ->
  PgTableName ->
  Set PgCompName ->
  MigrationActions (MigExt mig) ->
  m ()
tryRunMigration :: forall (mig :: Mig) (m :: * -> *).
(Monad m, MigrationEffect m, CustomMigration m mig) =>
TypeStatus
-> PgTableName
-> Set PgCompName
-> MigrationActions (MigExt mig)
-> m ()
tryRunMigration TypeStatus
Mismatch (PgTableName Text
name) Set PgCompName
_ MigrationActions (MigExt mig)
_ =
  forall (m :: * -> *). MigrationEffect m => Text -> m ()
MigrationEffect.error [exon|No migration fits the current table layout for #{name}|]
tryRunMigration TypeStatus
status PgTableName
tableName Set PgCompName
eligible MigrationActions (MigExt mig)
actions =
  forall (mig :: Mig) (m :: * -> *).
(Monad m, MigrationEffect m, CustomMigration m mig) =>
TypeStatus
-> PgTableName
-> Set PgCompName
-> MigrationActions (MigExt mig)
-> m ()
runMigration @mig TypeStatus
status PgTableName
tableName Set PgCompName
eligible MigrationActions (MigExt mig)
actions

autoKeys ::
  Map PgCompName CompAction ->
  Set (PgCompName, Bool)
autoKeys :: Map PgCompName CompAction -> Set (PgCompName, Bool)
autoKeys Map PgCompName CompAction
typeActions =
  forall a. Ord a => [a] -> Set a
Set.fromList (forall k a. Map k a -> [a]
Map.elems (forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey forall {a} {table :: Bool}. a -> TypeAction table -> (a, Bool)
keyAndAddition Map PgCompName CompAction
typeActions))
  where
    keyAndAddition :: a -> TypeAction table -> (a, Bool)
keyAndAddition a
k = \case
      AddAction PgColumns
_ -> (a
k, Bool
True)
      TypeAction table
_ -> (a
k, Bool
False)

typeKeys ::
  ∀ mig m .
  Applicative m =>
  CustomMigration m mig =>
  MigrationActions (MigExt mig) ->
  m (Set (PgCompName, Bool))
typeKeys :: forall (mig :: Mig) (m :: * -> *).
(Applicative m, CustomMigration m mig) =>
MigrationActions (MigExt mig) -> m (Set (PgCompName, Bool))
typeKeys = \case
  AutoActions TableAction
_ Map PgCompName CompAction
typeActions ->
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PgCompName CompAction -> Set (PgCompName, Bool)
autoKeys Map PgCompName CompAction
typeActions)
  CustomActions MigExt mig
actions ->
    forall (m :: * -> *) (mig :: Mig).
CustomMigration m mig =>
MigExt mig -> m (Set (PgCompName, Bool))
customTypeKeys @m @mig MigExt mig
actions

collectDirectMatches :: Set (PgCompName, Bool) -> Set PgCompName -> Set PgCompName
collectDirectMatches :: Set (PgCompName, Bool) -> Set PgCompName -> Set PgCompName
collectDirectMatches Set (PgCompName, Bool)
actions Set PgCompName
curMatches =
  forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PgCompName -> Bool -> Bool
matchAction) (forall a. Set a -> [a]
Set.toList Set (PgCompName, Bool)
actions))
  where
    matchAction :: PgCompName -> Bool -> Bool
matchAction PgCompName
name = \case
      Bool
True -> Bool -> Bool
not (forall a. Ord a => a -> Set a -> Bool
Set.member PgCompName
name Set PgCompName
curMatches)
      Bool
False -> forall a. Ord a => a -> Set a -> Bool
Set.member PgCompName
name Set PgCompName
curMatches

matchMessage :: PgTypeName table -> TypeStatus -> Set PgCompName -> Set PgCompName -> Set PgCompName -> Text
matchMessage :: forall (table :: Bool).
PgTypeName table
-> TypeStatus
-> Set PgCompName
-> Set PgCompName
-> Set PgCompName
-> Text
matchMessage (PgTypeName Text
tableName) TypeStatus
status Set PgCompName
currentMatches Set PgCompName
directMatches Set PgCompName
allMatches =
  [exon|Table #{tableName}: #{show status}
Matching types: #{showNames currentMatches}
Direct action matches: #{showNames directMatches}
All action matches: #{showNames allMatches}
|]
  where
    showNames :: Set (PgTypeName table) -> Text
showNames =
      Text -> [Text] -> Text
Text.intercalate Text
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (PgTypeName Text
name) -> Text
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall a. Set a -> [a]
Set.toList

runMigrationSteps ::
  ∀ m migs a .
  Monad m =>
  MigrationEffect m =>
  All (CustomMigration m) migs =>
  TypeStatus ->
  Set PgCompName ->
  PgTable a ->
  NP Migration migs ->
  m (TypeStatus, Set PgCompName)
runMigrationSteps :: forall {k} (m :: * -> *) (migs :: [Mig]) (a :: k).
(Monad m, MigrationEffect m, All (CustomMigration m) migs) =>
TypeStatus
-> Set PgCompName
-> PgTable a
-> NP Migration migs
-> m (TypeStatus, Set PgCompName)
runMigrationSteps TypeStatus
initialStatus Set PgCompName
_ PgTable a
_ NP Migration migs
Nil =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeStatus
initialStatus, forall a. Monoid a => a
mempty)
runMigrationSteps TypeStatus
initialStatus Set PgCompName
laterMatches PgTable a
table ((Migration PgTable from
currentTable PgTable to
_ MigrationActions ext
actions :: Migration mig) :* NP Migration xs
t) = do
  -- types that are identical in the database and the current migration's from-table
  (TypeStatus
status, Set PgCompName
currentTypeMatches) <- forall {k} (m :: * -> *) (from :: k).
(Monad m, MigrationEffect m) =>
TypeStatus -> PgTable from -> m (TypeStatus, Set PgCompName)
matches TypeStatus
initialStatus PgTable from
currentTable
  Set (PgCompName, Bool)
actionNamesAndAdditions <- forall (mig :: Mig) (m :: * -> *).
(Applicative m, CustomMigration m mig) =>
MigrationActions (MigExt mig) -> m (Set (PgCompName, Bool))
typeKeys @mig @m MigrationActions ext
actions
  let
    actionNames :: Set PgCompName
actionNames = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set (PgCompName, Bool)
actionNamesAndAdditions)
    mismatchHere :: Bool
mismatchHere = TypeStatus
status forall a. Eq a => a -> a -> Bool
== TypeStatus
Mismatch
    -- actions whose types match the database before any migrations are executed.
    -- these cannot be additions, since they are absent from the database if they are applicable.
    -- check whether additions need special treatment, i.e. execute if absent.
    directMatches :: Set PgCompName
directMatches = Set (PgCompName, Bool) -> Set PgCompName -> Set PgCompName
collectDirectMatches Set (PgCompName, Bool)
actionNamesAndAdditions Set PgCompName
currentTypeMatches
    -- actions whose types either match this migration's from-table or that of a later migration.
    allMatches :: Set PgCompName
allMatches = forall a. Ord a => Set a -> Set a -> Set a
Set.union Set PgCompName
directMatches Set PgCompName
laterMatches
  forall (m :: * -> *). MigrationEffect m => Text -> m ()
MigrationEffect.log (forall (table :: Bool).
PgTypeName table
-> TypeStatus
-> Set PgCompName
-> Set PgCompName
-> Set PgCompName
-> Text
matchMessage (PgTable from
currentTable forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "name" a => a
#name) TypeStatus
status Set PgCompName
currentTypeMatches Set PgCompName
directMatches Set PgCompName
allMatches)
  (TypeStatus
newStatus, Set PgCompName
eligible) <-
    -- if actionNames is a subset of allMatches, all actions can be executed either here or in a later migration.
    -- therefore we don't need to check earlier migrations and just execute the direct matches here and relay the rest
    -- to later migrations.
    -- if the current migration's table doesn't match the existing table, we still have to run earlier migrations,
    -- but those don't have to run any type actions.
    -- if the table is absent, earlier migrations don't have to be run, just like a match.
    if Bool -> Bool
not Bool
mismatchHere Bool -> Bool -> Bool
&& forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set PgCompName
actionNames Set PgCompName
allMatches
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeStatus
status, Set PgCompName
directMatches)
    else do
      -- if the table matched in an earlier migration, it will match here as well since the earlier migration
      -- executed.
      -- same for types, so add earlier matches to the direct matches.
      (TypeStatus
earlierStatus, Set PgCompName
earlierMatches) <- forall {k} (m :: * -> *) (migs :: [Mig]) (a :: k).
(Monad m, MigrationEffect m, All (CustomMigration m) migs) =>
TypeStatus
-> Set PgCompName
-> PgTable a
-> NP Migration migs
-> m (TypeStatus, Set PgCompName)
runMigrationSteps TypeStatus
status Set PgCompName
allMatches PgTable a
table NP Migration xs
t
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeStatus
earlierStatus, forall a. Ord a => Set a -> Set a -> Set a
Set.union Set PgCompName
earlierMatches Set PgCompName
directMatches)
  forall (mig :: Mig) (m :: * -> *).
(Monad m, MigrationEffect m, CustomMigration m mig) =>
TypeStatus
-> PgTableName
-> Set PgCompName
-> MigrationActions (MigExt mig)
-> m ()
runMigration @mig TypeStatus
newStatus (PgTable a
table forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "name" a => a
#name) Set PgCompName
eligible MigrationActions ext
actions
  pure (TypeStatus
newStatus, Set PgCompName
eligible)

createAbsent ::
  Monad m =>
  MigrationEffect m =>
  PgTable a ->
  TypeStatus ->
  m ()
createAbsent :: forall {k} (m :: * -> *) (a :: k).
(Monad m, MigrationEffect m) =>
PgTable a -> TypeStatus -> m ()
createAbsent PgTable a
table = \case
  TypeStatus
Absent -> forall {k} (m :: * -> *) (a :: k).
(Monad m, MigrationEffect m) =>
PgTable a -> m ()
initTable PgTable a
table
  TypeStatus
_ -> forall (f :: * -> *). Applicative f => f ()
unit

runMigrations ::
  ∀ m migs a .
  Monad m =>
  MigrationEffect m =>
  All (CustomMigration m) migs =>
  PgTable a ->
  Migrations m migs ->
  m ()
runMigrations :: forall {k} (m :: * -> *) (migs :: [Mig]) (a :: k).
(Monad m, MigrationEffect m, All (CustomMigration m) migs) =>
PgTable a -> Migrations m migs -> m ()
runMigrations PgTable a
table (Migrations NP Migration migs
steps) = do
  forall (m :: * -> *). MigrationEffect m => Text -> m ()
MigrationEffect.log [exon|Checking migrations for '#{name}'|]
  TypeStatus
initialStatus <- forall {k} (m :: * -> *) (a :: k).
(Monad m, MigrationEffect m) =>
TypeStatus -> PgTable a -> m TypeStatus
tableMatch TypeStatus
Mismatch PgTable a
table
  (TypeStatus
status, Set PgCompName
_) <- forall {k} (m :: * -> *) (migs :: [Mig]) (a :: k).
(Monad m, MigrationEffect m, All (CustomMigration m) migs) =>
TypeStatus
-> Set PgCompName
-> PgTable a
-> NP Migration migs
-> m (TypeStatus, Set PgCompName)
runMigrationSteps TypeStatus
initialStatus forall a. Monoid a => a
mempty PgTable a
table NP Migration migs
steps
  forall (m :: * -> *). MigrationEffect m => Text -> m ()
MigrationEffect.log [exon|Migrations for '#{name}' concluded with #{show status}|]
  forall {k} (m :: * -> *) (a :: k).
(Monad m, MigrationEffect m) =>
PgTable a -> TypeStatus -> m ()
createAbsent PgTable a
table TypeStatus
status
  where
    PgOnlyTableName Text
name = PgTable a
table forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "name" a => a
#name