{-# LANGUAGE DataKinds #-}

-- | uses Postgres migration to run all found
--   migrations in a transaction.
--   then use persistent to check if the persistent
--   model aligns with what's in the database.
module PostgreSQL.Migration.Persistent
  ( runMigrations,
    PMMigrationResult (..),

    -- * options
    defaultOptions,
    PersistentMigrationOptions (..),
  )
where

import qualified Data.Text.Encoding as Text
import qualified Data.Text as Text
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ReaderT (..), asks)
import Data.Pool (Pool)
import Data.Text (Text)
import Database.Persist.Postgresql (getSimpleConn, runSqlPool)
import Database.Persist.Sql (Migration, SqlBackend, showMigration)
import Database.PostgreSQL.Simple (Connection, rollback)
import Database.PostgreSQL.Simple.Migration qualified as Migration
import Database.PostgreSQL.Simple.Util qualified as Migration
import Prelude

-- | recommended default options for production settnigs
defaultOptions ::
  -- | migrations folder, for exmaple "migrations/up"
  FilePath ->
  -- | the logging options, for example
  --
  -- @
  --    (\\case
  --       Left errmsg -> runInIO $ $logTM AlertS $ logStr errmsg
  --       Right infoMsg -> runInIO $ $logTM InfoS $ logStr infoMsg)
  -- @
  (Either Text Text -> IO ()) ->
  PersistentMigrationOptions
defaultOptions :: FilePath
-> (Either Text Text -> IO ()) -> PersistentMigrationOptions
defaultOptions FilePath
filepath Either Text Text -> IO ()
logMsgs =
  PersistentMigrationOptions
    { pmoMigrationOptions :: MigrationOptions
pmoMigrationOptions =
        MigrationOptions
Migration.defaultOptions
          { Migration.optVerbose = Migration.Verbose,
            Migration.optLogWriter = logMsgs,
            -- NB we do the transaction around the entire thing
            Migration.optTransactionControl = Migration.NoNewTransaction
          },
      pmoMigrationSource :: MigrationCommand
pmoMigrationSource = FilePath -> MigrationCommand
Migration.MigrationDirectory FilePath
filepath
    }

-- | The result of the postgresql-migration operation.
data PMMigrationResult
  = MigrationConsistent
  | -- | rollback due to persistent inconsistencies
    MigrationRollbackDueTo [Text]
  | -- | some error from the postgres migration libraries
    MigrationLibraryError String
  | -- | caused by 'getSimpleConn' returning 'Nothing'
    MigrationNotBackedByPg
  deriving stock (Int -> PMMigrationResult -> ShowS
[PMMigrationResult] -> ShowS
PMMigrationResult -> FilePath
(Int -> PMMigrationResult -> ShowS)
-> (PMMigrationResult -> FilePath)
-> ([PMMigrationResult] -> ShowS)
-> Show PMMigrationResult
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PMMigrationResult -> ShowS
showsPrec :: Int -> PMMigrationResult -> ShowS
$cshow :: PMMigrationResult -> FilePath
show :: PMMigrationResult -> FilePath
$cshowList :: [PMMigrationResult] -> ShowS
showList :: [PMMigrationResult] -> ShowS
Show, PMMigrationResult -> PMMigrationResult -> Bool
(PMMigrationResult -> PMMigrationResult -> Bool)
-> (PMMigrationResult -> PMMigrationResult -> Bool)
-> Eq PMMigrationResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PMMigrationResult -> PMMigrationResult -> Bool
== :: PMMigrationResult -> PMMigrationResult -> Bool
$c/= :: PMMigrationResult -> PMMigrationResult -> Bool
/= :: PMMigrationResult -> PMMigrationResult -> Bool
Eq)

-- | Usually created with 'defaultOptions'
data PersistentMigrationOptions = PersistentMigrationOptions
  { PersistentMigrationOptions -> MigrationOptions
pmoMigrationOptions :: Migration.MigrationOptions,
    -- | by default this is set to load a folder with 'Migration.MigrationDirectory'.
    --   but certain poeple had trouble with that as it includes all files.
    --   so with this option you can make your own directory parsing
    --   and just put the command(s) in here.
    --   note 'Migration.MigrationCommands'.
    PersistentMigrationOptions -> MigrationCommand
pmoMigrationSource :: Migration.MigrationCommand
  }

-- | Run the given migrations in a single transaction.  If the migration fails
-- somehow the transaction is rolled back.
runMigrations ::
  -- | eg 'defaultOptions'
  PersistentMigrationOptions ->
  -- | the Automatic migration. usually made with 'Database.Persist.TH.migrateModels' and 'Database.Persist.TH.discoverEntities' (as splice).
  --
  -- @
  --    migrateAll :: Migration
  --    migrateAll = migrateModels $(discoverEntities)
  -- @
  Migration ->
  -- | sql pool, created with for example 'Database.Persist.Postgresql.withPostgresqlPool'.
  Pool SqlBackend ->
  IO PMMigrationResult
runMigrations :: PersistentMigrationOptions
-> Migration -> Pool SqlBackend -> IO PMMigrationResult
runMigrations PersistentMigrationOptions
config Migration
migrateAll Pool SqlBackend
pool =
  (ReaderT SqlBackend IO PMMigrationResult
 -> Pool SqlBackend -> IO PMMigrationResult)
-> Pool SqlBackend
-> ReaderT SqlBackend IO PMMigrationResult
-> IO PMMigrationResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT SqlBackend IO PMMigrationResult
-> Pool SqlBackend -> IO PMMigrationResult
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool Pool SqlBackend
pool (ReaderT SqlBackend IO PMMigrationResult -> IO PMMigrationResult)
-> ReaderT SqlBackend IO PMMigrationResult -> IO PMMigrationResult
forall a b. (a -> b) -> a -> b
$ do
    (SqlBackend -> Maybe Connection)
-> ReaderT SqlBackend IO (Maybe Connection)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SqlBackend -> Maybe Connection
forall backend.
BackendCompatible SqlBackend backend =>
backend -> Maybe Connection
getSimpleConn ReaderT SqlBackend IO (Maybe Connection)
-> (Maybe Connection -> ReaderT SqlBackend IO PMMigrationResult)
-> ReaderT SqlBackend IO PMMigrationResult
forall a b.
ReaderT SqlBackend IO a
-> (a -> ReaderT SqlBackend IO b) -> ReaderT SqlBackend IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Connection
Nothing -> PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult
forall a. a -> ReaderT SqlBackend IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult)
-> PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult
forall a b. (a -> b) -> a -> b
$ PMMigrationResult
MigrationNotBackedByPg
      Just Connection
conn -> do
        MigrationResult FilePath
result <- PersistentMigrationOptions
-> Connection -> ReaderT SqlBackend IO (MigrationResult FilePath)
runMigrationCommands PersistentMigrationOptions
config Connection
conn
        case MigrationResult FilePath
result of
          Migration.MigrationError FilePath
err ->
            PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult
forall a. a -> ReaderT SqlBackend IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult)
-> PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult
forall a b. (a -> b) -> a -> b
$ FilePath -> PMMigrationResult
MigrationLibraryError FilePath
err
          MigrationResult FilePath
Migration.MigrationSuccess ->
            Migration -> ReaderT SqlBackend IO PMMigrationResult
assertPersistentConsistency Migration
migrateAll ReaderT SqlBackend IO PMMigrationResult
-> (PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult)
-> ReaderT SqlBackend IO PMMigrationResult
forall a b.
ReaderT SqlBackend IO a
-> (a -> ReaderT SqlBackend IO b) -> ReaderT SqlBackend IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              PMMigrationResult
MigrationConsistent -> PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult
forall a. a -> ReaderT SqlBackend IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PMMigrationResult
MigrationConsistent
              PMMigrationResult
failure -> IO PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult
forall a. IO a -> ReaderT SqlBackend IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult)
-> IO PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult
forall a b. (a -> b) -> a -> b
$ PMMigrationResult
failure PMMigrationResult -> IO () -> IO PMMigrationResult
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Connection -> IO ()
rollback Connection
conn

runMigrationCommands :: PersistentMigrationOptions -> Connection -> ReaderT SqlBackend IO (Migration.MigrationResult String)
runMigrationCommands :: PersistentMigrationOptions
-> Connection -> ReaderT SqlBackend IO (MigrationResult FilePath)
runMigrationCommands PersistentMigrationOptions
options Connection
conn = do
  Bool
initialized <- IO Bool -> ReaderT SqlBackend IO Bool
forall a. IO a -> ReaderT SqlBackend IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT SqlBackend IO Bool)
-> IO Bool -> ReaderT SqlBackend IO Bool
forall a b. (a -> b) -> a -> b
$ Connection -> FilePath -> IO Bool
Migration.existsTable Connection
conn (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> ByteString
Migration.optTableName (MigrationOptions -> ByteString) -> MigrationOptions -> ByteString
forall a b. (a -> b) -> a -> b
$ PersistentMigrationOptions -> MigrationOptions
pmoMigrationOptions PersistentMigrationOptions
options
  let migrations :: [MigrationCommand]
migrations =
        if Bool
initialized
          then [PersistentMigrationOptions -> MigrationCommand
pmoMigrationSource PersistentMigrationOptions
options]
          else [MigrationCommand
Migration.MigrationInitialization, PersistentMigrationOptions -> MigrationCommand
pmoMigrationSource PersistentMigrationOptions
options]
  IO (MigrationResult FilePath)
-> ReaderT SqlBackend IO (MigrationResult FilePath)
forall a. IO a -> ReaderT SqlBackend IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MigrationResult FilePath)
 -> ReaderT SqlBackend IO (MigrationResult FilePath))
-> IO (MigrationResult FilePath)
-> ReaderT SqlBackend IO (MigrationResult FilePath)
forall a b. (a -> b) -> a -> b
$ Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult FilePath)
Migration.runMigrations Connection
conn (PersistentMigrationOptions -> MigrationOptions
pmoMigrationOptions PersistentMigrationOptions
options) [MigrationCommand]
migrations

assertPersistentConsistency :: Migration -> ReaderT SqlBackend IO PMMigrationResult
assertPersistentConsistency :: Migration -> ReaderT SqlBackend IO PMMigrationResult
assertPersistentConsistency Migration
migrateAll = do
  [Text]
persistentAutoMig <- Migration -> ReaderT SqlBackend IO [Text]
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m [Text]
showMigration Migration
migrateAll
  if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
persistentAutoMig
    then PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult
forall a. a -> ReaderT SqlBackend IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PMMigrationResult
MigrationConsistent
    else do
      PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult
forall a. a -> ReaderT SqlBackend IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult)
-> PMMigrationResult -> ReaderT SqlBackend IO PMMigrationResult
forall a b. (a -> b) -> a -> b
$ [Text] -> PMMigrationResult
MigrationRollbackDueTo [Text]
persistentAutoMig