Skip to content

Instantly share code, notes, and snippets.

@jkachmar
Last active October 14, 2021 17:21
Show Gist options
  • Save jkachmar/e036a1da6bd06595bce553d7443e4d10 to your computer and use it in GitHub Desktop.
Save jkachmar/e036a1da6bd06595bce553d7443e4d10 to your computer and use it in GitHub Desktop.
Dependency-Injected Servant Client Interpreter
{-# 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
{ 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
]))
];
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment