Servantでレスポンスヘッダーを追加する

Question

私はServantでレスポンスヘッダーをCORSに追加する方法を理解しようとしています（基本的にレスポンスヘッダー "Access-Control-Allow-Origin：*"を設定します）。私はaddHeaderの機能で以下の小さなテストケースを書いたが、エラーが出る。私は以下のエラーを理解する助けに感謝します。

コード：

{-# LANGUAGE CPP   #-} 
{-# LANGUAGE DataKinds  #-} 
{-# LANGUAGE DeriveGeneriC#-} 
{-# LANGUAGE TypeFamilies #-} 
{-# LANGUAGE TypeOperators #-} 
{-# LANGUAGE OverloadedStrings #-} 
module Main where 

import Data.Aeson 
import GHC.Generics 
import Network.Wai 
import Servant 
import Network.Wai.Handler.Warp (run) 
import Control.Monad.Trans.Either 
import Control.Monad.IO.Class (liftIO) 
import Control.Monad (when, (<$!>)) 
import Data.Text as T 
import Data.Configurator as C 
import Data.Maybe 
import System.Exit (exitFailure) 

data User = User 
    { name    :: T.Text 
    , password   :: T.Text 
    } deriving (Eq, Show, Generic) 

instance ToJSON User 
instance FromJSON User 

type Token = T.Text 

type UserAPI = "grant" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[Header "Access-Control-Allow-Origin" T.Text] Token) 

userAPI :: Proxy UserAPI 
userAPI = Proxy 

authUser :: User -> Bool 
authUser u = case (password u) of 
    "somepass" -> True 
    _  -> False 

server :: Server UserAPI 
server = users 
    where users :: User -> EitherT ServantErr IO Token 
     users u = case (authUser u) of 
      True -> return $ addHeader "*" $ ("ok" :: Token) 
      False -> return $ addHeader "*" $ ("notok" :: Token) 

app :: Application 
app = serve userAPI server 

main :: IO() 
main = run 8081 app 

これは私が取得エラーです：

src/Test.hs:43:10: 
    Couldn't match type ‘Headers 
          '[Header "Access-Control-Allow-Origin" Text] Text’ 
        with ‘Text’ 
    Expected type: Server UserAPI 
     Actual type: User -> EitherT ServantErr IO Token 
    In the expression: users 
    In an equation for ‘server’: 
     server 
      = users 
      where 
       users :: User -> EitherT ServantErr IO Token 
       users u 
       = case (authUser u) of { 
        True -> return $ addHeader "*" $ ("something" :: Token) 
        False -> return $ addHeader "*" $ ("something" :: Token) } 

src/Test.hs:46:28: 
    Couldn't match type ‘Text’ with ‘Headers '[Header h v0] Text’ 
    In the expression: addHeader "*" 
    In the second argument of ‘($)’, namely 
     ‘addHeader "*" $ ("something" :: Token)’ 
    In the expression: return $ addHeader "*" $ ("something" :: Token) 

src/Test.hs:47:29: 
    Couldn't match type ‘Text’ with ‘Headers '[Header h1 v1] Text’ 
    In the expression: addHeader "*" 
    In the second argument of ‘($)’, namely 
     ‘addHeader "*" $ ("something" :: Token)’ 
    In the expression: return $ addHeader "*" $ ("something" :: Token) 

私はそれが動作するシンプルなAPI（シンプルGET）との作業バージョンを持っています。しかし、上記のタイプのUserAPIでは、エラーが発生します。 addHeader関数型は、私がそれについて考えているように、型シグネチャに同意しているようです。私は間違いなくここに何かを逃している、またはこれのようにエラーになりません。

Answer 1

madjarはすでにこれを提案し、それにより展開する：addHeaderは、戻り値の型に変更：あなたのケースでは

x :: Int 
x = 5 

y :: Headers '[Header "SomeHeader" String] Int 
y = addHeader "headerVal" y 

を、これはあなたがEither ServantErr IO (Headers '[Header "Access-Control-Allow-Origin" T.Text] Token

を返すために結合 usersの種類を更新しなければならないことを意味します

もっと一般的には、ghciで:kind! Server UserAPIを使用すると、シノニムの種類がどのように拡大するのかを知ることができます。

Answer 2

CORSヘッダーを応答に追加する最も簡単な方法は、サーバーントの上にミドルウェアを使用することです。 wai-corsは、それはかなり簡単です：

あなたの実際の応答のために

import Network.Wai.Middleware.Cors 

[...] 

app :: Application 
app = simpleCors (serve userAPI server) 

---

、私はあなたがタイプHeaders '[Header "Access-Control-Allow-Origin" T.Textの値にタイプTextの値をオンにするaddHeaderを使用する必要があると思います。