# LANGUAGE AllowAmbiguousTypes #
# LANGUAGE DeriveFunctor #
# LANGUAGE DeriveGeneric #
# LANGUAGE FlexibleContexts #
# LANGUAGE GeneralizedNewtypeDeriving #
# LANGUAGE LambdaCase #
# LANGUAGE MultiParamTypeClasses #
{-# LANGUAGE OverloadedStrings #-}
# LANGUAGE ScopedTypeVariables #
# LANGUAGE TemplateHaskell #
# LANGUAGE TypeApplications #
# LANGUAGE TypeFamilies #

-- |
-- Module: Servant.Client_
  Copyright : Copyright © 2018 - 2020 Kadena LLC .
  License : MIT
  Maintainer :   <  >
-- Stability: experimental
--
-- A version of Servant's 'ClientM' that provides hooks to locally overwrite
-- requests and response.
--
-- TODO: it might be the cases that recent versions of servant directly support
-- this functionality and that this module is now obsolete.
--
module Servant.Client_
( ClientM_
, client_
, runClientM_
, modifyRequest
, modifyResponse
) where

import Control.Lens
import Control.Monad.Catch
import Control.Monad.Error.Class
import Control.Monad.Reader

import Data.Proxy

import GHC.Generics

import Servant.Client
import Servant.Client.Core

-- -------------------------------------------------------------------------- --
-- Run Modified Client

data Mods = Mods
    { _modReq :: !(Request -> IO Request)
    , _modRes :: !(Response -> IO Response)
    }

makeLenses ''Mods

  | ' ClientM _ ' mimics the behavior of '  ' , but provides the functions
-- 'modifyResponse' and 'modifyRequest' that allow to locally overwrite requests
-- and responses.
--
newtype ClientM_ a = ClientM_ { unClientM_ :: ReaderT Mods ClientM a }
  deriving
    ( Functor, Applicative, Monad, MonadIO
    , Generic
    , MonadError ClientError, MonadThrow , MonadCatch
    )

instance MonadReader ClientEnv ClientM_ where
    ask = ClientM_ $ lift ask
    local f = ClientM_ . mapReaderT (local f) . unClientM_
# INLINE ask #
# INLINE local #

instance RunClient ClientM_ where
    runRequestAcceptStatus s req = ClientM_ $ do
        e <- ask
        req' <- liftIO $ _modReq e req
        res <- lift (runRequestAcceptStatus s req')
        liftIO $ _modRes e res
# INLINE runRequestAcceptStatus #

    throwClientError = throwError
# INLINE throwClientError #

-- | Locally overwrite 'Request's made the inner computation.
--
modifyRequest :: (Request -> IO Request) -> ClientM_ a -> ClientM_ a
modifyRequest f = ClientM_ . local (set modReq f) . unClientM_
# INLINE modifyResponse #

-- | Locally overwrite 'Response's received the inner computation.
--
modifyResponse :: (Response -> IO Response) -> ClientM_ a -> ClientM_ a
modifyResponse f = ClientM_ . local (set modRes f) . unClientM_
# INLINE modifyRequest #

-- | Run a 'ClientM_' computation.
--
runClientM_ :: ClientM_ a -> ClientEnv -> IO (Either ClientError a)
runClientM_ cm env
    = flip runClientM env . flip runReaderT (Mods pure pure) $ unClientM_ cm
{-# INLINE runClientM_ #-}

-- | Create API client functions
--
client_ :: forall api . HasClient ClientM_ api => Client ClientM_ api
client_ = clientIn (Proxy @api) (Proxy @ClientM_)
{-# INLINE client_ #-}

# LANGUAGE OverloadedStrings #
 |
 Module: Servant.Client_
 Stability: experimental

 A version of Servant's 'ClientM' that provides hooks to locally overwrite
 requests and response.

 TODO: it might be the cases that recent versions of servant directly support
 this functionality and that this module is now obsolete.

 -------------------------------------------------------------------------- --
 Run Modified Client
 'modifyResponse' and 'modifyRequest' that allow to locally overwrite requests
 and responses.

 | Locally overwrite 'Request's made the inner computation.

 | Locally overwrite 'Response's received the inner computation.

 | Run a 'ClientM_' computation.

# INLINE runClientM_ #
 | Create API client functions

# INLINE client_ #
# LANGUAGE AllowAmbiguousTypes #
# LANGUAGE DeriveFunctor #
# LANGUAGE DeriveGeneric #
# LANGUAGE FlexibleContexts #
# LANGUAGE GeneralizedNewtypeDeriving #
# LANGUAGE LambdaCase #
# LANGUAGE MultiParamTypeClasses #
# LANGUAGE ScopedTypeVariables #
# LANGUAGE TemplateHaskell #
# LANGUAGE TypeApplications #
# LANGUAGE TypeFamilies #

  Copyright : Copyright © 2018 - 2020 Kadena LLC .
  License : MIT
  Maintainer :   <  >
module Servant.Client_
( ClientM_
, client_
, runClientM_
, modifyRequest
, modifyResponse
) where

import Control.Lens
import Control.Monad.Catch
import Control.Monad.Error.Class
import Control.Monad.Reader

import Data.Proxy

import GHC.Generics

import Servant.Client
import Servant.Client.Core


data Mods = Mods
    { _modReq :: !(Request -> IO Request)
    , _modRes :: !(Response -> IO Response)
    }

makeLenses ''Mods

  | ' ClientM _ ' mimics the behavior of '  ' , but provides the functions
newtype ClientM_ a = ClientM_ { unClientM_ :: ReaderT Mods ClientM a }
  deriving
    ( Functor, Applicative, Monad, MonadIO
    , Generic
    , MonadError ClientError, MonadThrow , MonadCatch
    )

instance MonadReader ClientEnv ClientM_ where
    ask = ClientM_ $ lift ask
    local f = ClientM_ . mapReaderT (local f) . unClientM_
# INLINE ask #
# INLINE local #

instance RunClient ClientM_ where
    runRequestAcceptStatus s req = ClientM_ $ do
        e <- ask
        req' <- liftIO $ _modReq e req
        res <- lift (runRequestAcceptStatus s req')
        liftIO $ _modRes e res
# INLINE runRequestAcceptStatus #

    throwClientError = throwError
# INLINE throwClientError #

modifyRequest :: (Request -> IO Request) -> ClientM_ a -> ClientM_ a
modifyRequest f = ClientM_ . local (set modReq f) . unClientM_
# INLINE modifyResponse #

modifyResponse :: (Response -> IO Response) -> ClientM_ a -> ClientM_ a
modifyResponse f = ClientM_ . local (set modRes f) . unClientM_
# INLINE modifyRequest #

runClientM_ :: ClientM_ a -> ClientEnv -> IO (Either ClientError a)
runClientM_ cm env
    = flip runClientM env . flip runReaderT (Mods pure pure) $ unClientM_ cm

client_ :: forall api . HasClient ClientM_ api => Client ClientM_ api
client_ = clientIn (Proxy @api) (Proxy @ClientM_)
