Haskell で relational-record を使って MySQL に繋いでみた

haskell programming

Haskell で SQL を函数型的に構築する方法としては、relational-record（以下、HRR と称す）と opaleye があるようだ。 今回は relational-record を選択してみた。

以下の記事が参考になるが、本稿執筆時点（2017年12月28日）では、少々変更があったり、嵌ったことがあったので、差分を記述する。 qiita.com

インストール

Stack を前提とする。以上のコマンドで、hrr-test なる名のパッケージが作られる。

$ stack new hrr-test

新し目の Stack ではデフォルトで hpack を利用したテンプレートが使われる。HRR は Stackage に登録されているために、package.yaml の dependencies 節に HRR 関連のパッケージを追加するだけでよい。

dependencies:
- base >= 4.7 && < 5
# ここより下を追加
# HRR
- relational-record
- relational-query
- relational-query-HDBC
- persistable-record
# データベース
- HDBC
- HDBC-mysql
# その他必要なパッケージ
- template-haskell
- time
- bytestring

DataSource.hs

DataSource.hs は以下のようになるだろう。

{-# LANGUAGE TemplateHaskell, TypeSynonymInstances #-}
module DataSource

import Data.ByteString (ByteString)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
import Data.Time.LocalTime (TimeZone, utcToLocalTime, hoursToTimeZone)
import Database.HDBC.Query.TH (defineTableFromDB)
import Database.HDBC.MySQL (MySQLConnectInfo, Connection, connectMySQL, defaultMySQLConnectInfo, mysqlUser, mysqlPassword, mysqlDatabase, mysqlHost, mysqlPort)
import Database.HDBC.Schema.MySQL (driverMySQL)
import Database.HDBC.Schema.Driver (driverConfig, typeMap)
import Database.Relational.Config (normalizedTableName, defaultConfig)
import Database.Relational.ProjectableClass (ShowConstantTermsSQL(..), showConstantTermsSQL)
import Language.Haskell.TH (Q, Dec, TypeQ)

connect :: IO Connection
connect = connectMySQL defaultMySQLConnectInfo
    { mysqlHost = "<mysql-host>"
    , mysqlDatabase = "INFORMATION_SCHEMA"
    }

-- haskell-relational-record-0.1.4.0 には MEDIUMINT の定義はあるが、SET や ENUM はない。
typeMap :: [(String, TypeQ)]
typeMap =
    [ ("SET", [t| ByteString |])
    , ("ENUM", [t| ByteString |])
    ]

defineTable :: String -> String -> Q [Dec]
defineTable schemaName tableName =
  defineTableFromDB
    connect
    (driverMySQL { driverConfig = defaultConfig { normalizedTableName = False }
                 , typeMap = typeMap
                 })
    schemaName
    tableName
    [''Show,]

-- データベースとの接続に使うタイムゾーンを指定する必要がある。
dbTimeZone :: TimeZone
dbTimeZone = hoursToTimeZone 9

-- relational-query-0.9.4.1 では、ShowConstantTermsSQL POSIXTime のインスタンスが定義されていないため、自分で定義する必要がありそう。
instance ShowConstantTermsSQL POSIXTime where
    showConstantTermsSQL' = showConstantTermsSQL' . utcToLocalTime dbTimeZone . posixSecondsToUTCTime

Main.hs は以下のようになる。

{-# LANGUAGE FlexibleContexts #-}

module Main where

import GHC.Int (Int32)
import Database.HDBC (disconnect)
import Database.HDBC.Record (runQuery')
-- Database.Relational.Query は廃用になった
import Database.Relational

import DataSource

hello :: Relation () (Int32, String)
hello = relation $ pure (value 0 >< value "Hello")

main :: IO ()
main = do
  conn <- connect
  putStrLn $ "SQL: " ++ show hello
  result <- runQuery' conn (relationalQuery hello) ()
  mapM_ print result
  disconnect conn

ここで、遅延評価版の runQuery ではなく runQuery' を使わないと、複数のクエリを発行した際に死ぬことがあるので注意すること。

その他嵌った点

COUNT の引数として列を一つ渡すことに気を付けなければならないようだ。

-- これは駄目
numberOfFruitsWrong :: (MonadQualify ConfigureQuery m) => m (Record Flat (Maybe Int64))
numberOfFruitsWrong = queryScalar $ aggregatedUnique (relation $ query fruit) id' count

-- こうする
numberOfFruits :: (MonadQualify ConfigureQuery m) => m (Record Flat (Maybe Int64))
numberOfFruits = queryScalar $ aggregatedUnique (relation $ query fruit >>= \j -> return (j ! Fruit.id')) id' count