{-# LANGUAGE Arrows #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Refurb.Run.Migrate where

import ClassyPrelude hiding ((</>), defaultTimeLocale, getCurrentTime, formatTime)
import Composite.Record (Record, pattern (:*:), pattern RNil)
import Control.Arrow (returnA)
import Control.Monad.Base (liftBase)
import Control.Monad.Logger (askLoggerIO, runLoggingT)
import Control.Lens (each, toListOf, view)
import Data.AffineSpace ((.-.))
import qualified Data.DList as DL
#if MIN_VERSION_these(1,0,0)
import Data.These.Lens (_This)
#else
import Data.These (_This)
#endif
import Data.Thyme.Clock (NominalDiffTime, getCurrentTime, toSeconds)
import Data.Thyme.Format (formatTime)
import Data.Thyme.Format.Human (humanTimeDiff)
import Data.Thyme.Time.Core (fromThyme)
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.Types as PG
import Language.Haskell.TH (Loc, loc_package, loc_module, loc_filename, loc_start)
import Opaleye (Insert (Insert), rCount, runInsert, toFields)
import Refurb.Cli (GoNoGo(GoNoGo), PreMigrationBackup(PreMigrationBackup), InstallSeedData(InstallSeedData))
import Refurb.MigrationUtils (doesSchemaExist)
import Refurb.Run.Backup (backup)
import Refurb.Run.Internal (MonadRefurb, contextDbConn, contextMigrations, optionallyColoredM)
import Refurb.Store (MigrationLogW, MigrationLogColsW, MigrationResult(MigrationSuccess, MigrationFailure), migrationLog, isProdSystem, readMigrationStatus)
import Refurb.Types (Migration, migrationQualifiedKey, migrationSchema, migrationType, migrationCheck, migrationExecute, MigrationType(MigrationSchema))
import System.Exit (exitFailure)
import System.Locale (defaultTimeLocale)
import System.Log.FastLogger (LogStr, fromLogStr, toLogStr)
import Text.PrettyPrint.ANSI.Leijen (Doc, (</>), (<+>), hang, fillSep, red, green, white, text)

-- |Helper which produces the standard prefix 'Doc' for a given migration: @migration key: @ with color.
migrationPrefixDoc :: Migration -> Doc
migrationPrefixDoc :: Migration -> Doc
migrationPrefixDoc Migration
migration = Doc -> Doc
white (String -> Doc
text (String -> Doc) -> (Migration -> String) -> Migration -> Doc
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack (Text -> String) -> (Migration -> Text) -> Migration -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Migration -> Text
migrationQualifiedKey (Migration -> Doc) -> Migration -> Doc
forall a b. (a -> b) -> a -> b
$ Migration
migration) Doc -> Doc -> Doc
forall m. Monoid m => m -> m -> m
++ String -> Doc
text String
":"

-- |Implement the @migrate@ command by verifying that seed data is only applied to non-production databases, reading the migration status, and determining
-- from that status which migrations to apply. If the user requested execution of migrations, delegate to 'applyMigrations' to actually do the work.
migrate :: (MonadUnliftIO m, MonadRefurb m) => GoNoGo -> Maybe PreMigrationBackup -> InstallSeedData -> m ()
migrate :: GoNoGo -> Maybe PreMigrationBackup -> InstallSeedData -> m ()
migrate (GoNoGo Bool
isGo) Maybe PreMigrationBackup
backupMay (InstallSeedData Bool
shouldInstallSeedData) = do
  Doc -> m ()
disp <- m (Doc -> m ())
forall (m :: * -> *). MonadRefurb m => m (Doc -> m ())
optionallyColoredM
  Connection
dbConn <- (Context -> Connection) -> m Connection
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> Connection
contextDbConn
  [Migration]
migrations <- (Context -> [Migration]) -> m [Migration]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> [Migration]
contextMigrations

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldInstallSeedData (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Connection -> m Bool
forall (m :: * -> *).
(MonadBaseControl IO m, MonadLogger m) =>
Connection -> m Bool
isProdSystem Connection
dbConn) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Doc -> m ()
disp (Doc -> m ()) -> (String -> Doc) -> String -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Doc -> Doc
red (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Doc
text (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Refusing to install seed data on production system."
      IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO ()
forall a. IO a
exitFailure

  [These Migration (Record MigrationLog)]
migrationStatus <- Connection
-> [Migration]
-> SelectArr (Record MigrationLogColsR) ()
-> m [These Migration (Record MigrationLog)]
forall (m :: * -> *).
(MonadBaseControl IO m, MonadLogger m) =>
Connection
-> [Migration]
-> SelectArr (Record MigrationLogColsR) ()
-> m [These Migration (Record MigrationLog)]
readMigrationStatus Connection
dbConn ((Element [Migration] -> Bool) -> [Migration] -> [Migration]
forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter Element [Migration] -> Bool
Migration -> Bool
useMigration [Migration]
migrations) (proc Record MigrationLogColsR
_ -> SelectArr () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ())

  let migrationsToApply :: [Migration]
migrationsToApply = Getting
  (Endo [Migration])
  [These Migration (Record MigrationLog)]
  Migration
-> [These Migration (Record MigrationLog)] -> [Migration]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf ((These Migration (Record MigrationLog)
 -> Const
      (Endo [Migration]) (These Migration (Record MigrationLog)))
-> [These Migration (Record MigrationLog)]
-> Const (Endo [Migration]) [These Migration (Record MigrationLog)]
forall s t a b. Each s t a b => Traversal s t a b
each ((These Migration (Record MigrationLog)
  -> Const
       (Endo [Migration]) (These Migration (Record MigrationLog)))
 -> [These Migration (Record MigrationLog)]
 -> Const
      (Endo [Migration]) [These Migration (Record MigrationLog)])
-> ((Migration -> Const (Endo [Migration]) Migration)
    -> These Migration (Record MigrationLog)
    -> Const
         (Endo [Migration]) (These Migration (Record MigrationLog)))
-> Getting
     (Endo [Migration])
     [These Migration (Record MigrationLog)]
     Migration
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Migration -> Const (Endo [Migration]) Migration)
-> These Migration (Record MigrationLog)
-> Const (Endo [Migration]) (These Migration (Record MigrationLog))
forall a b. Prism' (These a b) a
_This) [These Migration (Record MigrationLog)]
migrationStatus
  Doc -> m ()
disp (Doc -> m ()) -> (Doc -> Doc) -> Doc -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Doc -> Doc
hang Int
2 (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Doc
"Migrations to apply: " Doc -> Doc -> Doc
</> [Doc] -> Doc
fillSep ((Migration -> Doc) -> [Migration] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Doc -> Doc -> Doc
forall m. Monoid m => m -> m -> m
++ String -> Doc
text String
",") (Doc -> Doc) -> (Migration -> Doc) -> Migration -> Doc
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Doc -> Doc
white (Doc -> Doc) -> (Migration -> Doc) -> Migration -> Doc
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Doc
text (String -> Doc) -> (Migration -> String) -> Migration -> Doc
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack (Text -> String) -> (Migration -> Text) -> Migration -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Migration -> Text
migrationQualifiedKey) [Migration]
migrationsToApply)

  if Bool
isGo
    then (Element (Maybe PreMigrationBackup) -> m ())
-> Maybe PreMigrationBackup -> m ()
forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
(Element mono -> f b) -> mono -> f ()
traverse_ (\ (PreMigrationBackup path) -> String -> m ()
forall (m :: * -> *). MonadRefurb m => String -> m ()
backup String
path) Maybe PreMigrationBackup
backupMay m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Migration] -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadRefurb m) =>
[Migration] -> m ()
applyMigrations [Migration]
migrationsToApply
    else Doc -> m ()
disp (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Not applying migrations without --execute"

  where
    useMigration :: Migration -> Bool
useMigration Migration
m = Getting MigrationType Migration MigrationType
-> Migration -> MigrationType
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting MigrationType Migration MigrationType
Lens' Migration MigrationType
migrationType Migration
m MigrationType -> MigrationType -> Bool
forall a. Eq a => a -> a -> Bool
== MigrationType
MigrationSchema Bool -> Bool -> Bool
|| Bool
shouldInstallSeedData

-- |Given a pre-vetted list of 'Migration' structures to apply to the database, iterate through them and run their check actions (if any) followed by
-- execution actions with log output captured.
applyMigrations :: (MonadUnliftIO m, MonadRefurb m) => [Migration] -> m ()
applyMigrations :: [Migration] -> m ()
applyMigrations [Migration]
migrations = do
  Doc -> m ()
disp <- m (Doc -> m ())
forall (m :: * -> *). MonadRefurb m => m (Doc -> m ())
optionallyColoredM
  Connection
dbConn <- (Context -> Connection) -> m Connection
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> Connection
contextDbConn

  [Migration] -> (Element [Migration] -> m Int64) -> m ()
forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
mono -> (Element mono -> f b) -> f ()
for_ [Migration]
migrations ((Element [Migration] -> m Int64) -> m ())
-> (Element [Migration] -> m Int64) -> m ()
forall a b. (a -> b) -> a -> b
$ \ Element [Migration]
migration -> do
    let schema :: Text
schema = Getting Text Migration Text -> Migration -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Migration Text
Lens' Migration Text
migrationSchema Element [Migration]
Migration
migration
    m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (ReaderT Connection m Bool -> Connection -> m Bool
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Text -> ReaderT Connection m Bool
forall (m :: * -> *). MonadMigration m => Text -> m Bool
doesSchemaExist Text
schema) Connection
dbConn) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      m Int64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Int64 -> m ()) -> (IO Int64 -> m Int64) -> IO Int64 -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO Int64 -> m Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> m ()) -> IO Int64 -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Int64
PG.execute_ Connection
dbConn (ByteString -> Query
PG.Query (ByteString -> Query) -> ByteString -> Query
forall a b. (a -> b) -> a -> b
$ ByteString
"create schema " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
schema)

    m Int64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Int64 -> m ()) -> (IO Int64 -> m Int64) -> IO Int64 -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO Int64 -> m Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> m ()) -> IO Int64 -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> Only Text -> IO Int64
forall q. ToRow q => Connection -> Query -> q -> IO Int64
PG.execute Connection
dbConn Query
"set search_path = ?" (Text -> Only Text
forall a. a -> Only a
PG.Only (Text -> Only Text) -> Text -> Only Text
forall a b. (a -> b) -> a -> b
$ Getting Text Migration Text -> Migration -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Migration Text
Lens' Migration Text
migrationSchema Element [Migration]
Migration
migration)

    Maybe (ReaderT Connection m ())
-> (Element (Maybe (ReaderT Connection m ())) -> m ()) -> m ()
forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
mono -> (Element mono -> f b) -> f ()
for_ (Getting
  (Maybe (ReaderT Connection m ()))
  Migration
  (Maybe (ReaderT Connection m ()))
-> Migration -> Maybe (ReaderT Connection m ())
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Maybe (ReaderT Connection m ()))
  Migration
  (Maybe (ReaderT Connection m ()))
forall (m :: * -> *).
MonadMigration m =>
Getter Migration (Maybe (m ()))
migrationCheck Element [Migration]
Migration
migration) ((Element (Maybe (ReaderT Connection m ())) -> m ()) -> m ())
-> (Element (Maybe (ReaderT Connection m ())) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ Element (Maybe (ReaderT Connection m ()))
check ->
      m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
onException
        ( do ReaderT Connection m () -> Connection -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Connection m ()
Element (Maybe (ReaderT Connection m ()))
check Connection
dbConn
             Doc -> m ()
disp (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Migration -> Doc
migrationPrefixDoc Element [Migration]
Migration
migration Doc -> Doc -> Doc
<+> Doc -> Doc
green (String -> Doc
text String
"check passed") )
        (    Doc -> m ()
disp (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Migration -> Doc
migrationPrefixDoc Element [Migration]
Migration
migration Doc -> Doc -> Doc
<+> Doc -> Doc
red   (String -> Doc
text String
"check failed") )

    IORef (DList ByteString)
outputRef <- IO (IORef (DList ByteString)) -> m (IORef (DList ByteString))
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (IORef (DList ByteString)) -> m (IORef (DList ByteString)))
-> IO (IORef (DList ByteString)) -> m (IORef (DList ByteString))
forall a b. (a -> b) -> a -> b
$ DList ByteString -> IO (IORef (DList ByteString))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (DList ByteString
forall a. Monoid a => a
mempty :: DList ByteString)
    UTCTime
start <- IO UTCTime -> m UTCTime
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO UTCTime
getCurrentTime

    let insertLog :: MigrationResult -> m Int64
insertLog MigrationResult
result = do
          UTCTime
end <- IO UTCTime -> m UTCTime
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO UTCTime
getCurrentTime
          Text
output <- ByteString -> Text
forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8 (ByteString -> Text)
-> (DList ByteString -> ByteString) -> DList ByteString -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. DList ByteString -> ByteString
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
mono -> Element mono
concat (DList ByteString -> ByteString)
-> (DList ByteString -> DList ByteString)
-> DList ByteString
-> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Element (DList ByteString) -> DList ByteString -> DList ByteString
forall seq. SemiSequence seq => Element seq -> seq -> seq
intersperse Element (DList ByteString)
"\n" (DList ByteString -> Text) -> m (DList ByteString) -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (DList ByteString) -> m (DList ByteString)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IORef (DList ByteString) -> IO (DList ByteString)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DList ByteString)
outputRef)
          let duration :: Diff UTCTime
duration = UTCTime
end UTCTime -> UTCTime -> Diff UTCTime
forall p. AffineSpace p => p -> p -> Diff p
.-. UTCTime
start
              suffix :: Doc
suffix = String -> Doc
text String
"after" Doc -> Doc -> Doc
<+> String -> Doc
text (NominalDiffTime -> String
forall d. TimeDiff d => d -> String
humanTimeDiff NominalDiffTime
duration)

          case MigrationResult
result of
            MigrationResult
MigrationSuccess ->    Doc -> m ()
disp (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Migration -> Doc
migrationPrefixDoc Element [Migration]
Migration
migration Doc -> Doc -> Doc
<+> Doc -> Doc
green (String -> Doc
text String
"success") Doc -> Doc -> Doc
<+> Doc
suffix
            MigrationResult
MigrationFailure -> do Doc -> m ()
disp (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Migration -> Doc
migrationPrefixDoc Element [Migration]
Migration
migration Doc -> Doc -> Doc
<+> Doc -> Doc
red   (String -> Doc
text String
"failure") Doc -> Doc -> Doc
<+> Doc
suffix
                                   Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn Text
output

          m Int64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Int64 -> m ()) -> (IO Int64 -> m Int64) -> IO Int64 -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO Int64 -> m Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> m ()) -> IO Int64 -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Int64
PG.execute_ Connection
dbConn Query
"set search_path = 'public'"
          IO Int64 -> m Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> m Int64)
-> (Record MigrationLogW -> IO Int64)
-> Record MigrationLogW
-> m Int64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Connection -> Insert Int64 -> IO Int64
forall haskells. Connection -> Insert haskells -> IO haskells
runInsert Connection
dbConn (Insert Int64 -> IO Int64)
-> (Record MigrationLogW -> Insert Int64)
-> Record MigrationLogW
-> IO Int64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (\[Record MigrationLogColsW]
rows -> Table (Record MigrationLogColsW) (Record MigrationLogColsR)
-> [Record MigrationLogColsW]
-> Returning (Record MigrationLogColsR) Int64
-> Maybe OnConflict
-> Insert Int64
forall haskells fieldsW fieldsR.
Table fieldsW fieldsR
-> [fieldsW]
-> Returning fieldsR haskells
-> Maybe OnConflict
-> Insert haskells
Insert Table (Record MigrationLogColsW) (Record MigrationLogColsR)
migrationLog [Record MigrationLogColsW]
rows Returning (Record MigrationLogColsR) Int64
forall fieldsR. Returning fieldsR Int64
rCount Maybe OnConflict
forall a. Maybe a
Nothing) ([Record MigrationLogColsW] -> Insert Int64)
-> (Record MigrationLogW -> [Record MigrationLogColsW])
-> Record MigrationLogW
-> Insert Int64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Record MigrationLogColsW -> [Record MigrationLogColsW]
forall seq. MonoPointed seq => Element seq -> seq
singleton (Record MigrationLogColsW -> [Record MigrationLogColsW])
-> (Record MigrationLogW -> Record MigrationLogColsW)
-> Record MigrationLogW
-> [Record MigrationLogColsW]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Record MigrationLogW -> Record MigrationLogColsW
forall haskells fields.
Default ToFields haskells fields =>
haskells -> fields
toFields :: Record MigrationLogW -> Record MigrationLogColsW) (Record MigrationLogW -> m Int64)
-> Record MigrationLogW -> m Int64
forall a b. (a -> b) -> a -> b
$
            Maybe Int32
forall a. Maybe a
Nothing Maybe Int32
-> Rec
     Identity
     '["qualified_key" :-> Text, "applied" :-> UTCTime,
       "output" :-> Text, "result" :-> MigrationResult,
       "duration" :-> Double]
-> Record MigrationLogW
forall a (rs :: [*]) (s :: Symbol).
a -> Rec Identity rs -> Rec Identity ((s :-> a) : rs)
:*: Migration -> Text
migrationQualifiedKey Element [Migration]
Migration
migration Text
-> Rec
     Identity
     '["applied" :-> UTCTime, "output" :-> Text,
       "result" :-> MigrationResult, "duration" :-> Double]
-> Rec
     Identity
     '["qualified_key" :-> Text, "applied" :-> UTCTime,
       "output" :-> Text, "result" :-> MigrationResult,
       "duration" :-> Double]
forall a (rs :: [*]) (s :: Symbol).
a -> Rec Identity rs -> Rec Identity ((s :-> a) : rs)
:*: UTCTime -> UTCTime
forall a b. Thyme a b => b -> a
fromThyme UTCTime
start UTCTime
-> Rec
     Identity
     '["output" :-> Text, "result" :-> MigrationResult,
       "duration" :-> Double]
-> Rec
     Identity
     '["applied" :-> UTCTime, "output" :-> Text,
       "result" :-> MigrationResult, "duration" :-> Double]
forall a (rs :: [*]) (s :: Symbol).
a -> Rec Identity rs -> Rec Identity ((s :-> a) : rs)
:*: Text
output Text
-> Rec
     Identity '["result" :-> MigrationResult, "duration" :-> Double]
-> Rec
     Identity
     '["output" :-> Text, "result" :-> MigrationResult,
       "duration" :-> Double]
forall a (rs :: [*]) (s :: Symbol).
a -> Rec Identity rs -> Rec Identity ((s :-> a) : rs)
:*: MigrationResult
result MigrationResult
-> Rec Identity '["duration" :-> Double]
-> Rec
     Identity '["result" :-> MigrationResult, "duration" :-> Double]
forall a (rs :: [*]) (s :: Symbol).
a -> Rec Identity rs -> Rec Identity ((s :-> a) : rs)
:*: (NominalDiffTime -> Double
forall t n. (TimeDiff t, Fractional n) => t -> n
toSeconds :: NominalDiffTime -> Double) NominalDiffTime
duration Double -> Rec Identity '[] -> Rec Identity '["duration" :-> Double]
forall a (rs :: [*]) (s :: Symbol).
a -> Rec Identity rs -> Rec Identity ((s :-> a) : rs)
:*: Rec Identity '[]
forall u (a :: u -> *). Rec a '[]
RNil

    m Int64 -> m Int64 -> m Int64
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
onException
      ( do
        Loc -> Text -> LogLevel -> LogStr -> IO ()
logFunc <- m (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
        LoggingT m ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m ()
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (ReaderT Connection (LoggingT m) () -> Connection -> LoggingT m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Getting
  (ReaderT Connection (LoggingT m) ())
  Migration
  (ReaderT Connection (LoggingT m) ())
-> Migration -> ReaderT Connection (LoggingT m) ()
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (ReaderT Connection (LoggingT m) ())
  Migration
  (ReaderT Connection (LoggingT m) ())
forall (m :: * -> *). MonadMigration m => Getter Migration (m ())
migrationExecute Element [Migration]
Migration
migration) Connection
dbConn) ((Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ Loc
loc Text
src LogLevel
lvl LogStr
str -> do
          Loc -> Text -> LogLevel -> LogStr -> IO ()
logFunc Loc
loc Text
src LogLevel
lvl LogStr
str
          LogStr
dateLogStr <- IO LogStr
nowLogString
          let message :: ByteString
message = LogStr -> ByteString
fromLogStr (LogStr -> ByteString) -> LogStr -> ByteString
forall a b. (a -> b) -> a -> b
$ LogStr
dateLogStr LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" [" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> (LogLevel -> String) -> LogLevel -> LogStr
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LogLevel -> String
forall a. Show a => a -> String
show) LogLevel
lvl LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
str LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" @(" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Loc -> LogStr
locLogString Loc
loc LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
")"
          IORef (DList ByteString)
-> (DList ByteString -> DList ByteString) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef (DList ByteString)
outputRef (DList ByteString -> ByteString -> DList ByteString
forall a. DList a -> a -> DList a
`DL.snoc` ByteString
message)
        MigrationResult -> m Int64
insertLog MigrationResult
MigrationSuccess )
      ( MigrationResult -> m Int64
insertLog MigrationResult
MigrationFailure )

-- |Format a 'Loc' in the way we want for logging output - @package:module filename:line:column@
locLogString :: Loc -> LogStr
locLogString :: Loc -> LogStr
locLogString Loc
loc = LogStr
p LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
":" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
m LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
f LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
":" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
l LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
":" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
c
  where p :: LogStr
p = String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> (Loc -> String) -> Loc -> LogStr
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Loc -> String
loc_package (Loc -> LogStr) -> Loc -> LogStr
forall a b. (a -> b) -> a -> b
$ Loc
loc
        m :: LogStr
m = String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> (Loc -> String) -> Loc -> LogStr
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Loc -> String
loc_module (Loc -> LogStr) -> Loc -> LogStr
forall a b. (a -> b) -> a -> b
$ Loc
loc
        f :: LogStr
f = String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> (Loc -> String) -> Loc -> LogStr
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Loc -> String
loc_filename (Loc -> LogStr) -> Loc -> LogStr
forall a b. (a -> b) -> a -> b
$ Loc
loc
        l :: LogStr
l = String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> (Loc -> String) -> Loc -> LogStr
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Loc -> (Int, Int)
loc_start (Loc -> LogStr) -> Loc -> LogStr
forall a b. (a -> b) -> a -> b
$ Loc
loc
        c :: LogStr
c = String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> (Loc -> String) -> Loc -> LogStr
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Loc -> (Int, Int)
loc_start (Loc -> LogStr) -> Loc -> LogStr
forall a b. (a -> b) -> a -> b
$ Loc
loc

-- |Format the current timestamp in the way we want for logging output - @yyyy-mm-dd hh:mm:ss.SSS@
nowLogString :: IO LogStr
nowLogString :: IO LogStr
nowLogString = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  LogStr -> IO LogStr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogStr -> IO LogStr) -> (String -> LogStr) -> String -> IO LogStr
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> IO LogStr) -> String -> IO LogStr
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%d %T%Q" UTCTime
now