Haskellでクリーンアーキテクチャっぽいこと

Haskellの勉強の息抜きとして
Haskellでクリーンアーキテクチャっぽいことってできるのだろうか？とふと思って設計しました。

クリーンアーキテクチャはSOLID原則を駆使し依存関係に重点を置いたアーキテクチャ設計手法です。
各層の責務を明確にすることと依存の向きを注意することが設計のポイント。

OOPでは依存の向きを保つためにDIP（依存関係逆転の法則）を用いて実現する。Haskellで同様のことをやるためには型クラスを内側に置き、外側のレイヤーでインスタンスを作成できれば良いと思ったが実現できていない。
従って正確にはクリーンアーキテクチャではないのだけど。

##### 概要
今回のサンプルでは従業員(Employee）の登録を行う。
従業員の情報は名前と年齢です。

##### 概要補足
非常にシンプルですが、目的はレイヤーの構成と構成要素（モジュール）の責務を明確にすることなので、データの要素（部署、給与、チームなど）や処理の種類（CRUD)が増えても対応できると思います。
このサンプルをたたき台にユースケースを増やすのも面白いと思います。

##### 全体像

![1.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/294552/e53b5013-9eba-aca8-7784-f4623307b2a1.png)

##### Models層
業務に関わる型の定義と業務ロジックを定義するためのレイヤー。

- Models/Employee

| ファイル       |   概要    |
|:-----------------|:------------------|
| Age.hs| Age型 |
| EmployeeEntity.hs|EmployeeEntity型 (集約ルート) |
| EmployeeEntityFactory.hs|EmployeeEntity生成モジュール |
| Name.hs| Name型 |

```Age.hs
-- 年齢型(Maybe Intクラスの別名)
module Models.Employee.Age where

type Age = Maybe Int

generateAge :: Int -> Maybe Int
generateAge age = Just age
```

```EmployeeEntity.hs
module Models.Employee.EmployeeEntity where
    import Models.Employee.Age
    import Models.Employee.Name

    class EmployeeEntityClass a where
        getName :: a -> Name
        getAge  :: a -> Age

    data EmployeeEntity = EmployeeEntity {
        name :: Name,
        age :: Age
    } deriving (Show)

    instance EmployeeEntityClass EmployeeEntity where
        getName a = name a
        getAge a  = age a
```

```EmployeeEntityFactory.hs
-- 従業員モデル（データ型）作成ファクトリーの定義
module Models.Employee.EmployeeEntityFactory (generateEmployeeEntity) where
    import Models.Employee.Age
    import Models.Employee.EmployeeEntity
    import Models.Employee.Name

    generateEmployeeEntity :: Name -> Age -> EmployeeEntity
    generateEmployeeEntity name age = 
        EmployeeEntity {
            name = name,
            age = age
        }
```

```Name.hs
-- 名前型(Stringクラスの別名)
module Models.Employee.Name where
type Name = String

-- メソッド定義
generateName :: String -> Name
generateName name = name :: Name
```

##### UseCases層
ユースケースに応じてドメインモデルを取得、永続化の手続きを行う。

- UseCases/Services/Employee

| ファイル       |   概要    |
|:-----------------|:------------------|
| CreateEmployeeService.hs| ユースケースの実行 |

```CreateEmployeeService.hs
-- 従業員モデル（データ型）を作成するサービスの実装
module UseCases.Services.Employee.CreateEmployeeService (createEmployee) where
    import Gateways.Repositories.Employee.EmployeeRepository(addEmployee)
    import Models.Employee.Age
    import Models.Employee.EmployeeEntity
    import Models.Employee.EmployeeEntityFactory (generateEmployeeEntity)
    import Models.Employee.Name
    import Presenters.Converters.Employee.InputEmployeeData

    createEmployee inputEntityData = 
        let name = generateName $ getNameRaw inputEntityData
            age = generateAge $ getAgeRaw inputEntityData
            employeeEntity = generateEmployeeEntity name age
            in addEmployee employeeEntity
```

##### Controllers層
外部からのリクエストを受け付けユースケースを呼び出す。

- Controllers/Employee

| ファイル       |   概要    |
|:-----------------|:------------------|
| EmployeeController.hs| コントローラー |

```EmployeeController.hs
-- 従業員コントローラ―
module Controllers.Employee.EmployeeController(callCreateEmployee) where
    import Presenters.Converters.Employee.InputEmployeeData
    import UseCases.Services.Employee.CreateEmployeeService (createEmployee)

    callCreateEmployee :: String -> String -> IO ()
    callCreateEmployee inputName inputAge =
        createEmployee $ generateInputEmployeeData inputName inputAge
        

    generateInputEmployeeData :: String -> String -> InputEmployeeData
    generateInputEmployeeData inputName inputAge =
        InputEmployeeData {
            name = inputName,
            age = read inputAge
        }
```

##### Presenters層
入出力データの変換を担う。

- Presenters/Converters/Employee

| ファイル       |   概要    |
|:-----------------|:------------------|
| InputEmployeeData.hs| インプットデータを保持 |

```InputEmployeeData.hs
-- 従業員の入力データ型
module Presenters.Converters.Employee.InputEmployeeData where

    data InputEmployeeData = InputEmployeeData {
            name :: String,
            age :: Int
        } deriving (Show)

    class InputEmployeeClass a where
        getNameRaw :: a -> String
        getAgeRaw  :: a -> Int

    instance InputEmployeeClass InputEmployeeData where
        getNameRaw a = name a
        getAgeRaw a = age a
```

##### Gateways層
システムと外部の境界。
DBとの連携、外部サービスとの連携など。

- Gateways/Repositories/Employee

| ファイル       |   概要    |
|:-----------------|:------------------|
| EmployeeRepository.hs| Employeeテーブルとの連携 |

```EmployeeRepository.hs
-- 従業員リポジトリクラスの実装
{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Gateways.Repositories.Employee.EmployeeRepository(addEmployee) where
import           Control.Monad.IO.Class  (liftIO)
import           Control.Monad.Logger    (runStderrLoggingT)
import Data.ByteString.Char8 (pack) 
import           Database.Persist
import           Database.Persist.Postgresql
import           Database.Persist.TH
import Models.Employee.EmployeeEntity
import PostgresqlConfig.Setting(getConn)

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Employee
    name String
    age Int Maybe
    deriving Show
|]

host = getConn "host"
dbname = getConn "dbname"
user = getConn "user"
password = getConn "password"
port = getConn "port"

connStr = pack $ concat [host, dbname, user, password, port]

addEmployee :: EmployeeEntity -> IO ()
addEmployee employee = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll

        let 
            name = getName employee
            age = getAge employee

        -- -- 従業員テーブル
        empId <- insert $ Employee name $ age

        emp <- get empId
        liftIO $ print (emp :: Maybe Employee)
```

###### その他
今回はデータストアに`Postgresql`を利用しています。
ソースは「[github](https://github.com/kirakirapq/haskell-cleanarchitecture)」に置いておきます。