型安全な Persistent を使う

(2017.1 新規作成。)

Webアプリケーションフレームワーク Yesod 用のO/Rマッパ, Persistent を単体で使う。

テーブルごとに別のデータ型になる。ActiveRecord のようなイメージ。

それぞれのテーブルのidフィールドは, SQLまで落ちると単なる整数などになる。そこを, Haskell の世界では別々の型にマッピングすることで, コンパイル時に, 異なるテーブルのidを混ぜたり比較したりできないようにする。

インストール

cabal でインストール.

依存関係がとても多い。

Database.Persist.TH モジュールは別パッケージになっている。persistent-template パッケージ.

バックエンドも別パッケージ。sqlite なら persistent-sqlite パッケージ。 

# cabal install --dry-run --global persistent
Resolving dependencies...
In order, the following would be installed (use -v for more details):
auto-update-0.1.4
base-compat-0.9.1
blaze-builder-0.4.0.2
blaze-markup-0.7.1.1
blaze-html-0.8.1.3
bytestring-builder-0.10.8.1.0
dlist-0.8.0.2
easy-file-0.2.1
fail-4.9.0.0
mmorph-1.0.9
monad-loops-0.4.3
path-pieces-0.2.1
semigroups-0.18.2
silently-1.2.5
stm-chans-3.0.0.4
streaming-commons-0.1.16
time-locale-compat-0.1.1.3
transformers-base-0.4.4
monad-control-1.0.1.0
lifted-base-0.2.3.8
resource-pool-0.2.3.2
resourcet-1.1.9
conduit-1.2.8
conduit-extra-1.1.15
unix-time-0.3.7
fast-logger-2.4.7
monad-logger-0.3.20.1
uri-bytestring-0.2.2.1
uuid-types-1.0.3
aeson-1.1.0.0
http-api-data-0.3.3
persistent-2.6

# cabal install --dry-run --global persistent-template
Resolving dependencies...
In order, the following would be installed (use -v for more details):
nats-1.1.1
aeson-compat-0.3.6
persistent-template-2.5.1.6

最初のプログラム

テーブルを作って, 挿入したり問い合わせたりするサンプル。

テーブル定義

テーブル定義ファイルを読み込み, 各テーブルと同名のデータ型を作ります。

Model.hs ファイル

Haskell
[RAW]
  1. {-# LANGUAGE TypeFamilies #-} -- Illegal family instance
  2. {-# LANGUAGE TemplateHaskell #-} -- Parse error: naked expression at top level
  3. {-# LANGUAGE GADTs #-} -- Data constructor ‘UserId’ has existential
  4. {-# LANGUAGE MultiParamTypeClasses #-} -- Illegal instance declaration
  5. {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- Can't make a derived instance of ...
  6. {-# LANGUAGE EmptyDataDecls #-}
  8. module Model where
  10. import Database.Persist.TH -- share, mkPersist, persistFileWith
  11. import Database.Persist.Quasi -- lowerCaseSettings
  12. import Data.Text -- UTF-16. String よりこちらを使う.
  14. -- ファイルから読み込み、スキーマを定義する
  15. -- ここでも TemplateHaskell の機能で, migrateMyAll という識別子が作られる.
  16. share [mkPersist sqlSettings, mkMigrate "migrateMyAll"]
  17. $(persistFileWith lowerCaseSettings "config/models")

config/models ファイル

Haskell
[RAW]
  1. User -- テーブル名、かつデータ型の名前
  2. email Text -- フィールド名とその型
  3. name Text
  4. age Int Maybe -- ナル値を許可
  6. UniqueUser email -- 制約を付ける
  7. -- deriving できる型クラスは, Show, Read, Eq, Typeable, Ord か？
  8. deriving Show
  10. -- このファイルに, 複数のテーブルを書ける
  11. BlogPost
  12. -- id Int
  13. title Text
  14. authorId UserId -- 参照制約. テーブル名Tblから TblIdを自動生成
  16. -- UniqueBlogPost id
  17. deriving Show

TemplateHaskell の機能で, User, BlogPost というデータ型が宣言される

idというフィールドが自動作成される？

フィールドに使える型は, 型クラス PersistField のインスタンス (拡張可).

SQL Persistent
データ型 (VARCHAR, INTEGER, etc.) PersistValue
列 PersistField
表 PersistEntity

データ操作

これを利用して, データを投入したりする。

Application.hs ファイル

Haskell
[RAW]
  1. {-# LANGUAGE OverloadedStrings #-} -- Couldn't match expected type 'Data.Text.Internal.Text
  3. module Application where
  5. import Database.Persist -- insert, selectList, LimitTo, entityVal, get, delete, deleteWhere
  6. import Database.Persist.Sql (runMigration, runSqlConn)
  7. import Database.Persist.Sqlite (withSqliteConn)
  8. import Control.Monad.Trans.Resource (runResourceT)
  9. import Control.Monad.Logger (runNoLoggingT)
  10. import Control.Monad.IO.Class (liftIO) -- liftIO :: IO a -> m a
  11. import System.IO -- hPutStrLn
  13. -- Model.hs
  14. import Model
  16. -- この例では、ファイルではなくメモリ内にデータベースを作成する
  17. database = ":memory:"
  20. appMain :: IO ()
  21. -- runSqlConn から例外で抜けると roll back される
  22. appMain = runNoLoggingT $ runResourceT $ withSqliteConn database $ runSqlConn $ do
  24. -- テーブルの作成など、データベースを初期化する
  25. runMigration migrateMyAll
  27. -- データを登録する
  28. -- { } 内で列名を指定する. テーブル名が頭に付く
  29. johnId <- insert $ User { userName = "John Doe", userAge = Just 35,
  30. userEmail = "x" }
  32. -- 挿入に失敗する。ErrorConstraint (data Error の値) が発生.
  33. -- janeId <- insert $ User { userName = "Jane Doe", userAge = Nothing,
  34. -- userEmail = "x" }
  36. insert $ BlogPost { blogPostTitle = "My first post", blogPostAuthorId = johnId }
  37. insert $ BlogPost { blogPostTitle = "2つ目の投稿", blogPostAuthorId = johnId }
  38. insert $ BlogPost { blogPostTitle = "One more for good measure",
  39. blogPostAuthorId = johnId }
  41. -- データを検索する (問い合わせ)
  42. oneJohnPost <- selectList [BlogPostAuthorId ==. johnId] [LimitTo 2]
  43. liftIO $ print $ map (blogPostTitle . entityVal) oneJohnPost
  45. -- IDからレコードを取得
  46. -- DBにレコードがなければ見つからないので, Maybeで返ってくる.
  47. maybeJohn <- get johnId
  48. case maybeJohn of
  49. Nothing -> liftIO $ putStrLn "Just kidding, not really there"
  50. Just john -> liftIO $ print $ userName $ john
  52. -- データを削除する
  53. -- delete janeId
  54. deleteWhere [BlogPostAuthorId ==. johnId]
  56. return ()

Database.Persist.insert の型は, 次のようになっている. idを返す。 

Database.Persist.insert
  :: (Database.Persist.Class.PersistEntity.PersistEntity val,
      Control.Monad.IO.Class.MonadIO m,
      Database.Persist.Class.PersistStore.PersistStore
        (Database.Persist.Class.PersistEntity.PersistEntityBackend val)) =>
     val
     -> Control.Monad.Trans.Reader.ReaderT
          (Database.Persist.Class.PersistEntity.PersistEntityBackend val)
          m
          (Database.Persist.Class.PersistEntity.Key val)

getはこう; maybeJohn は 型 Maybe User になる。 

Database.Persist.get
  :: (Database.Persist.Class.PersistEntity.PersistEntity val,
      Control.Monad.IO.Class.MonadIO m,
      Database.Persist.Class.PersistStore.PersistStore
        (Database.Persist.Class.PersistEntity.PersistEntityBackend val)) =>
     Database.Persist.Class.PersistEntity.Key val
     -> Control.Monad.Trans.Reader.ReaderT
          (Database.Persist.Class.PersistEntity.PersistEntityBackend val)
          m
          (Maybe val)

上のサンプルではコメントアウトしているが、挿入に失敗すると, 例外が発生する。TODO: 例外への対処方法.

最後, main 関数.

app/main.hs ファイル

Haskell
[RAW]
  1. import Application (appMain)
  3. main :: IO ()
  4. main = appMain