extensible effects でやっていくドメインロジック記述

# 自己紹介

- 亀岡 亮太 (Ryota Kameoka)
- [株式会社HERP](https://herp.co.jp/) リードエンジニア
- Twitter [@ryotakameoka](https://twitter.com/ryotakameoka)
- GitHub [@ryota-ka](https://github.com/ryota-ka)

---

# ToC

- ドメインロジックとは
- なぜドメインロジック記述が重要か？
- extensible effects
- ドメインロジックの記述
- ドメインロジックの実行
- ドメインロジックのテスト

---

# 注意事項

- スライドのコードはかなり端折ってます
  - [実際の実装は GitHub をご覧ください](https://github.com/ryota-ka/domain-logic-on-eff)

---

# ToC

- <font color="#ed5565">ドメインロジックとは</font>
- なぜドメインロジック記述が重要か？
- extensible effects
- ドメインロジックの記述
- ドメインロジックの実行
- ドメインロジックのテスト

---

# ドメインロジックとは

- コドメインロジックの双対

---

# ドメインロジックとは

- ~~コドメインロジックの双対~~
- **ビジネスロジック**とも呼ばれる

> In computer software, business logic or domain logic is the part of the program that encodes the real-world business rules that determine how data can be created, stored, and changed.

https://en.wikipedia.org/wiki/Business_logic より引用

---

# ドメインロジックとは

![hexagonal architecture.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/68021/650f98c0-75fc-686b-4750-31d2d9c1e410.png)

CC BY-SA 4.0
created by Cth027
https://en.wikipedia.org/wiki/Hexagonal_architecture_(software)#/media/File:Hexagonal_Architecture.svg
一部改変

---

# ドメインロジックとは

![hexagonal architecture konohen.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/68021/6a6a9110-53da-c436-799a-ce3678569a24.png)

CC BY-SA 4.0
created by Cth027
https://en.wikipedia.org/wiki/Hexagonal_architecture_(software)#/media/File:Hexagonal_Architecture.svg
一部改変

---

# ドメインロジックとは

![clean architecture koreno.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/68021/b37326a2-7e16-78d8-d4f2-8a2aba09f219.png)

https://blog.cleancoder.com/uncle-bob/2012/08/13/the-clean-architecture.html より引用・一部改変

---

# ドメインロジックとは

![clean architecture konohen.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/68021/1772ff13-24b0-4f85-235f-b56240b85b6c.png)

https://blog.cleancoder.com/uncle-bob/2012/08/13/the-clean-architecture.html より引用・一部改変

---

# ToC

- ドメインロジックとは
- <font color="#ed5565">なぜドメインロジック記述が重要か？</font>
- extensible effects
- ドメインロジックの記述
- ドメインロジックの実行
- ドメインロジックのテスト

---

# なぜドメインロジック記述が重要か？

- 実装詳細に依存しない (抽象化の壁)
- 変更に強いコードベース
- 複雑性を減らす

---

# どのようにドメインロジックを記述したいか？

- 関心の分離
- 拡張性
- 合成性
- テスタビリティ

---

# ToC

- ドメインロジックとは
- なぜドメインロジック記述が重要か？
- <font color="#ed5565">extensible effects</font>
- ドメインロジックの記述
- ドメインロジックの実行
- ドメインロジックのテスト

---

# extensible effects

- **なんかいい感じの**モナドの合成手法
    - 複数の計算効果を**なんかいい感じに**混ぜることができる
- [Kiselyov and Ishii (2015) "Freer Monads, More Extensible Effects"](http://okmij.org/ftp/Haskell/extensible/more.pdf) の [スライド](https://www.slideshare.net/konn/freer-monads-more-extensible-effects-59411772)を15回ぐらい眺めるとわかる
- 複数の関心事を含んだ "プログラム" (monad) を上手く書ける
- 理論的背景や実装方法は本題じゃないので詳しくは懇親会で (誰かに聞いてください)

---

# extensible effects

ざっくり言うと

- "プログラムそのもの" が書ける (free(r) monads)
- 型 `f a` を「関心事 `f :: Type -> Type` が付いた型 `a`」と見る
    - `f` によって写されている
- 複数の関心事を混ぜることができる
    - `f, g, h :: Type -> Type`

---

# ToC

- ドメインロジックとは
- なぜドメインロジック記述が重要か？
- extensible effects
- <font color="#ed5565">ドメインロジックの記述</font>
- ドメインロジックの実行
- ドメインロジックのテスト

---

# 例) 新しいタレントを追加する

`addTalent` ユースケース

タレント:

```haskell
data Talent
    = Talent
    { id      :: TalentID      -- ^ 'Text' の newtype
    , name    :: TalentName    -- ^ 'Text' の newtype
    , addedAt :: TalentAddedAt -- ^ 'UTCTime' の newtype
    }
```

---

# 例) 新しいタレントを追加する

- タレント名を受け取る
- 現在時刻を取得する
- IDを発番する
- タレントを永続化する
- 作られたタレントを返す

---

# 例) 新しいタレントを追加する

- <font color="#ed5565">タレント名を受け取る</font> (引数)
- 現在時刻を取得する
- IDを発番する
- タレントを永続化する
- <font color="#ed5565">作られたタレントを返す</font> (戻り値)

`TalentName -> m Talent`

---

# 例) 新しいタレントを追加する

- タレント名を受け取る
- <font color="#ed5565">現在時刻を取得する</font> (effect)
- <font color="#ed5565">IDを発番する</font> (effect)
- <font color="#ed5565">タレントを永続化する</font> (effect)
- 作られたタレントを返す

---

# 例) 新しいタレントを追加する

- タレント名を受け取る
- <font color="#ed5565">現在時刻を取得する</font> (`Clock` effect)
- <font color="#ed5565">IDを発番する</font> (`TalentIDGenerator` effect)
- <font color="#ed5565">タレントを永続化する</font> (`TalentRepository` effect)
- 作られたタレントを返す

名前をつけてやる (関心の分離)

---

# `Clock` effect

出来合いの effect を使う

```haskell
module Effects.Clock where

import Data.Extensible (ReaderEff)
import Data.Time (UTCTime)

type AnonEff = ReaderEff UTCTime
type HasEff effs = _

ask :: forall effs. HasEff effs => Eff effs UTCTime
ask = _
```

---

# `TalentIDGenerator` effect

出来合いの effect を使う

```haskell
module Effects.TalentIDGenerator where

import Data.Extensible (ReaderEff)
import DomainObjects.Talent (TalentID)

type AnonEff = ReaderEff TalentID
type HasEff effs = _

next :: forall effs. HasEff effs => Eff effs TalentID
next = _
```

---

# `TalentRepository` effect

自分で effect を定義する

```haskell
module Effects.TalentRepository where

type AnonEff = TalentRepository
type HasEff effs = _

data TalentRepository a where
    Find  :: TalentID -> TalentRepository (Maybe Talent)
    Store :: Talent   -> TalentRepository ()

find :: forall effs. HasEff effs => TalentID -> Eff effs (Maybe Talent)
find talentID = _

store :: forall effs. HasEff effs => Talent -> Eff effs ()
store talent = _
```

---

# `addTalent` ユースケース

```haskell
addTalent
    :: forall effs
     . ( Clock.HasEff effs
       , TalentIDGenerator.HasEff effs
       , TalentRepository.HasEff effs
       )
    => TalentName
    -> Eff effs Talent
addTalent name = do               -- タレント名を受け取る
```

---

# 例) 新しいタレントを追加する

```haskell
addTalent
    :: forall effs
     . ( Clock.HasEff effs
       , TalentIDGenerator.HasEff effs
       , TalentRepository.HasEff effs
       )
    => TalentName
    -> Eff effs Talent
addTalent name = do               -- タレント名を受け取る
    now <- Clock.ask              -- 現在時刻を取得する
```
---

# 例) 新しいタレントを追加する

```haskell
addTalent
    :: forall effs
     . ( Clock.HasEff effs
       , TalentIDGenerator.HasEff effs
       , TalentRepository.HasEff effs
       )
    => TalentName
    -> Eff effs Talent
addTalent name = do               -- タレント名を受け取る
    now <- Clock.ask              -- 現在時刻を取得する
    id  <- TalentIDGenerator.next -- IDを発番する
```

---

# 例) 新しいタレントを追加する

```haskell
addTalent
    :: forall effs
     . ( Clock.HasEff effs
       , TalentIDGenerator.HasEff effs
       , TalentRepository.HasEff effs
       )
    => TalentName
    -> Eff effs Talent
addTalent name = do               -- タレント名を受け取る
    now <- Clock.ask              -- 現在時刻を取得する
    id  <- TalentIDGenerator.next -- IDを発番する

    let addedAt = TalentAddedAt.fromUTCTime now
        talent  = Talent { id, name, addedAt }
```

---

# 例) 新しいタレントを追加する

```haskell
addTalent
    :: forall effs
     . ( Clock.HasEff effs
       , TalentIDGenerator.HasEff effs
       , TalentRepository.HasEff effs
       )
    => TalentName
    -> Eff effs Talent
addTalent name = do               -- タレント名を受け取る
    now <- Clock.ask              -- 現在時刻を取得する
    id  <- TalentIDGenerator.next -- IDを発番する

    let addedAt = TalentAddedAt.fromUTCTime now
        talent  = Talent { id, name, addedAt }

    TalentRepository.store talent -- タレントを永続化する
```

---

# 例) 新しいタレントを追加する

```haskell
addTalent
    :: forall effs
     . ( Clock.HasEff effs
       , TalentIDGenerator.HasEff effs
       , TalentRepository.HasEff effs
       )
    => TalentName
    -> Eff effs Talent
addTalent name = do               -- タレント名を受け取る
    now <- Clock.ask              -- 現在時刻を取得する
    id  <- TalentIDGenerator.next -- IDを発番する

    let addedAt = TalentAddedAt.fromUTCTime now
        talent  = Talent { id, name, addedAt }

    TalentRepository.store talent -- タレントを永続化する

    pure talent                   -- 作られたタレントを返す
```

---

# 何をやっているのかがわかる！！

---

# ToC

- ドメインロジックとは
- なぜドメインロジック記述が重要か？
- extensible effects
- ドメインロジックの記述
- <font color="#ed5565">ドメインロジックの実行</font>
- ドメインロジックのテスト

---

# ドメインロジックの実行

- タレント名を受け取る
- <font color="#ed5565">現在時刻を取得する</font> (`Clock` effect)
- <font color="#ed5565">IDを発番する</font> (`TalentIDGenerator` effect)
- <font color="#ed5565">タレントを永続化する</font> (`TalentRepository` effect)
- 作られたタレントを返す

3つの effect を handle すればユースケースを"実行"できる

---

# 作戦会議

- `Clock` effect
    - システム・コールで現在時刻を取得する
        - `IO` っぽい
- `TalentIDGenerator` effect
    - IDを発番する (UUID v4 とかで)
        - `IO` っぽい
- `TalentRepository` effect
    - タレントを永続化する
        - ホンマは RDB に入れたいけど今日のところは `IORef` で勘弁しといたるか……
            - `IO` っぽい

---

# 作戦会議

- `Clock` effect
    - システム・コールで現在時刻を取得する
        - `IO` っぽい
- `TalentIDGenerator` effect
    - IDを発番する (UUID v4 とかで)
        - `IO` っぽい
- `TalentRepository` effect
    - タレントを永続化する
        - ホンマは RDB に入れたいけど今日のところは `IORef` で勘弁しといたるか……
            - `IO` っぽい

→ 一旦それぞれ `IO` に押し付けてあとでまとめて解決するか

---

# 作戦会議

![effect handling on server.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/68021/37d0947d-a986-f3cb-7955-dc761a5f01ca.png)

---

# `Clock` effect を handle する

```haskell
run
    :: forall effs a
     . IO.HasEff effs                 -- 残りの effects に IO が含まれていることを要求
    => Eff (Clock.NamedEff ': effs) a -- Clock effect を剥がす
    -> Eff effs a
run = peelEff0 pure interpret
  where
    interpret
        :: forall r
         . Clock.AnonEff r
        -> (r -> Eff effs a)
        -> Eff effs a
    interpret Refl k = do
        now <- IO.lift getCurrentTime -- IO に押し付ける
        k now
```

---

# `TalentIDGenerator` effect を handle する

```haskell
run
    :: forall effs a
     . IO.HasEff effs                             -- 残りの effects に IO が含まれていることを要求
    => Eff (TalentIDGenerator.NamedEff ': effs) a -- TalentIDGenerator effect を剥がす
    -> Eff effs a
run = peelEff0 pure interpret
  where
    interpret
        :: forall r
         . TalentIDGenerator.AnonEff r
        -> (r -> Eff effs a)
        -> Eff effs a
    interpret Refl k = do
        uuid <- IO.lift UUID.nextRandom           -- IO に押し付ける
        let text     = UUID.toText uuid
            talentID = TalentID.shamefullyConvertFromText text
        k talentID
```

---

# `TalentRepository` effect を handle する

```haskell

run
    :: forall effs a
     . IO.HasEff effs
    => IORef (Map Talent.ID Talent)
    -> Eff (TalentRepository.NamedEff ': effs) a
    -> Eff effs a
run ref effs = peelEff0 pure interpret effs
  where
    interpret :: forall r . TalentRepository.AnonEff r -> (r -> Eff effs a) -> Eff effs a
    interpret (Find id) k = do
        repo <- IO.lift $ readIORef ref
        let mtalent = Map.lookup id repo
        k mtalent
    interpret (Store talent@Talent { id }) k = do
        IO.lift $ atomicModifyIORef' ref (\repo -> (Map.insert id talent repo, ()))
        k ()
```

---

# Webサーバから呼び出す

```haskell
run :: IO ()
run = do
    talentRepo <- newIORef mempty

    let runUseCase
            :: forall a
             . Eff '[TalentRepository.NamedEff, TalentIDGenerator.NamedEff, Clock.NamedEff, IO.NamedEff] a
            -> IO a
        runUseCase = retractEff . Clock.run . TalentIDGenerator.run . TalentRepository.run talentRepo

    scotty 3000 $ do
        -- タレントの数を返す
        get "/talents.count" $ do
            repo <- liftIO $ readIORef talentRepo
            let count = length repo
            json $ object ["count" .= count]

        -- タレントを追加する
        post "/talents.add" $ do
            name <- param "name"
            _    <- liftIO . runUseCase $ do -- use case 呼び出し
                addTalent (TalentName.shamefullyConvertFromText name)
            status status201
            json $ object ["ok" .= True]
```

```sh
$ curl -X GET localhost:3000/talents.count
{"count":0}%

$ curl -X POST -d name=Alice localhost:3000/talents.add
{"ok":true}%

$ curl -X POST -d name=Bob localhost:3000/talents.add
{"ok":true}%

$ curl -X GET localhost:3000/talents.count
{"count":2}%
```

---

# ToC

- ドメインロジックとは
- なぜドメインロジック記述が重要か？
- extensible effects
- ドメインロジックの記述
- ドメインロジックの実行
- <font color="#ed5565">ドメインロジックのテスト</font>

---

# ドメインロジックのテスト

- このようにして記述したドメインロジックは容易にテスト可能
- 副作用を起こさずに pure に handle する

---

# 作戦会議

![effect handling on test.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/68021/ce37473c-5dd5-8da2-a895-7b5b438d8e73.png)

---

# `Clock` を pure に handle する

```haskell
run
    :: forall effs a
     . UTCTime
    -> Eff (Clock.NamedEff ': effs) a
    -> Eff effs a
run = flip runReaderEff
```

普通に `Reader`

---

# `TalentIDGenerator` を pure に handle する

```haskell
run
    :: forall effs a
     . Eff (TalentIDGenerator.NamedEff ': effs) a
    -> Eff effs a
run effs = peelEff1 (\x _ -> pure x) interpret effs 0
  where
    interpret :: forall r . TalentIDGenerator.AnonEff r -> (r -> Integer -> Eff effs a) -> Integer -> Eff effs a
    interpret Refl k n = do
        let text     = T.pack (show n)
            talentID = TalentID.shamefullyConvertFromText text
        k talentID (n + 1)
```

- `TalentID "0"`
- `TalentID "1"`
- `TalentID "2"`
- ...

を順に生成


---

# `TalentRepository` を pure に handle する

```haskell
run
    :: forall effs a
     . Map Talent.ID Talent
    -> Eff (TalentRepository.NamedEff ': effs) a
    -> Eff effs (a, Map Talent.ID Talent)
run initState effs = peelEff1 (\a s -> pure (a, s)) interpret effs initState
  where
    interpret
        :: forall r
         . TalentRepository.AnonEff r
        -> (r -> Map Talent.ID Talent -> Eff effs (a, Map Talent.ID Talent))
        -> Map Talent.ID Talent
        -> Eff effs (a, Map Talent.ID Talent)
    interpret (Find  id) k repo = k (Map.lookup id repo) repo
    interpret (Store talent@Talent { id }) k repo =
        let repo' = Map.insert id talent repo
         in k () repo'
```

---

# テストコード

pure な handler でユースケースを実行

```haskell
now :: UTCTime
now = posixSecondsToUTCTime 1234567890

runUseCase
    :: Eff '[TalentRepository.NamedEff, TalentIDGenerator.NamedEff, Clock.NamedEff] a -> (a, Map Talent.ID Talent)
runUseCase = leaveEff . Clock.run now . TalentIDGenerator.run . TalentRepository.run mempty

spec :: Spec
spec = describe "addTalent" $ do
    it "increments the number of talents in the repository" $ do
        let name      = TalentName.shamefullyConvertFromText "John Doe"
            (_, repo) = runUseCase $ addTalent name
        length repo `shouldBe` 1
```

---

# ユースケースのテスト

```sh
$ stack test use-cases:test:spec
use-cases> test (suite: spec)


UseCases.AddTalent
  addTalent
    increments the number of talents in the repository

Finished in 0.0003 seconds
1 example, 0 failures

use-cases> Test suite spec passed
```

---

# まとめ

extensible effects でロメインロジックを記述すると何が嬉しいか？

- **関心の分離**
    - effect を個別に定義できる
- **拡張性**
    - 新たな effect に対して開かれている (open union)
- **合成性**
    - monadic に合成可能
- **テスタビリティ**
    - pure に実行可能

---

# ご清聴ありがとうございました！