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 という関数で状態をまとめて取得できるようにしているようです。