More than 3 years have passed since last update.

【Servant】(9) Handlerモナド

Last updated at 2020-03-15Posted at 2020-02-29

遅くなりましたが、今回はHandlerモナドについてシッカリと見ていきます。

1.Handlerモナド

これまで使ってきた Server 型は、実は ServerT によって以下のように定義されたものです。
Servant.Server - Hackage

Server

type Server api = ServerT api Handler

HandlerでHandlerモナド以外のモナドを使いたい時はどうするのか、次の記事で紹介しました・
【Servant】(8) Another Monad - Qiita

しかしHandlerモナドがそもそもどんなモナドなのかはまだ説明していませんでした。Handlerモナドは、mtl を利用してIOモナドの上にExceptモナドを積み重ねたシンプルなものです。

servant-server: A family of combinators for defining webservices APIs and serving them

Handler

newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
  deriving
    ( Functor, Applicative, Monad, MonadIO, Generic
    , MonadError ServerError
    , MonadThrow, MonadCatch, MonadMask
    )

mtlではありませんが、Monad transformersとIOモナドについては以下の一連の過去記事にまとめてありますので、モナドの積み重ねに不慣れな方はご一読ください。ExceptTやIOを含め、4つのモナドを重ねたシンプルなモナドを説明しています。
【Control.Monad.Trans】(1) Identityモナド - Qiita

つまりHandlerモナドでは、ExceptTモナドとIOモナドの両方を使うことができます。

1-1. ExceptTモナド

Control.Monad.Except

ExceptTモナドでは成功と失敗を表現することができます。

成功 - return で結果を返します。
失敗 - throwError でエラーを投げます

1-2. IOモナド

HandlerモナドはIOモナドをbaseモナドにしており、MonadIOのインスタンスです。つまりHandlerで好きなIOモナドを書き、それをliftIO でHandlerモナドに持ち上げることができます。

MonadIO

class (Monad m) => MonadIO m where
    liftIO :: IO a -> m a

2. 全ソース

今回は以下の記事のソースコードに、IOモナドとExceptTモナドを追加してみます。
【Servant】(7) Post Data - Qiita

まず以下のimport文を追加します。

new-import

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Error.Class
import Servant.Server.Internal.ServerError

IOモナドとしてprintを追加しliftIOで持ち上げます。

liftIO

handlerName :: String -> Handler String 
handlerName nameIn = do
    liftIO $ print $ "input name = " ++ nameIn  -- IO monad
    return nameIn  -- Just output back the input string value

次はExceptTモナドの追加です。Handlerを追加します。

handlerWithError

handlerWithError :: Handler String
handlerWithError = if True -- If there was an error ?
  then throwError $ err500 { errBody = "Exception in module A.B.C:55.  Have a great day!" }  -- We throw error here. Read more about it below.
  else return "sras" -- else return result.

throwErrorでerr500を投げています。throwErrorはExceptT所属で、err500はServant.Server.Internal.ServerError所属です。

このHandlerに対応するAPIを追加します。3番目です。

ServantType

type ServantType =  "name" :> ReqBody '[JSON] String :> Post '[PlainText] String
               :<|> "age" :> Get '[PlainText] String
               :<|>  "errname" :> Get '[PlainText] String

serverについても3番目に追加します。

server :: Server ServantType
server = handlerName
    :<|> handlerAge
    :<|> handlerWithError

変更点は以上です。以下に全ソースを示します。

PostData.he

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module PostData
    ( runServant
    ) where

import Servant ( QueryParam
               , PlainText
               , JSON
               , FromHttpApiData(..)
               , Get
               , Post
               , ReqBody
               , Proxy(..)
               , type (:>)      -- Syntax for importing type operator
               , type (:<|>)
               , (:<|>)(..)
               )
import Servant.Server (Handler, Server, Application, serve)
import Network.Wai.Handler.Warp (run)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Error.Class
import Servant.Server.Internal.ServerError

-- ^^ This is the module from which the errors that we can throw are imported.
-- For some reason this is a not really mentioned in the documentation and is marked an Internal module.
-- To see all the possible types of errors we can throw or how to make our custom errors, refer the following.
-- https://hackage.haskell.org/package/servant-server-0.17/docs/Servant-Server-Internal-ServerError.html


-- In this example, we see how we can accept
-- input in the request body, say a Json payload.

handlerName :: String -> Handler String 
handlerName nameIn = do
    liftIO $ print $ "input name = " ++ nameIn  -- IO monad
    return nameIn  -- Just output back the input string value

handlerAge :: Handler String
handlerAge = return "31"


handlerWithError :: Handler String
handlerWithError = if True -- If there was an error ?
  then throwError $ err500 { errBody = "Exception in module A.B.C:55.  Have a great day!" }  -- We throw error here. Read more about it below.
  else return "sras" -- else return result.


-- The function err500 is part of Servant and returns a value of type 'ServantErr'.
-- The throwError function is not part of Servant library.
-- We can use it to throw errors of type `ServantErr` in the `Handler` monad
-- only because of the typeclass instance `MonadError ServantErr Handler`.
-- You can see it in the documentation page.
-- https://hackage.haskell.org/package/servant-server-0.17/docs/Servant-Server-Internal-ServerError.html


-- In the code below, look at the `ReqBody '[JSON] String` part.
-- This is what enables our endpoint to recieve a String encoded as JSON
-- in the body of the request.
--
type ServantType =  "name" :> ReqBody '[JSON] String :> Post '[PlainText] String
               :<|> "age" :> Get '[PlainText] String
               :<|>  "errname" :> Get '[PlainText] String

server :: Server ServantType
server = handlerName
    :<|> handlerAge
    :<|> handlerWithError

app :: Application
app = serve (Proxy :: Proxy ServantType) server

runServant :: IO ()
runServant = run 4000 app

メイン

Main.hs

module Main where

import qualified HtmlContent       as T1
import qualified PostData          as T2
import qualified CustomPostData    as T3
import qualified AnotherMonad      as T4

main :: IO ()
main = T2.runServant

使用するパッケージ

package.yaml

- base >= 4.7 && < 5
- servant
- servant-server
- aeson
- time
- wai
- warp
- http-media
- bytestring
- mtl

3. 実行結果

stack build && stack exec first-project-exe

まずIOモナドの確認です

$ curl -v -H "Content-Type:application/json" -d "\"John\"" http://127.0.0.1:4000/name
*   Trying 127.0.0.1:4000...
* TCP_NODELAY set
  % Total    % Received % Xferd  Average Speed   Time    Time     Time  Current
                                 Dload  Upload   Total   Spent    Left  Speed
  0     0    0     0    0     0      0      0 --:--:-- --:--:-- --:--:--     0* Connected to 127.0.0.1 (127.0.0.1) port 4000 (#0)
> POST /name HTTP/1.1
> Host: 127.0.0.1:4000
> User-Agent: curl/7.67.0
> Accept: */*
> Content-Type:application/json
> Content-Length: 6
>
} [6 bytes data]
* upload completely sent off: 6 out of 6 bytes
* Mark bundle as not supporting multiuse
< HTTP/1.1 200 OK
< Transfer-Encoding: chunked
< Date: Sat, 29 Feb 2020 01:33:24 GMT
< Server: Warp/3.3.5
< Content-Type: text/plain;charset=utf-8
<
{ [17 bytes data]
100    10    0     4  100     6   2000   3000 --:--:-- --:--:-- --:--:-- 10000
John   ### 実行結果
* Connection #0 to host 127.0.0.1 left intact

プリント出力が、サーバ側のコンソールに出力されています。OKですね。

"input name = John"

次にExceptTモナドの確認です。

$ curl -v http://127.0.0.1:4000/errname                                         *   Trying 127.0.0.1:4000...
* TCP_NODELAY set
  % Total    % Received % Xferd  Average Speed   Time    Time     Time  Current
                                 Dload  Upload   Total   Spent    Left  Speed
  0     0    0     0    0     0      0      0 --:--:-- --:--:-- --:--:--     0* Connected to 127.0.0.1 (127.0.0.1) port 4000 (#0)
> GET /errname HTTP/1.1
> Host: 127.0.0.1:4000
> User-Agent: curl/7.67.0
> Accept: */*
>
* Mark bundle as not supporting multiuse
< HTTP/1.1 500 Internal Server Error     ### サーバエラー
< Transfer-Encoding: chunked
< Date: Sat, 29 Feb 2020 01:33:54 GMT
< Server: Warp/3.3.5
<
{ [61 bytes data]
100    48    0    48    0     0  48000      0 --:--:-- --:--:-- --:--:-- 48000
Exception in module A.B.C:55.  Have a great day!     ### エラーメッセージ
* Connection #0 to host 127.0.0.1 left intact

サーバエラーとなり、エラーメッセージも返ってきています。OKですね。

今回は以上となります。

You get articles that match your needs
You can efficiently read back useful information
You can use dark theme

What you can do with signing up