{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
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 #-}