ユースケース層が投げうるエラーの型を「量化したopen union」にしておけば複数のユースケースを合成したときに上の層でエラーハンドリングが楽にできて最高です！

この記事はHaskell Advent Calendar 2020 20日目の記事です．

TL; DR#

タイトル

問題設定#

ユースケース層とサーヴァ層が存在するWebアプリケーションを考える．サーヴァ層はユースケース層を呼び出すことができるが，ユースケース層はサーヴァ層について無知でなければならない．

+----------------+
|  server layer  |
+-------+--------+
        |  depends on
+-------v--------+
| use case layer |
+----------------+

このようなアプリケーションのAPIリクエストハンドラにおいて，複数のユースケースを合成して呼び出すケースを例に挙げ，それぞれのユースケースが投げうるエラーをうまく扱うopen unionを用いたテクニックを紹介する．

今回はextensible effectsを用いてユースケース層を記述するが，特にextensible effectsに固有の話というわけではない．tagless finalでも，ExceptTや単なるEitherでも同じテクニックが使えるだろう．

extensible effectsのライブラリとしてextensible-skeletonを用いる．

`Error`effect#

ユースケース層はエラーを投げることができるものとする．下準備として，エラーを投げるためのError effectを定義しておく．

src/Effects/Error.hs

module Effects.Error
    ( HasEff
    , throw
    ) where

import "base" Data.Proxy (Proxy (..))
import "extensible-skeleton" Data.Extensible.Effect (Eff, EitherEff, throwEff)
import "membership" Type.Membership (Lookup)

type HasEff e effs = Lookup effs "Error" (EitherEff e)

throw
    :: forall e effs void
     . HasEff e effs
    => e
    -> Eff effs void
throw e = throwEff (Proxy @"Error") e

ユースケース#

引数で受け取ったIDに対応するTalentエンティティを返すユースケースであるfindTalentというユースケースがあるとしよう．ただし，対応するTalentが見付からなかった場合にはTalentNotFoundエラーを送出する．

src/UseCases/FindTalent.hs

module UseCases.FindTalent where

import "extensible-skeleton" Data.Extensible.Effect (Eff)

import qualified Effects.Error as Error (HasEff, throw)
import qualified Effects.TalentRepository as TalentRepository (find, HasEff)

{-
与えられた'TalentID'に対応する'Talent'を返す
見付からない場合には'TalentNotFound'を投げる
-}
findTalent
    :: forall effs
     . TalentRepository.HasEff effs
    => Error.HasEff TalentNotFound effs
    => TalentID
    -> Eff effs Talent
findTalent id = do
    mtalent <- TalentRepository.find id
    case mtalent of
        Nothing -> do
            let e = TalentNotFound id
            Error.throw e
        Just talent -> pure talent

findTalentとよく似たfindTagユースケースも準備しておく．

src/UseCases/FindTag.hs

module UseCases.FindTag where

import "extensible-skeleton" Data.Extensible.Effect (Eff)

import qualified Effects.Error as Error (HasEff, throw)
import qualified Effects.TagRepository as TagRepository (find, HasEff)

{-
与えられた'TagID'に対応する'Tag'を返す
見付からない場合には'TagNotFound'を投げる
-}
findTag
    :: forall effs
     . TagRepository.HasEff effs
    => Error.HasEff TagNotFound effs
    => TagID
    -> Eff effs Tag
findTag id = _ -- 実装は割愛

サーヴァ層からユースケースを呼び出す#

これら2つのユースケースを合成し，サーヴァ層から呼び出す場面に焦点を当てる．

ここでHandlerは，APIのリクエストハンドラを書くための言語であり，runUseCaseは，ユースケース記述言語からHandler言語への解釈を与える関数とする．ただし，Error effectはEitherとして解釈する．

src/Server/Handlers/API/Taggings/Create.hs

module Server.Handlers.API.Taggings.Create where

import UseCases.FindTag (findTag)
import UseCases.FindTalent (findTalent)

data Response = Response { ok :: Bool }

handler :: TalentID -> TagID -> Handler Response
handler talentID tagID = do
    result <- runUseCase $ do -- このdo以下で複数のユースケースを合成する
        talent <- findTalent talentID
        tag    <- findTag tagID
        createTagging talent tag

    case result of
        Left e  -> handleErrors e
        Just () -> pure Response { ok = True }

-- この関数でユースケースのエラーハンドリングを行いたい
handleErrors
    :: _ -- が，引数の型は？
    -> Handler Response
handleErrors = _

しかし，これはうまくいかない．findTalentが投げうるエラーの型はTalentNotFoundである一方，findTagが投げうるエラーの型はTagNotFoundであり，これらが一致しないからだ．これは本質的には（eとe'が異なる型であるときに）Either eとEither e'が組み合わせられない問題と同質である．

open union#

そもそも一般に，あるユースケースが投げたいエラーが1種類で事足りるとは限らない．ユースケースによっては，あらかじめ宣言した複数の種類のエラーのうち，状況に応じてどれかひとつを投げたい，という場合もあるだろう．このような欲求を満たすため，まずは投げるエラーをopen unionに埋め込むことにしよう．今回は既にextensible packageを使っているので，extensibleが提供するextensible sumを使うことにする．

src/UseCases/FindTalent.hs

@@ -1,5 +1,6 @@
 module UseCases.FindTalent where

+import "extensible" Data.Extensible.Plain (bury, OneOf)
 import "extensible-skeleton" Data.Extensible.Effect (Eff)

 import qualified Effects.Error as Error (HasEff, throw)
@@ -12,7 +13,7 @@ import qualified Effects.TalentRepository as TalentRepository (find, HasEff)
 findTalent
     :: forall effs
      . TalentRepository.HasEff effs
-    => Error.HasEff TalentNotFound effs
+    => Error.HasEff (OneOf '[TalentNotFound]) effs
     => TalentID
     -> Eff effs Talent
 findTalent id = do
@@ -20,5 +21,5 @@ findTalent id = do
     case mtalent of
         Nothing -> do
             let e = TalentNotFound id
-            Error.throw e
+            Error.throw (bury e)
         Just talent -> pure talent

また，findTagユースケースにも同様の変更を加える．

投げられうるエラーを量化する#

エラーをopen unionで扱うだけでは，エラーの型が一致しないという当初の問題が解消されるわけではない．OneOf '[TalentNotFound]とOneOf '[TagNotFound]は異なるので当然である．そこで，OneOfの引数を「少なくともTalentNotFoundを含む任意のリスト」という風に量化する．

src/UseCases/FindTalent.hs

@@ -1,5 +1,6 @@
 module UseCases.FindTalent where

+import "extensible" Data.Extensible (Include)
 import "extensible" Data.Extensible.Plain (bury, OneOf)
 import "extensible-skeleton" Data.Extensible.Effect (Eff)

@@ -11,9 +12,10 @@ import qualified Effects.TalentRepository as TalentRepository (find, HasEff)
 見付からない場合には'TalentNotFound'を投げる
 -}
 findTalent
-    :: forall effs
+    :: forall errors effs
      . TalentRepository.HasEff effs
-    => Error.HasEff (OneOf '[TalentNotFound]) effs
+    => errors `Include` '[TalentNotFound]
+    => Error.HasEff (OneOf errors) effs
     => TalentID
     -> Eff effs Talent
 findTalent id = do

新たな型変数errorsを導入し，エラーの型としてOneOf errorsを用いるように変更を加えた．

findTagが投げうるエラーについても同様に，少なくともTagNotFoundを含む任意のリストという風に量化してやる．

こうすれば，handleErrors関数は以下のように実装できる．ここにおいて，findTalentおよびfindTagのシグネチャ中の型変数errorsはいずれも'[TagNotFound, TalentNotFound]に解決される．

handleErrors
    :: OneOf '[TagNotFound, TalentNotFound]
    -> Handler Response
handleErrors = match
    $  Match (\(Identity (TagNotFound _)) -> throw NotFound)
    <: Match (\(Identity (TalentNotFound _)) -> throw NotFound)
    <: nil

要件が変更され，合成されたユースケースの最後で呼び出されていたcreateTaggingがTagAlreadyAttachedToTalentエラーやTooManyTagsAttachedToTalentエラーを投げるようになったとしよう．その場合でも，パターンマッチを増やすだけで対応できるため，拡張性にも富んでいる．

handleErrors
    :: OneOf '[TagNotFound, TalentNotFound, TagAlreadyAttachedToTalent, TooManyTagsAttachedToTalent]
    -> Handler Response
handleErrors = match
    $  Match (\(Identity (TagNotFound _)) -> throw NotFound)
    <: Match (\(Identity (TalentNotFound _)) -> throw NotFound)
    <: Match (\(Identity (TagAlreadyAttachedToTalent _)) -> pure Response { ok = True }) -- return 2xx for idempotent requests
    <: Match (\(Identity (TooManyTagsAttachedToTalent _)) -> throw Conflict)
    <: nil

広告#

HERP広告

この記事はHERP勤務中に書かれた。

HERPは本物のHaskellプログラマーを募集しています。

コード#

主要な部分のみを抜粋した不完全なコードである．GHC言語拡張や，細かい関数・データ型の定義などは適宜補ってほしい．また，本文中で最初に定義したError effectは，量化されたopen unionをエラーとして投げることを前提したUseCaseError effectで置き換えている．

src/Effects/UseCaseError.hs

module Effects.UseCaseError
    ( HasEff
    , throw
    ) where

import "base" Data.Proxy (Proxy (..))
import "extensible" Data.Extensible.Plain (bury, OneOf)
import "extensible-skeleton" Data.Extensible.Effect (Eff, EitherEff, throwEff)
import "membership" Type.Membership (Lookup, Member)

type HasEff errors effs = Lookup effs  "UseCaseError" (EitherEff (OneOf errors))

throw
    :: forall errors e effs void
     . Member errors e
    => HasEff errors effs
    => e
    -> Eff effs void
throw e = throwEff (Proxy @"UseCaseError") (bury e)

src/UseCases/FindTalent.hs

module UseCases.FindTalent where

import "extensible" Data.Extensible (Include)
import "extensible-skeleton" Data.Extensible.Effect (Eff)

{-
与えられた'TalentID'に対応する'Talent'を返す
見付からない場合には'TalentNotFound'を投げる
-}
findTalent
    :: forall errors effs
     . errors `Include` '[TalentNotFound]
    => TalentRepository.HasEff effs
    => UseCaseError.HasEff errors effs
    => TalentID
    -> Eff effs Talent
findTalent id = do
    mtalent <- TalentRepository.find id
    case mtalent of
        Nothing -> do
            let e = TalentNotFound id
            UseCaseError.throw e
        Just talent -> pure talent

src/UseCases/FindTag.hs

module UseCases.FindTag where

import "extensible" Data.Extensible (Include)
import "extensible-skeleton" Data.Extensible.Effect (Eff)

{-
与えられた'TagID'に対応する'Tag'を返す
見付からない場合には'TagNotFound'を投げる
-}
findTag
    :: forall errors effs
     . errors `Include` '[TagNotFound]
    => TagRepository.HasEff effs
    => UseCaseError.HasEff errors effs
    => TagID
    -> Eff effs Tag
findTag id = do
    mtag <- TagRepository.find id
    case mtag of
        Nothing -> do
            let e = TagNotFound id
            UseCaseError.throw e
        Just tag -> pure tag

src/Server/Handlers/API/Taggings/Create.hs

module Server.Handlers.API.Taggings.Create where

import "base" Data.Functor.Identity (Identity (..))
import "extensible" Data.Extensible ((<:), Match (..), match, nil)
import "extensible" Data.Extensible.Plain (OneOf)

import UseCases.FindTag (findTag)
import UseCases.FindTalent (findTalent)

handler :: TalentID -> TagID -> Handler Response
handler talentID tagID = do
    result <- runUseCase $ do
        talent <- findTalent talentID
        tag    <- findTag tagID
        createTagging talent tag

    case result of
        Left e  -> handleErrors e
        Just () -> pure Response { ok = True }

handleErrors
    :: OneOf '[TagNotFound, TalentNotFound]
    -> Handler Response
handleErrors = match
    $  Match (\(Identity (TagNotFound _)) -> throw NotFound)
    <: Match (\(Identity (TalentNotFound _)) -> throw NotFound)
    <: nil