Haskell Advent Calendar 2017 その３（！）、７日目の記事です。

HaskellでRESTサーバを書くライブラリはいくつかあるようですが、私が気に入っているのはservantです。対抗馬としてはScottyがあると思いますが、servantはより型に安全なそうなのと、APIのあり方が好きです。

servantはごく薄い機能しか提供していないので、本格的なRESTサーバに必須のDB連携を自分で書く必要があるのですが、巷にはこのサンプルが少ない気がしています。

また高レベルなDBアクセスフレームワークとしてはpersistentが有名だと思うのですが、servantと組み合わせた例が本家GitHubにあるにはあるのですが、persistentのバージョンが古くインターフェイスが変わっているのでコンパイルに通らなかったりするし、コネクションプーリングを使っていないので実戦的ではありません。

というわけで「一通り実戦で使えるであろう」というレベルのサンプルを作ったので紹介します。

なおこの記事内のコードで使っている主なライブラリとバージョンは以下の通りです。

servant-0.11
persistent-2.7.0
persistent-postgresql-2.6.1

全てのソースは次の場所にあります。
https://github.com/jabaraster/servant-persistent-sample/tree/7b9a086fc8cbd2742bed7758fd5618a1fe2252e9

まずは足回り

DBに関して、接続設定取得／コネクションプール作成／マイグレーション実施の３機能です。

module DataStore.Internal where

import Control.Monad.Logger         (runStdoutLoggingT)
import Control.Monad.Trans.Reader   (runReaderT)
import Control.Monad.Trans.Resource (runResourceT)
import Data.Yaml.Config             (loadYamlSettings
                                   , useEnv
                                    )
import Database.Persist.Postgresql  (PostgresConf(..)
                                   , withPostgresqlConn
                                   , createPostgresqlPool
                                    )
import Database.Persist.Sql         (Migration
                                   , ConnectionPool
                                   , runMigration
                                    )

-- loadYamlSettingsを使うと環境変数で設定を書き換えるのが楽になる
pgConf :: IO PostgresConf
pgConf = loadYamlSettings ["conf/database-setting.yml"] [] useEnv

pgPool :: IO ConnectionPool
pgPool = do
    conf <- pgConf
    runStdoutLoggingT $ createPostgresqlPool (pgConnStr conf) (pgPoolSize conf)

doMigration :: Migration -> IO ()
doMigration action = do
    conf <- pgConf
    runStdoutLoggingT $ runResourceT $ withPostgresqlConn (pgConnStr conf) $ runReaderT $ runMigration action

ここはservantと関係ないコードです。

一工夫したのは Data.Yaml.Config.loadYamlSettings 関数を使って設定値の読み込みを楽しているところ。この関数を使うとYAMLファイルから設定値を読み込めるのですが、環境変数やデフォルト値を簡単に設定できます。
次はYAMLファイルの例です。

user    : "_env:PG_USER:app"
password: "_env:PG_PASS:xxx"
host    : "_env:PG_HOST:localhost"
port    : "_env:PG_PORT:5432"
database: "_env:PG_DATABASE:app"
poolsize: "_env:PG_POOLSIZE:5"

ロギングについては、上記コードでは標準出力に出力しているのですが、もっと工夫の余地があると思います。

DBアクセス本体

ここもservantと関係ないです。DBアクセスする関数の引数でコネクションプールを受け取るようにするのがポイントです。

{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE QuasiQuotes                #-}

module DataStore where

import Control.Lens                 ((^.))
import Data.Text                    (Text)
import Database.Persist
import Database.Persist.Sql         (ConnectionPool
                                   , runSqlPool
                                    )
import Database.Persist.TH          (mkMigrate
                                   , mkPersist
                                   , persistLowerCase
                                   , share
                                   , sqlSettings
                                   , mpsGenerateLenses
                                    )
import DataStore.Internal
import GHC.Generics

share [mkPersist sqlSettings { mpsGenerateLenses = True }, mkMigrate "migrateAll"] [persistLowerCase|
User json
    name Text
    age Int
    UniqueUserName name
    deriving Eq Show Generic
|]

getUsers :: ConnectionPool -> IO [Entity User]
getUsers pool = flip runSqlPool pool $ selectList [] []

getUser :: ConnectionPool -> Key User -> IO (Maybe (Entity User))
getUser pool = flip runSqlPool pool . getEntity

insertUser :: ConnectionPool -> User -> IO (Maybe (Entity User))
insertUser pool user = flip runSqlPool pool $ do
    mInDb <- getBy $ UniqueUserName $ user^.userName
    case mInDb of
      Just inDb -> pure Nothing
      Nothing   -> do
                     key <- insert user
                     pure $ Just $ Entity key user

migrateDb :: IO ()
migrateDb = doMigration migrateAll

State を使えばConnectionPoolを引数から消せそうですが、まあこれはこれでアリでしょう。

servantと統合

いよいよservantと統合します。ConnectionPoolを受け取ってServantを返す関数を定義するのがポイントです。


{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE TypeOperators              #-}
module App where

import Control.Monad.IO.Class   (liftIO)
import Database.Persist.Sql
import DataStore
import DataStore.Internal       (pgPool)
import Network.Wai.Handler.Warp (run, Port)
import Servant

type ApiDef  = Get '[JSON] [Entity User]
            :<|> "users" :> Get '[JSON] [Entity User]

server :: ConnectionPool -> Server ApiDef
server pool = (liftIO $ getUsers pool)
         :<|> (liftIO $ getUsers pool)

api :: Proxy ApiDef
api = Proxy

app :: ConnectionPool -> Application
app pool = serve api $ server pool

mkApp :: IO Application
mkApp = do
    migrateDb
    pool <- pgPool
    return $ app pool

startServer :: Port -> IO ()
startServer port = do
    putStrLn "{- ----------------------------"
    putStrLn " - start server!"
    putStrLn " ----------------------------- -}"
    run port =<< mkApp

まとめ

このコードに行き着くまでに色々調べて苦労はしたのですが、終わってみれば至極真っ当なコードになりました。

今回はコネクションプールを状態として扱う必要があり、これをどう実現するかがポイントでした。関数の引数として引き回すのは素直な実装だと思います。しかし、引き回したい状態が多くなってきた場合は、関数の引数にするのは難しくなってきます。
そうなるとState（Readerかな）をうまく使う必要が出てくると思います。
Yesodなんかは getYesod という関数で状態をまとめて取得できるようにしているようです。