ServantTest.hs

{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE DeriveAnyClass   #-}
{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators    #-}

module Data.FFunctor.ServantTest where

import           Control.Monad.Error.Class (liftEither)
import           Control.Monad.Except
import           Data.Aeson                hiding ((.:))
import           Data.Composition
import           Data.FFunctor
import           Data.Functor.Identity
import           Data.Proxy                (Proxy (..))
import           Data.Time                 (UTCTime)
import           GHC.Generics
import           Network.HTTP.Client       (defaultManagerSettings, newManager)
import           Servant.API
import           Servant.Client

-- From the Servant Tutorial
-- https://haskell-servant.readthedocs.io/en/stable/tutorial/index.html

-- Define a domain object
data User = User
  { name              :: String
  , age               :: Int
  , email             :: String
  , registration_date :: UTCTime
  } deriving (Generic, FromJSON, ToJSON)

-- Define the HTTP endpoints as types
type API = "users" :> Get '[JSON] [User]
      :<|> "users" :> ReqBody '[JSON] User :> Post '[JSON] User
      :<|> "users" :> Capture "userid" Integer :> ReqBody '[JSON] User :> Put '[JSON] User

-- Servant.Client derives functions that return a ClientM that can be run to
-- call those endpoints.
getUsers  :: ClientM [User]
postUsers :: User -> ClientM User
putUsers  :: Integer -> User -> ClientM User
getUsers :<|> postUsers :<|> putUsers = client (Proxy @API)

-- A record of function is just a data type that has functions as fields.
-- We can abstract over a higher kinded type parameter that will eventually
-- be our application's monad stack.
--
-- For example, we can create a record of functions for the API we just defined.
data UserApi m = UserApi
  { apiGetUsers  :: m [User]
  , apiPostUsers :: User -> m User
  , apiPutUsers  :: Integer -> User -> m User
  }

-- An advantage of records of functions is that we can write custom
-- implementations for use in unit tests, without ever talking to a real HTTP
-- server, or performing any IO.
--
-- For example, we may wish to have a trivial mock for the Identity monad, like
-- so, or to have state and error handling via Either and State. Every unit test
-- can have its own custom behaviour.
mockApi :: UserApi Identity
mockApi = UserApi (pure []) (\u -> pure u) (\_ u -> pure u)

-- For production, we want to use the Servant.Client functions that we derived
-- above. But we don't want our application's monad stack to be a ClientM, so we
-- will need to transform this...
servantApi :: UserApi ClientM
servantApi = UserApi getUsers postUsers putUsers

-- To transform a `UserApi ClientM` into a `UserApi OurMonadStack` we need to be
-- able to map over the type parameter. That is exactly what the FFunctor
-- typeclass allows us to do.
--
-- UserAPI may have an instance of an FFunctor because all occurences of the
-- higher kinded type m only appear in return (i.e. covariant) position.
--
-- Creating instances of FFunctor is procedural. Each field (which is a
-- function) has the natural transformation applied according to its number of
-- parameters:
--
--   0. If there are no parameters, the nt is applied as a regular
--      function
--   1. If there is one parameter, the nt is composed with (.)
--   2. If there are more than one parameter, the Data.Composition package may
--      be used, which provides compositions of arbitrary arity.
--      Data.Composition functions are conveniently named such that the number
--      of dots after the initial one are the number of parameters, so .:
--      handles two parameters, .:. handles three, .:: handles four, etc.
--
-- Note that FFunctor is not the same shape as HFunctor, MFunctor or MonadTrans,
-- although they are all related from a category theory point of view.
instance FFunctor UserApi where
  ffmap nt (UserApi f1 f2 f3) = UserApi (nt f1) (nt . f2) (nt .: f3)

-- We need a natural transformation from ClientM into an arbitrary monad stack.
-- The bare minimum requirements to do this are:
--
--   1. we need a value of Servant.Client.ClientEnv, providing the host, port
--      and connection settings.
--   2. we need to be able to perform IO, implying MonadIO
--   3. we need to be able to report ServantError, implying MonadError
--
-- Such a natural transformation may be defined like this and may be shared by
-- all APIs.
liftClientM :: (MonadIO m, MonadError ServantError m)
  => ClientEnv
  -> ClientM a
  -> m a
liftClientM env ca = liftEither =<< (liftIO $ runClientM ca env)

-- We can now generate a UserApi for our application's monad stack, which we can
-- create during initalisation from the ClientEnv configuration.
userApi :: (MonadIO m, MonadError ServantError m) => ClientEnv -> UserApi m
userApi env = ffmap (liftClientM env) servantApi

-- But this demands that we have a `MonadError ServantError` in our stack. That
-- sucks!
--
-- The trick to overcome this limitation is to define a type alias that allows
-- us to have only local errors, provided by the ExceptT monad transformer. This
-- is a well known MTL trick (which doesn't seem to have a name) that can be
-- used to add a variety of locally scoped capabilities to a component, such as
-- a MonadState/MonadReader/MonadWriter via their associated monad transformers.
type UserApiT m = UserApi (ExceptT ServantError m)

-- For example, a downstream user may depend on UserApiT and must handle
-- ServantErrors at the point of use. They may chose to retry, recover, ignore
-- errors, or translate errors into an application specific error ADT.
--
-- Note that we only need the minimal set of constraints, so we only require a
-- Applicative to write:
doStuff :: Applicative m => UserApiT m -> String -> m Bool
doStuff http check = hasEmail <$> (runExceptT $ apiGetUsers http)
  where
    hasEmail (Left _)      = False
    hasEmail (Right users) = any (\u -> (email u) == check) users

-- Compare to the version where errors are ignored and must be handled at a
-- higher layer.
doStuff' :: Applicative m => UserApi m -> String -> m Bool
doStuff' http check = hasEmail <$> apiGetUsers http
  where
    hasEmail users = any (\u -> (email u) == check) users

-- Creating an instance of UserApiT is easy
myApp :: IO Bool
myApp = do
  mgr <- newManager defaultManagerSettings
  let base = BaseUrl Http "localhost" 8080 ""
      env = mkClientEnv mgr base
      api = userApi env
  doStuff api "wibble@wobble.com"