{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnicodeSyntax #-}

module MatrixBot.MatrixApi.Client where

import Data.Bifunctor (bimap)
import Data.Binary.Builder (toLazyByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Proxy
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (decodeUtf8)

import Control.Exception.Safe (MonadThrow, throwM)
import Control.Monad.IO.Class (MonadIO (..))
import qualified Control.Monad.Free as Free
import qualified Control.Monad.Logger as ML

import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP

import Servant.API
import Servant.Client
import Servant.Client.Core.Auth
import qualified Servant.Client.Core.Request as ServantRequest
import qualified Servant.Client.Free as ServantFree

import MatrixBot.Log (logDebug)
import qualified MatrixBot.SharedTypes as T


data MatrixApiClient = MatrixApiClient
  { MatrixApiClient
-> forall api (m :: * -> *) a.
   (MonadIO m, MonadFail m, Show a, MonadLogger m,
    HasClient (Free ClientF) api, HasClient ClientM api) =>
   Proxy api
   -> (forall (clientM :: * -> *).
       HasClient clientM api =>
       Client clientM api -> clientM a)
   -> m (Either ClientError a)
runMatrixApiClient
      ∷ ∀ api m a .
      ( MonadIO m
      , MonadFail m -- Resolving unexpected cases to a failure
      , Show a -- Paired with @MonadFail@ to print unexpected values
      , ML.MonadLogger m -- Logging the request
      , HasClient (Free.Free ServantFree.ClientF) api -- For logging requests
      , HasClient ClientM api
      )
      ⇒ Proxy api
      → (∀clientM. HasClient clientM api ⇒ Client clientM api → clientM a)
      → m (Either ClientError a)

  -- | Variant that doesn’t log request body that may contain passwords or streamed byte strings
  , MatrixApiClient
-> forall api (m :: * -> *) a.
   (MonadIO m, MonadFail m, Show a, MonadLogger m,
    HasClient (Free ClientF) api, HasClient ClientM api) =>
   Proxy api
   -> (forall (clientM :: * -> *).
       HasClient clientM api =>
       Client clientM api -> clientM a)
   -> m (Either ClientError a)
runMatrixApiClientDoNotShowReqBody
      ∷ ∀ api m a .
      ( MonadIO m
      , MonadFail m -- Resolving unexpected cases to a failure
      , Show a -- Paired with @MonadFail@ to print unexpected values
      , ML.MonadLogger m -- Logging the request
      , HasClient (Free.Free ServantFree.ClientF) api -- For logging requests
      , HasClient ClientM api
      )
      ⇒ Proxy api
      → (∀clientM. HasClient clientM api ⇒ Client clientM api → clientM a)
      → m (Either ClientError a)

  , MatrixApiClient
-> forall api (m :: * -> *) a.
   (MonadIO m, MonadFail m, Show a, MonadThrow m, MonadLogger m,
    HasClient (Free ClientF) api, HasClient ClientM api) =>
   Proxy api
   -> (forall (clientM :: * -> *).
       HasClient clientM api =>
       Client clientM api -> clientM a)
   -> m a
runMatrixApiClient'
      ∷ ∀ api m a .
      ( MonadIO m
      , MonadFail m -- Resolving unexpected cases to a failure
      , Show a -- Paired with @MonadFail@ to print unexpected values
      , MonadThrow m -- Throwing error instead of returning @Either ClientError@
      , ML.MonadLogger m -- Logging the request
      , HasClient (Free.Free ServantFree.ClientF) api -- For logging requests
      , HasClient ClientM api
      )
      ⇒ Proxy api
      → (∀clientM. HasClient clientM api ⇒ Client clientM api → clientM a)
      → m a

  -- | Variant that doesn’t log request body that may contain passwords or streamed byte strings
  , MatrixApiClient
-> forall api (m :: * -> *) a.
   (MonadIO m, MonadFail m, Show a, MonadThrow m, MonadLogger m,
    HasClient (Free ClientF) api, HasClient ClientM api) =>
   Proxy api
   -> (forall (clientM :: * -> *).
       HasClient clientM api =>
       Client clientM api -> clientM a)
   -> m a
runMatrixApiClientDoNotShowReqBody'
      ∷ ∀ api m a .
      ( MonadIO m
      , MonadFail m -- Resolving unexpected cases to a failure
      , Show a -- Paired with @MonadFail@ to print unexpected values
      , MonadThrow m -- Throwing error instead of returning @Either ClientError@
      , ML.MonadLogger m -- Logging the request
      , HasClient (Free.Free ServantFree.ClientF) api -- For logging requests
      , HasClient ClientM api
      )
      ⇒ Proxy api
      → (∀clientM. HasClient clientM api ⇒ Client clientM api → clientM a)
      → m a
  }


newtype RequestOptions = RequestOptions
  { RequestOptions -> Maybe Seconds
requestOptionsTimeout ∷ Maybe T.Seconds
  -- ^ "Nothing" means default timeout value (30 seconds)
  }


defaultRequestOptions ∷ RequestOptions
defaultRequestOptions :: RequestOptions
defaultRequestOptions = RequestOptions
  { requestOptionsTimeout :: Maybe Seconds
requestOptionsTimeout = Maybe Seconds
forall a. Maybe a
Nothing
  }


mkMatrixApiClient
  ∷ (MonadIO m, MonadThrow m, ML.MonadLogger m)
  ⇒ RequestOptions
  → T.HomeServer
  → m MatrixApiClient
mkMatrixApiClient :: forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadLogger m) =>
RequestOptions -> HomeServer -> m MatrixApiClient
mkMatrixApiClient RequestOptions
reqOpts HomeServer
homeServer = do
  Manager
tlsManager ←
    ManagerSettings -> m Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
HTTP.newTlsManagerWith ManagerSettings
HTTP.tlsManagerSettings { HTTP.managerResponseTimeout = responseTimeout }

  BaseUrl
baseUrl' ← String -> m BaseUrl
forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl (String -> m BaseUrl)
-> (HomeServer -> String) -> HomeServer -> m BaseUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> String) -> (HomeServer -> Text) -> HomeServer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"https://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (HomeServer -> Text) -> HomeServer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeServer -> Text
T.unHomeServer (HomeServer -> m BaseUrl) -> HomeServer -> m BaseUrl
forall a b. (a -> b) -> a -> b
$ HomeServer
homeServer

  let
    clientEnv :: ClientEnv
clientEnv = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
tlsManager BaseUrl
baseUrl'

    f
      ∷ ∀ api m a .
      ( MonadIO m
      , MonadFail m
      , ML.MonadLogger m
      , Show a
      , HasClient (Free.Free ServantFree.ClientF) api
      , HasClient ClientM api
      )
      ⇒ Bool
      -- ^ Show request body
      → Proxy api
      → (∀clientM. HasClient clientM api ⇒ Client clientM api → clientM a)
      → m (Either ClientError a)
    f :: forall api (m :: * -> *) a.
(MonadIO m, MonadFail m, MonadLogger m, Show a,
 HasClient (Free ClientF) api, HasClient ClientM api) =>
Bool
-> Proxy api
-> (forall (clientM :: * -> *).
    HasClient clientM api =>
    Client clientM api -> clientM a)
-> m (Either ClientError a)
f Bool
showReqBody p :: Proxy api
p@Proxy api
Proxy forall (clientM :: * -> *).
HasClient clientM api =>
Client clientM api -> clientM a
genericClientF = do
      case Client (Free ClientF) api -> Free ClientF a
forall (clientM :: * -> *).
HasClient clientM api =>
Client clientM api -> clientM a
genericClientF (Client (Free ClientF) api -> Free ClientF a)
-> (Proxy api -> Client (Free ClientF) api)
-> Proxy api
-> Free ClientF a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy api -> Client (Free ClientF) api
forall api.
HasClient (Free ClientF) api =>
Proxy api -> Client (Free ClientF) api
ServantFree.client (Proxy api -> Free ClientF a) -> Proxy api -> Free ClientF a
forall a b. (a -> b) -> a -> b
$ Proxy api
p of
        Free.Free (ServantFree.RunRequest Request
req Response -> Free ClientF a
_responseResolver) →
          let
            fReqBody ∷ ServantRequest.RequestBody → Text
            fReqBody :: RequestBody -> Text
fReqBody = \case
              ServantRequest.RequestBodyLBS LazyByteString
x →
                if Bool
showReqBody
                  then ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (LazyByteString -> ByteString) -> LazyByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> ByteString
toStrict (LazyByteString -> Text) -> LazyByteString -> Text
forall a b. (a -> b) -> a -> b
$ LazyByteString
x
                  else Text
"<REDACTED LAZY BYTE STRING>"
              ServantRequest.RequestBodyBS ByteString
x →
                if Bool
showReqBody
                  then ByteString -> Text
decodeUtf8 ByteString
x
                  else Text
"<REDACTED BYTE STRING>"
              ServantRequest.RequestBodySource SourceIO LazyByteString
_ → Text
"<REDACTED STREAM>"

            fPath :: Builder -> LazyByteString
fPath = Builder -> LazyByteString
toLazyByteString
          in do
            -- @defaultMakeClientRequest@ actually runs no side-effects.
            -- This is just for unwrapping @Request@ from @IO@.
            --
            -- Previously the type of @defaultMakeClientRequest@ was
            -- @BaseUrl → Request → Request@ but later it became
            -- @BaseUrl → Request → IO Request@.
            -- It has only @return …@ inside, no actual side-effects
            -- so I have no idea why there has to be a breaking change with zero
            -- necessity as it seems judjing by current implementation.
            -- See https://github.com/haskell-servant/servant/issues/1787
            Request
clientRequest ← IO Request -> m Request
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Request -> IO Request
defaultMakeClientRequest BaseUrl
baseUrl' Request
req

            Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
              [ Text
"Making a client request: "
              , String -> Text
pack (String -> Text) -> (Request -> String) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> String
forall a. Show a => a -> String
show (Request -> Text) -> Request -> Text
forall a b. (a -> b) -> a -> b
$ Request
clientRequest
              , String -> Text
pack (String -> Text) -> (Request -> String) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestF Text LazyByteString -> String
forall a. Show a => a -> String
show (RequestF Text LazyByteString -> String)
-> (Request -> RequestF Text LazyByteString) -> Request -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RequestBody -> Text)
-> (Builder -> LazyByteString)
-> Request
-> RequestF Text LazyByteString
forall a b c d.
(a -> b) -> (c -> d) -> RequestF a c -> RequestF b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap RequestBody -> Text
fReqBody Builder -> LazyByteString
fPath (Request -> Text) -> Request -> Text
forall a b. (a -> b) -> a -> b
$ Request
req
              ]
        Free.Free (ServantFree.Throw ClientError
x) →
          String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected client request mock failure: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ClientError -> String
forall a. Show a => a -> String
show ClientError
x
        Free.Pure a
x →
          String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected client request mock Pure: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x

      IO (Either ClientError a) -> m (Either ClientError a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ClientError a) -> m (Either ClientError a))
-> (Proxy api -> IO (Either ClientError a))
-> Proxy api
-> m (Either ClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientM a -> ClientEnv -> IO (Either ClientError a))
-> ClientEnv -> ClientM a -> IO (Either ClientError a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClientM a -> ClientEnv -> IO (Either ClientError a)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientEnv
clientEnv (ClientM a -> IO (Either ClientError a))
-> (Proxy api -> ClientM a)
-> Proxy api
-> IO (Either ClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client ClientM api -> ClientM a
forall (clientM :: * -> *).
HasClient clientM api =>
Client clientM api -> clientM a
genericClientF (Client ClientM api -> ClientM a)
-> (Proxy api -> Client ClientM api) -> Proxy api -> ClientM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy api -> Client ClientM api
forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client (Proxy api -> m (Either ClientError a))
-> Proxy api -> m (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ Proxy api
p

  MatrixApiClient -> m MatrixApiClient
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MatrixApiClient -> m MatrixApiClient)
-> MatrixApiClient -> m MatrixApiClient
forall a b. (a -> b) -> a -> b
$ (forall api (m :: * -> *) a.
 (MonadIO m, MonadFail m, Show a, MonadLogger m,
  HasClient (Free ClientF) api, HasClient ClientM api) =>
 Proxy api
 -> (forall (clientM :: * -> *).
     HasClient clientM api =>
     Client clientM api -> clientM a)
 -> m (Either ClientError a))
-> (forall api (m :: * -> *) a.
    (MonadIO m, MonadFail m, Show a, MonadLogger m,
     HasClient (Free ClientF) api, HasClient ClientM api) =>
    Proxy api
    -> (forall (clientM :: * -> *).
        HasClient clientM api =>
        Client clientM api -> clientM a)
    -> m (Either ClientError a))
-> (forall api (m :: * -> *) a.
    (MonadIO m, MonadFail m, Show a, MonadThrow m, MonadLogger m,
     HasClient (Free ClientF) api, HasClient ClientM api) =>
    Proxy api
    -> (forall (clientM :: * -> *).
        HasClient clientM api =>
        Client clientM api -> clientM a)
    -> m a)
-> (forall api (m :: * -> *) a.
    (MonadIO m, MonadFail m, Show a, MonadThrow m, MonadLogger m,
     HasClient (Free ClientF) api, HasClient ClientM api) =>
    Proxy api
    -> (forall (clientM :: * -> *).
        HasClient clientM api =>
        Client clientM api -> clientM a)
    -> m a)
-> MatrixApiClient
MatrixApiClient
    (Bool
-> Proxy api
-> (forall (clientM :: * -> *).
    HasClient clientM api =>
    Client clientM api -> clientM a)
-> m (Either ClientError a)
forall api (m :: * -> *) a.
(MonadIO m, MonadFail m, MonadLogger m, Show a,
 HasClient (Free ClientF) api, HasClient ClientM api) =>
Bool
-> Proxy api
-> (forall (clientM :: * -> *).
    HasClient clientM api =>
    Client clientM api -> clientM a)
-> m (Either ClientError a)
f Bool
True)
    (Bool
-> Proxy api
-> (forall (clientM :: * -> *).
    HasClient clientM api =>
    Client clientM api -> clientM a)
-> m (Either ClientError a)
forall api (m :: * -> *) a.
(MonadIO m, MonadFail m, MonadLogger m, Show a,
 HasClient (Free ClientF) api, HasClient ClientM api) =>
Bool
-> Proxy api
-> (forall (clientM :: * -> *).
    HasClient clientM api =>
    Client clientM api -> clientM a)
-> m (Either ClientError a)
f Bool
False)
    (\Proxy api
p forall (clientM :: * -> *).
HasClient clientM api =>
Client clientM api -> clientM a
clientF → Bool
-> Proxy api
-> (forall (clientM :: * -> *).
    HasClient clientM api =>
    Client clientM api -> clientM a)
-> m (Either ClientError a)
forall api (m :: * -> *) a.
(MonadIO m, MonadFail m, MonadLogger m, Show a,
 HasClient (Free ClientF) api, HasClient ClientM api) =>
Bool
-> Proxy api
-> (forall (clientM :: * -> *).
    HasClient clientM api =>
    Client clientM api -> clientM a)
-> m (Either ClientError a)
f Bool
True Proxy api
p Client clientM api -> clientM a
forall (clientM :: * -> *).
HasClient clientM api =>
Client clientM api -> clientM a
clientF m (Either ClientError a) -> (Either ClientError a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ClientError -> m a) -> (a -> m a) -> Either ClientError a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
    (\Proxy api
p forall (clientM :: * -> *).
HasClient clientM api =>
Client clientM api -> clientM a
clientF → Bool
-> Proxy api
-> (forall (clientM :: * -> *).
    HasClient clientM api =>
    Client clientM api -> clientM a)
-> m (Either ClientError a)
forall api (m :: * -> *) a.
(MonadIO m, MonadFail m, MonadLogger m, Show a,
 HasClient (Free ClientF) api, HasClient ClientM api) =>
Bool
-> Proxy api
-> (forall (clientM :: * -> *).
    HasClient clientM api =>
    Client clientM api -> clientM a)
-> m (Either ClientError a)
f Bool
False Proxy api
p Client clientM api -> clientM a
forall (clientM :: * -> *).
HasClient clientM api =>
Client clientM api -> clientM a
clientF m (Either ClientError a) -> (Either ClientError a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ClientError -> m a) -> (a -> m a) -> Either ClientError a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

  where
    responseTimeout :: ResponseTimeout
responseTimeout =
      ResponseTimeout
-> (Seconds -> ResponseTimeout) -> Maybe Seconds -> ResponseTimeout
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        ResponseTimeout
HTTP.responseTimeoutDefault
        (Int -> ResponseTimeout
HTTP.responseTimeoutMicro (Int -> ResponseTimeout)
-> (Seconds -> Int) -> Seconds -> ResponseTimeout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (Seconds -> Integer) -> Seconds -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Microseconds -> Integer
T.unMicroseconds (Microseconds -> Integer)
-> (Seconds -> Microseconds) -> Seconds -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seconds -> Microseconds
T.secondsToMicroseconds)
        (RequestOptions -> Maybe Seconds
requestOptionsTimeout RequestOptions
reqOpts)


type instance AuthClientData (AuthProtect "access-token") = T.AccessToken