Skip to content

Instantly share code, notes, and snippets.

@jkachmar
Last active May 19, 2022 13:20
Show Gist options
  • Save jkachmar/1dff8b221f835d81b173341277632c62 to your computer and use it in GitHub Desktop.
Save jkachmar/1dff8b221f835d81b173341277632c62 to your computer and use it in GitHub Desktop.
"Simple" example for how to set up Servant to automatically retry its client requests
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import Prelude
import Control.Exception.Safe (MonadCatch, MonadMask, MonadThrow,
throwM)
import Control.Lens
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, ReaderT)
import qualified Control.Retry as Retry
import Data.Default (def)
import Data.Proxy (Proxy (..))
import qualified Network.HTTP.Client as HttpClient
import qualified Network.HTTP.Types as HttpTypes
-- Servant API definition
import Servant.API
-- Servant Client Core
import qualified Servant.Client.Core as Servant
-- Servant Client HTTP
import qualified Servant.Client as Servant
--------------------------------------------------------------------------------
-- CONFIGURATION AND TYPES
--------------------------------------------------------------------------------
-- | Configuration record supplying the operating environment for Servant calls
data ClientConfig = ClientConfig
{ _ccClientEnv :: Servant.ClientEnv
, _ccRetryPolicy :: Retry.RetryPolicyM IO
, _ccRetryJudge :: Retry.RetryStatus -> Servant.ServantError -> Bool
}
makeClassy ''ClientConfig
-- | Construct an effectful 'ClientConfig' for production
--
-- Because we're operating in 'MonadIO', we can use 'Retry.fullJitterBackoff',
-- which introduces small perturbations in our request backoff delays
prodClientConfig :: Servant.ClientEnv
-> ClientConfig
prodClientConfig clientEnv =
let retryPolicy = Retry.fullJitterBackoff 50000
in ClientConfig clientEnv retryPolicy defaultRetryJudge
defaultRetryJudge :: Retry.RetryStatus -> Servant.ServantError -> Bool
defaultRetryJudge _ = \case
Servant.FailureResponse response ->
statusCode response `elem`
[ 408 -- Request timeout
, 504 -- Gateway timeout
, 524 -- A timeout occurred
, 598 -- (Informal convention) Network read timeout error
, 599 -- (Informal convention) Network connect timeout error
]
_ -> False
where
statusCode = HttpTypes.statusCode . Servant.responseStatusCode
-- | Construct a pure 'ClientConfig' for testing using the default 'RetryPolicy'
testClientConfig :: Servant.ClientEnv
-> ClientConfig
testClientConfig clientEnv = ClientConfig clientEnv def undefined
--------------------------------------------------------------------------------
-- | Configuration record supplying the operating environment for a 'App'
data AppConfig = AppConfig
{ _acClientConfig :: ClientConfig
, _acManager :: HttpClient.Manager
}
makeClassy ''AppConfig
instance HasClientConfig AppConfig where
clientConfig = acClientConfig
--------------------------------------------------------------------------------
-- | Alias for a 'AppT' running in 'IO' (the most common environment)
type App = AppT IO
newtype AppT m result = AppT (ReaderT AppConfig m result)
deriving ( Functor, Applicative, Monad
, MonadIO, MonadReader AppConfig
, MonadThrow, MonadCatch, MonadMask
)
--------------------------------------------------------------------------------
-- SERVANT STUFF
--------------------------------------------------------------------------------
type Routes = "api" :> (
("v1" :> Get '[JSON] Int)
:<|> ("v2" :> Get '[JSON] String)
)
type AppClientConstraints env m
= ( HasClientConfig env
, MonadReader env m
, MonadIO m
, MonadThrow m
)
type AppClientM env m response =
AppClientConstraints env m => m response
type AppClient response
= forall env m. AppClientM env m response
getV1 :: AppClient Int
getV2 :: AppClient String
getV1 :<|> getV2 =
Servant.hoistClient
(Proxy @Routes) handleClient (Servant.client (Proxy @Routes))
handleClient :: Servant.ClientM response
-> AppClient response
handleClient clientM = do
clientEnv <- view (clientConfig . ccClientEnv)
retryPolicy <- view (clientConfig . ccRetryPolicy)
retryJudge <- view (clientConfig . ccRetryJudge)
eResponse <- liftIO $ Retry.retrying
retryPolicy
(\retryStatus -> \case
Right _ -> pure False
Left err -> pure $ retryJudge retryStatus err
)
(\_ -> Servant.runClientM clientM clientEnv)
either throwM pure eResponse
--------------------------------------------------------------------------------
-- DEMO
--------------------------------------------------------------------------------
example :: App ()
example = do
_ <- getV1
_ <- getV2
undefined
--------------------------------------------------------------------------------
main :: IO ()
main = do
putStrLn "hello world"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment