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