{-# LANGUAGE Arrows #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Refurb.Run.Info where

import ClassyPrelude
import Composite.Record (Record)
import Control.Arrow (returnA)
import Control.Lens (Getting, _Wrapped, each, preview, to, view)
import Data.Monoid (First)
#if MIN_VERSION_these(1,0,0)
import Data.These (These(This, That, These))
import Data.These.Lens (there)
#else
import Data.These (These(This, That, These), there)
#endif
import Data.Thyme.Clock (NominalDiffTime, fromSeconds)
import Data.Thyme.Format.Human (humanTimeDiff)
import Opaleye ((.==), restrict, toFields)
import Refurb.Run.Internal (MonadRefurb, contextDbConn, contextMigrations, optionallyColoredM, migrationResultDoc)
import Refurb.Store (FQualifiedKey, MigrationLog, cQualifiedKey, fId, fApplied, fDuration, fOutput, fResult, fQualifiedKey, readMigrationStatus)
import Refurb.Types (Migration, MigrationType(MigrationSeedData), migrationQualifiedKey, migrationType)
import Text.PrettyPrint.ANSI.Leijen (Doc, (<+>), fill, bold, underline, black, red, white, parens, text)

-- |Given a migration status as read by 'readMigrationStatus', pretty print that information as a table on stdout.
showMigrationStatus :: (MonadRefurb m, MonoTraversable t, Element t ~ These Migration (Record MigrationLog)) => t -> m ()
showMigrationStatus :: forall (m :: * -> *) t.
(MonadRefurb m, MonoTraversable t,
 Element t ~ These Migration (Record MigrationLog)) =>
t -> m ()
showMigrationStatus t
migrationStatus = do
  Doc -> m ()
disp <- forall (m :: * -> *). MonadRefurb m => m (Doc -> m ())
optionallyColoredM
  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
bold forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Doc -> Doc
underline forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc -> Doc -> Doc -> Doc
row (String -> Doc
text String
"ID") (String -> Doc
text String
"Timestamp") (String -> Doc
text String
"Duration") (String -> Doc
text String
"Result") (String -> Doc
text String
"Key")
  forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
mono -> (Element mono -> f b) -> f ()
for_ t
migrationStatus forall a b. (a -> b) -> a -> b
$ \ Element t
these ->
    Doc -> m ()
disp forall a b. (a -> b) -> a -> b
$ case Element t
these of
      These Migration
m Record MigrationLog
mlog -> Record MigrationLog -> Doc
mlogRow Record MigrationLog
mlog Doc -> Doc -> Doc
<+> Migration -> Doc
seedDoc Migration
m
      This Migration
m       -> Doc -> Doc -> Doc -> Doc -> Doc -> Doc
row (String -> Doc
text String
"") (String -> Doc
text String
"not applied") (String -> Doc
text String
"") (String -> Doc
text String
"") (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 a b. (a -> b) -> a -> b
$ Migration -> Text
migrationQualifiedKey Migration
m) Doc -> Doc -> Doc
<+> Migration -> Doc
seedDoc Migration
m
      That Record MigrationLog
mlog    -> Record MigrationLog -> Doc
mlogRow Record MigrationLog
mlog Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Doc -> Doc
red Doc
"not in known migrations")

  where
    row :: Doc -> Doc -> Doc -> Doc -> Doc -> Doc
    row :: Doc -> Doc -> Doc -> Doc -> Doc -> Doc
row Doc
i Doc
t Doc
d Doc
r Doc
k = Int -> Doc -> Doc
fill Int
6 Doc
i Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
fill Int
19 Doc
t Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
fill Int
15 Doc
d Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
fill Int
7 Doc
r Doc -> Doc -> Doc
<+> Doc
k

    field :: Getting (First String) s String -> s -> Doc
    field :: forall s. Getting (First String) s String -> s -> Doc
field Getting (First String) s String
f = 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 a. a -> Maybe a -> a
fromMaybe String
"" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First String) s String
f

    seedDoc :: Migration -> Doc
    seedDoc :: Migration -> Doc
seedDoc (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Migration MigrationType
migrationType -> MigrationType
mtype)
      | MigrationType
mtype forall a. Eq a => a -> a -> Bool
== MigrationType
MigrationSeedData = String -> Doc
text String
"(seed data)"
      | Bool
otherwise                  = forall a. Monoid a => a
mempty

    mlogRow :: Record MigrationLog -> Doc
    mlogRow :: Record MigrationLog -> Doc
mlogRow =
      Doc -> Doc -> Doc -> Doc -> Doc -> Doc
row
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Getting (First String) s String -> s -> Doc
field (forall (f :: * -> *) (rs :: [*]).
(Functor f, FId ∈ rs) =>
(Int32 -> f Int32) -> Record rs -> f (Record rs)
fId forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. Show a => a -> String
show)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall (f :: * -> *) (rs :: [*]).
(Functor f, FApplied ∈ rs) =>
(UTCTime -> f UTCTime) -> Record rs -> f (Record rs)
fApplied forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (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 t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F %T"))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. Getting (First String) s String -> s -> Doc
field (forall (f :: * -> *) (rs :: [*]).
(Functor f, FDuration ∈ rs) =>
(Double -> f Double) -> Record rs -> f (Record rs)
fDuration forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (forall d. TimeDiff d => d -> String
humanTimeDiff forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall n t. (Real n, TimeDiff t) => n -> t
fromSeconds :: Double -> NominalDiffTime)))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall (f :: * -> *) (rs :: [*]).
(Functor f, FResult ∈ rs) =>
(MigrationResult -> f MigrationResult)
-> Record rs -> f (Record rs)
fResult forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to MigrationResult -> Doc
migrationResultDoc)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall (f :: * -> *) (rs :: [*]).
(Functor f, FQualifiedKey ∈ rs) =>
(Text -> f Text) -> Record rs -> f (Record rs)
fQualifiedKey forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (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))

-- |Implement the @show-log@ command by reading the entire migration log and displaying it with 'showMigrationStatus'.
showLog :: MonadRefurb m => m ()
showLog :: forall (m :: * -> *). MonadRefurb m => m ()
showLog = do
  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
  [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 [Migration]
migrations (proc Record MigrationLogColsR
_ -> forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ())
  forall (m :: * -> *) t.
(MonadRefurb m, MonoTraversable t,
 Element t ~ These Migration (Record MigrationLog)) =>
t -> m ()
showMigrationStatus [These Migration (Record MigrationLog)]
migrationStatus

-- |Implement the @show-migration@ command by reading migration log pertaining to the given migration key and displaying it with 'showMigrationStatus' plus
-- its log output.
showMigration :: MonadRefurb m => FQualifiedKey -> m ()
showMigration :: forall (m :: * -> *). MonadRefurb m => FQualifiedKey -> m ()
showMigration (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped -> Unwrapped FQualifiedKey
key) = 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 forall a b. (a -> b) -> a -> b
$ forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter ((forall a. Eq a => a -> a -> Bool
== Unwrapped FQualifiedKey
key) 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 {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Context -> [Migration]
contextMigrations
  [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 [Migration]
migrations forall a b. (a -> b) -> a -> b
$ proc Record MigrationLogColsR
mlog ->
    SelectArr (Field SqlBool) ()
restrict -< forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *) (rs :: [*]).
(Functor f, CQualifiedKey ∈ rs) =>
(Field SqlText -> f (Field SqlText)) -> Record rs -> f (Record rs)
cQualifiedKey Record MigrationLogColsR
mlog forall a. Field a -> Field a -> Field SqlBool
.== forall haskells fields.
Default ToFields haskells fields =>
haskells -> fields
toFields Unwrapped FQualifiedKey
key

  forall (m :: * -> *) t.
(MonadRefurb m, MonoTraversable t,
 Element t ~ These Migration (Record MigrationLog)) =>
t -> m ()
showMigrationStatus [These Migration (Record MigrationLog)]
migrationStatus
  forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn Text
""
  case forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (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 c a b. Traversal (These c a) (These c b) a b
there) [These Migration (Record MigrationLog)]
migrationStatus of
    Maybe (Record MigrationLog)
Nothing   -> 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
black forall a b. (a -> b) -> a -> b
$ Doc
"Never been run." -- n.b.: black is not black
    Just Record MigrationLog
mlog -> forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *) (rs :: [*]).
(Functor f, FOutput ∈ rs) =>
(Text -> f Text) -> Record rs -> f (Record rs)
fOutput forall a b. (a -> b) -> a -> b
$ Record MigrationLog
mlog