{-# 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 :: t -> m ()
showMigrationStatus t
migrationStatus = do
  Doc -> m ()
disp <- m (Doc -> m ())
forall (m :: * -> *). MonadRefurb m => m (Doc -> m ())
optionallyColoredM
  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
. Doc -> Doc
bold (Doc -> Doc) -> (Doc -> Doc) -> Doc -> 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
underline (Doc -> m ()) -> Doc -> m ()
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")
  t -> (Element t -> m ()) -> m ()
forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
mono -> (Element mono -> f b) -> f ()
for_ t
migrationStatus ((Element t -> m ()) -> m ()) -> (Element t -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ Element t
these ->
    Doc -> m ()
disp (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$ case Element t
these of
      These m mlog -> Record MigrationLog -> Doc
mlogRow Record MigrationLog
mlog Doc -> Doc -> Doc
<+> Migration -> Doc
seedDoc Migration
m
      This 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 (Doc -> Doc) -> (Text -> Doc) -> Text -> 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) -> (Text -> String) -> Text -> 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 -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ Migration -> Text
migrationQualifiedKey Migration
m) Doc -> Doc -> Doc
<+> Migration -> Doc
seedDoc Migration
m
      That 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 :: Getting (First String) s String -> s -> Doc
field Getting (First String) s String
f = String -> Doc
text (String -> Doc) -> (s -> String) -> s -> Doc
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> (s -> Maybe String) -> s -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Getting (First String) s String -> s -> Maybe String
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 (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 -> MigrationType
mtype)
      | MigrationType
mtype MigrationType -> MigrationType -> Bool
forall a. Eq a => a -> a -> Bool
== MigrationType
MigrationSeedData = String -> Doc
text String
"(seed data)"
      | Bool
otherwise                  = Doc
forall a. Monoid a => a
mempty

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

-- |Implement the @show-log@ command by reading the entire migration log and displaying it with 'showMigrationStatus'.
showLog :: MonadRefurb m => m ()
showLog :: m ()
showLog = do
  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
  [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 [Migration]
migrations (proc Record MigrationLogColsR
_ -> SelectArr () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ())
  [These Migration (Record MigrationLog)] -> m ()
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 :: FQualifiedKey -> m ()
showMigration (Getting Text FQualifiedKey Text -> FQualifiedKey -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text FQualifiedKey Text
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped -> Text
key) = 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]) -> m [Migration])
-> (Context -> [Migration]) -> m [Migration]
forall a b. (a -> b) -> a -> b
$ (Element [Migration] -> Bool) -> [Migration] -> [Migration]
forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
key) (Text -> Bool) -> (Migration -> Text) -> Migration -> Bool
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] -> [Migration])
-> (Context -> [Migration]) -> Context -> [Migration]
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 <- 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 [Migration]
migrations (SelectArr (Record MigrationLogColsR) ()
 -> m [These Migration (Record MigrationLog)])
-> SelectArr (Record MigrationLogColsR) ()
-> m [These Migration (Record MigrationLog)]
forall a b. (a -> b) -> a -> b
$ proc Record MigrationLogColsR
mlog ->
    SelectArr (Field SqlBool) ()
restrict -< Getting (Field SqlText) (Record MigrationLogColsR) (Field SqlText)
-> Record MigrationLogColsR -> Field SqlText
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Field SqlText) (Record MigrationLogColsR) (Field SqlText)
forall (f :: * -> *) (rs :: [*]).
(Functor f, CQualifiedKey ∈ rs) =>
(Field SqlText -> f (Field SqlText)) -> Record rs -> f (Record rs)
cQualifiedKey Record MigrationLogColsR
mlog Field SqlText -> Field SqlText -> Field SqlBool
forall a. Field a -> Field a -> Field SqlBool
.== Text -> Field SqlText
forall haskells fields.
Default ToFields haskells fields =>
haskells -> fields
toFields Text
key

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