{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

module HaskellWorks.CabalCache.AWS.Env
  ( awsLogger
  , mkEnv
  , setEnvEndpoint
  ) where

import Control.Concurrent           (myThreadId)
import Data.ByteString.Builder      (toLazyByteString)
import Data.Generics.Product.Any    (the)
import HaskellWorks.Prelude
import Lens.Micro
import Network.HTTP.Client          (HttpException (..), HttpExceptionContent (..))

import qualified Amazonka                           as AWS
import qualified Data.ByteString                    as BS
import qualified Data.ByteString.Lazy               as L
import qualified Data.ByteString.Lazy               as LBS
import qualified Data.ByteString.Lazy.Char8         as LC8
import qualified Data.Text.Encoding                 as T
import qualified HaskellWorks.CabalCache.IO.Console as CIO
import qualified System.IO                          as IO

setEnvEndpoint :: Maybe (ByteString, Int, Bool) -> IO AWS.Env -> IO AWS.Env
setEnvEndpoint :: Maybe (ByteString, Int, Bool) -> IO Env -> IO Env
setEnvEndpoint Maybe (ByteString, Int, Bool)
mHostEndpoint IO Env
getEnv = do
  Env
env <- IO Env
getEnv
  case Maybe (ByteString, Int, Bool)
mHostEndpoint of
    Just (ByteString
host, Int
port, Bool
ssl) ->
      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
env
        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) -> Env -> Env
forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Service
svc -> do
            Service
svc Service -> (Service -> Service) -> Service
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 @"endpoint" (((Region -> Endpoint) -> Identity (Region -> Endpoint))
 -> Service -> Identity Service)
-> ((Region -> Endpoint) -> Region -> Endpoint)
-> Service
-> Service
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Region -> Endpoint
mkEndpoint Region
region -> do
              Region -> Endpoint
mkEndpoint Region
region
                Endpoint -> (Endpoint -> Endpoint) -> Endpoint
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 @"host" ((ByteString -> Identity ByteString)
 -> Endpoint -> Identity Endpoint)
-> ByteString -> Endpoint -> Endpoint
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ByteString
host
                Endpoint -> (Endpoint -> Endpoint) -> Endpoint
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 @"port" ((Int -> Identity Int) -> Endpoint -> Identity Endpoint)
-> Int -> Endpoint -> Endpoint
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
port
                Endpoint -> (Endpoint -> Endpoint) -> Endpoint
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 @"secure" ((Bool -> Identity Bool) -> Endpoint -> Identity Endpoint)
-> Bool -> Endpoint -> Endpoint
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
ssl
    Maybe (ByteString, Int, Bool)
Nothing -> Env -> IO Env
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env

mkEnv :: AWS.Region -> (AWS.LogLevel -> LBS.ByteString -> IO ()) -> IO AWS.Env
mkEnv :: Region -> (LogLevel -> ByteStringLazy -> IO ()) -> IO Env
mkEnv Region
region LogLevel -> ByteStringLazy -> IO ()
lg = do
  Logger
lgr <- (LogLevel -> ByteStringLazy -> IO ()) -> IO Logger
forall (m :: * -> *).
Monad m =>
(LogLevel -> ByteStringLazy -> IO ()) -> m Logger
newAwsLogger LogLevel -> ByteStringLazy -> IO ()
lg
  Env
discoveredEnv <- (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 -> IO Env
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
discoveredEnv
    { AWS.logger = lgr
    , AWS.region = region
    , AWS.retryCheck = retryPolicy 5
    }

newAwsLogger :: Monad m => (AWS.LogLevel -> LBS.ByteString -> IO ()) -> m AWS.Logger
newAwsLogger :: forall (m :: * -> *).
Monad m =>
(LogLevel -> ByteStringLazy -> IO ()) -> m Logger
newAwsLogger LogLevel -> ByteStringLazy -> IO ()
lg = Logger -> m Logger
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> m Logger) -> Logger -> m Logger
forall a b. (a -> b) -> a -> b
$ \LogLevel
y ByteStringBuilder
b ->
  let lazyMsg :: ByteStringLazy
lazyMsg = ByteStringBuilder -> ByteStringLazy
toLazyByteString ByteStringBuilder
b
  in case ByteStringLazy -> ByteString
L.toStrict ByteStringLazy
lazyMsg of
      ByteString
msg | ByteString -> ByteString -> Bool
BS.isInfixOf ByteString
"404 Not Found" ByteString
msg    -> LogLevel -> ByteStringLazy -> IO ()
lg LogLevel
AWS.Debug ByteStringLazy
lazyMsg
      ByteString
msg | ByteString -> ByteString -> Bool
BS.isInfixOf ByteString
"304 Not Modified" ByteString
msg -> LogLevel -> ByteStringLazy -> IO ()
lg LogLevel
AWS.Debug ByteStringLazy
lazyMsg
      ByteString
_                                         -> LogLevel -> ByteStringLazy -> IO ()
lg LogLevel
y ByteStringLazy
lazyMsg

retryPolicy :: Int -> Int -> AWS.HttpException -> Bool
retryPolicy :: Int -> Int -> HttpException -> Bool
retryPolicy Int
maxNum Int
attempt HttpException
ex = (Int
attempt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxNum) Bool -> Bool -> Bool
&& HttpException -> Bool
shouldRetry HttpException
ex

shouldRetry :: AWS.HttpException -> Bool
shouldRetry :: HttpException -> Bool
shouldRetry HttpException
ex = case HttpException
ex of
  HttpExceptionRequest Request
_ HttpExceptionContent
ctx -> case HttpExceptionContent
ctx of
    HttpExceptionContent
ResponseTimeout          -> Bool
True
    HttpExceptionContent
ConnectionTimeout        -> Bool
True
    ConnectionFailure SomeException
_      -> Bool
True
    HttpExceptionContent
InvalidChunkHeaders      -> Bool
True
    HttpExceptionContent
ConnectionClosed         -> Bool
True
    InternalException SomeException
_      -> Bool
True
    HttpExceptionContent
NoResponseDataReceived   -> Bool
True
    ResponseBodyTooShort Word64
_ Word64
_ -> Bool
True
    HttpExceptionContent
_                        -> Bool
False
  HttpException
_ -> Bool
False

awsLogger :: Maybe AWS.LogLevel -> AWS.LogLevel -> LC8.ByteString -> IO ()
awsLogger :: Maybe LogLevel -> LogLevel -> ByteStringLazy -> IO ()
awsLogger Maybe LogLevel
maybeConfigLogLevel LogLevel
msgLogLevel ByteStringLazy
message =
  Maybe LogLevel -> (LogLevel -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe LogLevel
maybeConfigLogLevel ((LogLevel -> IO ()) -> IO ()) -> (LogLevel -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LogLevel
configLogLevel ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
msgLogLevel LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= LogLevel
configLogLevel) do
      ThreadId
threadId <- IO ThreadId
myThreadId
      Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LogLevel -> Text
forall a. Show a => a -> Text
tshow LogLevel
msgLogLevel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] [tid: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ThreadId -> Text
forall a. Show a => a -> Text
tshow ThreadId
threadId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text
  where text :: Text
text = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteStringLazy -> ByteString
LBS.toStrict ByteStringLazy
message