Database in Haskell with Servant
peristent を使って Servant server を実装する方法を紹介します。
本記事のソースコードは以下のリポジトリにおいてあります。
http://github.com/algas/haskell-servant-cookbook
Model
Template Haskell を使って User 型を定義します。
要素はこれまでのサンプルで使っていたものと同じです。
Persistent のモデルであると同時に JSON instance としても定義されています。
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
User json
name Text
age Int
deriving Eq Show Generic
|]
API
/users に GET で全ユーザ一覧を取得し、
/users/(name)/(age) に POST でユーザを作成します。
type HelloAPI = "users" :> Get '[JSON] [User]
:<|> "users" :> Capture "name" Text :> Capture "age" Int :> Post '[JSON] ()
Database
この例では persistent-mysql を使います。
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
サーバ機能を実装します。
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 を実行するようにします。
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 を書き出しておきます。
{-# 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)
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"}]
ユーザを作成して一覧取得できたことが確認できました。
参考文献
