{-# 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)
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
":"
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
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 )
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
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