{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

{-
This module creates an environment for the Lambda function.
-}
module Control.Distributed.Fork.AWS.Lambda.Internal.Stack
  ( withStack,
    StackInfo (..),
    awsUploadObject,
    awsObjectExists,
  )
where

import Control.Distributed.Fork.AWS.Lambda.Internal.Constants
import Control.Distributed.Fork.AWS.Lambda.Internal.Types
import Control.Exception.Safe
import Control.Lens
import Control.Monad
import Data.Aeson (Value (Object))
import Data.Aeson.QQ
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
import Data.List
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.AWS hiding (environment)
import Network.AWS.CloudFormation
import Network.AWS.Lambda
import qualified Network.AWS.S3 as S3
import Network.AWS.Waiter
import qualified Stratosphere as S

{-
Our infrastructure in AWS Lambda looks like this.

We're using CloudFormation to create all the necessary services declaratively
and delete all of them by deleting the stack.

The components are:

* The lambda function.

* A role for the function:

    Lambda functions need to have a role attached. Currently we are both too
    lax (we're not restricting the sqs:SendMessage permission to relevant topics)
    and too strict (we're not letting user to provide a custom policy). This part
    is probably the first one to change.

* Two queues called answerQueue and deadLetterQueue

    Lambda functins have two ways to invoke them on-demand, synchronously and
    asynchronously. Using the synchronous invocation is simpler, you call the API
    and it returns the result. However it requires the HTTP connection to be open
    for the whole time. This puts a hard-cap on the scalability since the driver
    can only have so many open HTTP connections simultaneously.

    To mitigate this, we're going to use asynchronous invocation type, but use
    an SQS queue (answerQueue) to gather the results. We use another queue
    (deadLetterQueue) for collecting the failures.
-}
seTemplate :: StackOptions -> S.Template
seTemplate :: StackOptions -> Template
seTemplate StackOptions {soLambdaCode :: StackOptions -> S3Loc
soLambdaCode = S3Loc (BucketName Text
bucketName) Text
path, Int
soLambdaMemory :: StackOptions -> Int
soLambdaMemory :: Int
soLambdaMemory} =
  Resources -> Template
S.template
    ( [Resource] -> Resources
S.Resources
        [ Text -> LambdaFunction -> Resource
forall a. ToResourceProperties a => Text -> a -> Resource
S.resource Text
templateOutputFunc (LambdaFunction -> Resource) -> LambdaFunction -> Resource
forall a b. (a -> b) -> a -> b
$
            LambdaFunctionCode
-> Val Text -> Val Text -> Val Runtime -> LambdaFunction
S.lambdaFunction
              ( LambdaFunctionCode
S.lambdaFunctionCode
                  LambdaFunctionCode
-> (LambdaFunctionCode -> LambdaFunctionCode) -> LambdaFunctionCode
forall a b. a -> (a -> b) -> b
& (Maybe (Val Text) -> Identity (Maybe (Val Text)))
-> LambdaFunctionCode -> Identity LambdaFunctionCode
Lens' LambdaFunctionCode (Maybe (Val Text))
S.lfcS3Bucket
                  ((Maybe (Val Text) -> Identity (Maybe (Val Text)))
 -> LambdaFunctionCode -> Identity LambdaFunctionCode)
-> Val Text -> LambdaFunctionCode -> LambdaFunctionCode
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text -> Val Text
forall a. a -> Val a
S.Literal Text
bucketName
                  LambdaFunctionCode
-> (LambdaFunctionCode -> LambdaFunctionCode) -> LambdaFunctionCode
forall a b. a -> (a -> b) -> b
& (Maybe (Val Text) -> Identity (Maybe (Val Text)))
-> LambdaFunctionCode -> Identity LambdaFunctionCode
Lens' LambdaFunctionCode (Maybe (Val Text))
S.lfcS3Key
                  ((Maybe (Val Text) -> Identity (Maybe (Val Text)))
 -> LambdaFunctionCode -> Identity LambdaFunctionCode)
-> Val Text -> LambdaFunctionCode -> LambdaFunctionCode
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text -> Val Text
forall a. a -> Val a
S.Literal Text
path
              )
              Val Text
"handler.handle"
              (Text -> Text -> Val Text
forall a. Text -> Text -> Val a
S.GetAtt Text
"role" Text
"Arn")
              (Runtime -> Val Runtime
forall a. a -> Val a
S.Literal Runtime
S.Python27)
              LambdaFunction
-> (LambdaFunction -> LambdaFunction) -> LambdaFunction
forall a b. a -> (a -> b) -> b
& (Maybe (Val Integer) -> Identity (Maybe (Val Integer)))
-> LambdaFunction -> Identity LambdaFunction
Lens' LambdaFunction (Maybe (Val Integer))
S.lfTimeout
              ((Maybe (Val Integer) -> Identity (Maybe (Val Integer)))
 -> LambdaFunction -> Identity LambdaFunction)
-> Val Integer -> LambdaFunction -> LambdaFunction
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Integer -> Val Integer
forall a. a -> Val a
S.Literal Integer
300
              LambdaFunction
-> (LambdaFunction -> LambdaFunction) -> LambdaFunction
forall a b. a -> (a -> b) -> b
& (Maybe (Val Integer) -> Identity (Maybe (Val Integer)))
-> LambdaFunction -> Identity LambdaFunction
Lens' LambdaFunction (Maybe (Val Integer))
S.lfMemorySize
              ((Maybe (Val Integer) -> Identity (Maybe (Val Integer)))
 -> LambdaFunction -> Identity LambdaFunction)
-> Val Integer -> LambdaFunction -> LambdaFunction
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Integer -> Val Integer
forall a. a -> Val a
S.Literal (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
soLambdaMemory)
              LambdaFunction
-> (LambdaFunction -> LambdaFunction) -> LambdaFunction
forall a b. a -> (a -> b) -> b
& (Maybe LambdaFunctionDeadLetterConfig
 -> Identity (Maybe LambdaFunctionDeadLetterConfig))
-> LambdaFunction -> Identity LambdaFunction
Lens' LambdaFunction (Maybe LambdaFunctionDeadLetterConfig)
S.lfDeadLetterConfig
              ((Maybe LambdaFunctionDeadLetterConfig
  -> Identity (Maybe LambdaFunctionDeadLetterConfig))
 -> LambdaFunction -> Identity LambdaFunction)
-> LambdaFunctionDeadLetterConfig
-> LambdaFunction
-> LambdaFunction
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Maybe (Val Text) -> LambdaFunctionDeadLetterConfig
S.LambdaFunctionDeadLetterConfig (Val Text -> Maybe (Val Text)
forall a. a -> Maybe a
Just (Val Text -> Maybe (Val Text)) -> Val Text -> Maybe (Val Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Val Text
forall a. Text -> Text -> Val a
S.GetAtt Text
"deadLetterQueue" Text
"Arn"),
          Text -> IAMRole -> Resource
forall a. ToResourceProperties a => Text -> a -> Resource
S.resource Text
"role" IAMRole
seRole,
          Text -> SQSQueue -> Resource
forall a. ToResourceProperties a => Text -> a -> Resource
S.resource Text
templateOutputAnswerQueue SQSQueue
S.sqsQueue,
          Text -> SQSQueue -> Resource
forall a. ToResourceProperties a => Text -> a -> Resource
S.resource Text
templateOutputDeadLetterQueue SQSQueue
S.sqsQueue,
          Text -> S3Bucket -> Resource
forall a. ToResourceProperties a => Text -> a -> Resource
S.resource Text
templateOutputAnswerBucket S3Bucket
S.s3Bucket
        ]
    )
    Template -> (Template -> Template) -> Template
forall a b. a -> (a -> b) -> b
& (Maybe Outputs -> Identity (Maybe Outputs))
-> Template -> Identity Template
Lens' Template (Maybe Outputs)
S.templateOutputs
    ((Maybe Outputs -> Identity (Maybe Outputs))
 -> Template -> Identity Template)
-> Outputs -> Template -> Template
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Output] -> Outputs
S.Outputs
      [ Text -> Val Text -> Output
S.output Text
templateOutputFunc (Text -> Val Text
forall a. Text -> Val a
S.Ref Text
templateOutputFunc),
        Text -> Val Text -> Output
S.output Text
templateOutputAnswerQueue (Text -> Val Text
forall a. Text -> Val a
S.Ref Text
templateOutputAnswerQueue),
        Text -> Val Text -> Output
S.output Text
templateOutputDeadLetterQueue (Text -> Val Text
forall a. Text -> Val a
S.Ref Text
templateOutputDeadLetterQueue),
        Text -> Val Text -> Output
S.output Text
templateOutputAnswerBucket (Text -> Val Text
forall a. Text -> Val a
S.Ref Text
templateOutputAnswerBucket)
      ]

seRole :: S.IAMRole
seRole :: IAMRole
seRole =
  Object -> IAMRole
S.iamRole Object
assumeRolePolicy
    IAMRole -> (IAMRole -> IAMRole) -> IAMRole
forall a b. a -> (a -> b) -> b
& (Maybe [IAMRolePolicy] -> Identity (Maybe [IAMRolePolicy]))
-> IAMRole -> Identity IAMRole
Lens' IAMRole (Maybe [IAMRolePolicy])
S.iamrPolicies
    ((Maybe [IAMRolePolicy] -> Identity (Maybe [IAMRolePolicy]))
 -> IAMRole -> Identity IAMRole)
-> [IAMRolePolicy] -> IAMRole -> IAMRole
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [ Object -> Val Text -> IAMRolePolicy
S.iamRolePolicy Object
sqsAccessPolicy (Text -> Val Text
forall a. a -> Val a
S.Literal Text
"sqs"),
         Object -> Val Text -> IAMRolePolicy
S.iamRolePolicy Object
cloudwatchPolicy (Text -> Val Text
forall a. a -> Val a
S.Literal Text
"cloudwatch")
       ]
  where
    assumeRolePolicy :: Object
assumeRolePolicy =
      Value -> Object
valueToObject
        [aesonQQ|
      {
        "Version":"2012-10-17",
        "Statement": [{
          "Effect": "Allow",
          "Principal": {
            "Service": [ "lambda.amazonaws.com" ]
          },
          "Action": [ "sts:AssumeRole" ]
        }]
      }
    |]
    sqsAccessPolicy :: Object
sqsAccessPolicy =
      Value -> Object
valueToObject
        [aesonQQ|
      {
        "Version": "2012-10-17",
        "Statement": [{
          "Effect": "Allow",
          "Action": [
              "sqs:SendMessage"
          ],
          "Resource": "arn:aws:sqs:*"
        }, {
          "Effect": "Allow",
          "Action": [
              "s3:PutObject",
              "s3:GetObject"
          ],
          "Resource": "arn:aws:s3:::*"
        }]
      }
    |]
    cloudwatchPolicy :: Object
cloudwatchPolicy =
      Value -> Object
valueToObject
        [aesonQQ|
      {
        "Version": "2012-10-17",
        "Statement": [{
          "Action": [
            "logs:CreateLogGroup",
            "logs:CreateLogStream",
            "logs:PutLogEvents"
          ],
          "Effect": "Allow",
          "Resource": "arn:aws:logs:*:*:*"
        }]
      }
    |]
    valueToObject :: Value -> Object
valueToObject = \case
      Object Object
hm -> Object
hm
      Value
_ -> String -> Object
forall a. HasCallStack => String -> a
error String
"invariant violation"

templateOutputFunc :: T.Text
templateOutputFunc :: Text
templateOutputFunc = Text
"output"

templateOutputAnswerQueue :: T.Text
templateOutputAnswerQueue :: Text
templateOutputAnswerQueue = Text
"answerQueue"

templateOutputDeadLetterQueue :: T.Text
templateOutputDeadLetterQueue :: Text
templateOutputDeadLetterQueue = Text
"deadLetterQueue"

templateOutputAnswerBucket :: T.Text
templateOutputAnswerBucket :: Text
templateOutputAnswerBucket = Text
"answerBucket"

{-
Before creating a stack, we need to upload the artifact to S3.
-}
awsUploadObject :: S3Loc -> BS.ByteString -> AWS ()
awsUploadObject :: S3Loc -> ByteString -> AWS ()
awsUploadObject (S3Loc (BucketName Text
bucket) Text
path) ByteString
contents = do
  PutObjectResponse
pors <-
    PutObject -> AWST' Env (ResourceT IO) (Rs PutObject)
forall (m :: * -> *) a. (MonadAWS m, AWSRequest a) => a -> m (Rs a)
send (PutObject -> AWST' Env (ResourceT IO) (Rs PutObject))
-> PutObject -> AWST' Env (ResourceT IO) (Rs PutObject)
forall a b. (a -> b) -> a -> b
$
      BucketName -> ObjectKey -> RqBody -> PutObject
S3.putObject
        (Text -> BucketName
S3.BucketName Text
bucket)
        (Text -> ObjectKey
S3.ObjectKey Text
path)
        (ByteString -> RqBody
forall a. ToBody a => a -> RqBody
toBody ByteString
contents)
  Bool -> AWS () -> AWS ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PutObjectResponse
pors PutObjectResponse -> Getting Int PutObjectResponse Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PutObjectResponse Int
Lens' PutObjectResponse Int
S3.porsResponseStatus Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200)
    (AWS () -> AWS ()) -> AWS () -> AWS ()
forall a b. (a -> b) -> a -> b
$ StackException -> AWS ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
      (StackException -> AWS ())
-> (Text -> StackException) -> Text -> AWS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> StackException
StackException
    (Text -> AWS ()) -> Text -> AWS ()
forall a b. (a -> b) -> a -> b
$ Text
"Upload failed. Status code: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ PutObjectResponse
pors PutObjectResponse -> Getting Int PutObjectResponse Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PutObjectResponse Int
Lens' PutObjectResponse Int
S3.porsResponseStatus)

awsObjectExists :: S3Loc -> AWS Bool
awsObjectExists :: S3Loc -> AWS Bool
awsObjectExists (S3Loc (BucketName Text
bucket) Text
path) = do
  ListObjectsResponse
lors <-
    ListObjects -> AWST' Env (ResourceT IO) (Rs ListObjects)
forall (m :: * -> *) a. (MonadAWS m, AWSRequest a) => a -> m (Rs a)
send (ListObjects -> AWST' Env (ResourceT IO) (Rs ListObjects))
-> ListObjects -> AWST' Env (ResourceT IO) (Rs ListObjects)
forall a b. (a -> b) -> a -> b
$
      BucketName -> ListObjects
S3.listObjects (Text -> BucketName
S3.BucketName Text
bucket)
        ListObjects -> (ListObjects -> ListObjects) -> ListObjects
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> ListObjects -> Identity ListObjects
Lens' ListObjects (Maybe Text)
S3.loPrefix
        ((Maybe Text -> Identity (Maybe Text))
 -> ListObjects -> Identity ListObjects)
-> Text -> ListObjects -> ListObjects
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
path
  Bool -> AWS () -> AWS ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ListObjectsResponse
lors ListObjectsResponse -> Getting Int ListObjectsResponse Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int ListObjectsResponse Int
Lens' ListObjectsResponse Int
S3.lorsResponseStatus Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200)
    (AWS () -> AWS ()) -> AWS () -> AWS ()
forall a b. (a -> b) -> a -> b
$ StackException -> AWS ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
      (StackException -> AWS ())
-> (Text -> StackException) -> Text -> AWS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> StackException
StackException
    (Text -> AWS ()) -> Text -> AWS ()
forall a b. (a -> b) -> a -> b
$ Text
"List objects failed. Status code: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ListObjectsResponse -> String
forall a. Show a => a -> String
show ListObjectsResponse
lors)
  let files :: [ObjectKey]
files = (Object -> ObjectKey) -> [Object] -> [ObjectKey]
forall a b. (a -> b) -> [a] -> [b]
map (Getting ObjectKey Object ObjectKey -> Object -> ObjectKey
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ObjectKey Object ObjectKey
Lens' Object ObjectKey
S3.oKey) (ListObjectsResponse
lors ListObjectsResponse
-> Getting [Object] ListObjectsResponse [Object] -> [Object]
forall s a. s -> Getting a s a -> a
^. Getting [Object] ListObjectsResponse [Object]
Lens' ListObjectsResponse [Object]
S3.lorsContents)
  Bool -> AWS Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> AWS Bool) -> Bool -> AWS Bool
forall a b. (a -> b) -> a -> b
$ (ObjectKey -> Bool) -> [ObjectKey] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(S3.ObjectKey Text
k) -> Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
path) [ObjectKey]
files

{-
Here we are actually creating the stack.

Tricky part is that, since our lambda function publish to answerQueue, it needs
to know the URL for it. However LambdaFunctionEnvironment in CloudFormation does
not support referring to stack variables inside, so we need to patch the function
afterwards to add the URL to the environment
-}
data StackInfo
  = StackInfo
      { StackInfo -> Text
siId :: T.Text,
        StackInfo -> Text
siFunc :: T.Text,
        StackInfo -> Text
siAnswerQueue :: T.Text,
        StackInfo -> Text
siDeadLetterQueue :: T.Text,
        StackInfo -> Text
siAnswerBucket :: T.Text
      }

seCreateStack :: StackOptions -> AWS StackInfo
seCreateStack :: StackOptions -> AWS StackInfo
seCreateStack options :: StackOptions
options@StackOptions {soName :: StackOptions -> StackName
soName = StackName Text
stackName} = do
  CreateStackResponse
csrs <-
    CreateStack -> AWST' Env (ResourceT IO) (Rs CreateStack)
forall (m :: * -> *) a. (MonadAWS m, AWSRequest a) => a -> m (Rs a)
send (CreateStack -> AWST' Env (ResourceT IO) (Rs CreateStack))
-> CreateStack -> AWST' Env (ResourceT IO) (Rs CreateStack)
forall a b. (a -> b) -> a -> b
$
      Text -> CreateStack
createStack Text
stackName
        CreateStack -> (CreateStack -> CreateStack) -> CreateStack
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> CreateStack -> Identity CreateStack
Lens' CreateStack (Maybe Text)
csTemplateBody
        ((Maybe Text -> Identity (Maybe Text))
 -> CreateStack -> Identity CreateStack)
-> Text -> CreateStack -> CreateStack
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (Template -> ByteString) -> Template -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Template -> ByteString) -> Template -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Template -> ByteString
S.encodeTemplate (Template -> Text) -> Template -> Text
forall a b. (a -> b) -> a -> b
$ StackOptions -> Template
seTemplate StackOptions
options)
        CreateStack -> (CreateStack -> CreateStack) -> CreateStack
forall a b. a -> (a -> b) -> b
& ([Capability] -> Identity [Capability])
-> CreateStack -> Identity CreateStack
Lens' CreateStack [Capability]
csCapabilities
        (([Capability] -> Identity [Capability])
 -> CreateStack -> Identity CreateStack)
-> [Capability] -> CreateStack -> CreateStack
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Capability
CapabilityIAM]
  Bool -> AWS () -> AWS ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CreateStackResponse
csrs CreateStackResponse -> Getting Int CreateStackResponse Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int CreateStackResponse Int
Lens' CreateStackResponse Int
csrsResponseStatus Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200)
    (AWS () -> AWS ()) -> AWS () -> AWS ()
forall a b. (a -> b) -> a -> b
$ StackException -> AWS ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
    (StackException -> AWS ()) -> StackException -> AWS ()
forall a b. (a -> b) -> a -> b
$ Text -> StackException
StackException
      (Text
"CloudFormation stack creation request failed." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (CreateStackResponse -> String
forall a. Show a => a -> String
show CreateStackResponse
csrs))
  Text
stackId <-
    case CreateStackResponse
csrs CreateStackResponse
-> Getting (Maybe Text) CreateStackResponse (Maybe Text)
-> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) CreateStackResponse (Maybe Text)
Lens' CreateStackResponse (Maybe Text)
csrsStackId of
      Maybe Text
Nothing ->
        StackException -> AWST' Env (ResourceT IO) Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackException -> AWST' Env (ResourceT IO) Text)
-> StackException -> AWST' Env (ResourceT IO) Text
forall a b. (a -> b) -> a -> b
$
          Text -> StackException
StackException
            Text
"Could not determine stack id."
      Just Text
xs -> Text -> AWST' Env (ResourceT IO) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
xs
  Wait DescribeStacks
-> DescribeStacks -> AWST' Env (ResourceT IO) Accept
forall (m :: * -> *) a.
(MonadAWS m, AWSRequest a) =>
Wait a -> a -> m Accept
await Wait DescribeStacks
stackCreateComplete (DescribeStacks
describeStacks DescribeStacks
-> (DescribeStacks -> DescribeStacks) -> DescribeStacks
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> DescribeStacks -> Identity DescribeStacks
Lens' DescribeStacks (Maybe Text)
dStackName ((Maybe Text -> Identity (Maybe Text))
 -> DescribeStacks -> Identity DescribeStacks)
-> Text -> DescribeStacks -> DescribeStacks
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
stackId) AWST' Env (ResourceT IO) Accept -> (Accept -> AWS ()) -> AWS ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Accept
AcceptSuccess -> () -> AWS ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Accept
err ->
      StackException -> AWS ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackException -> AWS ())
-> (Text -> StackException) -> Text -> AWS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> StackException
StackException (Text -> AWS ()) -> Text -> AWS ()
forall a b. (a -> b) -> a -> b
$ Text
"CloudFormation stack creation failed." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Accept -> String
forall a. Show a => a -> String
show Accept
err)
  DescribeStacksResponse
dsrs <- DescribeStacks -> AWST' Env (ResourceT IO) (Rs DescribeStacks)
forall (m :: * -> *) a. (MonadAWS m, AWSRequest a) => a -> m (Rs a)
send (DescribeStacks -> AWST' Env (ResourceT IO) (Rs DescribeStacks))
-> DescribeStacks -> AWST' Env (ResourceT IO) (Rs DescribeStacks)
forall a b. (a -> b) -> a -> b
$ DescribeStacks
describeStacks DescribeStacks
-> (DescribeStacks -> DescribeStacks) -> DescribeStacks
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> DescribeStacks -> Identity DescribeStacks
Lens' DescribeStacks (Maybe Text)
dStackName ((Maybe Text -> Identity (Maybe Text))
 -> DescribeStacks -> Identity DescribeStacks)
-> Text -> DescribeStacks -> DescribeStacks
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
stackName
  Bool -> AWS () -> AWS ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DescribeStacksResponse
dsrs DescribeStacksResponse
-> Getting Int DescribeStacksResponse Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int DescribeStacksResponse Int
Lens' DescribeStacksResponse Int
dsrsResponseStatus Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200)
    (AWS () -> AWS ()) -> AWS () -> AWS ()
forall a b. (a -> b) -> a -> b
$ StackException -> AWS ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
      (StackException -> AWS ())
-> (Text -> StackException) -> Text -> AWS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> StackException
StackException
    (Text -> AWS ()) -> Text -> AWS ()
forall a b. (a -> b) -> a -> b
$ Text
"CloudFormation describeStack failed. Status code: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ DescribeStacksResponse
dsrs DescribeStacksResponse
-> Getting Int DescribeStacksResponse Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int DescribeStacksResponse Int
Lens' DescribeStacksResponse Int
dsrsResponseStatus)
  Stack
stackRs <-
    case DescribeStacksResponse
dsrs DescribeStacksResponse
-> Getting [Stack] DescribeStacksResponse [Stack] -> [Stack]
forall s a. s -> Getting a s a -> a
^. Getting [Stack] DescribeStacksResponse [Stack]
Lens' DescribeStacksResponse [Stack]
dsrsStacks of
      [Stack
x] -> Stack -> AWST' Env (ResourceT IO) Stack
forall (m :: * -> *) a. Monad m => a -> m a
return Stack
x
      [Stack]
_ -> StackException -> AWST' Env (ResourceT IO) Stack
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackException -> AWST' Env (ResourceT IO) Stack)
-> StackException -> AWST' Env (ResourceT IO) Stack
forall a b. (a -> b) -> a -> b
$ Text -> StackException
StackException Text
"Unexpected answer from DescribeStacks."
  Text
func <-
    case Stack -> Text -> Maybe Text
lookupOutput Stack
stackRs Text
templateOutputFunc of
      Maybe Text
Nothing -> StackException -> AWST' Env (ResourceT IO) Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackException -> AWST' Env (ResourceT IO) Text)
-> StackException -> AWST' Env (ResourceT IO) Text
forall a b. (a -> b) -> a -> b
$ Text -> StackException
StackException Text
"Could not determine function name."
      Just Text
t -> Text -> AWST' Env (ResourceT IO) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
  Text
answerQueue <-
    case Stack -> Text -> Maybe Text
lookupOutput Stack
stackRs Text
templateOutputAnswerQueue of
      Maybe Text
Nothing -> StackException -> AWST' Env (ResourceT IO) Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackException -> AWST' Env (ResourceT IO) Text)
-> StackException -> AWST' Env (ResourceT IO) Text
forall a b. (a -> b) -> a -> b
$ Text -> StackException
StackException Text
"Could not determine answerQueue URL."
      Just Text
t -> Text -> AWST' Env (ResourceT IO) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
  Text
deadLetterQueue <-
    case Stack -> Text -> Maybe Text
lookupOutput Stack
stackRs Text
templateOutputDeadLetterQueue of
      Maybe Text
Nothing -> StackException -> AWST' Env (ResourceT IO) Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackException -> AWST' Env (ResourceT IO) Text)
-> StackException -> AWST' Env (ResourceT IO) Text
forall a b. (a -> b) -> a -> b
$ Text -> StackException
StackException Text
"Could not determine deadLetterQueue URL."
      Just Text
t -> Text -> AWST' Env (ResourceT IO) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
  Text
answerBucket <-
    case Stack -> Text -> Maybe Text
lookupOutput Stack
stackRs Text
templateOutputAnswerBucket of
      Maybe Text
Nothing -> StackException -> AWST' Env (ResourceT IO) Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackException -> AWST' Env (ResourceT IO) Text)
-> StackException -> AWST' Env (ResourceT IO) Text
forall a b. (a -> b) -> a -> b
$ Text -> StackException
StackException Text
"Could not determine answerBucket URL."
      Just Text
t -> Text -> AWST' Env (ResourceT IO) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
  FunctionConfiguration
_ <-
    UpdateFunctionConfiguration
-> AWST' Env (ResourceT IO) (Rs UpdateFunctionConfiguration)
forall (m :: * -> *) a. (MonadAWS m, AWSRequest a) => a -> m (Rs a)
send (UpdateFunctionConfiguration
 -> AWST' Env (ResourceT IO) (Rs UpdateFunctionConfiguration))
-> UpdateFunctionConfiguration
-> AWST' Env (ResourceT IO) (Rs UpdateFunctionConfiguration)
forall a b. (a -> b) -> a -> b
$
      Text -> UpdateFunctionConfiguration
updateFunctionConfiguration Text
func
        UpdateFunctionConfiguration
-> (UpdateFunctionConfiguration -> UpdateFunctionConfiguration)
-> UpdateFunctionConfiguration
forall a b. a -> (a -> b) -> b
& (Maybe Environment -> Identity (Maybe Environment))
-> UpdateFunctionConfiguration
-> Identity UpdateFunctionConfiguration
Lens' UpdateFunctionConfiguration (Maybe Environment)
ufcEnvironment
        ((Maybe Environment -> Identity (Maybe Environment))
 -> UpdateFunctionConfiguration
 -> Identity UpdateFunctionConfiguration)
-> Environment
-> UpdateFunctionConfiguration
-> UpdateFunctionConfiguration
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( Environment
environment
               Environment -> (Environment -> Environment) -> Environment
forall a b. a -> (a -> b) -> b
& (Maybe (HashMap Text Text) -> Identity (Maybe (HashMap Text Text)))
-> Environment -> Identity Environment
Lens' Environment (Maybe (HashMap Text Text))
eVariables
               ((Maybe (HashMap Text Text)
  -> Identity (Maybe (HashMap Text Text)))
 -> Environment -> Identity Environment)
-> HashMap Text Text -> Environment -> Environment
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
                 [ (Text
envAnswerQueueUrl, Text
answerQueue),
                   (Text
envAnswerBucketUrl, Text
answerBucket)
                 ]
           )
  StackInfo -> AWS StackInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (StackInfo -> AWS StackInfo) -> StackInfo -> AWS StackInfo
forall a b. (a -> b) -> a -> b
$
    StackInfo :: Text -> Text -> Text -> Text -> Text -> StackInfo
StackInfo
      { siId :: Text
siId = Text
stackId,
        siFunc :: Text
siFunc = Text
func,
        siAnswerQueue :: Text
siAnswerQueue = Text
answerQueue,
        siDeadLetterQueue :: Text
siDeadLetterQueue = Text
deadLetterQueue,
        siAnswerBucket :: Text
siAnswerBucket = Text
answerBucket
      }
  where
    lookupOutput :: Stack -> T.Text -> Maybe T.Text
    lookupOutput :: Stack -> Text -> Maybe Text
lookupOutput Stack
st Text
key =
      (Output -> Text) -> Maybe Output -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Output
i -> Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Output
i Output -> Getting (Maybe Text) Output (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) Output (Maybe Text)
Lens' Output (Maybe Text)
oOutputValue)
        (Maybe Output -> Maybe Text)
-> ([Output] -> Maybe Output) -> [Output] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Output -> Bool) -> [Output] -> Maybe Output
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Output
o -> Output
o Output -> Getting (Maybe Text) Output (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) Output (Maybe Text)
Lens' Output (Maybe Text)
oOutputKey Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
key)
        ([Output] -> Maybe Text) -> [Output] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Stack
st
          Stack -> Getting [Output] Stack [Output] -> [Output]
forall s a. s -> Getting a s a -> a
^. Getting [Output] Stack [Output]
Lens' Stack [Output]
sOutputs

seDeleteStack :: StackInfo -> AWS ()
seDeleteStack :: StackInfo -> AWS ()
seDeleteStack = AWST' Env (ResourceT IO) DeleteStackResponse -> AWS ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AWST' Env (ResourceT IO) DeleteStackResponse -> AWS ())
-> (StackInfo -> AWST' Env (ResourceT IO) DeleteStackResponse)
-> StackInfo
-> AWS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeleteStack -> AWST' Env (ResourceT IO) DeleteStackResponse
forall (m :: * -> *) a. (MonadAWS m, AWSRequest a) => a -> m (Rs a)
send (DeleteStack -> AWST' Env (ResourceT IO) DeleteStackResponse)
-> (StackInfo -> DeleteStack)
-> StackInfo
-> AWST' Env (ResourceT IO) DeleteStackResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DeleteStack
deleteStack (Text -> DeleteStack)
-> (StackInfo -> Text) -> StackInfo -> DeleteStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackInfo -> Text
siId

newtype StackException
  = StackException T.Text
  deriving (Int -> StackException -> ShowS
[StackException] -> ShowS
StackException -> String
(Int -> StackException -> ShowS)
-> (StackException -> String)
-> ([StackException] -> ShowS)
-> Show StackException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StackException] -> ShowS
$cshowList :: [StackException] -> ShowS
show :: StackException -> String
$cshow :: StackException -> String
showsPrec :: Int -> StackException -> ShowS
$cshowsPrec :: Int -> StackException -> ShowS
Show)

instance Exception StackException

withStack :: StackOptions -> Env -> (StackInfo -> IO a) -> IO a
withStack :: StackOptions -> Env -> (StackInfo -> IO a) -> IO a
withStack StackOptions
opts Env
env = IO StackInfo -> (StackInfo -> IO ()) -> (StackInfo -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket IO StackInfo
create StackInfo -> IO ()
destroy
  where
    create :: IO StackInfo
create =
      ResourceT IO StackInfo -> IO StackInfo
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO StackInfo -> IO StackInfo)
-> (AWS StackInfo -> ResourceT IO StackInfo)
-> AWS StackInfo
-> IO StackInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AWS StackInfo -> ResourceT IO StackInfo
forall (m :: * -> *) r a.
(MonadResource m, HasEnv r) =>
r -> AWS a -> m a
runAWS Env
env (AWS StackInfo -> IO StackInfo) -> AWS StackInfo -> IO StackInfo
forall a b. (a -> b) -> a -> b
$ StackOptions -> AWS StackInfo
seCreateStack StackOptions
opts
    destroy :: StackInfo -> IO ()
destroy =
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (StackOptions -> Bool
soKeep StackOptions
opts) (IO () -> IO ()) -> (StackInfo -> IO ()) -> StackInfo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceT IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO () -> IO ())
-> (StackInfo -> ResourceT IO ()) -> StackInfo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AWS () -> ResourceT IO ()
forall (m :: * -> *) r a.
(MonadResource m, HasEnv r) =>
r -> AWS a -> m a
runAWS Env
env (AWS () -> ResourceT IO ())
-> (StackInfo -> AWS ()) -> StackInfo -> ResourceT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackInfo -> AWS ()
seDeleteStack