Yesod   フォーム

ホーム   目次

Stack のインストール

macOS

$ curl -sSL https://get.haskellstack.org/ | sh
    

Windows

下記サイトよりインストーラーをダウンロード

Get Started with Haskell Windows

Linux

$ wget -qO- https://get.haskellstack.org/ | sh
    

詳しくは下記サイトを参照

Get started with Haskell

プロジェクトの作成

よりシンプルにするために、プロジェクトを手動で作ります。

$ mkdir yesod-web
$ cd yesod-web
$ mkdir src
    

サンプル 1

「yesod-web」プロジェクト内に、次の内容の「yesod-web.cabal」というファイルを 作ります。

name:                yesod-web
version:             0.1.0.0
category:            Web
build-type:          Simple
cabal-version:       >=1.10

executable yesod-web
  main-is:            Main.hs
  build-depends:      base >=4.10 && <4.11
                    , yesod
                    , text
                    , time
                    , yesod-form
  hs-source-dirs:     src
  default-language:   Haskell2010
    

「yesod-web」プロジェクト内の「src」ディレクトリ内に、 次の内容の「Main.hs」というファイルを作ります。

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
import           Control.Applicative ((<$>), (<*>))
import           Data.Text           (Text)
import           Data.Time           (Day)
import           Yesod
import           Yesod.Form.Jquery

data App = App

mkYesod "App" [parseRoutes|
/ HomeR GET
/person PersonR POST
|]

instance Yesod App

-- 標準の英語のメッセージを使用するようにアプリケーションに指示します。
-- 国際化が必要な場合は、代わりに翻訳機能を提供することができます。
instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

-- そしてjQueryライブラリの場所を教えてください。 デフォルトを使います。
-- これはGoogle CDNを指しています。
instance YesodJquery App

-- フォームから受け取りたいデータ型
data Person = Person
    { personName          :: Text
    , personBirthday      :: Day
    , personFavoriteColor :: Maybe Text
    , personEmail         :: Text
    , personWebsite       :: Maybe Text
    }
  deriving Show

personForm :: Html -> MForm Handler (FormResult Person, Widget)
personForm = renderDivs $ Person
    <$> areq textField "Name" Nothing
    <*> areq (jqueryDayField def
        { jdsChangeYear = True -- give a year dropdown
        , jdsYearRange = "1900:-5" -- 1900 till five years ago
        }) "Birthday" Nothing
    <*> aopt textField "Favorite color" Nothing
    <*> areq emailField "Email address" Nothing
    <*> aopt urlField "Website" Nothing

-- GETハンドラはフォームを表示します
getHomeR :: Handler Html
getHomeR = do
    -- 表示するフォームを生成する
    (widget, enctype) <- generateFormPost personForm
    defaultLayout
        [whamlet|
            <p>
                生成されたウィジェットはフォームの内容のみを含みます。
                フォームタグ自体ではありません。
            <form method=post action=@{PersonR} enctype=#{enctype}>
                ^{widget}
                <p>送信ボタンも含まれていません。
                <button>Submit
        |]

-- POSTハンドラがフォームを処理します。
-- 成功した場合は、解析されたPersonが表示されます。
-- それ以外の場合は、エラーメッセージとともにフォームを再度表示します。
postPersonR :: Handler Html
postPersonR = do
    ((result, widget), enctype) <- runFormPost personForm
    case result of
        FormSuccess person -> defaultLayout [whamlet|
#{show person}|]
        _ -> defaultLayout
            [whamlet|
                <p>Invalid input, let's try again.
                <form method=post action=@{PersonR} enctype=#{enctype}>
                    ^{widget}
                    <button>Submit
            |]

main :: IO ()
main = warp 3000 App
    

ビルドと実行

ビルド

$ stack init
$ stack build
    

初回のビルドは「Yesod」の開発環境と実行環境をインストールするため、 非常に時間がかかります。2回目からのビルドはすぐに終わります。 「stack init」は、初回の1回だけで構いません。

なお、「Yesod」のオフィシャルページでは、「Yesod コマンド」 をインストールしなければならないことになっていますが、 インストールしなくても問題なくビルドできます。 もしビルドできない場合は次のようにして、 「yesod コマンド」をインストールしてください。

$ stack install yesod-bin
    

インストールには、すごく時間がかかります。

実行

$ stack exec yesod-web
    

ブラウザを起動して「https://localhost:3000/」 へアクセスすると次のように表示されます。

日本語も入力できますが、送信後は正しく表示されません。

終了させるには、 ターミナルで、Controlキーを押しながらc を押します。

^C
    

サンプル 2

Main.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
import           Control.Applicative
import           Data.Text           (Text)
import           Yesod

data App = App

mkYesod "App" [parseRoutes|
/ HomeR GET
|]

instance Yesod App

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

data Person = Person
    { personName :: Text
    , personAge  :: Int
    }
    deriving Show

personForm :: Html -> MForm Handler (FormResult Person, Widget)
personForm extra = do
    (nameRes, nameView) <- mreq textField "this is not used" Nothing
    (ageRes, ageView) <- mreq intField "neither is this" Nothing
    let personRes = Person <$> nameRes <*> ageRes
    let widget = do
            toWidget
                [lucius|
                    ##{fvId ageView} {
                        width: 3em;
                    }
                |]
            [whamlet|
                #{extra}
                <p>
                    Hello, my name is #
                    ^{fvInput nameView}
                    \ and I am #
                    ^{fvInput ageView}
                    \ years old. #
                    <input type=submit value="Introduce myself">
            |]
    return (personRes, widget)

getHomeR :: Handler Html
getHomeR = do
    ((res, widget), enctype) <- runFormGet personForm
    defaultLayout
        [whamlet|
            <p>Result: #{show res}
            <form enctype=#{enctype}>
                ^{widget}
        |]

main :: IO ()
main = warp 3000 App
    

「yesod-web.cabal」は「サンプル 1」と同じものを使います。

サンプル 3

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
import           Control.Applicative
import           Data.Text           (Text)
import           Yesod

data App = App

mkYesod "App" [parseRoutes|
/ HomeR GET
/input InputR GET
|]

instance Yesod App

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

data Person = Person
    { personName :: Text
    , personAge  :: Int
    }
    deriving Show

getHomeR :: Handler Html
getHomeR = defaultLayout
    [whamlet|
        <form action=@{InputR}>
            <p>
                My name is
                <input type=text name=name>
                and I am
                <input type=text name=age>
                years old.
                <input type=submit value="Introduce myself">
    |]

getInputR :: Handler Html
getInputR = do
    person <- runInputGet $ Person
                <$> ireq textField "name"
                <*> ireq intField "age"
    defaultLayout [whamlet|
#{show person}|]

main :: IO ()
main = warp 3000 App
    

サンプル 4

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
import           Control.Applicative
import           Data.Text           (Text)
import           Data.Time
import           Yesod

newtype UserId = UserId Int
    deriving Show

data App = App

mkYesod "App" [parseRoutes|
/ HomeR GET POST
|]

instance Yesod App

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

type Form a = Html -> MForm Handler (FormResult a, Widget)

data Blog = Blog
    { blogTitle    :: Text
    , blogContents :: Textarea
    , blogUser     :: UserId
    , blogPosted   :: UTCTime
    }
    deriving Show

form :: UserId -> Form Blog
form userId = renderDivs $ Blog
    <$> areq textField "Title" Nothing
    <*> areq textareaField "Contents" Nothing
    <*> pure userId
    <*> lift (liftIO getCurrentTime)

getHomeR :: Handler Html
getHomeR = do
    let userId = UserId 5 -- again, see the authentication chapter
    ((res, widget), enctype) <- runFormPost $ form userId
    defaultLayout
        [whamlet|
            <p>:Previous result: #{show res}
            <form method=post action=@{HomeR} enctype=#{enctype}>
                ^{widget}
                <input type=submit>
        |]

postHomeR :: Handler Html
postHomeR = getHomeR

main :: IO ()
main = warp 3000 App
    

ホーム   目次   ページトップ