{-# 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall mono. MonoFoldable mono => mono -> [Element mono]
unpack 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 forall a b. (a -> b) -> a -> b
$ Migration
migration) 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 :: forall (m :: * -> *).
(MonadUnliftIO m, MonadRefurb m) =>
GoNoGo -> Maybe PreMigrationBackup -> InstallSeedData -> m ()
migrate (GoNoGo Bool
isGo) Maybe PreMigrationBackup
backupMay (InstallSeedData Bool
shouldInstallSeedData) = do
  Doc -> m ()
disp <- forall (m :: * -> *). MonadRefurb m => m (Doc -> m ())
optionallyColoredM
  Connection
dbConn <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> Connection
contextDbConn
  [Migration]
migrations <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> [Migration]
contextMigrations

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldInstallSeedData forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *).
(MonadBaseControl IO m, MonadLogger m) =>
Connection -> m Bool
isProdSystem Connection
dbConn) forall a b. (a -> b) -> a -> b
$ do
      Doc -> m ()
disp 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 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 forall a b. (a -> b) -> a -> b
$ String
"Refusing to install seed data on production system."
      forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a. IO a
exitFailure

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

  let migrationsToApply :: [Migration]
migrationsToApply = forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (forall s t a b. Each s t a b => Traversal s t a b
each forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. Prism' (These a b) a
_This) [These Migration (Record MigrationLog)]
migrationStatus
  Doc -> m ()
disp 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 forall a b. (a -> b) -> a -> b
$ Doc
"Migrations to apply: " Doc -> Doc -> Doc
</> [Doc] -> Doc
fillSep (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((forall m. Monoid m => m -> m -> m
++ String -> Doc
text String
",") 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 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall mono. MonoFoldable mono => mono -> [Element mono]
unpack 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 forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
(Element mono -> f b) -> mono -> f ()
traverse_ (\ (PreMigrationBackup String
path) -> forall (m :: * -> *). MonadRefurb m => String -> m ()
backup String
path) Maybe PreMigrationBackup
backupMay forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
(MonadUnliftIO m, MonadRefurb m) =>
[Migration] -> m ()
applyMigrations [Migration]
migrationsToApply
    else Doc -> m ()
disp forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Not applying migrations without --execute"

  where
    useMigration :: Migration -> Bool
useMigration Migration
m = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Migration MigrationType
migrationType Migration
m 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 :: forall (m :: * -> *).
(MonadUnliftIO m, MonadRefurb m) =>
[Migration] -> m ()
applyMigrations [Migration]
migrations = do
  Doc -> m ()
disp <- forall (m :: * -> *). MonadRefurb m => m (Doc -> m ())
optionallyColoredM
  Connection
dbConn <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> Connection
contextDbConn

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

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

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

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

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

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

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

    forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
onException
      ( do
        Loc -> Text -> LogLevel -> LogStr -> IO ()
logFunc <- forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
        forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (m :: * -> *). MonadMigration m => Getter Migration (m ())
migrationExecute Element [Migration]
migration) Connection
dbConn) 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 forall a b. (a -> b) -> a -> b
$ LogStr
dateLogStr forall a. Semigroup a => a -> a -> a
<> LogStr
" [" forall a. Semigroup a => a -> a -> a
<> (forall msg. ToLogStr msg => msg -> LogStr
toLogStr forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show) LogLevel
lvl forall a. Semigroup a => a -> a -> a
<> LogStr
"] " forall a. Semigroup a => a -> a -> a
<> LogStr
str forall a. Semigroup a => a -> a -> a
<> LogStr
" @(" forall a. Semigroup a => a -> a -> a
<> Loc -> LogStr
locLogString Loc
loc forall a. Semigroup a => a -> a -> a
<> LogStr
")"
          forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef (DList ByteString)
outputRef (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 forall a. Semigroup a => a -> a -> a
<> LogStr
":" forall a. Semigroup a => a -> a -> a
<> LogStr
m forall a. Semigroup a => a -> a -> a
<> LogStr
" " forall a. Semigroup a => a -> a -> a
<> LogStr
f forall a. Semigroup a => a -> a -> a
<> LogStr
":" forall a. Semigroup a => a -> a -> a
<> LogStr
l forall a. Semigroup a => a -> a -> a
<> LogStr
":" forall a. Semigroup a => a -> a -> a
<> LogStr
c
  where p :: LogStr
p = forall msg. ToLogStr msg => msg -> LogStr
toLogStr 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 forall a b. (a -> b) -> a -> b
$ Loc
loc
        m :: LogStr
m = forall msg. ToLogStr msg => msg -> LogStr
toLogStr 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 forall a b. (a -> b) -> a -> b
$ Loc
loc
        f :: LogStr
f = forall msg. ToLogStr msg => msg -> LogStr
toLogStr 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 forall a b. (a -> b) -> a -> b
$ Loc
loc
        l :: LogStr
l = forall msg. ToLogStr msg => msg -> LogStr
toLogStr forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> a
fst forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Loc -> CharPos
loc_start forall a b. (a -> b) -> a -> b
$ Loc
loc
        c :: LogStr
c = forall msg. ToLogStr msg => msg -> LogStr
toLogStr forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> b
snd forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Loc -> CharPos
loc_start 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall msg. ToLogStr msg => msg -> LogStr
toLogStr forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%d %T%Q" UTCTime
now