Hinzufügen Antwort Header in Servant

Question

Ich versuche herauszufinden, wie CORS Response-Header in Servant (im Wesentlichen legen Sie eine Antwort-Header "Access-Control-Allow-Origin: *"). Ich schrieb unten einen kleinen Testfall mit addHeader Funktion, aber es ist fehlerhaft. Ich schätze die Hilfe bei der Ermittlung des Fehlers unten.

Code:

{-# 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 

Dies ist der Fehler, den ich bekommen:

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) 

Ich habe eine funktionierende Version mit einer einfacheren API (einfache GET), wo es funktioniert. Aber für UserAPI von oben genannten Typ, es aus. addHeader Funktionstyp scheint mit der Typensignatur übereinzustimmen, wie ich darüber denke. Ich verpasse definitiv etwas hier oder es wird kein Fehler wie folgt.

Answer 1

Madjar dies bereits vorgeschlagen, aber darauf zu erweitern: addHeader ändert den Rückgabetyp:

x :: Int 
x = 5 

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

In Ihrem Fall bedeutet dies, Sie die Art der users zu aktualisieren, wo Either ServantErr IO (Headers '[Header "Access-Control-Allow-Origin" T.Text] Token

zurückzukehren Bindung

Allgemeiner können Sie :kind! Server UserAPI in ghci verwenden, um zu sehen, wozu das Typen-Synonym erweitert wird - das ist oft hilfreich bei Diener!

Answer 2

Ich denke, der einfachste Weg, um CORS-Header zur Antwort hinzuzufügen, ist die Verwendung einer Middleware auf dem Servant. wai-cors macht es recht einfach:

import Network.Wai.Middleware.Cors 

[...] 

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

---

Für Ihre tatsächliche Antwort, ich glaube, Sie brauchen addHeader zu verwenden, um einen Wert vom Typ Headers '[Header "Access-Control-Allow-Origin" T.TextText in einen Wert vom Typ einzuschalten.