今回はServant-Clientについてです。Servant-Clientを使えば、ServantのAPIに対応したクライアント用のクエリ関数を自動生成してくれます。

servant-client: Automatic derivation of querying functions for servant

1. 全ソース

前回のSqliteのプログラムを少し修正します。
【Servant】(10) SQLite - Qiita

Client.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}

module Client
    ( runServant
    ) where

import Control.Concurrent
import Control.Exception (bracket)
import Control.Monad.IO.Class
import Database.SQLite.Simple
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Network.Wai.Handler.Warp
import Servant
import Servant.Client



type Message = String

type API = ReqBody '[PlainText] Message :> Post '[JSON] NoContent
      :<|> Get '[JSON] [Message]

api :: Proxy API
api = Proxy


initDB :: FilePath -> IO ()
initDB dbfile = withConnection dbfile $ \conn ->
  execute_ conn
    "CREATE TABLE IF NOT EXISTS messages (msg text not null)"



server :: FilePath -> Server API
server dbfile = postMessage :<|> getMessages

  where postMessage :: Message -> Handler NoContent
        postMessage msg = do
          liftIO . withConnection dbfile $ \conn ->
            execute conn
                    "INSERT INTO messages VALUES (?)"
                    (Only msg)
          return NoContent

        getMessages :: Handler [Message]
        getMessages = fmap (map fromOnly) . liftIO $
         withConnection dbfile $ \conn ->
            query_ conn "SELECT msg FROM messages"

runApp :: FilePath -> IO ()
runApp dbfile = run 8080 (serve api $ server dbfile)


postMsg :: Message -> ClientM NoContent
getMsgs :: ClientM [Message]
postMsg :<|> getMsgs = client api


runServant :: IO ()
runServant = do
  -- you could read this from some configuration file,
  -- environment variable or somewhere else instead.
  let dbfile = "test.db"
  initDB dbfile
  mgr <- newManager defaultManagerSettings
  bracket (forkIO $ runApp dbfile) killThread $ \_ -> do
    ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
      postMsg "hello"
      postMsg "world"
      getMsgs
    print ms

メイン

Main.hs

module Main where

import qualified HtmlContent       as T1
import qualified PostData          as T2
import qualified CustomPostData    as T3
import qualified AnotherMonad      as T4
import qualified Sqlite            as T5
import qualified Client            as T6

main :: IO ()
main = T6.runServant

使用するパッケージ

package.yaml

dependencies:
- base >= 4.7 && < 5
- servant
- servant-server
- servant-client
- aeson
- time
- wai
- warp
- http-media
- http-client
- bytestring
- mtl
- sqlite-simple

2.説明

servant-client: Automatic derivation of querying functions for servant

client はServantで定義されたAPIのそれぞれのエンドポイントに対するクエリ関数を自動生成します。今回の以下の定義では、postMsgとgetMsgのクエリ関数が自動生成されます。

client

type API = ReqBody '[PlainText] Message :> Post '[JSON] NoContent
      :<|> Get '[JSON] [Message]

api :: Proxy API
api = Proxy
--
postMsg :: Message -> ClientM NoContent
getMsgs :: ClientM [Message]
postMsg :<|> getMsgs = client api

postMsgとgetMsgsはClientMモナドの文脈で実行されます。
ちなみにClientMモナドは,IOモナドをベースに、ExceptTモナドを積み、更にReaderTモナドを積み重ねたものです。

ClientM

-- | @ClientM@ is the monad in which client functions run. Contains the
-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
newtype ClientM a = ClientM
  { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
  deriving ( Functor, Applicative, Monad, MonadIO, Generic
           , MonadReader ClientEnv, MonadError ClientError, MonadThrow
           , MonadCatch)

ClientMモナドはrunClientMで実行されます。今回の例ではflipで、runClientMの第一引数と第二引数を入れ替えていることに注意してください。

runClientM

runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)

runClientMの値としては、ClientM a の実行結果（成功した場合）が IO (Right a)の形で得られることになります。

自動生成されたpostMsgとgetMsgは以下のように使われます。

runServant

runServant :: IO ()
runServant = do
  -- you could read this from some configuration file,
  -- environment variable or somewhere else instead.
  let dbfile = "test.db"
  initDB dbfile
  mgr <- newManager defaultManagerSettings
  bracket (forkIO $ runApp dbfile) killThread $ \_ -> do
    ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
      postMsg "hello"
      postMsg "world"
      getMsgs
    print ms

以下の一行で、サーバとクライアントを起動しています。

bracket

  bracket (forkIO $ runApp dbfile) killThread $ \_ -> do

bracket で (forkIO \$ runApp dbfile)を起動し、killThread でリソースの後始末をします。後始末のタイミングは「$ _ -> do」以下の本体（クライアントプログラム）が終了したタイミングです。

ちなみに以下のClientMモナド全体の値は、全部成功した場合ですけど、最後のgetMsgsの値となります。それはrunClientM で実行されたモナドの値 ms となります。

ClientM

do
  postMsg "hello"
  postMsg "world"
  getMsgs

最後にrunClientM の第2引数のClientEnv型の定義をみてみます。

ClientEnv

-- | The environment in which a request is run.
--   The 'baseUrl' and 'makeClientRequest' function are used to create a @http-client@ request.
--   Cookies are then added to that request if a 'CookieJar' is set on the environment.
--   Finally the request is executed with the 'manager'.
--   The 'makeClientRequest' function can be used to modify the request to execute 
--   and set values which
--   are not specified on a @servant@ 'Request' like 'responseTimeout' or 'redirectCount'
data ClientEnv
  = ClientEnv
  { manager :: Client.Manager
  , baseUrl :: BaseUrl
  , cookieJar :: Maybe (TVar Client.CookieJar)
  , makeClientRequest :: BaseUrl -> Request -> Client.Request
  -- ^ this function can be used to customize the creation of @http-client@ requests
  -- from @servant@ requests. Default value: 'defaultMakeClientRequest'
  --   Note that:
  --      1. 'makeClientRequest' exists to allow overriding operational semantics
  --          e.g. 'responseTimeout' per request,
  --          If you need global modifications, you should use 'managerModifyRequest'
  --      2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called.
  }

mkClientEnv関数でClientEnv型データを作成します

mkClientEnv

import qualified Network.HTTP.Client         as Client
---
-- | 'ClientEnv' smart constructor.
mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest

3. 実行結果

実行します。

stack build && stack exec first-project-exe

以下のような結果が出力されます。

Right ["hello","world"]

今回は以上です

【Servant】(11) Servant-Client

1. 全ソース

2.説明

3. 実行結果