-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

module Morley.Client.RPC.HttpClient
  ( newClientEnv
  ) where

import Network.HTTP.Client (ManagerSettings(..), Request(..), defaultManagerSettings, newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Servant.Client (BaseUrl(..), ClientEnv, Scheme(..), mkClientEnv)

-- | Make servant client environment from morley client config.
--
-- Note: Creating a new servant manager is a relatively expensive
-- operation, so this function is not supposed to be called often.
newClientEnv :: BaseUrl -> IO ClientEnv
newClientEnv :: BaseUrl -> IO ClientEnv
newClientEnv BaseUrl
endpointUrl = do
  Manager
manager' <- ManagerSettings -> IO Manager
newManager (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ case BaseUrl -> Scheme
baseUrlScheme BaseUrl
endpointUrl of
    Scheme
Http  -> ManagerSettings
defaultManagerSettings{ managerModifyRequest :: Request -> IO Request
managerModifyRequest = Request -> IO Request
fixRequest }
    Scheme
Https -> ManagerSettings
tlsManagerSettings{ managerModifyRequest :: Request -> IO Request
managerModifyRequest = Request -> IO Request
fixRequest }
  return $ Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager' BaseUrl
endpointUrl

-- | Add header, required by the Tezos RPC interface
fixRequest :: Request -> IO Request
fixRequest :: Request -> IO Request
fixRequest Request
req = Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$
  Request
req { requestHeaders :: RequestHeaders
requestHeaders = (HeaderName
"Content-Type", ByteString
"application/json") (HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:
        ((HeaderName, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName
"Content-Type" HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/=) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (Request -> RequestHeaders
requestHeaders Request
req)
      }