YesodのHandler関数からJSONを返す方法

Yesod Advent Calendar 2016を通してたくさんの知見が得られたことを嬉しく思います。

Yesodは素晴らしいフレームワークです。Haskellらしい厳密さに対するこだわりに満ちていて、Webアプリ内でのリンク切れは起きません。DBアクセスにも型安全にこだわり抜かれていて、常に、「何かに守られている」感覚でプログラムすることが出来ます。

しかし・・・型安全を捨てねばならない時もあります。昨今のクライアント側はReactで構築することが多く、この場合、WebサーバはAPIのみを提供すれば充分。型安全なHTMLの出番はなくなります。

この場合、Yesodの旨味はかなり無くなりますが、それでもそれなりに意味はあって、私がリリースしたWebアプリの場合、データ量が多いページを非力なスマホで表示する際に、Reactでは遅すぎて辛かった時に、hamletでHTMLを組み立てる方針に転換したことがあります。

たとえAPIのみの提供であってもリソースに型が割り当てられるというところに非常に嬉しさがあって、工夫次第でAPIの各URLを安全にクライアントに伝えることができるのです。

さて、本エントリでは、APIのコンテンツとしてよく使われるJSONをHandler関数で返す方法を説明します。

Handler関数の型宣言

stackが作るテンプレートプロジェクトで、実はJSONを返す実装が書かれています。
Comment型は、config/models の中で json というアノテーションが書かれているのが前提です。

Comment json -- Adding "json" causes ToJSON and FromJSON instances to be derived.
    message Text
    userId UserId Maybe
    deriving Eq
    deriving Show

Comment.hs

module Handler.Comment where

import Import

postCommentR :: Handler Value
postCommentR = do
    -- requireJsonBody will parse the request body into the appropriate type, or return a 400 status code if the request JSON is invalid.
    -- (The ToJSON and FromJSON instances are derived in the config/models file).
    comment <- (requireJsonBody :: Handler Comment)

    -- The YesodAuth instance in Foundation.hs defines the UserId to be the type used for authentication.
    maybeCurrentUserId <- maybeAuthId
    let comment' = comment { commentUserId = maybeCurrentUserId }

    insertedComment <- runDB $ insertEntity comment'
    returnJson insertedComment

ただ、この型宣言は汎用的すぎて好ましくありません。
出来れば

Comment.hs

postCommentR :: Handler (Entity Comment)

と書きたい。そのためには、Entity Comment を ToContent と ToTypedContent のインスタンスにします。
下記に、書き換えた例を載せます。

Comment.hs

module Handler.Comment where

import Import

import Data.Aeson (encode)

postCommentR :: Handler (Entity Comment)
postCommentR = do
    -- requireJsonBody will parse the request body into the appropriate type, or return a 400 status code if the request JSON is invalid.
    -- (The ToJSON and FromJSON instances are derived in the config/models file).
    comment <- (requireJsonBody :: Handler Comment)

    -- The YesodAuth instance in Foundation.hs defines the UserId to be the type used for authentication.
    maybeCurrentUserId <- maybeAuthId
    let comment' = comment { commentUserId = maybeCurrentUserId }

    insertedComment <- runDB $ insertEntity comment'
    return insertedComment

instance ToContent (Entity Comment) where
  toContent = toContent . encode
instance ToTypedContent (Entity Comment) where
  toTypedContent = TypedContent "application/json" . toContent

下４行がインスタンスを宣言している箇所です。定型的なコードでいけます。
ただ、ビルド時に orphan instance の警告が出ることがあります。

 Orphan instance: instance ToContent (Entity Comment)

この意味と解消の検討方法については、拙エントリ「Warning: Orphan instanceを回避する」をご覧下さい。

まとめ

これで理想的な型宣言を得ることが出来ました。
ToContent と ToTypedContent のインスタンスにするのが少し面倒ですが、適切な型宣言を得るには軽い代償だと思います。