{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Galley.Aws
  ( Env,
    mkEnv,
    awsEnv,
    eventQueue,
    QueueUrl (..),
    Amazon,
    execute,
    enqueue,

    -- * Errors
    Error (..),
  )
where

import Amazonka qualified as AWS
import Amazonka.SQS qualified as SQS
import Amazonka.SQS.Lens qualified as SQS
import Control.Lens hiding ((.=))
import Control.Monad.Catch
import Control.Monad.Trans.Resource
import Control.Retry (exponentialBackoff, limitRetries, retrying)
import Data.ByteString.Base64 qualified as B64
import Data.ByteString.Builder (toLazyByteString)
import Data.ProtoLens.Encoding
import Data.Text.Encoding (decodeLatin1)
import Data.UUID (toText)
import Data.UUID.V4
import Galley.Options
import Imports
import Network.HTTP.Client
  ( HttpException (..),
    HttpExceptionContent (..),
    Manager,
  )
import Network.TLS qualified as TLS
import Proto.TeamEvents qualified as E
import System.Logger qualified as Logger
import System.Logger.Class
import Util.Options hiding (endpoint)

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

data Error where
  GeneralError :: (Show e, AWS.AsError e) => e -> Error

deriving instance Show Error

deriving instance Typeable Error

instance Exception Error

data Env = Env
  { Env -> Env
_awsEnv :: !AWS.Env,
    Env -> Logger
_logger :: !Logger,
    Env -> QueueUrl
_eventQueue :: !QueueUrl
  }

makeLenses ''Env

newtype Amazon a = Amazon
  { forall a. Amazon a -> ReaderT Env (ResourceT IO) a
unAmazon :: ReaderT Env (ResourceT IO) a
  }
  deriving
    ( (forall a b. (a -> b) -> Amazon a -> Amazon b)
-> (forall a b. a -> Amazon b -> Amazon a) -> Functor Amazon
forall a b. a -> Amazon b -> Amazon a
forall a b. (a -> b) -> Amazon a -> Amazon b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Amazon a -> Amazon b
fmap :: forall a b. (a -> b) -> Amazon a -> Amazon b
$c<$ :: forall a b. a -> Amazon b -> Amazon a
<$ :: forall a b. a -> Amazon b -> Amazon a
Functor,
      Functor Amazon
Functor Amazon =>
(forall a. a -> Amazon a)
-> (forall a b. Amazon (a -> b) -> Amazon a -> Amazon b)
-> (forall a b c.
    (a -> b -> c) -> Amazon a -> Amazon b -> Amazon c)
-> (forall a b. Amazon a -> Amazon b -> Amazon b)
-> (forall a b. Amazon a -> Amazon b -> Amazon a)
-> Applicative Amazon
forall a. a -> Amazon a
forall a b. Amazon a -> Amazon b -> Amazon a
forall a b. Amazon a -> Amazon b -> Amazon b
forall a b. Amazon (a -> b) -> Amazon a -> Amazon b
forall a b c. (a -> b -> c) -> Amazon a -> Amazon b -> Amazon c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Amazon a
pure :: forall a. a -> Amazon a
$c<*> :: forall a b. Amazon (a -> b) -> Amazon a -> Amazon b
<*> :: forall a b. Amazon (a -> b) -> Amazon a -> Amazon b
$cliftA2 :: forall a b c. (a -> b -> c) -> Amazon a -> Amazon b -> Amazon c
liftA2 :: forall a b c. (a -> b -> c) -> Amazon a -> Amazon b -> Amazon c
$c*> :: forall a b. Amazon a -> Amazon b -> Amazon b
*> :: forall a b. Amazon a -> Amazon b -> Amazon b
$c<* :: forall a b. Amazon a -> Amazon b -> Amazon a
<* :: forall a b. Amazon a -> Amazon b -> Amazon a
Applicative,
      Applicative Amazon
Applicative Amazon =>
(forall a b. Amazon a -> (a -> Amazon b) -> Amazon b)
-> (forall a b. Amazon a -> Amazon b -> Amazon b)
-> (forall a. a -> Amazon a)
-> Monad Amazon
forall a. a -> Amazon a
forall a b. Amazon a -> Amazon b -> Amazon b
forall a b. Amazon a -> (a -> Amazon b) -> Amazon b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Amazon a -> (a -> Amazon b) -> Amazon b
>>= :: forall a b. Amazon a -> (a -> Amazon b) -> Amazon b
$c>> :: forall a b. Amazon a -> Amazon b -> Amazon b
>> :: forall a b. Amazon a -> Amazon b -> Amazon b
$creturn :: forall a. a -> Amazon a
return :: forall a. a -> Amazon a
Monad,
      Monad Amazon
Monad Amazon => (forall a. IO a -> Amazon a) -> MonadIO Amazon
forall a. IO a -> Amazon a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Amazon a
liftIO :: forall a. IO a -> Amazon a
MonadIO,
      Monad Amazon
Monad Amazon =>
(forall e a. (HasCallStack, Exception e) => e -> Amazon a)
-> MonadThrow Amazon
forall e a. (HasCallStack, Exception e) => e -> Amazon a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> Amazon a
throwM :: forall e a. (HasCallStack, Exception e) => e -> Amazon a
MonadThrow,
      MonadThrow Amazon
MonadThrow Amazon =>
(forall e a.
 (HasCallStack, Exception e) =>
 Amazon a -> (e -> Amazon a) -> Amazon a)
-> MonadCatch Amazon
forall e a.
(HasCallStack, Exception e) =>
Amazon a -> (e -> Amazon a) -> Amazon a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
Amazon a -> (e -> Amazon a) -> Amazon a
catch :: forall e a.
(HasCallStack, Exception e) =>
Amazon a -> (e -> Amazon a) -> Amazon a
MonadCatch,
      MonadCatch Amazon
MonadCatch Amazon =>
(forall b.
 HasCallStack =>
 ((forall a. Amazon a -> Amazon a) -> Amazon b) -> Amazon b)
-> (forall b.
    HasCallStack =>
    ((forall a. Amazon a -> Amazon a) -> Amazon b) -> Amazon b)
-> (forall a b c.
    HasCallStack =>
    Amazon a
    -> (a -> ExitCase b -> Amazon c)
    -> (a -> Amazon b)
    -> Amazon (b, c))
-> MonadMask Amazon
forall b.
HasCallStack =>
((forall a. Amazon a -> Amazon a) -> Amazon b) -> Amazon b
forall a b c.
HasCallStack =>
Amazon a
-> (a -> ExitCase b -> Amazon c)
-> (a -> Amazon b)
-> Amazon (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. Amazon a -> Amazon a) -> Amazon b) -> Amazon b
mask :: forall b.
HasCallStack =>
((forall a. Amazon a -> Amazon a) -> Amazon b) -> Amazon b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. Amazon a -> Amazon a) -> Amazon b) -> Amazon b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. Amazon a -> Amazon a) -> Amazon b) -> Amazon b
$cgeneralBracket :: forall a b c.
HasCallStack =>
Amazon a
-> (a -> ExitCase b -> Amazon c)
-> (a -> Amazon b)
-> Amazon (b, c)
generalBracket :: forall a b c.
HasCallStack =>
Amazon a
-> (a -> ExitCase b -> Amazon c)
-> (a -> Amazon b)
-> Amazon (b, c)
MonadMask,
      MonadReader Env,
      MonadIO Amazon
MonadIO Amazon =>
(forall a. ResourceT IO a -> Amazon a) -> MonadResource Amazon
forall a. ResourceT IO a -> Amazon a
forall (m :: * -> *).
MonadIO m =>
(forall a. ResourceT IO a -> m a) -> MonadResource m
$cliftResourceT :: forall a. ResourceT IO a -> Amazon a
liftResourceT :: forall a. ResourceT IO a -> Amazon a
MonadResource,
      MonadIO Amazon
MonadIO Amazon =>
(forall b. ((forall a. Amazon a -> IO a) -> IO b) -> Amazon b)
-> MonadUnliftIO Amazon
forall b. ((forall a. Amazon a -> IO a) -> IO b) -> Amazon b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b. ((forall a. Amazon a -> IO a) -> IO b) -> Amazon b
withRunInIO :: forall b. ((forall a. Amazon a -> IO a) -> IO b) -> Amazon b
MonadUnliftIO
    )

instance MonadLogger Amazon where
  log :: Level -> (Msg -> Msg) -> Amazon ()
log Level
l Msg -> Msg
m = Getting Logger Env Logger -> Amazon Logger
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Logger Env Logger
Lens' Env Logger
logger Amazon Logger -> (Logger -> Amazon ()) -> Amazon ()
forall a b. Amazon a -> (a -> Amazon b) -> Amazon b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Logger
g -> Logger -> Level -> (Msg -> Msg) -> Amazon ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
Logger.log Logger
g Level
l Msg -> Msg
m

mkEnv :: Logger -> Manager -> JournalOpts -> IO Env
mkEnv :: Logger -> Manager -> JournalOpts -> IO Env
mkEnv Logger
lgr Manager
mgr JournalOpts
opts = do
  let g :: Logger
g = Maybe Text -> Logger -> Logger
Logger.clone (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"aws.galley") Logger
lgr
  Env
e <- Logger -> IO Env
mkAwsEnv Logger
g
  QueueUrl
q <- Env -> Text -> IO QueueUrl
getQueueUrl Env
e (JournalOpts
opts JournalOpts -> Getting Text JournalOpts Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text JournalOpts Text
Lens' JournalOpts Text
queueName)
  Env -> IO Env
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env -> Logger -> QueueUrl -> Env
Env Env
e Logger
g QueueUrl
q)
  where
    sqs :: AWSEndpoint -> Service
sqs AWSEndpoint
e = Bool -> ByteString -> Int -> Service -> Service
AWS.setEndpoint (AWSEndpoint
e AWSEndpoint -> Getting Bool AWSEndpoint Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool AWSEndpoint Bool
Lens' AWSEndpoint Bool
awsSecure) (AWSEndpoint
e AWSEndpoint
-> Getting ByteString AWSEndpoint ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString AWSEndpoint ByteString
Lens' AWSEndpoint ByteString
awsHost) (AWSEndpoint
e AWSEndpoint -> Getting Int AWSEndpoint Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int AWSEndpoint Int
Lens' AWSEndpoint Int
awsPort) Service
SQS.defaultService
    mkAwsEnv :: Logger -> IO Env
mkAwsEnv Logger
g = do
      Env
baseEnv <-
        (EnvNoAuth -> IO Env) -> IO Env
forall (m :: * -> *). MonadIO m => (EnvNoAuth -> m Env) -> m Env
AWS.newEnv EnvNoAuth -> IO Env
forall (m :: * -> *) (withAuth :: * -> *).
(MonadCatch m, MonadIO m, Foldable withAuth) =>
Env' withAuth -> m Env
AWS.discover
          IO Env -> (Env -> Env) -> IO Env
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Service -> Env -> Env
forall (withAuth :: * -> *).
Service -> Env' withAuth -> Env' withAuth
AWS.configureService (AWSEndpoint -> Service
sqs (JournalOpts
opts JournalOpts
-> Getting AWSEndpoint JournalOpts AWSEndpoint -> AWSEndpoint
forall s a. s -> Getting a s a -> a
^. Getting AWSEndpoint JournalOpts AWSEndpoint
Lens' JournalOpts AWSEndpoint
endpoint))
      Env -> IO Env
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env -> IO Env) -> Env -> IO Env
forall a b. (a -> b) -> a -> b
$
        Env
baseEnv
          { AWS.logger = awsLogger g,
            AWS.retryCheck = retryCheck,
            AWS.manager = mgr
          }
    awsLogger :: Logger -> LogLevel -> Builder -> m ()
awsLogger Logger
g LogLevel
l = Logger -> Level -> (Msg -> Msg) -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
Logger.log Logger
g (LogLevel -> Level
mapLevel LogLevel
l) ((Msg -> Msg) -> m ())
-> (Builder -> Msg -> Msg) -> Builder -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Logger.msg (ByteString -> Msg -> Msg)
-> (Builder -> ByteString) -> Builder -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString
    mapLevel :: LogLevel -> Level
mapLevel LogLevel
AWS.Info = Level
Logger.Info
    -- Debug output from amazonka can be very useful for tracing requests
    -- but is very verbose (and multiline which we don't handle well)
    -- distracting from our own debug logs, so we map amazonka's 'Debug'
    -- level to our 'Trace' level.
    mapLevel LogLevel
AWS.Debug = Level
Logger.Trace
    mapLevel LogLevel
AWS.Trace = Level
Logger.Trace
    -- n.b. Errors are either returned or thrown. In both cases they will
    -- already be logged if left unhandled. We don't want errors to be
    -- logged inside amazonka already, before we even had a chance to handle
    -- them, which results in distracting noise. For debugging purposes,
    -- they are still revealed on debug level.
    mapLevel LogLevel
AWS.Error = Level
Logger.Debug
    -- TODO: Remove custom retryCheck? Should be fixed since tls 1.3.9?
    -- account occasional TLS handshake failures.
    -- See: https://github.com/vincenthz/hs-tls/issues/124
    -- See: https://github.com/brendanhay/amazonka/issues/269
    retryCheck :: a -> HttpException -> Bool
retryCheck a
_ InvalidUrlException {} = Bool
False
    retryCheck a
n (HttpExceptionRequest Request
_ HttpExceptionContent
ex) = case HttpExceptionContent
ex of
      HttpExceptionContent
_ | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
3 -> Bool
False
      HttpExceptionContent
NoResponseDataReceived -> Bool
True
      HttpExceptionContent
ConnectionTimeout -> Bool
True
      HttpExceptionContent
ConnectionClosed -> Bool
True
      ConnectionFailure SomeException
_ -> Bool
True
      InternalException SomeException
x -> case SomeException -> Maybe TLSException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x of
        Just TLS.HandshakeFailed {} -> Bool
True
        Maybe TLSException
_ -> Bool
False
      HttpExceptionContent
_ -> Bool
False
    getQueueUrl :: AWS.Env -> Text -> IO QueueUrl
    getQueueUrl :: Env -> Text -> IO QueueUrl
getQueueUrl Env
e Text
q = do
      Either Error GetQueueUrlResponse
x <-
        ResourceT IO (Either Error GetQueueUrlResponse)
-> IO (Either Error GetQueueUrlResponse)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO (Either Error GetQueueUrlResponse)
 -> IO (Either Error GetQueueUrlResponse))
-> ResourceT IO (Either Error GetQueueUrlResponse)
-> IO (Either Error GetQueueUrlResponse)
forall a b. (a -> b) -> a -> b
$
          Getting (First Error) SomeException Error
-> ResourceT IO GetQueueUrlResponse
-> ResourceT IO (Either Error GetQueueUrlResponse)
forall (m :: * -> *) a r.
MonadCatch m =>
Getting (First a) SomeException a -> m r -> m (Either a r)
AWS.trying Getting (First Error) SomeException Error
forall a. AsError a => Prism' a Error
Prism' SomeException Error
AWS._Error (ResourceT IO GetQueueUrlResponse
 -> ResourceT IO (Either Error GetQueueUrlResponse))
-> ResourceT IO GetQueueUrlResponse
-> ResourceT IO (Either Error GetQueueUrlResponse)
forall a b. (a -> b) -> a -> b
$
            Env -> GetQueueUrl -> ResourceT IO (AWSResponse GetQueueUrl)
forall (m :: * -> *) a.
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a)) =>
Env -> a -> m (AWSResponse a)
AWS.send Env
e (Text -> GetQueueUrl
SQS.newGetQueueUrl Text
q)
      (Error -> IO QueueUrl)
-> (GetQueueUrlResponse -> IO QueueUrl)
-> Either Error GetQueueUrlResponse
-> IO QueueUrl
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        (Error -> IO QueueUrl
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (Error -> IO QueueUrl) -> (Error -> Error) -> Error -> IO QueueUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Error
forall e. (Show e, AsError e) => e -> Error
GeneralError)
        (QueueUrl -> IO QueueUrl
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QueueUrl -> IO QueueUrl)
-> (GetQueueUrlResponse -> QueueUrl)
-> GetQueueUrlResponse
-> IO QueueUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> QueueUrl
QueueUrl (Text -> QueueUrl)
-> (GetQueueUrlResponse -> Text) -> GetQueueUrlResponse -> QueueUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text GetQueueUrlResponse Text
-> GetQueueUrlResponse -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text GetQueueUrlResponse Text
Lens' GetQueueUrlResponse Text
SQS.getQueueUrlResponse_queueUrl)
        Either Error GetQueueUrlResponse
x

execute :: (MonadIO m) => Env -> Amazon a -> m a
execute :: forall (m :: * -> *) a. MonadIO m => Env -> Amazon a -> m a
execute Env
e Amazon a
m = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ReaderT Env (ResourceT IO) a -> Env -> ResourceT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Amazon a -> ReaderT Env (ResourceT IO) a
forall a. Amazon a -> ReaderT Env (ResourceT IO) a
unAmazon Amazon a
m) Env
e)

enqueue :: E.TeamEvent -> Amazon ()
enqueue :: TeamEvent -> Amazon ()
enqueue TeamEvent
e = do
  QueueUrl Text
url <- Getting QueueUrl Env QueueUrl -> Amazon QueueUrl
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting QueueUrl Env QueueUrl
Lens' Env QueueUrl
eventQueue
  UUID
rnd <- IO UUID -> Amazon UUID
forall a. IO a -> Amazon a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
nextRandom
  Env
amaznkaEnv <- Getting Env Env Env -> Amazon Env
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Env Env Env
Lens' Env Env
awsEnv
  Either Error SendMessageResponse
res <- RetryPolicyM Amazon
-> (RetryStatus -> Either Error SendMessageResponse -> Amazon Bool)
-> (RetryStatus -> Amazon (Either Error SendMessageResponse))
-> Amazon (Either Error SendMessageResponse)
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying (Int -> RetryPolicy
limitRetries Int
5 RetryPolicyM Amazon -> RetryPolicyM Amazon -> RetryPolicyM Amazon
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicyM Amazon
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
exponentialBackoff Int
1000000) ((Either Error SendMessageResponse -> Amazon Bool)
-> RetryStatus -> Either Error SendMessageResponse -> Amazon Bool
forall a b. a -> b -> a
const Either Error SendMessageResponse -> Amazon Bool
forall (m :: * -> *) a. MonadIO m => Either Error a -> m Bool
canRetry) ((RetryStatus -> Amazon (Either Error SendMessageResponse))
 -> Amazon (Either Error SendMessageResponse))
-> (RetryStatus -> Amazon (Either Error SendMessageResponse))
-> Amazon (Either Error SendMessageResponse)
forall a b. (a -> b) -> a -> b
$ Amazon (Either Error SendMessageResponse)
-> RetryStatus -> Amazon (Either Error SendMessageResponse)
forall a b. a -> b -> a
const (Env
-> SendMessage -> Amazon (Either Error (AWSResponse SendMessage))
forall r.
(AWSRequest r, Typeable r, Typeable (AWSResponse r)) =>
Env -> r -> Amazon (Either Error (AWSResponse r))
sendCatch Env
amaznkaEnv (Text -> UUID -> SendMessage
req Text
url UUID
rnd))
  (Error -> Amazon ())
-> (SendMessageResponse -> Amazon ())
-> Either Error SendMessageResponse
-> Amazon ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Error -> Amazon ()
forall e a. (HasCallStack, Exception e) => e -> Amazon a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (Error -> Amazon ()) -> (Error -> Error) -> Error -> Amazon ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Error
forall e. (Show e, AsError e) => e -> Error
GeneralError) (Amazon () -> SendMessageResponse -> Amazon ()
forall a b. a -> b -> a
const (() -> Amazon ()
forall a. a -> Amazon a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) Either Error SendMessageResponse
res
  where
    event :: Text
event = ByteString -> Text
decodeLatin1 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ TeamEvent -> ByteString
forall msg. Message msg => msg -> ByteString
encodeMessage TeamEvent
e
    req :: Text -> UUID -> SendMessage
req Text
url UUID
dedup =
      Text -> Text -> SendMessage
SQS.newSendMessage Text
url Text
event
        SendMessage -> (SendMessage -> SendMessage) -> SendMessage
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> SendMessage -> Identity SendMessage
Lens' SendMessage (Maybe Text)
SQS.sendMessage_messageGroupId ((Maybe Text -> Identity (Maybe Text))
 -> SendMessage -> Identity SendMessage)
-> Text -> SendMessage -> SendMessage
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"team.events"
        SendMessage -> (SendMessage -> SendMessage) -> SendMessage
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> SendMessage -> Identity SendMessage
Lens' SendMessage (Maybe Text)
SQS.sendMessage_messageDeduplicationId ((Maybe Text -> Identity (Maybe Text))
 -> SendMessage -> Identity SendMessage)
-> Text -> SendMessage -> SendMessage
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ UUID -> Text
toText UUID
dedup

--------------------------------------------------------------------------------
-- Utilities

sendCatch ::
  ( AWS.AWSRequest r,
    Typeable r,
    Typeable (AWS.AWSResponse r)
  ) =>
  AWS.Env ->
  r ->
  Amazon (Either AWS.Error (AWS.AWSResponse r))
sendCatch :: forall r.
(AWSRequest r, Typeable r, Typeable (AWSResponse r)) =>
Env -> r -> Amazon (Either Error (AWSResponse r))
sendCatch Env
e = Getting (First Error) SomeException Error
-> Amazon (AWSResponse r) -> Amazon (Either Error (AWSResponse r))
forall (m :: * -> *) a r.
MonadCatch m =>
Getting (First a) SomeException a -> m r -> m (Either a r)
AWS.trying Getting (First Error) SomeException Error
forall a. AsError a => Prism' a Error
Prism' SomeException Error
AWS._Error (Amazon (AWSResponse r) -> Amazon (Either Error (AWSResponse r)))
-> (r -> Amazon (AWSResponse r))
-> r
-> Amazon (Either Error (AWSResponse r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> r -> Amazon (AWSResponse r)
forall (m :: * -> *) a.
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a)) =>
Env -> a -> m (AWSResponse a)
AWS.send Env
e

canRetry :: (MonadIO m) => Either AWS.Error a -> m Bool
canRetry :: forall (m :: * -> *) a. MonadIO m => Either Error a -> m Bool
canRetry (Right a
_) = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
canRetry (Left Error
e) = case Error
e of
  AWS.TransportError (HttpExceptionRequest Request
_ HttpExceptionContent
ResponseTimeout) -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  AWS.ServiceError ServiceError
se | ServiceError
se ServiceError
-> Getting ErrorCode ServiceError ErrorCode -> ErrorCode
forall s a. s -> Getting a s a -> a
^. Getting ErrorCode ServiceError ErrorCode
Lens' ServiceError ErrorCode
AWS.serviceError_code ErrorCode -> ErrorCode -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> ErrorCode
AWS.ErrorCode Text
"RequestThrottled" -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Error
_ -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False