Haskell Servant 入門 (Database)

# Database in Haskell with Servant

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

## Model

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

```hs: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` でユーザを作成します。 

```hs:persistent/Main.hs
type HelloAPI  = "users" :> Get '[JSON] [User]
            :<|> "users" :> Capture "name" Text :> Capture "age" Int :> Post '[JSON] ()
```

## Database

この例では [persistent-mysql](https://hackage.haskell.org/package/persistent-mysql) を使います。

```hs: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

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

```hs: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 を実行するようにします。

```hs: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 を書き出しておきます。

```hs: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)
```

```hs: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` で動作しているものとします。

### セットアップ

1. build  
```
stack build
```
2. create database  
```
mysql -u test -e 'create database' -psecret servant_persistent
```
3. migrate  
```
stack exec persistent migrate
```
4. 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"}]
```

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

## 参考文献

http://www.parsonsmatt.org/2015/06/07/servant-persistent.html