"Simple" example for how to set up Servant to automatically retry its client requests

Main.hs

{-# 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"