Dependency-Injected Servant Client Interpreter

Example.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Example where

import Control.Lens (Lens', view)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Free (Free, foldFree)
import Control.Monad.Reader (MonadReader)
import Control.Monad.Except (throwError)
import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.Kind (Constraint, Type)
import GHC.Generics (Generic)
import Servant.API (Get, JSON, NoContent, (:>))
import Servant.API.Generic ((:-))
import Servant.Client (ClientEnv(..), ClientError, mkClientEnv)
import Servant.Client.Free (ClientF(..))
import Servant.Client.Generic (genericClientHoist, AsClientT)
import Servant.Client.Internal.HttpClient (clientResponseToResponse)
import Network.HTTP.Client (httpLbs)

--------------------------------------------------------------------------------

newtype ClientInterpreter params m = ClientInterpreter
  { getClientInterpreter ::
      forall response.
      params ->
      ClientEnv ->
      ClientF response ->
      ExceptT ClientError m response
  }

type HasClientInterpreter :: (Type -> (Type -> Type) -> Type) -> Constraint
class HasClientInterpreter context where
  clientInterpreterL :: Lens' (context params m) (ClientInterpreter params m)

instance HasClientInterpreter ClientInterpreter where
  clientInterpreterL = id

interpretClient ::
  ( Monad m,
    MonadTrans t,
    MonadReader (context params m) (t m),
    HasClientInterpreter context
  ) =>
  ClientEnv ->
  params ->
  Free ClientF response ->
  (t m) (Either ClientError response)
interpretClient env params client = do
  -- NOTE: Using 'view (clientInterpreterL . to getClientInterpreter)' fails.
  (ClientInterpreter interpreter) <- view clientInterpreterL
  lift . runExceptT $ foldFree (interpreter params env) client

--------------------------------------------------------------------------------
data API mode = API
  { _route :: mode :- "example" :> Get '[JSON] NoContent
  }
  deriving stock (Generic)

concreteClient :: forall m.
  ( Monad m
  ) =>
  ReaderT (ClientInterpreter () m) m (API (AsClientT (ExceptT ClientError m)))
concreteClient = do
  let env = mkClientEnv undefined undefined
      params = ()
  (ClientInterpreter interpret) <- view clientInterpreterL
  pure $ genericClientHoist (foldFree $ interpret params env)

abstractClient ::
  forall m t context.
  ( Monad m,
    MonadTrans t,
    MonadReader (context () m) (t m),
    HasClientInterpreter context
  ) =>
  (t m) (API (AsClientT (ExceptT ClientError m)))
abstractClient = do
  let env = mkClientEnv undefined undefined
      params = ()
  (ClientInterpreter interpret) <- view clientInterpreterL
  pure $ genericClientHoist (foldFree $ interpret params env)

--------------------------------------------------------------------------------
-- | An interpreter for a Servant Client that doesn't accept any additional
-- parameters to augment the query or response with, and operates purely in
-- terms of 'IO'.
passthruInterpreter :: MonadIO m => ClientInterpreter () m
passthruInterpreter =
  let
    interpret _params ClientEnv{manager, baseUrl, makeClientRequest} = \case
      RunRequest req next -> do
        let httpReq = makeClientRequest baseUrl req
        httpResp <- liftIO $ httpLbs httpReq manager
        pure . next $ clientResponseToResponse id httpResp
      Throw err -> throwError err
  in
    ClientInterpreter interpret

example :: IO ()
example = do
  API{_route} <- flip runReaderT passthruInterpreter $ abstractClient
  runExceptT _route >>= \case
    Left err -> print err
    Right resp -> print resp

shell.nix

{ pkgs ? import <nixpkgs> { } }:

pkgs.mkShell {
  buildInputs =
    (with pkgs; [
      cabal-install
      ghcid
      haskellPackages.ormolu
    ]) ++ [
      (pkgs.haskell.packages.ghc8104.ghcWithPackages (hpkgs: with hpkgs; [
        free
        mtl
        transformers

        generic-lens
        lens

        http-client
        servant
        servant-client
        servant-client-core

        retry
      ]))
    ];
}