Haskell の GraphQL ライブラリ Morpheus を使ってみた

Haskell で GraphQL の API を構築できるライブラリ Morpheus GraphQL を使ってみました。
README の Getting Started を参考に、プロジェクト作成から GraphiQL でクエリを投げて動作確認するところまで行いました。

最終的に出来上がったコードは以下のリポジトリにまとめてあります。

プロジェクト作成

READMEに従い、Stackを使って開発をしていきます。
stack new コマンドでプロジェクトを作成します。

$ stack new morpheus-sample

使用するパッケージとバージョンの指定

package.yaml ファイルの dependencies に morpheus-graphql を追加します。

package.yaml

dependencies:
  - base >= 4.7 && < 5
  - morpheus-graphql

さらに、stack.yaml ファイルを以下のように変更します。

stack.yaml

resolver: lts-16.2
packages:
  - .
extra-deps:
  - morpheus-graphql-0.17.0
  - morpheus-graphql-app-0.17.0
  - morpheus-graphql-core-0.17.0

ここで一旦ビルドします。stack build でビルドしてみましょう。

$ stack build
...
Registering library for morpheus-sample-0.1.0.0..
Completed 27 action(s). 

よさそうです。

スキーマの定義

スキーマの定義方法は２つあります。
GraphQLの記法で定義を書いたファイルを読み込む方法と、Haskellの型として定義する方法です。
せっかくHaskellで書いているので、今回は型で定義してみました。

Main.hs

data Query m = Query
  { user :: UserArgs -> m User
  } deriving (Generic, GQLType)

data User = User
  { name :: Text
  , email :: Text
  } deriving (Generic, GQLType)

data UserArgs = UserArgs
  { name :: Text
  } deriving (Generic, GQLType)

ユーザーは名前(name)とメールアドレス(email)を持ち、名前で検索できる、という感じです。

データベースもどきの準備

データベースを用意する代わりに、ユーザーのリストと検索用の関数を作りました。

Main.hs

userDB :: [User]
userDB = 
  [ User "Thoru" "[e-mail]"
  , User "Kanna" "[e-mail]"
  , User "Fafnir" "[e-mail]"
  , User "Lucoa" "[e-mail]"
  , User "Elma" "[e-mail]"
  , User "Ilulu" "[e-mail]"
  ]

findUserByName :: Text -> Maybe User
findUserByName name = find (\(User name' _) -> name == name') userDB

次はこれを元にリゾルバを作成していきます。

リゾルバの実装

ユーザーのリゾルバ resolveUser を実装をします。
resolveUser の型 UserArgs -> ResolverQ e IO User はスキーマで定義した user :: UserArgs -> m User に対応しています。

Main.hs

resolveUser :: UserArgs -> ResolverQ e IO User
resolveUser (UserArgs name) = maybe (fail "User not found.") return $ findUserByName name

そして、以下のように rootResolver を作成し、それを interpreter に渡すことで、gqlApi が完成しました。
（今回、Mutation と Subscription は実装しないので、Undefined を指定しています。）

Main.hs

rootResolver :: RootResolver IO () Query Undefined Undefined
rootResolver =
  RootResolver
    { queryResolver = Query {user = resolveUser}
    , mutationResolver = Undefined
    , subscriptionResolver = Undefined
    }

gqlApi :: ByteString -> IO ByteString
gqlApi = interpreter rootResolver

gqlApi にクエリを渡すと、リゾルバを通して適切なデータが返ってきます。

サーバーの実装

Morpheus の README では scotty でサーバーを実装していますが、今回は wai と warp を使ってサーバーを実装してみました。リクエストのBodyを gqlApi に渡し、実行結果を返すようにしています。

Main.hs

app :: Application
app request respond = do
  body <- getRequestBodyChunk request
  respond . responseLBS status200 [("Content-Type", "text/plain")] <=< gqlApi $ B.fromStrict body

main :: IO ()
main = do
  putStrLn $ "http://localhost:3000/"
  run 3000 app

これで完成です！

動作確認

stack exec でサーバーを起動します。

$ stack exec morpheus-sample-exe
http://localhost:3000/

GraphiQLでクエリを投げてみます。

正しくデータが取得できました。

おまけ

上記コードと言語拡張やインポート等を含めた完成版のファイルを以下に掲載します。

Main.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveAnyClass #-}

module Main where

import Control.Monad
import Data.Morpheus
import Data.Morpheus.Types
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B
import Data.Text (Text)
import qualified Data.Text as T
import Data.List
import GHC.Generics
import Network.Wai
import Network.HTTP.Types (status200)
import Network.Wai.Handler.Warp (run)

data Query m = Query
  { user :: UserArgs -> m User
  } deriving (Generic, GQLType)

data User = User
  { name :: Text
  , email :: Text
  } deriving (Generic, GQLType)

data UserArgs = UserArgs
  { name :: Text
  } deriving (Generic, GQLType)

userDB :: [User]
userDB = 
  [ User "Thoru" "[e-mail]"
  , User "Kanna" "[e-mail]"
  , User "Fafnir" "[e-mail]"
  , User "Lucoa" "[e-mail]"
  , User "Elma" "[e-mail]"
  , User "Ilulu" "[e-mail]"
  ]

findUserByName :: Text -> Maybe User
findUserByName name = find (\(User name' _) -> name == name') userDB

resolveUser :: UserArgs -> ResolverQ e IO User
resolveUser (UserArgs name) = maybe (fail "User not found.") return $ findUserByName name

rootResolver :: RootResolver IO () Query Undefined Undefined
rootResolver =
  RootResolver
    { queryResolver = Query {user = resolveUser}
    , mutationResolver = Undefined
    , subscriptionResolver = Undefined
    }

gqlApi :: ByteString -> IO ByteString
gqlApi = interpreter rootResolver

app :: Application
app request respond = do
  body <- getRequestBodyChunk request
  respond . responseLBS status200 [("Content-Type", "text/plain")] <=< gqlApi $ B.fromStrict body

main :: IO ()
main = do
  putStrLn $ "http://localhost:3000/"
  run 3000 app