module Stackctl.Spec.Deploy
  ( DeployOptions (..)
  , DeployConfirmation (..)
  , parseDeployOptions
  , runDeploy
  ) where

import Stackctl.Prelude

import Blammo.Logging.Logger (pushLoggerLn)
import qualified Data.Text as T
import Data.Time (defaultTimeLocale, formatTime, utcToLocalZonedTime)
import Options.Applicative
import Stackctl.AWS hiding (action)
import Stackctl.AWS.Scope
import Stackctl.Action
import Stackctl.Colors
import Stackctl.Config (HasConfig)
import Stackctl.DirectoryOption (HasDirectoryOption)
import Stackctl.FilterOption (HasFilterOption)
import Stackctl.ParameterOption
import Stackctl.Prompt
import Stackctl.RemovedStack
import Stackctl.Spec.Changes.Format
import Stackctl.Spec.Discover
import Stackctl.StackSpec
import Stackctl.TagOption
import UnliftIO.Directory (createDirectoryIfMissing)

data DeployOptions = DeployOptions
  { DeployOptions -> [Parameter]
sdoParameters :: [Parameter]
  , DeployOptions -> [Tag]
sdoTags :: [Tag]
  , DeployOptions -> Maybe FilePath
sdoSaveChangeSets :: Maybe FilePath
  , DeployOptions -> DeployConfirmation
sdoDeployConfirmation :: DeployConfirmation
  , DeployOptions -> Bool
sdoRemovals :: Bool
  , DeployOptions -> Bool
sdoClean :: Bool
  }

-- brittany-disable-next-binding

parseDeployOptions :: Parser DeployOptions
parseDeployOptions :: Parser DeployOptions
parseDeployOptions =
  [Parameter]
-> [Tag]
-> Maybe FilePath
-> DeployConfirmation
-> Bool
-> Bool
-> DeployOptions
DeployOptions
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Parameter
parameterOption
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Tag
tagOption
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
      ( forall s. IsString s => Mod OptionFields s -> Parser s
strOption
          ( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"save-change-sets"
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"DIRECTORY"
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Save executed changesets to DIRECTORY"
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasCompleter f => FilePath -> Mod f a
action FilePath
"directory"
          )
      )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> a -> Mod FlagFields a -> Parser a
flag
      DeployConfirmation
DeployWithConfirmation
      DeployConfirmation
DeployWithoutConfirmation
      ( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"no-confirm"
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Don't confirm changes before executing"
      )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( Bool -> Bool
not
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
switch
              ( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"no-remove"
                  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Don't delete removed Stacks"
              )
        )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
      ( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"clean"
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Remove all changesets from Stack after deploy"
      )

runDeploy
  :: ( MonadMask m
     , MonadUnliftIO m
     , MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasLogger env
     , HasAwsScope env
     , HasAwsEnv env
     , HasConfig env
     , HasDirectoryOption env
     , HasFilterOption env
     )
  => DeployOptions
  -> m ()
runDeploy :: forall (m :: * -> *) env.
(MonadMask m, MonadUnliftIO m, MonadResource m, MonadLogger m,
 MonadReader env m, HasLogger env, HasAwsScope env, HasAwsEnv env,
 HasConfig env, HasDirectoryOption env, HasFilterOption env) =>
DeployOptions -> m ()
runDeploy DeployOptions {Bool
[Tag]
[Parameter]
Maybe FilePath
DeployConfirmation
sdoClean :: Bool
sdoRemovals :: Bool
sdoDeployConfirmation :: DeployConfirmation
sdoSaveChangeSets :: Maybe FilePath
sdoTags :: [Tag]
sdoParameters :: [Parameter]
sdoClean :: DeployOptions -> Bool
sdoRemovals :: DeployOptions -> Bool
sdoDeployConfirmation :: DeployOptions -> DeployConfirmation
sdoSaveChangeSets :: DeployOptions -> Maybe FilePath
sdoTags :: DeployOptions -> [Tag]
sdoParameters :: DeployOptions -> [Parameter]
..} = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sdoRemovals forall a b. (a -> b) -> a -> b
$ do
    [Stack]
removed <- forall (m :: * -> *) env.
(MonadUnliftIO m, MonadResource m, MonadReader env m,
 HasAwsEnv env, HasAwsScope env, HasFilterOption env) =>
m [Stack]
inferRemovedStacks
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *) env.
(MonadMask m, MonadResource m, MonadLogger m, MonadReader env m,
 HasLogger env, HasAwsEnv env) =>
DeployConfirmation -> Stack -> m ()
deleteRemovedStack DeployConfirmation
sdoDeployConfirmation) [Stack]
removed

  forall (m :: * -> *) env.
(MonadMask m, MonadResource m, MonadLogger m, MonadReader env m,
 HasAwsScope env, HasConfig env, HasDirectoryOption env,
 HasFilterOption env) =>
(StackSpec -> m ()) -> m ()
forEachSpec_ forall a b. (a -> b) -> a -> b
$ \StackSpec
spec -> do
    forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Pair] -> m a -> m a
withThreadContext [Key
"stackName" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= StackSpec -> StackName
stackSpecStackName StackSpec
spec] forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) env.
(MonadUnliftIO m, MonadResource m, MonadLogger m,
 MonadReader env m, HasLogger env, HasAwsEnv env) =>
DeployConfirmation -> StackName -> m ()
checkIfStackRequiresDeletion DeployConfirmation
sdoDeployConfirmation
        forall a b. (a -> b) -> a -> b
$ StackSpec -> StackName
stackSpecStackName StackSpec
spec

      Either Text (Maybe ChangeSet)
emChangeSet <- forall (m :: * -> *) env.
(MonadUnliftIO m, MonadResource m, MonadLogger m,
 MonadReader env m, HasAwsEnv env) =>
StackSpec
-> [Parameter] -> [Tag] -> m (Either Text (Maybe ChangeSet))
createChangeSet StackSpec
spec [Parameter]
sdoParameters [Tag]
sdoTags

      case Either Text (Maybe ChangeSet)
emChangeSet of
        Left Text
err -> do
          forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError forall a b. (a -> b) -> a -> b
$ Text
"Error creating ChangeSet" Text -> [SeriesElem] -> Message
:# [Key
"error" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
err]
          forall (m :: * -> *) a. MonadIO m => m a
exitFailure
        Right Maybe ChangeSet
Nothing -> forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo Message
"Stack is up to date"
        Right (Just ChangeSet
changeSet) -> do
          let stackName :: StackName
stackName = StackSpec -> StackName
stackSpecStackName StackSpec
spec

          forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FilePath
sdoSaveChangeSets forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
            let out :: FilePath
out = FilePath
dir FilePath -> FilePath -> FilePath
</> Text -> FilePath
unpack (StackName -> Text
unStackName StackName
stackName) FilePath -> FilePath -> FilePath
<.> FilePath
"json"
            forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Recording changeset" Text -> [SeriesElem] -> Message
:# [Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
out]
            forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True FilePath
dir
            forall (m :: * -> *). MonadIO m => FilePath -> Text -> m ()
writeFileUtf8 FilePath
out forall a b. (a -> b) -> a -> b
$ ChangeSet -> Text
changeSetJSON ChangeSet
changeSet

          forall (m :: * -> *) env.
(MonadUnliftIO m, MonadResource m, MonadLogger m,
 MonadReader env m, HasLogger env, HasAwsEnv env) =>
DeployConfirmation -> ChangeSet -> m ()
deployChangeSet DeployConfirmation
sdoDeployConfirmation ChangeSet
changeSet
          forall (m :: * -> *) env.
(MonadResource m, MonadLogger m, MonadReader env m, HasLogger env,
 HasAwsEnv env) =>
StackName -> ActionOn -> [Action] -> m ()
runActions StackName
stackName ActionOn
PostDeploy forall a b. (a -> b) -> a -> b
$ StackSpec -> [Action]
stackSpecActions StackSpec
spec
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sdoClean forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadResource m, MonadLogger m, MonadReader env m,
 HasAwsEnv env) =>
StackName -> m ()
awsCloudFormationDeleteAllChangeSets StackName
stackName

deleteRemovedStack
  :: ( MonadMask m
     , MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasLogger env
     , HasAwsEnv env
     )
  => DeployConfirmation
  -> Stack
  -> m ()
deleteRemovedStack :: forall (m :: * -> *) env.
(MonadMask m, MonadResource m, MonadLogger m, MonadReader env m,
 HasLogger env, HasAwsEnv env) =>
DeployConfirmation -> Stack -> m ()
deleteRemovedStack DeployConfirmation
confirmation Stack
stack = do
  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Pair] -> m a -> m a
withThreadContext [Key
"stack" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= StackName
stackName] forall a b. (a -> b) -> a -> b
$ do
    Colors
colors <- forall env (m :: * -> *).
(MonadReader env m, HasLogger env) =>
m Colors
getColorsLogger
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
Text -> m ()
pushLoggerLn forall a b. (a -> b) -> a -> b
$ Colors -> Format -> Stack -> Text
formatRemovedStack Colors
colors Format
FormatTTY Stack
stack

    case DeployConfirmation
confirmation of
      DeployConfirmation
DeployWithConfirmation -> do
        forall (m :: * -> *) env.
(MonadIO m, MonadLogger m, MonadReader env m, HasLogger env) =>
m ()
promptContinue
        forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo Message
"Deleting Stack"
      DeployConfirmation
DeployWithoutConfirmation -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    forall (m :: * -> *) env.
(MonadResource m, MonadLogger m, MonadReader env m,
 HasAwsEnv env) =>
StackName -> m ()
deleteStack StackName
stackName
 where
  stackName :: StackName
stackName = Text -> StackName
StackName forall a b. (a -> b) -> a -> b
$ Stack
stack forall s a. s -> Getting a s a -> a
^. Lens' Stack Text
stack_stackName

data DeployConfirmation
  = DeployWithConfirmation
  | DeployWithoutConfirmation
  deriving stock (DeployConfirmation -> DeployConfirmation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeployConfirmation -> DeployConfirmation -> Bool
$c/= :: DeployConfirmation -> DeployConfirmation -> Bool
== :: DeployConfirmation -> DeployConfirmation -> Bool
$c== :: DeployConfirmation -> DeployConfirmation -> Bool
Eq)

checkIfStackRequiresDeletion
  :: ( MonadUnliftIO m
     , MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasLogger env
     , HasAwsEnv env
     )
  => DeployConfirmation
  -> StackName
  -> m ()
checkIfStackRequiresDeletion :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadResource m, MonadLogger m,
 MonadReader env m, HasLogger env, HasAwsEnv env) =>
DeployConfirmation -> StackName -> m ()
checkIfStackRequiresDeletion DeployConfirmation
confirmation StackName
stackName = do
  Maybe Stack
mStack <- forall (m :: * -> *) env.
(MonadUnliftIO m, MonadResource m, MonadReader env m,
 HasAwsEnv env) =>
StackName -> m (Maybe Stack)
awsCloudFormationDescribeStackMaybe StackName
stackName

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Stack -> Maybe StackStatus
stackStatusRequiresDeletion forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Stack
mStack) forall a b. (a -> b) -> a -> b
$ \StackStatus
status -> do
    forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"Stack must be deleted before proceeding" Text -> [SeriesElem] -> Message
:# [Key
"status" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= StackStatus
status]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StackStatus
status forall a. Eq a => a -> a -> Bool
== StackStatus
StackStatus_ROLLBACK_FAILED)
      forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logWarn
        Message
"Stack is in ROLLBACK_FAILED. This may require elevated permissions for the delete to succeed"

    case DeployConfirmation
confirmation of
      DeployConfirmation
DeployWithConfirmation -> forall (m :: * -> *) env.
(MonadIO m, MonadLogger m, MonadReader env m, HasLogger env) =>
m ()
promptContinue
      DeployConfirmation
DeployWithoutConfirmation -> do
        forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError Message
"Refusing to delete without confirmation"
        forall (m :: * -> *) a. MonadIO m => m a
exitFailure

    forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo Message
"Deleting Stack"
    forall (m :: * -> *) env.
(MonadResource m, MonadLogger m, MonadReader env m,
 HasAwsEnv env) =>
StackName -> m ()
deleteStack StackName
stackName

deleteStack
  :: (MonadResource m, MonadLogger m, MonadReader env m, HasAwsEnv env)
  => StackName
  -> m ()
deleteStack :: forall (m :: * -> *) env.
(MonadResource m, MonadLogger m, MonadReader env m,
 HasAwsEnv env) =>
StackName -> m ()
deleteStack StackName
stackName = do
  StackDeleteResult
result <- forall (m :: * -> *) env.
(MonadResource m, MonadLogger m, MonadReader env m,
 HasAwsEnv env) =>
StackName -> m StackDeleteResult
awsCloudFormationDeleteStack StackName
stackName

  case StackDeleteResult
result of
    StackDeleteResult
StackDeleteSuccess -> forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ StackDeleteResult -> Text
prettyStackDeleteResult StackDeleteResult
result Text -> [SeriesElem] -> Message
:# []
    StackDeleteFailure {} -> forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ StackDeleteResult -> Text
prettyStackDeleteResult StackDeleteResult
result Text -> [SeriesElem] -> Message
:# []

deployChangeSet
  :: ( MonadUnliftIO m
     , MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasLogger env
     , HasAwsEnv env
     )
  => DeployConfirmation
  -> ChangeSet
  -> m ()
deployChangeSet :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadResource m, MonadLogger m,
 MonadReader env m, HasLogger env, HasAwsEnv env) =>
DeployConfirmation -> ChangeSet -> m ()
deployChangeSet DeployConfirmation
confirmation ChangeSet
changeSet = do
  Colors
colors <- forall env (m :: * -> *).
(MonadReader env m, HasLogger env) =>
m Colors
getColorsLogger

  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
Text -> m ()
pushLoggerLn forall a b. (a -> b) -> a -> b
$ Colors -> Text -> Maybe ChangeSet -> Text
formatTTY Colors
colors (StackName -> Text
unStackName StackName
stackName) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ChangeSet
changeSet

  case DeployConfirmation
confirmation of
    DeployConfirmation
DeployWithConfirmation -> forall (m :: * -> *) env.
(MonadIO m, MonadLogger m, MonadReader env m, HasLogger env) =>
m ()
promptContinue
    DeployConfirmation
DeployWithoutConfirmation -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- It can take a minute to get this batch of events to work out where we're
  -- tailing from, so do that part synchronously
  Maybe Text
mLastId <- forall (m :: * -> *) env.
(MonadResource m, MonadReader env m, HasAwsEnv env) =>
StackName -> m (Maybe Text)
awsCloudFormationGetMostRecentStackEventId StackName
stackName
  Async Any
asyncTail <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env a.
(MonadResource m, MonadLogger m, MonadReader env m, HasLogger env,
 HasAwsEnv env) =>
StackName -> Maybe Text -> m a
tailStackEventsSince StackName
stackName Maybe Text
mLastId

  forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Executing ChangeSet" Text -> [SeriesElem] -> Message
:# [Key
"changeSetId" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ChangeSetId
changeSetId]
  StackDeployResult
result <- do
    forall (m :: * -> *) env.
(MonadResource m, MonadReader env m, HasAwsEnv env) =>
ChangeSetId -> m ()
awsCloudFormationExecuteChangeSet ChangeSetId
changeSetId
    forall (m :: * -> *) env.
(MonadUnliftIO m, MonadResource m, MonadReader env m,
 HasAwsEnv env) =>
StackName -> m StackDeployResult
awsCloudFormationWait StackName
stackName

  forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async Any
asyncTail

  let
    onSuccess :: m ()
onSuccess = forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ StackDeployResult -> Text
prettyStackDeployResult StackDeployResult
result Text -> [SeriesElem] -> Message
:# []
    onFailure :: m ()
onFailure = do
      forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError forall a b. (a -> b) -> a -> b
$ StackDeployResult -> Text
prettyStackDeployResult StackDeployResult
result Text -> [SeriesElem] -> Message
:# []
      forall (m :: * -> *) a. MonadIO m => m a
exitFailure

  case StackDeployResult
result of
    StackDeployResult
StackCreateSuccess -> m ()
onSuccess
    StackCreateFailure {} -> m ()
onFailure
    StackDeployResult
StackUpdateSuccess -> m ()
onSuccess
    StackUpdateFailure {} -> m ()
onFailure
 where
  stackName :: StackName
stackName = ChangeSet -> StackName
csStackName ChangeSet
changeSet
  changeSetId :: ChangeSetId
changeSetId = ChangeSet -> ChangeSetId
csChangeSetId ChangeSet
changeSet

tailStackEventsSince
  :: ( MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasLogger env
     , HasAwsEnv env
     )
  => StackName
  -> Maybe Text
  -- ^ StackEventId
  -> m a
tailStackEventsSince :: forall (m :: * -> *) env a.
(MonadResource m, MonadLogger m, MonadReader env m, HasLogger env,
 HasAwsEnv env) =>
StackName -> Maybe Text -> m a
tailStackEventsSince StackName
stackName Maybe Text
mLastId = do
  Colors
colors <- forall env (m :: * -> *).
(MonadReader env m, HasLogger env) =>
m Colors
getColorsLogger
  [StackEvent]
events <- forall (m :: * -> *) env.
(MonadResource m, MonadReader env m, HasAwsEnv env) =>
StackName -> Maybe Text -> m [StackEvent]
awsCloudFormationDescribeStackEvents StackName
stackName Maybe Text
mLastId
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
Text -> m ()
pushLoggerLn forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *). MonadIO m => Colors -> StackEvent -> m Text
formatStackEvent Colors
colors) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [StackEvent]
events

  -- Without this small delay before looping, our requests seem to hang
  -- intermittently (without errors) and often we miss events.
  forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
1 forall a. Num a => a -> a -> a
* Int
1000000

  -- Tail from the next "last id". If we got no events, be sure to pass along
  -- any last-id we were given
  forall (m :: * -> *) env a.
(MonadResource m, MonadLogger m, MonadReader env m, HasLogger env,
 HasAwsEnv env) =>
StackName -> Maybe Text -> m a
tailStackEventsSince StackName
stackName forall a b. (a -> b) -> a -> b
$ [StackEvent] -> Maybe Text
getLastEventId [StackEvent]
events forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
mLastId

formatStackEvent :: MonadIO m => Colors -> StackEvent -> m Text
formatStackEvent :: forall (m :: * -> *). MonadIO m => Colors -> StackEvent -> m Text
formatStackEvent Colors {Text -> Text
gray :: Colors -> Text -> Text
black :: Colors -> Text -> Text
cyan :: Colors -> Text -> Text
magenta :: Colors -> Text -> Text
blue :: Colors -> Text -> Text
yellow :: Colors -> Text -> Text
green :: Colors -> Text -> Text
red :: Colors -> Text -> Text
bold :: Colors -> Text -> Text
dim :: Colors -> Text -> Text
dim :: Text -> Text
bold :: Text -> Text
red :: Text -> Text
green :: Text -> Text
yellow :: Text -> Text
blue :: Text -> Text
magenta :: Text -> Text
cyan :: Text -> Text
black :: Text -> Text
gray :: Text -> Text
..} StackEvent
e = do
  FilePath
timestamp <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"%F %T %Z"
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> IO ZonedTime
utcToLocalZonedTime
        (StackEvent
e forall s a. s -> Getting a s a -> a
^. Lens' StackEvent UTCTime
stackEvent_timestamp)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ forall a. IsString a => FilePath -> a
fromString FilePath
timestamp
      , Text
" | "
      , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ResourceStatus -> Text
colorStatus forall a b. (a -> b) -> a -> b
$ StackEvent
e forall s a. s -> Getting a s a -> a
^. Lens' StackEvent (Maybe ResourceStatus)
stackEvent_resourceStatus
      , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text -> Text
magenta forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
" " forall a. Semigroup a => a -> a -> a
<>)) forall a b. (a -> b) -> a -> b
$ StackEvent
e forall s a. s -> Getting a s a -> a
^. Lens' StackEvent (Maybe Text)
stackEvent_logicalResourceId
      , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((\Text
x -> Text
" (" forall a. Semigroup a => a -> a -> a
<> Text
x forall a. Semigroup a => a -> a -> a
<> Text
")") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip)
          forall a b. (a -> b) -> a -> b
$ StackEvent
e
          forall s a. s -> Getting a s a -> a
^. Lens' StackEvent (Maybe Text)
stackEvent_resourceStatusReason
      ]
 where
  colorStatus :: ResourceStatus -> Text
colorStatus = \case
    ResourceStatus' Text
x
      | Text
"ROLLBACK" Text -> Text -> Bool
`T.isInfixOf` Text
x -> Text -> Text
red Text
x
      | Text
"COMPLETE" Text -> Text -> Bool
`T.isSuffixOf` Text
x -> Text -> Text
green Text
x
      | Text
"FAILED" Text -> Text -> Bool
`T.isSuffixOf` Text
x -> Text -> Text
red Text
x
      | Text
"IN_PROGRESS" Text -> Text -> Bool
`T.isSuffixOf` Text
x -> Text -> Text
blue Text
x
      | Text
"SKIPPED" Text -> Text -> Bool
`T.isSuffixOf` Text
x -> Text -> Text
yellow Text
x
      | Bool
otherwise -> Text
x

getLastEventId :: [StackEvent] -> Maybe Text
getLastEventId :: [StackEvent] -> Maybe Text
getLastEventId = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s a. s -> Getting a s a -> a
^. Lens' StackEvent Text
stackEvent_eventId) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe