{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE TypeApplications #-}

{- HLINT ignore "Use let" -}

module HaskellWorks.Polysemy.Amazonka
  ( AwsError,
    AwsLogEntry(..),
    runReaderAwsEnvDiscover,
    sendAws,
    interpretDataLogAwsLogEntryToLog,
    interpretDataLogAwsLogEntryToLogWith,
    interpretDataLogAwsLogEntryLocalToLogWith,
    awsLogLevelToSeverity,
  ) where

import           Control.Monad.IO.Class
import           Control.Monad.Trans.Resource
import           Data.Typeable

import qualified Amazonka                                          as AWS
import qualified Control.Concurrent.STM                            as STM
import           Control.Lens
import           Data.Binary.Builder                               (Builder)
import qualified Data.Binary.Builder                               as B
import           Data.Generics.Product.Any
import qualified Data.List                                         as L
import qualified Data.Text                                         as T
import qualified Data.Text.Encoding                                as T
import qualified Data.Text.Lazy                                    as LT
import qualified Data.Text.Lazy.Encoding                           as LT
import qualified GHC.Stack                                         as GHC
import           HaskellWorks.Polysemy.Amazonka.Errors
import           HaskellWorks.Polysemy.Control.Concurrent.STM.TVar
import           HaskellWorks.Polysemy.Log
import           HaskellWorks.Polysemy.System.Environment
import           HaskellWorks.Prelude
import           Polysemy
import           Polysemy.Error
import           Polysemy.Internal.Tactics                         (liftT)
import           Polysemy.Log
import qualified Polysemy.Log.Effect.DataLog                       as Log
import           Polysemy.Reader
import           Polysemy.Resource
import           Polysemy.Time                                     (GhcTime)
import qualified System.IO                                         as IO
import           Text.Read

data AwsLogEntry = AwsLogEntry
  { AwsLogEntry -> CallStack
callStack :: CallStack
  , AwsLogEntry -> LogLevel
logLevel  :: AWS.LogLevel
  , AwsLogEntry -> Builder
builder   :: Builder
  }
  deriving ((forall x. AwsLogEntry -> Rep AwsLogEntry x)
-> (forall x. Rep AwsLogEntry x -> AwsLogEntry)
-> Generic AwsLogEntry
forall x. Rep AwsLogEntry x -> AwsLogEntry
forall x. AwsLogEntry -> Rep AwsLogEntry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AwsLogEntry -> Rep AwsLogEntry x
from :: forall x. AwsLogEntry -> Rep AwsLogEntry x
$cto :: forall x. Rep AwsLogEntry x -> AwsLogEntry
to :: forall x. Rep AwsLogEntry x -> AwsLogEntry
Generic, Int -> AwsLogEntry -> ShowS
[AwsLogEntry] -> ShowS
AwsLogEntry -> String
(Int -> AwsLogEntry -> ShowS)
-> (AwsLogEntry -> String)
-> ([AwsLogEntry] -> ShowS)
-> Show AwsLogEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AwsLogEntry -> ShowS
showsPrec :: Int -> AwsLogEntry -> ShowS
$cshow :: AwsLogEntry -> String
show :: AwsLogEntry -> String
$cshowList :: [AwsLogEntry] -> ShowS
showList :: [AwsLogEntry] -> ShowS
Show, Typeable)

maybeSetEndpoint :: ()
  => Maybe (String, String)
  -> (AWS.Service -> AWS.Service)
  -> AWS.Service
  -> AWS.Service
maybeSetEndpoint :: Maybe (String, String)
-> (Service -> Service) -> Service -> Service
maybeSetEndpoint = \case
  Just (String
host, String
portString) ->
    case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
portString of
      Just Int
port -> ((Service -> Service) -> (Service -> Service) -> Service -> Service
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ByteString -> Int -> Service -> Service
AWS.setEndpoint Bool
False (Text -> ByteString
T.encodeUtf8 (String -> Text
T.pack String
host)) Int
port)
      Maybe Int
Nothing   -> (Service -> Service) -> Service -> Service
forall a. a -> a
id
  Maybe (String, String)
Nothing           -> (Service -> Service) -> Service -> Service
forall a. a -> a
id

runReaderAwsEnvDiscover :: forall a r. ()
  => Member (Embed IO) r
  => Sem (Reader AWS.Env : r) a
  -> Sem r a
runReaderAwsEnvDiscover :: forall a (r :: EffectRow).
Member (Embed IO) r =>
Sem (Reader Env : r) a -> Sem r a
runReaderAwsEnvDiscover Sem (Reader Env : r) a
f = do
  LogLevel -> Builder -> IO ()
logger' <- IO (LogLevel -> Builder -> IO ())
-> Sem r (LogLevel -> Builder -> IO ())
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (LogLevel -> Builder -> IO ())
 -> Sem r (LogLevel -> Builder -> IO ()))
-> IO (LogLevel -> Builder -> IO ())
-> Sem r (LogLevel -> Builder -> IO ())
forall a b. (a -> b) -> a -> b
$ LogLevel -> Handle -> IO (LogLevel -> Builder -> IO ())
forall (m :: * -> *).
MonadIO m =>
LogLevel -> Handle -> m (LogLevel -> Builder -> IO ())
AWS.newLogger LogLevel
AWS.Debug Handle
IO.stdout

  Maybe String
mLocalStackHost <- String -> Sem r (Maybe String)
forall (r :: EffectRow).
(HasCallStack, Member (Embed IO) r) =>
String -> Sem r (Maybe String)
lookupEnv String
"AWS_LOCALSTACK_HOST"
  Maybe String
mLocalStackPort <- String -> Sem r (Maybe String)
forall (r :: EffectRow).
(HasCallStack, Member (Embed IO) r) =>
String -> Sem r (Maybe String)
lookupEnv String
"AWS_LOCALSTACK_PORT"
  Maybe (String, String)
mLocalStackEndpoint <- Maybe (String, String) -> Sem r (Maybe (String, String))
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (String, String) -> Sem r (Maybe (String, String)))
-> Maybe (String, String) -> Sem r (Maybe (String, String))
forall a b. (a -> b) -> a -> b
$ (,)
    (String -> String -> (String, String))
-> Maybe String -> Maybe (String -> (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
mLocalStackHost
    Maybe (String -> (String, String))
-> Maybe String -> Maybe (String, String)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe String
mLocalStackPort

  Env
discoveredAwsEnv <- IO Env -> Sem r Env
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Env -> Sem r Env) -> IO Env -> Sem r Env
forall a b. (a -> b) -> a -> b
$ (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

  Env
awsEnv <- Env -> Sem r Env
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env -> Sem r Env) -> Env -> Sem r Env
forall a b. (a -> b) -> a -> b
$ Env
discoveredAwsEnv
    Env -> (Env -> Env) -> Env
forall a b. a -> (a -> b) -> b
& forall {k} (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"logger" (((LogLevel -> Builder -> IO ())
  -> Identity (LogLevel -> Builder -> IO ()))
 -> Env -> Identity Env)
-> (LogLevel -> Builder -> IO ()) -> Env -> Env
forall s t a b. ASetter s t a b -> b -> s -> t
.~ LogLevel -> Builder -> IO ()
logger'
    Env -> (Env -> Env) -> Env
forall a b. a -> (a -> b) -> b
& forall {k} (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"overrides" (((Service -> Service) -> Identity (Service -> Service))
 -> Env -> Identity Env)
-> ((Service -> Service) -> Service -> Service) -> Env -> Env
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Maybe (String, String)
-> (Service -> Service) -> Service -> Service
maybeSetEndpoint Maybe (String, String)
mLocalStackEndpoint

  Env -> Sem (Reader Env : r) a -> Sem r a
forall i (r :: EffectRow) a. i -> Sem (Reader i : r) a -> Sem r a
runReader Env
awsEnv Sem (Reader Env : r) a
f

sendAwsInternal :: ()
  => AWS.AWSRequest a
  => Member (Embed m) r
  => Member (Error AwsError) r
  => MonadIO m
  => Typeable (AWS.AWSResponse a)
  => Typeable a
  => AWS.Env
  -> a
  -> Sem r (AWS.AWSResponse a)
sendAwsInternal :: forall a (m :: * -> *) (r :: EffectRow).
(AWSRequest a, Member (Embed m) r, Member (Error AwsError) r,
 MonadIO m, Typeable (AWSResponse a), Typeable a) =>
Env -> a -> Sem r (AWSResponse a)
sendAwsInternal Env
envAws a
req =
  Either AwsError (AWSResponse a) -> Sem r (AWSResponse a)
forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither (Either AwsError (AWSResponse a) -> Sem r (AWSResponse a))
-> Sem r (Either AwsError (AWSResponse a)) -> Sem r (AWSResponse a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Either AwsError (AWSResponse a))
-> Sem r (Either AwsError (AWSResponse a))
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Either AwsError (AWSResponse a))
-> m (Either AwsError (AWSResponse a))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AwsError (AWSResponse a))
 -> m (Either AwsError (AWSResponse a)))
-> IO (Either AwsError (AWSResponse a))
-> m (Either AwsError (AWSResponse a))
forall a b. (a -> b) -> a -> b
$ ResourceT IO (Either AwsError (AWSResponse a))
-> IO (Either AwsError (AWSResponse a))
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO (Either AwsError (AWSResponse a))
 -> IO (Either AwsError (AWSResponse a)))
-> ResourceT IO (Either AwsError (AWSResponse a))
-> IO (Either AwsError (AWSResponse a))
forall a b. (a -> b) -> a -> b
$ Env -> a -> ResourceT IO (Either AwsError (AWSResponse a))
forall (m :: * -> *) a.
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a)) =>
Env -> a -> m (Either AwsError (AWSResponse a))
AWS.sendEither Env
envAws a
req)

sendAws :: forall a r m. ()
  => HasCallStack
  => AWS.AWSRequest a
  => Member (DataLog AwsLogEntry) r
  => Member (Embed m) r
  => Member (Error AwsError) r
  => Member (Reader AWS.Env) r
  => Member Resource r
  => MonadIO m
  => Typeable (AWS.AWSResponse a)
  => Typeable a
  => a
  -> Sem r (AWS.AWSResponse a)
sendAws :: forall a (r :: EffectRow) (m :: * -> *).
(HasCallStack, AWSRequest a, Member (DataLog AwsLogEntry) r,
 Member (Embed m) r, Member (Error AwsError) r,
 Member (Reader Env) r, Member Resource r, MonadIO m,
 Typeable (AWSResponse a), Typeable a) =>
a -> Sem r (AWSResponse a)
sendAws a
req = (HasCallStack => Sem r (AWSResponse a)) -> Sem r (AWSResponse a)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => Sem r (AWSResponse a)) -> Sem r (AWSResponse a))
-> (HasCallStack => Sem r (AWSResponse a)) -> Sem r (AWSResponse a)
forall a b. (a -> b) -> a -> b
$ do
  TVar [AwsLogEntry]
tStack <- forall a (r :: EffectRow) (m :: * -> *).
(MonadIO m, Member (Embed m) r) =>
a -> Sem r (TVar a)
newTVarIO @[AwsLogEntry] []
  Env
envAws0 <- forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask @AWS.Env

  let logger ::  AWS.LogLevel -> Builder -> IO ()
      logger :: LogLevel -> Builder -> IO ()
logger LogLevel
ll Builder
b = STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [AwsLogEntry] -> ([AwsLogEntry] -> [AwsLogEntry]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar TVar [AwsLogEntry]
tStack (CallStack -> LogLevel -> Builder -> AwsLogEntry
AwsLogEntry CallStack
HasCallStack => CallStack
GHC.callStack LogLevel
ll Builder
bAwsLogEntry -> [AwsLogEntry] -> [AwsLogEntry]
forall a. a -> [a] -> [a]
:)

  let envAws1 :: Env
envAws1 = Env
envAws0 { AWS.logger = logger }

  Env -> a -> Sem r (AWSResponse a)
forall a (m :: * -> *) (r :: EffectRow).
(AWSRequest a, Member (Embed m) r, Member (Error AwsError) r,
 MonadIO m, Typeable (AWSResponse a), Typeable a) =>
Env -> a -> Sem r (AWSResponse a)
sendAwsInternal Env
envAws1 a
req
    Sem r (AWSResponse a)
-> (Sem r (AWSResponse a) -> Sem r (AWSResponse a))
-> Sem r (AWSResponse a)
forall a b. a -> (a -> b) -> b
& do (Sem r (AWSResponse a) -> Sem r () -> Sem r (AWSResponse a))
-> Sem r () -> Sem r (AWSResponse a) -> Sem r (AWSResponse a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Sem r (AWSResponse a) -> Sem r () -> Sem r (AWSResponse a)
forall (r :: EffectRow) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
finally do
            [AwsLogEntry]
entries <- [AwsLogEntry] -> [AwsLogEntry]
forall a. [a] -> [a]
L.reverse ([AwsLogEntry] -> [AwsLogEntry])
-> Sem r [AwsLogEntry] -> Sem r [AwsLogEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar [AwsLogEntry] -> Sem r [AwsLogEntry]
forall a (r :: EffectRow) (m :: * -> *).
(MonadIO m, Member (Embed m) r) =>
TVar a -> Sem r a
readTVarIO TVar [AwsLogEntry]
tStack
            [AwsLogEntry] -> (AwsLogEntry -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AwsLogEntry]
entries AwsLogEntry -> Sem r ()
forall a (r :: EffectRow). Member (DataLog a) r => a -> Sem r ()
dataLog

interpretDataLogAwsLogEntryToLog :: forall r. ()
  => Member (DataLog (LogEntry LogMessage)) r
  => Member GhcTime r
  => Member Log r
  => InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryToLog :: forall (r :: EffectRow).
(Member (DataLog (LogEntry LogMessage)) r, Member GhcTime r,
 Member Log r) =>
InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryToLog =
  (LogLevel -> Severity) -> InterpreterFor (DataLog AwsLogEntry) r
forall (r :: EffectRow).
(Member (DataLog (LogEntry LogMessage)) r, Member GhcTime r,
 Member Log r) =>
(LogLevel -> Severity) -> InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryToLogWith LogLevel -> Severity
awsLogLevelToSeverity

interpretDataLogAwsLogEntryToLogWith :: forall r. ()
  => Member (DataLog (LogEntry LogMessage)) r
  => Member GhcTime r
  => Member Log r
  => (AWS.LogLevel -> Severity)
  -> InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryToLogWith :: forall (r :: EffectRow).
(Member (DataLog (LogEntry LogMessage)) r, Member GhcTime r,
 Member Log r) =>
(LogLevel -> Severity) -> InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryToLogWith LogLevel -> Severity
mapSeverity
  = (LogLevel -> Severity)
-> (AwsLogEntry -> AwsLogEntry)
-> InterpreterFor (DataLog AwsLogEntry) r
forall (r :: EffectRow).
(Member (DataLog (LogEntry LogMessage)) r, Member GhcTime r,
 Member Log r) =>
(LogLevel -> Severity)
-> (AwsLogEntry -> AwsLogEntry)
-> InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryLocalToLogWith LogLevel -> Severity
mapSeverity AwsLogEntry -> AwsLogEntry
forall a. a -> a
id

interpretDataLogAwsLogEntryLocalToLogWith :: forall r. ()
  => Member (DataLog (LogEntry LogMessage)) r
  => Member GhcTime r
  => Member Log r
  => (AWS.LogLevel -> Severity)
  -> (AwsLogEntry -> AwsLogEntry)
  -> InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryLocalToLogWith :: forall (r :: EffectRow).
(Member (DataLog (LogEntry LogMessage)) r, Member GhcTime r,
 Member Log r) =>
(LogLevel -> Severity)
-> (AwsLogEntry -> AwsLogEntry)
-> InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryLocalToLogWith LogLevel -> Severity
mapSeverity AwsLogEntry -> AwsLogEntry
context =
  (forall (rInitial :: EffectRow) x.
 DataLog AwsLogEntry (Sem rInitial) x
 -> Tactical (DataLog AwsLogEntry) (Sem rInitial) r x)
-> Sem (DataLog AwsLogEntry : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Log.DataLog AwsLogEntry
logEntry -> do
      let cs :: CallStack
cs = AwsLogEntry
logEntry.callStack
      let severity :: Severity
severity = LogLevel -> Severity
mapSeverity AwsLogEntry
logEntry.logLevel
      let text :: Text
text = Text -> Text
LT.toStrict (ByteString -> Text
LT.decodeUtf8 (Builder -> ByteString
B.toLazyByteString AwsLogEntry
logEntry.builder))
      Sem r x
-> Sem (WithTactics (DataLog AwsLogEntry) f (Sem rInitial) r) (f x)
forall (m :: * -> *) (f :: * -> *) (r :: EffectRow)
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (CallStack -> Severity -> Text -> Sem r ()
forall (r :: EffectRow).
Members '[DataLog (LogEntry LogMessage), GhcTime] r =>
CallStack -> Severity -> Text -> Sem r ()
logCs CallStack
cs Severity
severity Text
text)
    Log.Local AwsLogEntry -> AwsLogEntry
f Sem rInitial x
ma ->
      Sem r (f x)
-> Sem (WithTactics (DataLog AwsLogEntry) f (Sem rInitial) r) (f x)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise (Sem r (f x)
 -> Sem
      (WithTactics (DataLog AwsLogEntry) f (Sem rInitial) r) (f x))
-> (Sem (DataLog AwsLogEntry : r) (f x) -> Sem r (f x))
-> Sem (DataLog AwsLogEntry : r) (f x)
-> Sem (WithTactics (DataLog AwsLogEntry) f (Sem rInitial) r) (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogLevel -> Severity)
-> (AwsLogEntry -> AwsLogEntry)
-> InterpreterFor (DataLog AwsLogEntry) r
forall (r :: EffectRow).
(Member (DataLog (LogEntry LogMessage)) r, Member GhcTime r,
 Member Log r) =>
(LogLevel -> Severity)
-> (AwsLogEntry -> AwsLogEntry)
-> InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryLocalToLogWith LogLevel -> Severity
mapSeverity (AwsLogEntry -> AwsLogEntry
f (AwsLogEntry -> AwsLogEntry)
-> (AwsLogEntry -> AwsLogEntry) -> AwsLogEntry -> AwsLogEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AwsLogEntry -> AwsLogEntry
context) (Sem (DataLog AwsLogEntry : r) (f x)
 -> Sem
      (WithTactics (DataLog AwsLogEntry) f (Sem rInitial) r) (f x))
-> Sem
     (WithTactics (DataLog AwsLogEntry) f (Sem rInitial) r)
     (Sem (DataLog AwsLogEntry : r) (f x))
-> Sem (WithTactics (DataLog AwsLogEntry) f (Sem rInitial) r) (f x)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem rInitial x
-> Sem
     (WithTactics (DataLog AwsLogEntry) f (Sem rInitial) r)
     (Sem (DataLog AwsLogEntry : r) (f x))
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial x
ma
{-# inline interpretDataLogAwsLogEntryLocalToLogWith #-}

awsLogLevelToSeverity :: ()
  => AWS.LogLevel
  -> Severity
awsLogLevelToSeverity :: LogLevel -> Severity
awsLogLevelToSeverity = \case
  LogLevel
AWS.Trace -> Severity
Debug
  LogLevel
AWS.Debug -> Severity
Debug
  LogLevel
AWS.Info  -> Severity
Info
  LogLevel
AWS.Error -> Severity
Error
{-# inline awsLogLevelToSeverity #-}