Skip to content

Instantly share code, notes, and snippets.

@divarvel divarvel/Lib.hs
Created Dec 31, 2018

Embed
What would you like to do?
A tale of servant clients
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.