ClojurianがHaskellでWeb API開発に入門してみた

Clojurian時々Haskellerでラブライブ!ファン(海未🏹&曜⛵推し)の[lagénorhynque](https://twitter.com/lagenorhynque) (a.k.a. カマイルカ)です。

[Opt Technologies](https://www.opt.ne.jp/opttechnologies/)所属で、普段は広告運用に関わる社内向けプロダクトをPHP, TypeScript, Clojureで開発しています。

最近までに[Clojureをプロダクトに導入](http://tech-magazine.opt.ne.jp/entry/2017/09/06/074020)したり、[Haskell/Elmプロダクトの開発者を募集](https://twitter.com/OptTechnologies/status/936123304259104768)したりと、社内でもClojureやHaskellといった言語への注目度がこれまで以上に高まっています(断言)。

そこで今回は、今年11月から新たに始まったClojure勉強会[clj-nakano](https://clj-nakano.connpass.com/)での課題を題材に、HaskellでのWeb API開発に入門してみることにしました。

ちなみにclj-nakanoといえば、Clojure開発者Rich HickeyのClojure/conj 2017でのキーノート[Effective Programs - 10 Years of Clojure](https://youtu.be/2V1FtfBDsLU)を解説した[日本語資料](https://gitpitch.com/clj-nakano/effective-programs-ja/)も先日一部で話題になっていたようです。

# situated-program-challenge

clj-nakanoでは、Rich Hickeyのキーノートでも出てきた表現"situated program"というものについて探求するべく、[situated-program-challenge](https://github.com/clj-nakano/situated-program-challenge)という課題に取り組んでいます。

詳しくはリポジトリの[README](https://github.com/clj-nakano/situated-program-challenge/blob/master/README.md)に書かれていますが、所定のデータベースにアクセスするREST APIのサーバとクライアントを複数言語で実装し、典型的なWeb APIをいかに簡潔に実装できるか、仕様変更に対していかに柔軟に対応できるか、検証してみようというものです。

第2回clj-nakanoではClojureとScalaでの実装例が紹介されました。

- Clojure版 by @iku000888 さん: [iku000888/situated-program-challenge at clj-solution](https://github.com/iku000888/situated-program-challenge/tree/clj-solution)
- Scala版 by @shinichy さん: [shinichy/situated-program-challenge at version1](https://github.com/shinichy/situated-program-challenge/tree/version1)

というわけで、Web API開発の入門にも適したsituated-program-challengeのREST APIサーバをHaskellで実装してみます。

# Haskell版の実装

実際にsituated-program-challengeの仕様version1の内容に即して実装してみたHaskell版:

[lagenorhynque/situated-program-challenge at hs-version1](https://github.com/lagenorhynque/situated-program-challenge/tree/hs-version1)

HaskellでWeb APIを作ろうとするとフレームワークにもいろいろ選択肢があるようですが、今回はちょうど最近 [*Seven Web Frameworks in Seven Weeks*](https://pragprog.com/book/7web/seven-web-frameworks-in-seven-weeks) という本で[Yesod](https://github.com/yesodweb/yesod)に触れたところだったため、Yesodで開発してみました。

Yesodは型安全(type-safe)なルーティングやDBアクセスなどが可能なフルスタックフレームワークで、DBアクセスには[Persistent](https://github.com/yesodweb/persistent)と[Esqueleto](https://github.com/bitemyapp/esqueleto)がスムーズに利用できました。

個人的には[『Haskell入門』](http://gihyo.jp/book/2017/978-4-7741-9237-6)でも紹介されているフレームワーク[Spock](https://github.com/agrafix/Spock), [Scotty](https://github.com/scotty-web/scotty)、DBアクセスのための[Haskell Relational Record](https://github.com/khibino/haskell-relational-record)あたりも気になっています。

時間の都合により、本記事執筆時点ではsituated-program-challengeの課題のうちRESTサーバのみの実装で(RESTクライアントは未実装)、Yesodのscaffoldによる不要なコード/ファイルが残っていたり、ユニットテストがなかったりしますが、ひとまず以下のような流れで開発できました。

## 1. プロジェクトの生成

Yesod公式の[quick start guide](https://www.yesodweb.com/page/quickstart)などを参考にプロジェクトを生成し、コマンドラインツールをインストールする。

```sh
$ stack new rest-server yesod-postgres
$ cd rest-server
$ stack install yesod-bin --install-ghc
```

ビルドするには、

```sh
$ stack build
```

開発サーバを起動するには、

```sh
$ stack exec -- yesod devel
```

## 2. DB接続設定

[docker-compose.yml](https://github.com/lagenorhynque/situated-program-challenge/blob/hs-version1/docker-compose.yml)で利用するPostgreSQLのデータベース接続情報が与えられているので、Yesodの設定ファイルに反映する。

- [rest-server/config/settings.yml](https://github.com/lagenorhynque/situated-program-challenge/blob/hs-version1/rest-server/config/settings.yml) (抜粋)

```yaml
database:
  user:     "_env:PGUSER:meetup"
  password: "_env:PGPASS:password123"
  host:     "_env:PGHOST:localhost"
  port:     "_env:PGPORT:5432"
  # See config/test-settings.yml for an override during tests
  database: "_env:PGDATABASE:meetup"
  poolsize: "_env:PGPOOLSIZE:10"
```

## 3. モデルの定義

`lein migratus` による[マイグレーション](https://github.com/lagenorhynque/situated-program-challenge/tree/hs-version1/resources/migrations)で得られたテーブルに対応するモデルを定義する。

cf. [Persistent Entity Syntax](https://github.com/yesodweb/persistent/blob/master/docs/Persistent-entity-syntax.md)

- [rest-server/config/models](https://github.com/lagenorhynque/situated-program-challenge/blob/hs-version1/rest-server/config/models)

```haskell
Group sql=groups
    name Text sqltype=text Maybe
    createdAt UTCTime Maybe
    deriving Eq
    deriving Show

GroupMember sql=groups_members
    groupId GroupId
    memberId MemberId
    Primary groupId memberId
    admin Bool default=false Maybe
    deriving Eq
    deriving Show

Meetup sql=meetups
    title Text sqltype=text
    startAt UTCTime Maybe
    endAt UTCTime Maybe
    venueId VenueId Maybe
    groupId GroupId Maybe
    deriving Eq
    deriving Show

MeetupMember sql=meetups_members
    meetupId MeetupId
    memberId MemberId
    Primary meetupId memberId
    deriving Eq
    deriving Show

Member sql=members
    firstName Text sqltype=text Maybe
    lastName Text sqltype=text Maybe
    email Text sqltype=text Maybe
    deriving Eq
    deriving Show

Venue sql=venues
    name Text sqltype=text Maybe
    postalCode Text sqltype=text Maybe
    prefecture Text sqltype=text Maybe
    city Text sqltype=text Maybe
    street1 Text sqltype=text Maybe
    street2 Text sqltype=text Maybe
    groupId GroupId Maybe
    deriving Eq
    deriving Show
```

↑の `model` ファイルの定義が↓で読み込まれて[Template Haskell](https://wiki.haskell.org/Template_Haskell)によって展開され、対応するデータ型(レコード)や型クラスのインスタンスが自動生成される仕組みらしい(Clojurian/Lisperとしてはこのあたりのマクロによるメタプログラミングがとても気になる)。

---

- [rest-server/src/Model.hs](https://github.com/lagenorhynque/situated-program-challenge/blob/hs-version1/rest-server/src/Model.hs)

```haskell
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
module Model where

import           ClassyPrelude.Yesod
import           Data.Aeson.TH
import           Database.Persist.Quasi

import qualified Data.Aeson.Casing      as Casing
import qualified Text.Casing            as Casing

-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkMigrate "migrateAll"]
    $(persistFileWith lowerCaseSettings "config/models")

deriveJSON (Casing.aesonPrefix Casing.kebab) ''Group
deriveJSON (Casing.aesonPrefix Casing.kebab) ''Meetup
deriveJSON (Casing.aesonPrefix Casing.kebab) ''Member
deriveJSON (Casing.aesonPrefix Casing.kebab) ''Venue
```

今回のAPIではJSONのキーがkebab-caseであるため、Data.Aeson.THの `deriveJSON` でモデルのレコードをJSONにする際にレコードフィールド名のプレフィックスを落としてcamelCaseからkebab-caseに変換するようにしている。

ここでもTemplate Haskellの力でモデルとJSONの相互変換のボイラープレートコードが削減されている。

## 4. ルーティングの定義

[swagger spec](https://github.com/lagenorhynque/situated-program-challenge/blob/hs-version1/swagger-spec-v1.json)としてAPIの仕様が与えられているので、それに従ってルーティングを定義する。

- [rest-server/config/routes](https://github.com/lagenorhynque/situated-program-challenge/blob/hs-version1/rest-server/config/routes)

```haskell
/members MembersR GET POST
/members/#MemberId MemberR GET
/members/#MemberId/meetups/#MeetupId MeetupMemberR POST
/members/#MemberId/groups/#GroupId GroupMemberR POST
/groups GroupsR GET POST
/groups/#GroupId/venues VenuesR GET POST
/groups/#GroupId/meetups MeetupsR GET POST
/groups/#GroupId/meetups/#MeetupId MeetupR GET
```

Yesodのコマンドラインツールを利用すると、例えば以下のようにルーティング定義と対応するハンドラーのファイルが自動生成できてちょっと便利。

e.g.

```sh
$ stack exec -- yesod add-handler
Name of route (without trailing R): Groups
Enter route pattern (ex: /entry/#EntryId): /groups
Enter space-separated list of methods (ex: GET POST): GET POST
```

## 5. ハンドラーの実装

リクエストを受け取ってからレスポンスを返すまでのAPIのビジネスロジックをハンドラー関数として実装する。

ここでは、入出力のJSONを適宜変換したり、Persistent/EsqueletoでDBアクセスしたり。

- [rest-server/src/Handler/Members.hs](https://github.com/lagenorhynque/situated-program-challenge/blob/hs-version1/rest-server/src/Handler/Members.hs)

```haskell
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Handler.Members where

import           Import

import           Control.Lens
import           Data.Aeson.Lens

getMembersR :: Handler Value
getMembersR = do
    ms <- runDB $ selectList [] [] :: Handler [Entity Member]
    returnJson $ map memberValueWithId ms

postMembersR :: Handler Value
postMembersR = do
    m <- requireJsonBody :: Handler Member
    mid <- runDB $ insert m
    returnJson . memberValueWithId $ Entity mid m

getMemberR :: MemberId -> Handler Value
getMemberR memberId = do
    m <- runDB $ get404 memberId
    returnJson . memberValueWithId $ Entity memberId m

memberValueWithId :: Entity Member -> Value
memberValueWithId (Entity mid m) =
    toJSON m & _Object . at "member-id" ?~ toJSON mid
```

Persistentの標準機能でSQLの `SELECT` や `INSERT` など基本的なDB操作が簡潔に書けた。

e.g.

```haskell
-- SELECT
ms <- runDB $ selectList [] [] :: Handler [Entity Member]

-- INSERT
mid <- runDB $ insert m
```

また、[aeson](https://hackage.haskell.org/package/aeson)でJSONを扱う際に[lens](https://hackage.haskell.org/package/lens), [lens-aeson](https://hackage.haskell.org/package/lens-aeson)も一部利用してみた。

---

- [rest-server/src/Handler/Meetups.hs](https://github.com/lagenorhynque/situated-program-challenge/blob/hs-version1/rest-server/src/Handler/Meetups.hs)

```haskell
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Handler.Meetups where

import           Import

import           Database.Esqueleto ((^.))
import qualified Database.Esqueleto as E

import           Handler.Members    (memberValueWithId)
import           Handler.Venues     (venueValueWithAddress)

getMeetupsR :: GroupId -> Handler Value
getMeetupsR groupId = do
    ms <- runDB $ selectList [MeetupGroupId ==. Just groupId] []
    meetupDetails <- mapM fetchMeetupDetail ms
    returnJson meetupDetails

postMeetupsR :: GroupId -> Handler Value
postMeetupsR groupId = do
    m <- requireJsonBody :: Handler Meetup
    let m' = m { meetupGroupId = Just groupId }
    mid <- runDB $ insert m'
    meetupDetail <- fetchMeetupDetail $ Entity mid m'
    returnJson meetupDetail

getMeetupR :: GroupId -> MeetupId -> Handler Value
getMeetupR _ = getMeetup

postMeetupMemberR :: MemberId -> MeetupId -> Handler Value
postMeetupMemberR memberId meetupId = do
    _ <- runDB . insert $ MeetupMember { meetupMemberMeetupId = meetupId
                                       , meetupMemberMemberId = memberId
                                       }
    getMeetup meetupId

fetchMeetupDetail :: Entity Meetup -> Handler Value
fetchMeetupDetail em@(Entity mid Meetup{..}) = do
    v <- maybe (return Nothing) (runDB . getEntity) meetupVenueId
    ms <- runDB $ E.select
                $ E.from $ \(member' `E.InnerJoin` meetupMember') -> do
                    E.on $ member' ^. MemberId E.==. meetupMember' ^. MeetupMemberMemberId
                    E.where_ $ meetupMember' ^. MeetupMemberMeetupId E.==. E.val mid
                    return member'
    return $ meetupWithVenueAndMembers em v ms

getMeetup :: MeetupId -> Handler Value
getMeetup mid = do
    m <- runDB $ get404 mid
    meetupDetail <- fetchMeetupDetail $ Entity mid m
    returnJson meetupDetail

meetupWithVenueAndMembers :: Entity Meetup -> Maybe (Entity Venue) -> [Entity Member] -> Value
meetupWithVenueAndMembers (Entity mid Meetup{..}) venue members =
    object [ "event-id" .= mid
           , "title" .= meetupTitle
           , "start-at" .= meetupStartAt
           , "end-at" .= meetupEndAt
           , "venue" .= fmap venueValueWithAddress venue
           , "members" .= fmap memberValueWithId members
           ]
```

こちらのハンドラーでは、多対多関係を表現するテーブルを `JOIN` して検索するために、より柔軟に(しかも型安全に)SQLが書けるEsqueletoを利用している。

```haskell
ms <- runDB $ E.select
            $ E.from $ \(member' `E.InnerJoin` meetupMember') -> do
                E.on $ member' ^. MemberId E.==. meetupMember' ^. MeetupMemberMemberId
                E.where_ $ meetupMember' ^. MeetupMemberMeetupId E.==. E.val mid
                return member'
```

その他のハンドラーも同様に実装してRESTサーバは完成!

- [rest-server/src/Handler/Groups.hs](https://github.com/lagenorhynque/situated-program-challenge/blob/hs-version1/rest-server/src/Handler/Groups.hs)
- [rest-server/src/Handler/Venues.hs](https://github.com/lagenorhynque/situated-program-challenge/blob/hs-version1/rest-server/src/Handler/Venues.hs)

# Clojure版の実装

Clojureらしいデータ駆動(data-driven)/データ指向(data-oriented)なフレームワーク[Duct](https://github.com/duct-framework/duct)、DBアクセスに[HoneySQL](https://github.com/jkk/honeysql)あたりを利用して実装したClojure版(予定):

[lagenorhynque/situated-program-challenge at clj-version1](https://github.com/lagenorhynque/situated-program-challenge/tree/clj-version1)

時間の都合により、本記事執筆時点では[Ataraxy](https://github.com/weavejester/ataraxy)とPostgreSQLを使う想定でRESTサーバ用のプロジェクトを生成したところで止まっています(Haskell版と対比してみたかったのですが、普通に間に合いませんでした😇……)。

```sh
$ lein new duct rest-server +api +ataraxy +postgres
```

Haskell版とともに近日中に実装していく予定なので、興味のある方は日を改めてご確認ください😅

【2017/12/22追記】

Clojure (Duct)版のRESTサーバを実装してみました!

[ClojureのDuctでWeb API開発してみた - Qiita](https://qiita.com/lagenorhynque/items/57d5aa086c4a080a1c54)

# まとめ

- HaskellのフルスタックフレームワークYesodで型安全性に支えられながらWeb APIが開発できた
- Clojureでは常にREPLと対話しながら開発するが、Haskellのコンパイラとある種の対話をしながら開発するスタイルも良いかも
- Haskellはまだまだ私には難しいけど、徐々に分かってくると楽しい＞ω＜/
- Haskellの言語とエコシステムについてもっと理解すればもっとコードを改善できそう

Haskellerの皆さん(もちろんその他の言語使いの方々も)、[situated-program-challenge](https://github.com/clj-nakano/situated-program-challenge)を気軽に試してみてください|дﾟ)ﾁﾗｯ

# Further Reading

- [*Seven Web Frameworks in Seven Weeks*](https://pragprog.com/book/7web/seven-web-frameworks-in-seven-weeks)
    - Ring
    - Yesod
- [『Haskell入門 関数型プログラミング言語の基礎と実践』](http://gihyo.jp/book/2017/978-4-7741-9237-6)
- [HaskellとJSON、そしてレコード型 - syocy’s diary](http://syocy.hatenablog.com/entry/2017/08/14/235830)
- [Yesod Web Framework Book- Version 1.4](https://www.yesodweb.com/book)
    - [Routing and Handlers](https://www.yesodweb.com/book/routing-and-handlers)
    - [Persistent](https://www.yesodweb.com/book/persistent)
    - [RESTful Content](https://www.yesodweb.com/book/restful-content)
    - [SQL Joins](https://www.yesodweb.com/book/sql-joins)
- [persistent/docs](https://github.com/yesodweb/persistent/tree/master/docs)
- [Building Web Services with Duct](https://www.booleanknot.com/blog/2017/05/29/building-web-services-with-duct.html)