Database in Haskell with Servant

peristent を使って Servant server を実装する方法を紹介します。
本記事のソースコードは以下のリポジトリにおいてあります。
http://github.com/algas/haskell-servant-cookbook

Model

Template Haskell を使って User 型を定義します。
要素はこれまでのサンプルで使っていたものと同じです。
Persistent のモデルであると同時に JSON instance としても定義されています。

persistent/Main.hs

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
User json
    name     Text
    age      Int
    deriving Eq Show Generic
|]

API

/users に GET で全ユーザ一覧を取得し、
/users/(name)/(age) に POST でユーザを作成します。

persistent/Main.hs

type HelloAPI  = "users" :> Get '[JSON] [User]
            :<|> "users" :> Capture "name" Text :> Capture "age" Int :> Post '[JSON] ()

Database

この例では persistent-mysql を使います。

persistent/Main.hs

runDB :: ConnectInfo -> SqlPersistT (ResourceT (NoLoggingT IO)) a -> IO a
runDB info = runNoLoggingT . runResourceT . withMySQLConn info . runSqlConn

doMigration :: IO ()
doMigration = runNoLoggingT $ runResourceT $ withMySQLConn connInfo $ runReaderT $ runMigration migrateAll

selectUsers :: IO [User]
selectUsers = do
    userList <- runDB connInfo $ selectList [] []
    return $ map (\(Entity _ u) -> u) userList

insertUser :: User -> IO ()
insertUser = runDB connInfo . insert_

runDB はクエリを投げるアクションを生成する関数です。
selectUsers でユーザ一覧をデータベースから取得します。
insertUser で新規ユーザをデータベースに作成します。
doMigration は初期テーブルを作成するアクションです。

Server

サーバ機能を実装します。

persistent/Main.hs

server :: Server HelloAPI
server = getUsers :<|> postUser
    where
        getUsers = lift selectUsers
        postUser n a = lift $ insertUser (User n a)

selectUsers :: IO [User] から getUsers :: ExceptT ServantErr IO [User] に変換するために lift を使っています。

Main

第一引数に 'migrate' をつけたら migration を実行するようにします。

persistent/Main.hs

main :: IO ()
main = do
    args <- getArgs
    let arg1 = if (length args > 0) then Just (args !! 0) else Nothing
    case arg1 of
        Just "migrate" -> doMigration
        _ -> run 8080 app

Dependencies

特に persistent 関連で多くのライブラリに依存しています。
import と language extensions を書き出しておきます。

persistent/Main.hs

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
module Main where

import           Control.Monad.Logger         (NoLoggingT (..))
import           Control.Monad.Trans.Class    (lift)
import           Control.Monad.Trans.Reader   (runReaderT)
import           Control.Monad.Trans.Resource (ResourceT, runResourceT)
import           Data.Aeson
import           Data.Text                    (Text)
import qualified Data.Text                    as T
import qualified Data.Text.IO                 as T
import           Database.Persist
import           Database.Persist.MySQL       (ConnectInfo (..),
                                               SqlBackend (..),
                                               defaultConnectInfo, runMigration,
                                               runSqlPool, withMySQLConn)
import           Database.Persist.Sql         (SqlPersistT, runSqlConn)
import           Database.Persist.TH          (mkMigrate, mkPersist,
                                               persistLowerCase, share,
                                               sqlSettings)
import           GHC.Generics
import           Network.Wai
import           Network.Wai.Handler.Warp
import           Servant
import           Servant.API
import           System.Environment           (getArgs)

haskell-servant-cookbook.cabal

executable persistent
  hs-source-dirs:      persistent
  main-is:             Main.hs
  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
  build-depends:       base
                     , text
                     , either
                     , aeson
                     , wai
                     , warp
                     , mtl
                     , monad-logger
                     , resourcet
                     , transformers
                     , persistent
                     , persistent-mysql
                     , persistent-template
                     , servant
                     , servant-server
                     , haskell-servant-cookbook
  default-language:    Haskell2010

使い方

早速サンプルを動かしてみましょう。
mysql server が localhost:3306 で動作しているものとします。

セットアップ

build

stack build

create database

mysql -u test -e 'create database' -psecret servant_persistent

migrate

stack exec persistent migrate

test migration

mysql -u test -e 'show tables' -psecret servant_persistent

user table が作成されていればOK
5. serve

stack exec persistent

動作確認

以下のコマンドで動作を確認します。

$ curl -X POST http://localhost:8080/users/foo/12
[]
$ curl http://localhost:8080/users
[{"age":12,"name":"foo"}]

ユーザを作成して一覧取得できたことが確認できました。

参考文献