読者です 読者をやめる 読者になる 読者になる

bitterharvest’s diary

A Bitter Harvestは小説の題名。作者は豪州のPeter Yeldham。苦闘の末に勝ちえた偏見からの解放は命との引換になったという悲しい物語

Haskellでウェブ・アプリケーション(4)

1.ブログを作成する

次の課題は「簡単なブログ」である。これは次の図に示すように三種類の機能を有している。一つはこれまでの記事の一覧表示であり、二つ目は新しい記事の入力であり、三番目は選択された記事の内容の表示である。
f:id:bitterharvest:20140809093929j:plain
この課題は二つの相互に関連するサービスを有する。一つはブログそのものに対するものであり、他の一つは記事に関するものである。そこで、これらに対して、BlogとArticleという名称を与え、それぞれ、コントロール部分を次のように作成する。

yesod add-handler
Name of route (without trailing R): Blog
Enter route pattern (ex: /entry/#EntryId): /blog
Enter space-separated list of methods (ex: GET POST): GET POST

上記で、GETは記事の一覧を表示し、POSTは新しい記事の作成である。

yesod add-handler
Name of route (without trailing R): Article
Enter route pattern (ex: /entry/#EntryId): /blog/#ArticleId
Enter space-separated list of methods (ex: GET POST): GET

上記で、GETはArticleIdで指定された記事の内容を表示する。

次にモデルの追加を行う。記事をデータベースに記憶しておくことが必要なので、次のようにする。

Article
    title   Text
    content Html
    deriving

なお、HtmlはRead,Show,Eqのインスタンスではないので、データベースへの読み書きができるようにするためにderivingを加える。これをしないとエラーとなる。

また、Blog.hsの先頭部分は次のようにする。

module Handler.Blog
    ( getBlogR
    , postBlogR
    )
where

import Import

-- to use Html into forms
import Yesod.Form.Nic (YesodNic, nicHtmlField)
instance YesodNic App

まず、記事の一覧を表示する機能と新しい記事を作成するための機能を外部から用いることができるようにするため、getBlogRとpostBlogRをmoduleの定義のカッコの中に書込む。また、Htmlでフォームを利用できるようにするため、YosodNicのインスタンスも加える。(本来は、Foundation.hsにおくべきものである)。

次に、新しい記事を追加するためのフォームを以下のように定義する。

entryForm :: Form Article
entryForm = renderDivs $ Article
    <$> areq   textField "Title" Nothing
    <*> areq   nicHtmlField "Content" Nothing

ここで利用しているareqは、三種類の引数type, label, default_valueを必要とする。

一覧を表示する機能は次のようにする。

-- The view showing the list of articles
getBlogR :: Handler Html
getBlogR = do
    -- Get the list of articles inside the database.
    articles <- runDB $ selectList [] [Desc ArticleTitle]
    -- We'll need the two "objects": articleWidget and enctype
    -- to construct the form (see templates/articles.hamlet).
    (articleWidget, enctype) <- generateFormPost entryForm
    defaultLayout $ do
        $(widgetFile "articles")

これはデータベースから記事の一覧を得て、フォームを作成する。

これに対応したtemplateは次の通りとなる。(フィル名はarticles.hamlet)

<h1> Articles
$if null articles
    <p> There are no articles in the blog
$else
    <ul>
        $forall Entity articleId article <- articles
            <li>
                <a href=@{ArticleR articleId} > #{articleTitle article}
<hr>
  <form method=post enctype=#{enctype}>
    ^{articleWidget}
    <div>
        <input type=submit value="Post New Article">

注目すべき点は、記事を書き込むためのフォームarticleWidgetがYesodによって作成されることである。また、記事を投稿するためのボタンを最後の行で用意している。

Blog.hsに戻る。新しい記事を作成するための機能は次のようになる。

postBlogR :: Handler Html
postBlogR = do
    ((res,articleWidget),enctype) <- runFormPost entryForm
    case res of
         FormSuccess article -> do
            articleId <- runDB $ insert article
            setMessage $ toHtml $ (articleTitle article) <> " created"
            redirect $ ArticleR articleId
         _ -> defaultLayout $ do
                setTitle "Please correct your entry form"
                $(widgetFile "articleAddError")

これは新しい記事を作るためのもので、フォームを受け取ってその処理を行う。もしエラーがなければ、次のことを行う。
1) 新しい記事をデータベースに書込む。(runDB $ insert article)
2) 新しい記事を表示の一覧に加える。(setMessage $ …)
3) 記事のホームページに移動する。

エラーに関するtemplateは次のようになる。(フィル名はarticleAddError.hamlet)

<form method=post enctype=#{enctype}>
    ^{articleWidget}
    <div>
        <input type=submit value="Post New Article">

Articl.hsの未定義部分は以下のように定義する。

getArticleR :: ArticleId -> Handler Html
getArticleR articleId = do
    article <- runDB $ get404 articleId
    defaultLayout $ do
        setTitle $ toHtml $ articleTitle article
        $(widgetFile "article")

また、templateは次のようになる。(フィル名はarticle.hamlet)

<h1> #{articleTitle article}
<article> #{articleContent article}
<hr>
<a href=@{BlogR}>
    Go to article list.

後はコンパイルして、展開すれば利用できる。
なお、Blog.hsはつぎはぎで説明したが、全体は次のようになっている。

module Handler.Blog
    ( getBlogR
    , postBlogR
    )
where

import Import
import Yesod.Form.Nic (YesodNic,nicHtmlField)
instance YesodNic App

entryForm :: Form Article
entryForm = renderDivs $ Article
    <$> areq    textField "Title" Nothing
    <*> areq    nicHtmlField "Content" Nothing

getBlogR :: Handler Html
getBlogR = do
    -- Get the list of articles inside the database
    articles <- runDB $ selectList [] [Desc ArticleTitle]
    -- We'll need the two "objects": articleWidget and enctype
    -- to construct the form (see temlates/articles.hamlet)
    (articleWidget, enctype) <- generateFormPost entryForm
    defaultLayout $ do
        $(widgetFile "articles")

postBlogR :: Handler Html
postBlogR = do
    ((res,articleWidget),enctype) <- runFormPost entryForm
    case res of
        FormSuccess article -> do
            articleId <- runDB $ insert article
            setMessage $ toHtml $ (articleTitle article) <> " created"
            redirect $ ArticleR articleId
        _ -> defaultLayout $ do
            setTitle "Please correct your entry form"
            $(widgetFile "articleAddError")