はじめに

先日リリースしたHaskellのモックライブラリmethodの新バージョンをリリースしました。

前回の記事はこちらです。

この記事では今回追加した次の二つの新機能を紹介します。

複数のメソッドの使われ方を同時にテストする機能
多相メソッドをモックする機能

新機能1: Protocol

モックメソッドが呼び出されたかどうかをテストするにはMonitorをつかうことができました。
しかし、Monitorは一つのメソッドの呼ばれ方をテストするのには適していますが、
複数のメソッドの呼ばれ方をテストするのは大変です。

新しいProtocol DSLを使うと、

複数のメソッドがどのような順序・引数で何回呼び出されるかテストできます
モックの振る舞いと呼び出し仕様を一つのDSLで記述できます。

使い方

例としてサインアップロジックをテストすることを考えましょう。

Signup.hs

{-# LANGUAGE RecordWildCards #-}
module Signup where

import RIO(bracketOnError_)

type UserName = String
type UserId = Int
type Password = String

data Service = Service {
  findUser :: UserName -> IO (Maybe UserId),
  createUser :: UserName -> IO UserId,
  setPassword :: UserName -> Password -> IO (),
  beginTransaction :: IO (),
  commitTransaction :: IO (),
  rollbackTransaction :: IO ()
}

signup :: Service -> UserName -> Password -> IO (Maybe UserId)
signup Service{..} usernm passwd = do
   mId <- findUser usernm
   case mId of
     Just _ -> pure Nothing
     Nothing -> bracketOnError_ beginTransaction rollbackTransaction $ do
       userId <- createUser usernm
       setPassword usernm passwd
       commitTransaction
       pure $ Just userId

このsignupメソッドは６つのメソッドに依存しています。
このメソッドが以下の仕様を満たしているかテストします。

findUserがJust userIdを返した場合、何もせずNothingを返す
findUserがNothingを返した場合、
- トランザクションを開始し、createUser とsetPasswordを呼び出し（呼び出し順不同）コミットし、createUserの返り値を Justに包んで返す。
- トランザクション途中で例外が発生した場合、メソッドもその例外を投げ、トランザクションをロールバックする

それではテストを書いていきましょう。今回使う言語拡張とモジュールは以下のとおりです。

SignupSpec.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}

module SignupSpec where

import RIO
import Test.Hspec
import Test.Method

import Signup

Protocol DSLでは複数のメソッドを識別するために、メソッドの名前と型を紐づけたGADTを定義します。

data Methods m where
  FindUser :: Methods (UserName -> IO (Maybe UserId))
  CreateUser :: Methods (UserName -> IO UserId)
  SetPassword :: Methods (UserName -> Password -> IO ())
  BeginTransaction :: Methods (IO ()),
  CommitTransaction :: Methods (IO ()),
  RollbackTransaction :: Methods (IO ())
  
deriving instance Eq (Methods m)
deriving instance Ord (Methods m)
deriving instance Show (Methods m)

まずは一つ目の仕様を書いてみましょう。

spec :: Spec
spec = describe "signup" $ do
  let usernm = "user1"
      passwd = "pass1"
      userId = 0
  context "`findUser`が`Just userId`を返した場合" $ do
    it "何もせず`Nothing`を返す" $ do
      penv <- protocol $ do
        decl $ whenArgs FindUser (==usernm) `thenReturn` Just userId
      let service = mkService penv
      signup service usernm passwd `shouldReturn` Nothing
      verify penv
      
mkService :: ProtocolEnv Methods -> Service
mkService env = Service {
  findUser = lookupMock FindUser env,
  createUser = lookupMock CreateUser env,
  setPassword = lookupMock SetPassword env,
  beginTransaction = lookupMock BeginTransaction env,
  commitTransaction = lookupMock CommitTransaction env,
  rollbackTransaction = lookupMock RollbackTransaction env
}

protocolの引数に依存メソッドのふるまい（プロトコル）を記述します。

protocol $ do
  decl $ whenArgs FindUser (==usernm) `thenReturn` Just userId

このプロトコルでは、「findUserメソッドをちょうど一回呼び出す。そのときの引数はusernmと等しく、返り値は Just userIdである」ということを表します。
また、暗黙的にそのほかのメソッドは呼び出さないということも意味しています。

protocol関数はProtocolEnv Methodsを返します。この環境からモックメソッドを
lookupMockを使って取り出すことができます。

mkService :: ProtocolEnv Methods -> Service
mkService env = Service {
  findUser = lookupMock FindUser env,
  createUser = lookupMock CreateUser env,
  setPassword = lookupMock SetPassword env,
  beginTransaction = lookupMock BeginTransaction env,
  commitTransaction = lookupMock CommitTransaction env,
  rollbackTransaction = lookupMock RollbackTransaction env
}

これらのモックメソッドはプロトコルで指定した通りに動作し、それ以外の使い方をすると例外を投げます。
最後にverifyを呼び出し、プロトコルで指定された呼び出しのうち未発火のものがないかテストします。

  signup service usernm passwd `shouldReturn` Nothing
  verify penv

このテストを実行すると無事成功します。

一方、signupの実装を以下のように変えるとテストは失敗します。

signup :: Service -> UserName -> Password -> IO (Maybe UserId)
signup Service {..} usernm passwd = do
  mId <- findUser usernm
  bracketOnError_ beginTransaction rollbackTransaction $ case mId of
    Just _ -> pure Nothing
    Nothing -> do
      userId <- createUser usernm
      setPassword usernm passwd
      commitTransaction
      pure $ Just userI

Failures:

  test/SignupSpec.hs:30:5: 
  1) Signup.signup, `findUser`が`Just userId`を返した場合, 何もせず`Nothing`を返す
       uncaught exception: ErrorCall
       0-th call of method BeginTransaction is unspecified
       CallStack (from HasCallStack):
         error, called at src/Test/Method/Protocol.hs:189:7 in mthd-0.3.0.0-cb36a25c:Test.Method.Protocol
       CallStack (from -prof):
         Test.Method.Protocol.lookupMockWithShow (src/Test/Method/Protocol.hs:(186,1)-(209,36))
         Test.Method.Protocol.lookupMock (src/Test/Method/Protocol.hs:170:1-48)
         SignupSpec.mkService (test/SignupSpec.hs:(38,1)-(46,5))
         Test.Hspec.Expectations.shouldReturn (src/Test/Hspec/Expectations.hs:129:1-65)
         SignupSpec.spec (test/SignupSpec.hs:(25,1)-(35,17))

ログを読むと無駄にトランザクションを開始しているのが原因だとすぐにわかります。

さて、次の仕様のテストを追加しましょう。

Signup.hs

spec :: Spec
spec = do
  ...
  context "`findUSer`が`Nothing`を返した場合" $ do
    it "トランザクションを開始し、`createUser` と`setPassword`を呼び出し（呼び出し順不同）コミットし、`createUser`の返り値を `Just`に包んで返す。" $ do
      penv <- protocol $ do
        findUserCall <-
          decl $
            whenArgs FindUser (== usernm) `thenReturn` Nothing
        beginCall <-
          decl $
            whenArgs BeginTransaction () `thenReturn` ()
              `dependsOn` [findUserCall]
        createUserCall <-
          decl $
            whenArgs CreateUser (== usernm) `thenReturn` userId
              `dependsOn` [beginCall]
        setPasswordCall <-
          decl $
            whenArgs SetPassword ((== usernm), (== passwd)) `thenReturn` ()
              `dependsOn` [beginCall]
        decl $
          whenArgs CommitTransaction () `thenReturn` ()
            `dependsOn` [createUserCall, setPasswordCall]
      let service = mkService penv
      signup service usernm passwd `shouldReturn` Just userId
      verify penv

一つ目のプロトコルに比べると複雑ですが、呼び出すべきメソッドを順番に書いているだけです。
着目して欲しいところは dependsOnを用いてメソッドの呼び出し順を指定している点です。

このプロトコルでは createUserと setPasswordは順不同ですが、beginTransactionを
createUserよりも後に呼び出すことはできません。

例えば、signupの実装を以下のようにするとテストが失敗します。

signup :: Service -> UserName -> Password -> IO (Maybe UserId)
signup Service {..} usernm passwd = do
  mId <- findUser usernm
  case mId of
    Just _ -> pure Nothing
    Nothing -> do
      userId <- createUser usernm
      bracketOnError_ beginTransaction rollbackTransaction $ do
        setPassword usernm passwd
        commitTransaction
        pure $ Just userId

Failures:

  test/SignupSpec.hs:37:5: 
  1) Signup.signup.`findUser`が`Nothing`を返した場合 トランザクションを開始し、`createUser` と`setPassword`を呼び出し（呼び出し順不同）コミットし、`createUser`の返り値を `Just`に包んで返す。
       uncaught exception: ErrorCall
       dependent method BeginTransaction is not called: CallId {unCallId = 1}
       CallStack (from HasCallStack):
         error, called at src/Test/Method/Protocol.hs:207:21 in mthd-0.3.0.0-cb36a25c:Test.Method.Protocol
       CallStack (from -prof):
         Test.Method.Protocol.lookupMockWithShow (src/Test/Method/Protocol.hs:(186,1)-(209,36))
         Test.Method.Protocol.lookupMock (src/Test/Method/Protocol.hs:170:1-48)
         SignupSpec.mkService (test/SignupSpec.hs:(62,1)-(70,5))
         Signup.signup (src/Signup.hs:(23,1)-(32,26))

最後の仕様のテストも追加しましょう。


spec :: Spec
spec = do
  ...
  context "`findUser`が`Nothing`を返した場合" $ do
    ...
    context "トランザクション途中で例外が発生した場合" $ do
      it "その例外を投げ、トランザクションをロールバックする" $ do
        penv <- protocol $ do
          findUserCall <-
            decl $
              whenArgs FindUser (== usernm) `thenReturn` Nothing
          beginCall <-
            decl $
              whenArgs BeginTransaction () `thenReturn` ()
                `dependsOn` [findUserCall]
          createUserCall <-
            decl $
              whenArgs CreateUser (== usernm) `thenAction` throwString "DB Error"
                `dependsOn` [beginCall]
          decl $
            whenArgs RollbackTransaction () `thenReturn` ()
              `dependsOn` [createUserCall]
        let service = mkService penv
            anyStringException :: StringException -> Bool
            anyStringException _ = True
        signup service usernm passwd `shouldThrow` anyStringException
        verify penv

ついうっかりrollbackをするのを忘れたとしましょう。

signup :: Service -> UserName -> Password -> IO (Maybe UserId)
signup Service {..} usernm passwd = do
  mId <- findUser usernm
  case mId of
    Just _ -> pure Nothing
    Nothing -> do
      beginTransaction
      userId <- createUser usernm
      setPassword usernm passwd
      commitTransaction
      pure $ Just userId

テストが失敗するので安心です。

Failures:

  test/SignupSpec.hs:62:7: 
  1) Signup.signup.`findUser`が`Nothing`を返した場合.トランザクション途中で例外が発生した場合 その例外を投げ、トランザクションをロールバックする
       uncaught exception: ErrorCall
       method RollbackTransaction should be called 1 times, but actually is called 0 times
       CallStack (from HasCallStack):
         error, called at src/Test/Method/Protocol.hs:242:7 in mthd-0.3.0.0-cb36a25c:Test.Method.Protocol
       CallStack (from -prof):
         Test.Method.Protocol.verify (src/Test/Method/Protocol.hs:(237,1)-(246,21))
         SignupSpec.spec (test/SignupSpec.hs:(26,1)-(82,19))

新機能2: 多相関数のモック

mockupを使うとメソッドをモックすることができますが、多相型のメソッドをうまくモックする事はできません。
今回、Dynamic型を用いて多相型をもつメソッドもうまくモックできるようになりました。

使い方

例えば、 postgresql-simpleの query関数を使ったプログラムのテストをしたい場合を考えましょう。

query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]

Repository.hs

{-# LANGUAGE OverloadedStrings #-}
module Repository where

import Database.PostgreSQL.Simple

type UserName = String

type UserId = Int

findUser :: Connection -> UserName -> IO (Maybe UserId)
findUser conn usernm = do
  r <- query conn "SELECT user_id FROM user WHERE user_name = ?" (Only usernm)
  case r of
    [Only userId] -> pure $ Just userId
    _ -> pure $ Nothing

このままだとquery関数を注入できないので、DIできる形に書き直します。

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Repository where

...

newtype QueryService = QueryService
  { queryService :: forall q r. (ToRow q, FromRow r) => Query -> q -> IO [r]
  }

findUser :: Connection -> UserName -> IO (Maybe UserId)
findUser conn =
  findUserQ (QueryService (query conn))

findUserQ :: QueryService -> UserName -> IO (Maybe UserId)
findUserQ svc usernm = do
  r <- queryService svc "SELECT user_id FROM user WHERE user_name = ?" (Only usernm)
  case r of
    [Only userId] -> pure $ Just userId
    _ -> pure Nothing

つぎに、モックするメソッドの各型変数の型制約にTypeableとShowを追加します。
TypeableはGHCが勝手にインスタンスを生成してくれるので、制約が強まるわけではありません。
Showは実装できない場合、制約つけなくてもよいです。（つけたほうがデバッグしやすくなります）

今回はqにTypeableとShowを追加し、rにTypeableを追加します。

import Data.Typeable

...

data QueryService = QueryService {
  queryService :: forall q r. (ToRow q, Typeable q, Show q, FromRow r, Typeable r)
    => Query -> q -> IO [r]
}

これでProductionコードの準備ができました。

テストコードにて次のようにするとQueryServiceをモックできるようになります。

型変数qを DynamicShowにrをDynamic ^[1]にそれぞれ置換したモックメソッドを作成します。
```
queryD :: Query -> DynamicShow -> IO [Dynamic] -- 型宣言は省略できません
queryD = mockup $ do
  when (args ((== sql), dynArg (== Only "user1"))) `thenReturn` toDyn [Only 0 :: Only UserId]

sql = "SELECT user_id FROM user WHERE user_name = ?"
```
引数のMatcherはdynArgを使うとDynamic型（またはDynamicShow型）のMatcherに変換することができます。また、
返り値はtoDynを使ってDynamic型（またはDynamicShow型）に変換できます。^[2]
castMethodを使ってDynamic版のメソッドを多相型のメソッドに変換します。
```
svc :: QueryService
svc = QueryService (castMethod queryD)
```

テストコード全体はつぎのようになります。

RepositorySpec.hs

{-# LANGUAGE OverloadedStrings #-}

module RepositorySpec where

import Database.PostgreSQL.Simple
import Repository
import Test.Hspec
import Test.Method

spec :: Spec
spec = describe "findUser" $ do
  let usernm = "user1"
      userId = 0
  context "`query`の結果が1行の時" $ do
    it "`Just userId`を返す" $ do
      let queryD :: Query -> DynamicShow -> IO [Dynamic]
          queryD = mockup $ do
            when (args ((== sql), dynArg (== Only usernm))) `thenReturn` toDyn [Only userId]
          sql = "SELECT user_id FROM user WHERE user_name = ?"
      findUserQ (QueryService (castMethod queryD)) usernm `shouldReturn` Just userId
  context "`query`の結果が0行の時" $ do
    it "`Nothing`を返す" $ do
      let queryD :: Query -> DynamicShow -> IO [Dynamic]
          queryD = mockup $ do
            when (args ((== sql), dynArg (== Only usernm))) `thenReturn` toDyn ([] :: [Only UserId])
          sql = "SELECT user_id FROM user WHERE user_name = ?"
      findUserQ (QueryService (castMethod queryD)) usernm `shouldReturn` Nothing

まとめ

Protocolを使うと、複数の依存メソッドをもつ関数のテストすることができます。
- 依存メソッドがどのような順序で、どの引数で呼ばれ、そのときの返り値は何なのかを記述できます。
- 記述した振る舞いと異なる呼び出し方をした場合、例外として検出されます。
多相型のメソッドはDynamic型をつかった単相メソッドとしてモックすることができます。
二つの機能は直交しているので組み合わせることも可能です。

モックライブラリmethodは以下で開発されています。Issueお待ちしております。

https://github.com/autotaker/method

脚注

DynamicShowは中身が表示できるDynamic型です。Show制約がついた型変数はDynamicShowにして、Show制約をつけられない型変数はDynamicにしましょう。 ↩︎
toDynは[]やMaybeやタプル等をイイ感じにリフトして変換してくれます。 ↩︎

Discussion