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

module HaskellWorks.Polysemy.Amazonka
  ( 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.Lazy                                    as LT
import qualified Data.Text.Lazy.Encoding                           as LT
import           HaskellWorks.Polysemy.Control.Concurrent.STM.TVar
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 qualified System.IO                                         as IO

data AwsLogEntry = AwsLogEntry
  { 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)

runReaderAwsEnvDiscover :: ()
  => Member (Embed IO) r
  => Sem (Reader AWS.Env : r) a
  -> Sem r a
runReaderAwsEnvDiscover :: forall (r :: EffectRow) a.
Member (Embed IO) r =>
Sem (Reader Env : r) a -> Sem r a
runReaderAwsEnvDiscover Sem (Reader Env : r) a
f = do
  Logger
logger' <- IO Logger -> Sem r Logger
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Logger -> Sem r Logger) -> IO Logger -> Sem r Logger
forall a b. (a -> b) -> a -> b
$ LogLevel -> Handle -> IO Logger
forall (m :: * -> *). MonadIO m => LogLevel -> Handle -> m Logger
AWS.newLogger LogLevel
AWS.Debug Handle
IO.stdout
  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
  let awsEnv :: Env
awsEnv = Env
discoveredAwsEnv { AWS.logger = logger' }
  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

sendAws :: ()
  => AWS.AWSRequest a
  => Member (DataLog AwsLogEntry) r
  => Member (Embed m) r
  => Member (Error AWS.Error) 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 :: * -> *).
(AWSRequest a, Member (DataLog AwsLogEntry) r, Member (Embed m) r,
 Member (Error Error) r, Member (Reader Env) r, Member Resource r,
 MonadIO m, Typeable (AWSResponse a), Typeable a) =>
a -> Sem r (AWSResponse a)
sendAws a
req = do
  TVar [AwsLogEntry]
tStack <- forall a (m :: * -> *) (r :: EffectRow).
(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 :: Logger
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 (LogLevel -> Builder -> AwsLogEntry
AwsLogEntry LogLevel
ll Builder
bAwsLogEntry -> [AwsLogEntry] -> [AwsLogEntry]
forall a. a -> [a] -> [a]
:)

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

  (Either Error (AWSResponse a) -> Sem r (AWSResponse a)
forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither (Either Error (AWSResponse a) -> Sem r (AWSResponse a))
-> Sem r (Either Error (AWSResponse a)) -> Sem r (AWSResponse a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Either Error (AWSResponse a))
-> Sem r (Either Error (AWSResponse a))
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Either Error (AWSResponse a))
-> m (Either Error (AWSResponse a))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Error (AWSResponse a))
 -> m (Either Error (AWSResponse a)))
-> IO (Either Error (AWSResponse a))
-> m (Either Error (AWSResponse a))
forall a b. (a -> b) -> a -> b
$ ResourceT IO (Either Error (AWSResponse a))
-> IO (Either Error (AWSResponse a))
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO (Either Error (AWSResponse a))
 -> IO (Either Error (AWSResponse a)))
-> ResourceT IO (Either Error (AWSResponse a))
-> IO (Either Error (AWSResponse a))
forall a b. (a -> b) -> a -> b
$ Env -> a -> ResourceT IO (Either Error (AWSResponse a))
forall (m :: * -> *) a.
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a)) =>
Env -> a -> m (Either Error (AWSResponse a))
AWS.sendEither 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 (m :: * -> *) (r :: EffectRow).
(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 Log r
  => InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryToLog :: forall (r :: EffectRow).
Member Log r =>
InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryToLog =
  (LogLevel -> Severity) -> InterpreterFor (DataLog AwsLogEntry) r
forall (r :: EffectRow).
Member Log r =>
(LogLevel -> Severity) -> InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryToLogWith LogLevel -> Severity
awsLogLevelToSeverity

interpretDataLogAwsLogEntryToLogWith :: forall r. ()
  => Member Log r
  => (AWS.LogLevel -> Severity)
  -> InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryToLogWith :: forall (r :: EffectRow).
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 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 Log r
  => (AWS.LogLevel -> Severity)
  -> (AwsLogEntry -> AwsLogEntry)
  -> InterpreterFor (DataLog AwsLogEntry) r
interpretDataLogAwsLogEntryLocalToLogWith :: forall (r :: EffectRow).
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 severity :: Severity
severity = LogLevel -> Severity
mapSeverity (AwsLogEntry
logEntry AwsLogEntry -> Getting LogLevel AwsLogEntry LogLevel -> LogLevel
forall s a. s -> Getting a s a -> a
^. 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 @"logLevel")
      let text :: Text
text = Text -> Text
LT.toStrict (ByteString -> Text
LT.decodeUtf8 (Builder -> ByteString
B.toLazyByteString (AwsLogEntry
logEntry AwsLogEntry -> Getting Builder AwsLogEntry Builder -> Builder
forall s a. s -> Getting a s a -> a
^. 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 @"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 (Severity -> Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Severity -> Text -> Sem r ()
log 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 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 #-}