Adding a response header to Servant

Question

I am trying to figure out how to add a CORS response header to Servant (basically setting the response header to "Access-Control-Allow-Origin: *"). I wrote a small test case below with the addHeader function, but it is wrong. I will be grateful for the help in finding out the error below.

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 

This is the error I get:

 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) 

I have a working version with a simpler API (simple GET ) where it works. But, for the UserAPI above type, it is erroneous. addHeader type of the function seems to agree with the type signature, as I think of it. I definitely missed something here, or it won’t fail in this way.

Answer 1

madjar already suggested this, but to extend it: addHeader changes the return type:

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

In your case, this means that you need to update the users type, where the binding is to return Either ServantErr IO (Headers '[Header "Access-Control-Allow-Origin" T.Text] Token

More generally, you can use :kind! Server UserAPI :kind! Server UserAPI in ghci to find out what type synonym expands to - which is often useful when working with servant!

Answer 2

I think the easiest way to add CORS headers to the answer is to use middleware on top of the servant. wai-cors makes this pretty easy:

 import Network.Wai.Middleware.Cors [...] app :: Application app = simpleCors (serve userAPI server) 

---

For your real answer, I think you need to use addHeader to turn the value of type Text into the value of type Headers '[Header "Access-Control-Allow-Origin" T.Text .