在 Servant 中添加响应 header

Question

我正在尝试弄清楚如何在 Servant 中添加 CORS 响应 header（基本上，设置一个响应 header "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

我认为将 CORS headers 添加到响应的最简单方法是在 servant 之上使用中间件。 wai-cors 非常简单：

import Network.Wai.Middleware.Cors

[...]

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

对于您的实际响应，我猜您需要使用 addHeader 将类型 Text 的值转换为类型 Headers '[Header "Access-Control-Allow-Origin" T.Text 的值。

Answer 2

madjar 已经建议了这一点，但要扩展它：addHeader 更改 return 类型：

x :: Int
x = 5

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

在您的情况下，这意味着您必须更新绑定到 return Either ServantErr IO (Headers '[Header "Access-Control-Allow-Origin" T.Text] Token

的 users 的类型

更一般地说，您可以在 ghci 中使用 :kind! Server UserAPI 来查看类型同义词扩展到什么 - 这通常对 servant 很有帮助！

在 Servant 中添加响应 header

Adding response header in Servant

haskell

servant