Добавление заголовка ответа в Servant

Question

Я пытаюсь выяснить, как добавить CORS ответный заголовок в Servant (в основном, установить заголовок ответа «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

Маджар уже предложил это, но и расширить на нем: 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

В более общем плане, вы можете использовать :kind! Server UserAPI в ghci, чтобы узнать, чем расширяется синоним типа - это часто полезно при работе!

Answer 2

Я думаю, что самый простой способ добавить заголовки CORS к ответу - использовать промежуточное программное обеспечение поверх слуги. wai-cors делает это довольно легко:

import Network.Wai.Middleware.Cors 

[...] 

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

---

Для фактического ответа, я думаю, вам нужно использовать addHeader превратить значение типа Text в значение типа Headers '[Header "Access-Control-Allow-Origin" T.Text.