saito's memo

--  -*- coding: utf-8 -*-
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}

import Database.Persist
import Database.Persist.Sql (runMigration, runSqlConn)
import Database.Persist.Sqlite (withSqliteConn)
import Database.Persist.TH (share, mkPersist, sqlSettings, mkMigrate, persistUpperCase)
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Logger (runNoLoggingT)
import Control.Monad.IO.Class (liftIO)

-- データベースのスキーマを定義する
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
Person
  name     String
  age      Int Maybe
BlogPost
  title    String
  authorId PersonId
|]

-- この例では、とりあえずファイルではなくメモリ内にデータベースを作成する
database = ":memory:"

main :: IO ()
main = runNoLoggingT $ runResourceT $ withSqliteConn database $ runSqlConn $ do

         -- テーブルの作成など、データベースを初期化する
         runMigration migrateAll

         -- データを登録する
         johnId <- insert $ Person "John Doe" $ Just 35
         janeId <- insert $ Person "Jane Doe" $ Nothing

         insert $ BlogPost "My fr1st p0st" johnId
         insert $ BlogPost "One more for good measure" johnId

         -- データを検索する
         oneJohnPost <- selectList [BlogPostAuthorId ==. johnId] [LimitTo 2]
         liftIO $ print $ map (blogPostTitle . entityVal) oneJohnPost

         john <- get johnId
         liftIO $ print $ fmap personName john

         -- データを削除する
         delete janeId
         deleteWhere [BlogPostAuthorId ==. johnId]

         return ()

--  -*- coding: utf-8 -*-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}

import Yesod
import Database.Persist.Sqlite
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Logger (runStderrLoggingT)
import System.Directory (removeFile, doesFileExist)
import Control.Monad (when)

-- データベースのスキーマを定義する
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Person
    firstName String
    lastName  String
    age Int
    deriving (Show)
|]

-- Yesodアプリケーションのデータ型
data PersistTest = PersistTest ConnectionPool

-- URLのルーティングを定義
mkYesod "PersistTest" [parseRoutes|
/                 HomeR   GET
/person/#PersonId PersonR GET
|]

-- ユーザ定義のYesodアプリケーションのデータ型をYesod型クラスのインスタンスにする
instance Yesod PersistTest

-- ユーザ定義のYesodアプリケーションのデータ型をYesodPersist型クラスのインスタンスにし、runDB関数を定義する
instance YesodPersist PersistTest where
    type YesodPersistBackend PersistTest = SqlPersistT

    runDB action = do
        PersistTest pool <- getYesod
        runSqlPool action pool

-- ルートURLでは、Personの一覧を表示する
getHomeR :: Handler Html
getHomeR = do
    people <- runDB $ selectList [] [Asc PersonAge]
    defaultLayout [whamlet|
<ul>
  $forall Entity personid person <- people
    <li>
      <a href=@{PersonR personid}>#{personFirstName person}
|]

-- /person/PersonID にアクセスすると、そのPersonIDに対応するデータが表示される
-- もし、PersonIDが存在しない場合、404 Not Foundを返す
getPersonR :: PersonId -> Handler String
getPersonR personId = do
    person <- runDB $ get404 personId
    return $ show person

-- データベースのコネクションプールの数
openConnectionCount :: Int
openConnectionCount = 10

removeFileIfExists :: FilePath -> IO ()
removeFileIfExists path = do
  exists <- doesFileExist path
  when exists $ removeFile path

main :: IO ()
main = do
  -- データベースが既に存在する場合は、削除する
  removeFileIfExists "test.sqlite3"

  withSqlitePool "test.sqlite3" openConnectionCount $ \pool -> do

    -- Webサーバを起動する前に、データベースを初期化し、初期データを追加する
    runResourceT $ runStderrLoggingT $ flip runSqlPool pool $ do
        runMigration migrateAll
        insert $ Person "Akio" "Saito" 29

    -- Webサーバを起動する
    let app = PersistTest pool
    warp 3000 app