A tale of servant clients

Lib.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
module Lib
    ( showRoutes
    , API
    ) where

import           Control.Category         ((>>>))
import           Control.Monad.IO.Class   (MonadIO, liftIO)
import           Control.Monad.Reader     (MonadReader, ask)
import           Data.Aeson
import qualified Data.Text.IO             as TIO
import qualified Generics.SOP             as SOP
import qualified GHC.Generics             as GHC
import           Network.Wai
import           Network.Wai.Handler.Warp
import           Servant
import           Servant.Client

type UserId = Int

type API =
    BasicAuth "user-management" User :>
      "users" :> UsersAPI

type UsersAPI =
      Get '[JSON] [User]
 :<|> ReqBody '[JSON] UserData :> Post '[JSON] NoContent
 :<|> Capture "userId" UserId :> UserAPI

type UserAPI =
        Get '[JSON] User
   :<|> ReqBody '[JSON] UserData :> Put '[JSON] NoContent
   :<|> Delete '[JSON] NoContent

data User = User
  { userId        :: Int
  , userFirstName :: String
  , userLastName  :: String
  }
  deriving stock (Eq, Show, GHC.Generic)
  deriving anyclass (FromJSON, ToJSON)

data UserData = UserData
  { firstName :: String
  , lastName  :: String
  }
  deriving stock (Eq, Show, GHC.Generic)
  deriving anyclass (FromJSON, ToJSON)

api :: Proxy API
api = Proxy

-- Manual client extraction via patter matching
listUsersClient :: BasicAuthData -> ClientM [User]
listUsersClient auth =
  let lu :<|> _ = client api auth
  in lu

editUserClient :: BasicAuthData -> UserId -> UserData -> ClientM NoContent
editUserClient auth userId =
  let _ :<|> _ :<|> ue = client api auth
      _ :<|> eu :<|> _ = ue userId
  in eu

-- Generic client derivation
type APIClient = BasicAuthData -> UsersAPIClient

data UsersAPIClient = UsersAPIClient
  { listUsers  :: ClientM [User]
  , createUser :: UserData -> ClientM NoContent
  , withUser   :: UserId -> UserAPIClient
  }
  deriving stock (GHC.Generic)
  deriving anyclass (SOP.Generic)

-- declare the correspondence between the record and
-- the API type (UsersAPI / UsersAPIClient)
instance (Client ClientM UsersAPI ~ client)
  => ClientLike client UsersAPIClient

data UserAPIClient = UserAPIClient
  { getUser    :: ClientM User
  , editUser   :: UserData -> ClientM NoContent
  , deleteUser :: ClientM NoContent
  }
  deriving stock (GHC.Generic)
  deriving anyclass (SOP.Generic)

-- declare the correspondence between the record and
-- the API type (UserAPI / UserAPIClient)
instance (Client ClientM UserAPI ~ client)
  => ClientLike client UserAPIClient

newClient :: APIClient
newClient = mkClient $ client api

listUsersClient' :: BasicAuthData -> ClientM [User]
listUsersClient' auth = listUsers $ newClient auth

editUserClient' :: BasicAuthData
                -> UserId -> UserData
                -> ClientM NoContent
editUserClient' auth userId userData =
  editUser (withUser (newClient auth) userId) userData

editUserClient'' :: BasicAuthData
                 -> UserId -> UserData
                 -> ClientM NoContent
editUserClient'' auth userId userData =
  ($ userData) . editUser . ($ userId) . withUser $ newClient auth

editUserClientWithWildCards :: BasicAuthData
                            -> UserId -> UserData
                            -> ClientM NoContent
editUserClientWithWildCards auth userId userData =
    let UsersAPIClient{..} = newClient auth
        UserAPIClient{..} = withUser userId
    in editUser userData

withParam :: a -> (a -> b) -> b
withParam = flip ($)

(//) :: (a -> b) -> (b -> c) -> (a -> c)
(//) = flip (.)

type App a =
    forall m. (MonadReader (BasicAuthData, ClientEnv) m, MonadIO m) => m a

runClient :: (UsersAPIClient -> ClientM a)
          -> App (Either ServantError a)
runClient f = do
    (auth, clientEnv) <- ask
    liftIO $ runClientM (f $ newClient auth) clientEnv

editUserClient''' :: UserId -> UserData
                  -> App (Either ServantError NoContent)
editUserClient''' userId userData =
  runClient $
    withUser >>> withParam userId >>> editUser >>> withParam userData
    -- infix used
    -- (`withUser` userId) >>> (`editUser` userData)
    -- with fancy alias and dollar sections
    -- withUser // ($ userId) // editUser // ($ userData)

showRoutes :: IO ()
showRoutes = TIO.putStrLn $ layoutWithContext api ctx
  where
    ctx = buggy :. EmptyContext
    buggy :: BasicAuthCheck User
    buggy = undefined