はじめに

この記事では拙作のhierarchical-envというライブラリの紹介記事です。

RIOモナドとHasパターン

RIOモナドはReader + IOの機能を持ったモナドのことです。

newtype RIO env a = RIO { unRIO :: ReaderT env IO a }

ReaderとIOを組み合わせただけなのですが、
Hasパターンと組み合わせることでその真価を発揮します。

例えばRIOモナド上でログを出力する関数は以下のシグネチャを持っています。

logInfo :: (HasLogFunc env) => Utf8Builder -> RIO env ()

ここでHasLogFuncは以下の型クラスです。

class HasLogFunc env where
  logFuncL :: Lens' env LogFunc

実際に使うenv型でHasLogFuncを実装すればlogInfo関数を使うことができます。

このようにRIO env aのenv型（この記事では環境とよびます）に様々なデータを保持することで柔軟な副作用を組み合わせられるというのがRIOモナドの強みです。

Hasパターンについては以下の記事を参考にすると良いでしょう。

hierarchical-envの特長

さて、RIOモナド+Hasパターンは強力なのですが、
Hasパターンでアプリケーションを書いてみると以下のような問題点があります。

型クラスをたくさん定義・実装することになりボイラーポレートが多い
環境の再利用がしにくく環境が肥大化しがち

今回作成したhierarchical-envというライブラリではつぎのようにこれらの問題を解決します。

HasX envの型クラスをHas T envという型制約で一般化
必要なデータをフィールドにもつデータ型を定義するだけでTemplateHaskellによってHas T envの型制約を解決するコードを自動生成
環境を拡張して別の環境を作ることができ、一つの環境が肥大化することを防止

チュートリアル

以下では具体的なアプリケーションをリファクタリングしながらhierarchical-envの使い方を紹介します。

お題

今回は、例として以下のようなシンプルなSlack通知アプリを作ってみましょう。

データベース(MySQL)から未処理の問い合わせの件数を取得する
取得件数をSlackのIncoming Webhookを使って通知する

パラメータの注入

さて、このアプリを作る際には環境情報としてデータベースのコネクションプールとIncomming Webhook URLが必要です。

まず、これらのパラメータをnewtypeで定義します。

Interface.hs

module Tutorial1.Interface where

...

newtype ConnectionPool = ConnectionPool (Pool Connection)

newtype SlackWebhookURL = SlackWebhookURL String

アプリのコードでは型制約Has x envを用いて依存性を表現し、view getLでパラメータを読みます。例えばIncoming Webhookを叩くロジックは以下のように書けます。

App.hs

postSlack :: (Has SlackWebhookURL env) => Text -> RIO env ()
postSlack text = do
  SlackWebhookURL url <- view getL
  req <-
    parseRequestThrow ("POST " <> url)
      <&> setRequestBodyJSON (object ["text" .= text])
  void $ httpNoBody req

同様にしてアプリのメインロジックをappに実装しましょう。

App.hs

countInqueries :: (Has ConnectionPool env) => RIO env Int
countInqueries = ...

app :: (Has SlackWebhookURL env, Has ConnectionPool env) => RIO env ()
app = do
  n <- countInqueries
  let msg = "There are " <> display n <> " open inqueries"
  postSlack $ textDisplay msg

型制約からappの依存パラメータがSlackWebhookURLとConnectionPoolであることがわかります。

さて、このappを実行するためには、(Has SlackWebhookURL env, Has ConnectionPool env)を満たす型envを作る必要があります。

hierarchical-envでは依存パラメータをフィールドに持つデータ型を定義しderiveEnv ''Envで必要な型クラスを導出することでそのような型をつくります。

Env.hs

module Tutorial1.Env where

...

data Env = Env ConnectionPool SlackWebhookURL

deriveEnv ''Env

mkEnv :: ConnectionPool -> SlackWebhookURL -> Env
mkEnv = Env

Main.hsでは本番環境のパラメータを注入するようにします。

Main.hs

main :: IO ()
main = do
  cInfo <- getConnectionInfo
  hook <- getSlackWebhookURL
  pool <- createPool (connect cInfo) close 1 0.5 10
  let env = mkEnv (ConnectionPool pool) hook
  runRIO env app

さて次にpostSlackとcountInqueriesのユニットテストを書きましょう。

postSlack :: (Has SlackWebhookURL env) => Text -> RIO env ()

countInqueries :: (Has ConnectionPool env) => RIO env Int

postSlackはSlackWebhookURLに依存しており、ConnectionPoolには依存していません。
したがってpostSlackのテスト時にはローカルにモックのAPIサーバのみを立てて、ローカルのURLを注入するようにしましょう。

AppSpec.hs


newtype MockWHEnv = MockWHEnv SlackWebhookURL

deriveEnv ''MockWHEnv

...

spec :: Spec
spec = do
  describe "postSlack" $
    aroundAll withMockAPI $ do
      it "send post request to SlackWebhookURL" $ \() -> do
        let env = MockWHEnv (SlackWebhookURL "http://localhost:10080/webhook")
        runRIO env (postSlack "Hello World!") `shouldReturn` ()

同様にcountInqueriesのテスト時にはローカルのDBサーバの接続情報のみを注入します。

AppSpec.hs

...

newtype MockDBEnv = MockDBEnv ConnectionPool

deriveEnv ''MockDBEnv

spec :: Spec
spec = do
  ...
  describe "countInqueries" $
    aroundAll withConnectionPool $ do
      beforeWith setupTable $ do
        it "count the number of inqueriew whose status is not close" $ \cp -> do
          let env = MockDBEnv cp
          runRIO env countInqueries `shouldReturn` 5

依存パラメータが独立しており、必要な依存パラメータのみをモックすればよいため、テストの保守性が高くなります。

ここまでのコードの詳細は以下から確認できます。

インターフェースの注入

さて、次にappのユニットテストを書いてみましょう。

app :: (Has SlackWebhookURL env, Has ConnectionPool env) => RIO env ()

この型制約だとAPIサーバとDBサーバ両方をモックしなければならず、テストの保守性が低くなります。
問題の原因はappがpostSlackとcountInqueriesと密結合になっており、依存性逆転の原則に反していることです。

疎結合になるようにリファクタリングしましょう。Interface.hsにSlackAPI型とInqueryRepo型を追加します。

Interface.hs

+newtype SlackAPI env = SlackAPI
+  { _postMessage :: Text -> RIO env ()
+  }
+
+makeLenses ''SlackAPI
+
+newtype InqueryRepo env = InqueryRepo
+  { _countOpen :: RIO env Int
+  }
+
+makeLenses ''InqueryRepo

a_1 -> a_2 -> ... -> a_n -> RIO env bの形をした関数のことをメソッドと呼ぶことにします。複数のメソッドをまとめたデータ型のことをインターフェースと呼びます。

さて、次にappの依存インターフェースにSlackAPIとInqueryRepoを追加します。
hierarchical-envではHas1 F env制約でインターフェスFへの依存を表現します。

App.hs

-app :: (Has SlackWebhookURL env, Has ConnectionPool env) => RIO env ()
+app :: (Has1 SlackAPI env, Has1 InqueryRepo env) => RIO env ()

依存インターフェースのメソッドはrunIF関数を使って呼び出します。runIFの型は少し特殊です。

runIF :: Has1 f env => (forall env'. f env' -> RIO env' a) -> RIO env a

runIFの引数にはそのインターフェースを使った計算を行う関数を渡します。ただし、
現在の環境envと異なる環境env'で実行されるため、渡す関数はenv'に対して多相的である必要があります。

app中のcountInqueriesとpostSlackの呼び出しをインターフェース経由の呼び出しに書き換えます。

App.hs

-app :: (Has SlackWebhookURL env, Has ConnectionPool env) => RIO env ()
+app :: (Has1 SlackAPI env, Has1 InqueryRepo env) => RIO env ()
 app = do
-  n <- countInqueries
+  n <- runIF $ view countOpen
   let msg = "There are " <> display n <> " open inqueries"
-  postSlack $ textDisplay msg
+  runIF $ \api -> view postMessage api $ textDisplay msg

また、SlackAPIとInqueryRepoの実装も追加しましょう。

App.hs

+slackAPIImpl :: (Has SlackWebhookURL env) => SlackAPI env
+slackAPIImpl = SlackAPI postSlack

+inqueryRepoImpl :: (Has ConnectionPool env) => InqueryRepo env
+inqueryRepoImpl = InqueryRepo countInqueries

Env.hsで依存インターフェースを解決します。InqueryRepo EnvとSlackAPI Env型をフィールドに追加し、mkEnv関数で実装を注入します。

Env.hs

-data Env = Env ConnectionPool SlackWebhookURL
+data Env
+  = Env
+      ConnectionPool
+      SlackWebhookURL
+      (InqueryRepo Env)
+      (SlackAPI Env)
 
 deriveEnv ''Env
 
 mkEnv :: ConnectionPool -> SlackWebhookURL -> Env
-mkEnv = Env
+mkEnv pool hook = Env pool hook inqueryRepoImpl slackAPIImpl

最後にappのユニットテストを追加しましょう。フィールドにSlackAPI MockAppEnvとInqueryRepo MockAppEnvを持つMockAppEnvを追加し、インターフェースのモックを渡します。

AppSpec.hs

+data MockAppEnv = MockAppEnv (SlackAPI MockAppEnv) (InqueryRepo MockAppEnv)
+
+deriveEnv ''MockAppEnv

spec :: Spec
spec = do
  ...
+  describe "app" $
+    it "send a slack notification that tells the number of open inqueries" $ do
+      let env = MockAppEnv slackAPIMock inqueryRepoMock
+          slackAPIMock = SlackAPI $ \msg -> do
+            liftIO $ msg `shouldBe` "There are 10 open inqueries"
+          inqueryRepoMock = InqueryRepo $ pure 10
+      runRIO env app `shouldReturn` ()

これでappのテスト時に面倒なモックサーバの設定を避けることができました。

ここまでのコードの詳細は以下から確認できます。

環境を階層化する

さて、ここまでの実装では依存関係の解決はすべてEnv型が担っていました。
こうするとインターフェースが増えていくにつれてEnv型やアプリケーションのシグネチャがどんどん巨大化して手に負えなくなってしまいます。

data Env = 
  Env
    (Interface1 Env) 
    (Interface2 Env)
    (Interface3 Env)
    ....
    (Interface100 Env)
    
mainApp :: (Has1 Interface1 env, Has1 Interface2 env, ... Has1 Interface100 env) => RIO env ()
mainApp = ....

この問題を避けるため、hierarchical-envでは環境を階層化させることができます。
たとえばBaseEnv型を拡張したExtEnv型を作ることができ、ExtEnv型はBaseEnv型の部分型として振る舞います。

より正確に言うと

任意のパラメータTに対してHas T BaseEnv ならば Has T ExtEnvが成り立ちます
任意のインターフェースFに対してHas1 F BaseEnvならば　Has1 F ExtEnvが成り立ちます

さて、お題のアプリケーションで例を示します。
SlackAPIやInqueryRepoはappだけが使うインターフェースなので、Env型には含めないようにリファクタリングしましょう。

まず、appをインターフェースAppに抽出します。Interface.hsにインターフェースを追加します。

Interface.hs

+newtype App env = App
+  { _app :: RIO env ()
+  }
+  deriving (Generic)
+
+makeLenses ''App
+
+instance Interface App where
+  type IBase App = RIO

interface Interface App where ...の部分はおまじないです。

App.hsにAppEnv env型を追加します。AppEnv envはenv型を拡張した環境です。
hierarchical-envでは拡張元の環境をExtends型で包んだフィールドを追加するだけで環境を拡張することができます。

App.hs

+data AppEnv env = AppEnv (InqueryRepo (AppEnv env)) (SlackAPI (AppEnv env)) (Extends env)
+
+deriveEnv ''AppEnv

このAppEnvとmapBaseRIO関数を使うと依存インターフェースを部分的に解決することができます。

mapBaseRIO :: (Interface f, IBase f ~ RIO) => (env -> env') -> f env' -> f env

App.hs

+appImpl :: (Has ConnectionPool env, Has SlackWebhookURL env) => App env
+appImpl = mapBaseRIO (AppEnv inqueryRepoImpl slackAPIImpl . Extends) $ App app

これでEnvからInqueryRepoとSlackAPIのフィールドを削除して直接依存するAppに置き換えることができます。

Env.hs

-data Env
-  = Env
-      ConnectionPool
-      SlackWebhookURL
-      (InqueryRepo Env)
-      (SlackAPI Env)
+data Env = Env ConnectionPool SlackWebhookURL (App Env)
 
 deriveEnv ''Env
 
 mkEnv :: ConnectionPool -> SlackWebhookURL -> Env
-mkEnv pool hook = Env pool hook inqueryRepoImpl slackAPIImpl
+mkEnv pool hook = Env pool hook appImpl

最後にmain中のapp呼び出しを依存インターフェース経由に変えて完成です

Main.hs

 main :: IO ()
 main = do
   ...
   let env = mkEnv (ConnectionPool pool) hook
-  runRIO env app
+  runRIO env (runIF _app)

ここまでのコードの詳細は以下から確認できます。

まとめ

hierarchical-envの使い方を簡単にまとめると

Has T env型制約でT型の依存パラメータを表現します
Has1 F env型制約でF型の依存インターフェースを表現します
deriveEnv ''Env でHas T envやHas1 F envを解決するボイラーポレートを自動生成します。
ExtEnvにExtends BaseEnv型のフィールドを追加することでBaseEnv型の持つHas T envやHas1 F envをタダでExtEnvでも使えるようになります

このライブラリを使えばRIO+Hasパターンをさらに使いこなすことができるでしょう。

issueおまちしています。

Discussion