在Servant中添加響應頭

我想弄清楚如何在Servant中添加CORS響應頭（基本上，設置響應頭「Access-Control-Allow-Origin：*」）。我用addHeader函數編寫了一個小測試用例，但它出錯了。我將非常感謝幫忙解決下面的錯誤。在Servant中添加響應頭

代碼：

{-# 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，則會出錯。我認爲它的功能類型似乎與類型簽名一致。我肯定在這裏錯過了一些東西，否則它不會像這樣錯誤。

來源

2016-02-08 Sal

madjar已經建議這一點，但在它擴大：addHeader改變返回值類型：

x :: Int 
x = 5 

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

在你的情況，這意味着你必須更新users的類型，其中結合返回Either ServantErr IO (Headers '[Header "Access-Control-Allow-Origin" T.Text] Token

更一般地說，您可以在ghci中使用:kind! Server UserAPI來查看類型同義詞的擴展名 - 這通常對僕人很有幫助！

來源

2016-02-08 11:30:21 user2141650

aha，我才知道這個有用的庫，非常有教育意義。謝謝！我很困惑爲什麼添加標題時類型不會改變。正如你指出的那樣，它們會改變。 – Sal

我認爲將CORS頭添加到響應的最簡單方法是在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類型的值。

來源

2016-02-08 08:24:31 madjar

@majdar，非常有幫助的指針。這可能是我將採取的路線。直到你指出 – Sal

在Servant中添加響應頭

回答

相關問題