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

Opt Technologies所属で、普段は広告運用に関わる社内向けプロダクトをPHP, TypeScript, Clojureで開発しています。

最近までにClojureをプロダクトに導入したり、Haskell/Elmプロダクトの開発者を募集したりと、社内でもClojureやHaskellといった言語への注目度がこれまで以上に高まっています(断言)。

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

ちなみにclj-nakanoといえば、Clojure開発者Rich HickeyのClojure/conj 2017でのキーノートEffective Programs - 10 Years of Clojureを解説した日本語資料も先日一部で話題になっていたようです。

situated-program-challenge

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

詳しくはリポジトリのREADMEに書かれていますが、所定のデータベースにアクセスするREST APIのサーバとクライアントを複数言語で実装し、典型的なWeb APIをいかに簡潔に実装できるか、仕様変更に対していかに柔軟に対応できるか、検証してみようというものです。

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

Clojure版 by @iku000888 さん: iku000888/situated-program-challenge at clj-solution
Scala版 by @shinichy さん: shinichy/situated-program-challenge at version1

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

Haskell版の実装

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

lagenorhynque/situated-program-challenge at hs-version1

HaskellでWeb APIを作ろうとするとフレームワークにもいろいろ選択肢があるようですが、今回はちょうど最近 Seven Web Frameworks in Seven Weeks という本でYesodに触れたところだったため、Yesodで開発してみました。

Yesodは型安全(type-safe)なルーティングやDBアクセスなどが可能なフルスタックフレームワークで、DBアクセスにはPersistentとEsqueletoがスムーズに利用できました。

個人的には『Haskell入門』でも紹介されているフレームワークSpock, Scotty、DBアクセスのためのHaskell Relational Recordあたりも気になっています。

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

1. プロジェクトの生成

Yesod公式のquick start guideなどを参考にプロジェクトを生成し、コマンドラインツールをインストールする。

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

ビルドするには、

$ stack build

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

$ stack exec -- yesod devel

2. DB接続設定

docker-compose.ymlで利用するPostgreSQLのデータベース接続情報が与えられているので、Yesodの設定ファイルに反映する。

rest-server/config/settings.yml (抜粋)

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 によるマイグレーションで得られたテーブルに対応するモデルを定義する。

cf. Persistent Entity Syntax

rest-server/config/models

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によって展開され、対応するデータ型(レコード)や型クラスのインスタンスが自動生成される仕組みらしい(Clojurian/Lisperとしてはこのあたりのマクロによるメタプログラミングがとても気になる)。

rest-server/src/Model.hs

{-# 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としてAPIの仕様が与えられているので、それに従ってルーティングを定義する。

rest-server/config/routes

/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.

$ 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

{-# 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.

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

-- INSERT
mid <- runDB $ insert m

また、aesonでJSONを扱う際にlens, lens-aesonも一部利用してみた。

rest-server/src/Handler/Meetups.hs

{-# 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を利用している。

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サーバは完成!

Clojure版の実装

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

lagenorhynque/situated-program-challenge at clj-version1

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

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

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

【2017/12/22追記】

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

ClojureのDuctでWeb API開発してみた - Qiita

まとめ

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

Haskellerの皆さん(もちろんその他の言語使いの方々も)、situated-program-challengeを気軽に試してみてください|дﾟ)ﾁﾗｯ

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