{-# LANGUAGE NamedFieldPuns #-}

-- | Actions that can be performed on certain Stack management events
--
-- For example, to invoke a Lambda whose name is found in the deploying Stack's
-- outputs after it's been deployed:
--
-- @
-- Actions:
--   - on: PostDeploy
--     run:
--       InvokeLambdaByStackOutput: OnDeployFunction
-- @
module Stackctl.Action
  ( Action
  , newAction
  , ActionOn (..)
  , ActionRun (..)
  , runActions
  ) where

import Stackctl.Prelude hiding (on)

import Blammo.Logging.Logger (flushLogger)
import Data.Aeson
import Data.List (find)
import qualified Data.List.NonEmpty as NE
import Stackctl.AWS
import Stackctl.AWS.Lambda
import Stackctl.OneOrListOf
import qualified Stackctl.OneOrListOf as OneOrListOf
import System.Process.Typed

data Action = Action
  { Action -> ActionOn
on :: ActionOn
  , Action -> OneOrListOf ActionRun
run :: OneOrListOf ActionRun
  }
  deriving stock (Action -> Action -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Action -> Action -> Bool
$c/= :: Action -> Action -> Bool
== :: Action -> Action -> Bool
$c== :: Action -> Action -> Bool
Eq, Int -> Action -> ShowS
[Action] -> ShowS
Action -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Action] -> ShowS
$cshowList :: [Action] -> ShowS
show :: Action -> String
$cshow :: Action -> String
showsPrec :: Int -> Action -> ShowS
$cshowsPrec :: Int -> Action -> ShowS
Show, forall x. Rep Action x -> Action
forall x. Action -> Rep Action x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Action x -> Action
$cfrom :: forall x. Action -> Rep Action x
Generic)
  deriving anyclass (Value -> Parser [Action]
Value -> Parser Action
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Action]
$cparseJSONList :: Value -> Parser [Action]
parseJSON :: Value -> Parser Action
$cparseJSON :: Value -> Parser Action
FromJSON, [Action] -> Encoding
[Action] -> Value
Action -> Encoding
Action -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Action] -> Encoding
$ctoEncodingList :: [Action] -> Encoding
toJSONList :: [Action] -> Value
$ctoJSONList :: [Action] -> Value
toEncoding :: Action -> Encoding
$ctoEncoding :: Action -> Encoding
toJSON :: Action -> Value
$ctoJSON :: Action -> Value
ToJSON)

newAction :: ActionOn -> [ActionRun] -> Action
newAction :: ActionOn -> [ActionRun] -> Action
newAction ActionOn
on [ActionRun]
runs = Action {ActionOn
on :: ActionOn
on :: ActionOn
on, run :: OneOrListOf ActionRun
run = forall a. [a] -> OneOrListOf a
OneOrListOf.fromList [ActionRun]
runs}

data ActionOn = PostDeploy
  deriving stock (ActionOn -> ActionOn -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ActionOn -> ActionOn -> Bool
$c/= :: ActionOn -> ActionOn -> Bool
== :: ActionOn -> ActionOn -> Bool
$c== :: ActionOn -> ActionOn -> Bool
Eq, Int -> ActionOn -> ShowS
[ActionOn] -> ShowS
ActionOn -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActionOn] -> ShowS
$cshowList :: [ActionOn] -> ShowS
show :: ActionOn -> String
$cshow :: ActionOn -> String
showsPrec :: Int -> ActionOn -> ShowS
$cshowsPrec :: Int -> ActionOn -> ShowS
Show, forall x. Rep ActionOn x -> ActionOn
forall x. ActionOn -> Rep ActionOn x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ActionOn x -> ActionOn
$cfrom :: forall x. ActionOn -> Rep ActionOn x
Generic)

instance FromJSON ActionOn where
  parseJSON :: Value -> Parser ActionOn
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"ActionOn" forall a b. (a -> b) -> a -> b
$ \case
    Text
"PostDeploy" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ActionOn
PostDeploy
    Text
x ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid ActionOn: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
x forall a. Semigroup a => a -> a -> a
<> String
", must be one of [PostDeploy]"

instance ToJSON ActionOn where
  toJSON :: ActionOn -> Value
toJSON = \case
    ActionOn
PostDeploy -> forall a. ToJSON a => a -> Value
toJSON @Text Text
"PostDeploy"
  toEncoding :: ActionOn -> Encoding
toEncoding = \case
    ActionOn
PostDeploy -> forall a. ToJSON a => a -> Encoding
toEncoding @Text Text
"PostDeploy"

data ActionRun
  = InvokeLambdaByStackOutput Text
  | InvokeLambdaByName Text
  | Exec (NonEmpty String)
  | Shell String
  deriving stock (ActionRun -> ActionRun -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ActionRun -> ActionRun -> Bool
$c/= :: ActionRun -> ActionRun -> Bool
== :: ActionRun -> ActionRun -> Bool
$c== :: ActionRun -> ActionRun -> Bool
Eq, Int -> ActionRun -> ShowS
[ActionRun] -> ShowS
ActionRun -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActionRun] -> ShowS
$cshowList :: [ActionRun] -> ShowS
show :: ActionRun -> String
$cshow :: ActionRun -> String
showsPrec :: Int -> ActionRun -> ShowS
$cshowsPrec :: Int -> ActionRun -> ShowS
Show)

instance FromJSON ActionRun where
  parseJSON :: Value -> Parser ActionRun
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ActionRun" forall a b. (a -> b) -> a -> b
$ \Object
o ->
    (Text -> ActionRun
InvokeLambdaByStackOutput forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"InvokeLambdaByStackOutput")
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> ActionRun
InvokeLambdaByName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"InvokeLambdaByName")
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (NonEmpty String -> ActionRun
Exec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"Exec")
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> ActionRun
Shell forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"Shell")

instance ToJSON ActionRun where
  toJSON :: ActionRun -> Value
toJSON =
    [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      InvokeLambdaByStackOutput Text
name -> [Key
"InvokeLambdaByStackOutput" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
name]
      InvokeLambdaByName Text
name -> [Key
"InvokeLambdaByName" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
name]
      Exec NonEmpty String
args -> [Key
"Exec" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty String
args]
      Shell String
arg -> [Key
"Shell" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
arg]
  toEncoding :: ActionRun -> Encoding
toEncoding =
    Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      InvokeLambdaByStackOutput Text
name -> Key
"InvokeLambdaByStackOutput" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
name
      InvokeLambdaByName Text
name -> Key
"InvokeLambdaByName" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
name
      Exec NonEmpty String
args -> Key
"Exec" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty String
args
      Shell String
arg -> Key
"Shell" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
arg

data ActionFailure
  = NoSuchOutput
  | InvokeLambdaFailure
  | ExecFailure ExitCode
  deriving stock (Int -> ActionFailure -> ShowS
[ActionFailure] -> ShowS
ActionFailure -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActionFailure] -> ShowS
$cshowList :: [ActionFailure] -> ShowS
show :: ActionFailure -> String
$cshow :: ActionFailure -> String
showsPrec :: Int -> ActionFailure -> ShowS
$cshowsPrec :: Int -> ActionFailure -> ShowS
Show)
  deriving anyclass (Show ActionFailure
Typeable ActionFailure
SomeException -> Maybe ActionFailure
ActionFailure -> String
ActionFailure -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: ActionFailure -> String
$cdisplayException :: ActionFailure -> String
fromException :: SomeException -> Maybe ActionFailure
$cfromException :: SomeException -> Maybe ActionFailure
toException :: ActionFailure -> SomeException
$ctoException :: ActionFailure -> SomeException
Exception)

runActions
  :: ( MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasLogger env
     , HasAwsEnv env
     )
  => StackName
  -> ActionOn
  -> [Action]
  -> m ()
runActions :: forall (m :: * -> *) env.
(MonadResource m, MonadLogger m, MonadReader env m, HasLogger env,
 HasAwsEnv env) =>
StackName -> ActionOn -> [Action] -> m ()
runActions StackName
stackName ActionOn
on =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *) env.
(MonadResource m, MonadLogger m, MonadReader env m, HasLogger env,
 HasAwsEnv env) =>
StackName -> Action -> m ()
runAction StackName
stackName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Action -> ActionOn -> Bool
`shouldRunOn` ActionOn
on)

shouldRunOn :: Action -> ActionOn -> Bool
shouldRunOn :: Action -> ActionOn -> Bool
shouldRunOn Action {ActionOn
on :: ActionOn
on :: Action -> ActionOn
on} ActionOn
on' = ActionOn
on forall a. Eq a => a -> a -> Bool
== ActionOn
on'

runAction
  :: ( MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasLogger env
     , HasAwsEnv env
     )
  => StackName
  -> Action
  -> m ()
runAction :: forall (m :: * -> *) env.
(MonadResource m, MonadLogger m, MonadReader env m, HasLogger env,
 HasAwsEnv env) =>
StackName -> Action -> m ()
runAction StackName
stackName Action {ActionOn
on :: ActionOn
on :: Action -> ActionOn
on, OneOrListOf ActionRun
run :: OneOrListOf ActionRun
run :: Action -> OneOrListOf ActionRun
run} = do
  forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Running action" Text -> [SeriesElem] -> Message
:# [Key
"on" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ActionOn
on, Key
"run" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OneOrListOf ActionRun
run]

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ OneOrListOf ActionRun
run forall a b. (a -> b) -> a -> b
$ \case
    InvokeLambdaByStackOutput Text
outputName -> do
      [Output]
outputs <- forall (m :: * -> *) env.
(MonadResource m, MonadReader env m, HasAwsEnv env) =>
StackName -> m [Output]
awsCloudFormationDescribeStackOutputs StackName
stackName
      case Text -> [Output] -> Maybe Text
findOutputValue Text
outputName [Output]
outputs of
        Maybe Text
Nothing -> do
          forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError
            forall a b. (a -> b) -> a -> b
$ Text
"Output not found"
            Text -> [SeriesElem] -> Message
:# [ Key
"stackName" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= StackName
stackName
               , Key
"desiredOutput" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
outputName
               , Key
"availableOutputs" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. Lens' Output (Maybe Text)
output_outputKey) [Output]
outputs
               ]
          forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ActionFailure
NoSuchOutput
        Just Text
name -> Text -> m ()
invoke Text
name
    InvokeLambdaByName Text
name -> Text -> m ()
invoke Text
name
    Exec NonEmpty String
args -> forall (m :: * -> *) env.
(MonadIO m, MonadLogger m, MonadReader env m, HasLogger env) =>
String -> [String] -> m ()
execProcessAction (forall a. NonEmpty a -> a
NE.head NonEmpty String
args) (forall a. NonEmpty a -> [a]
NE.tail NonEmpty String
args)
    Shell String
arg -> forall (m :: * -> *) env.
(MonadIO m, MonadLogger m, MonadReader env m, HasLogger env) =>
String -> [String] -> m ()
execProcessAction String
"sh" [String
"-c", String
arg]
 where
  invoke :: Text -> m ()
invoke Text
name = do
    LambdaInvokeResult
result <- forall (m :: * -> *) env a.
(MonadResource m, MonadLogger m, MonadReader env m, HasAwsEnv env,
 ToJSON a) =>
Text -> a -> m LambdaInvokeResult
awsLambdaInvoke Text
name Value
payload
    forall (m :: * -> *). MonadLogger m => LambdaInvokeResult -> m ()
logLambdaInvocationResult LambdaInvokeResult
result
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LambdaInvokeResult -> Bool
isLambdaInvocationSuccess LambdaInvokeResult
result) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ActionFailure
InvokeLambdaFailure

  payload :: Value
payload = [Pair] -> Value
object [Key
"stack" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= StackName
stackName, Key
"event" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ActionOn
on]

findOutputValue :: Text -> [Output] -> Maybe Text
findOutputValue :: Text -> [Output] -> Maybe Text
findOutputValue Text
name =
  forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Output (Maybe Text)
output_outputValue forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Output (Maybe Text)
output_outputKey)

execProcessAction
  :: (MonadIO m, MonadLogger m, MonadReader env m, HasLogger env)
  => String
  -> [String]
  -> m ()
execProcessAction :: forall (m :: * -> *) env.
(MonadIO m, MonadLogger m, MonadReader env m, HasLogger env) =>
String -> [String] -> m ()
execProcessAction String
cmd [String]
args = do
  forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"runProcess" Text -> [SeriesElem] -> Message
:# [Key
"command" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (String
cmd forall a. a -> [a] -> [a]
: [String]
args)]
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
m ()
flushLogger

  ExitCode
ec <- forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess forall a b. (a -> b) -> a -> b
$ String -> [String] -> ProcessConfig () () ()
proc String
cmd [String]
args
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
ec forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ ExitCode -> ActionFailure
ExecFailure ExitCode
ec