Adding response header in Servant

Question

I am trying to figure out how to add CORS response header in Servant (basically, set a response header "Access-Control-Allow-Origin: *"). I wrote a small test case below with addHeader function but it errors out. I will appreciate help with figuring 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 UserAPI of above type, it errors out. addHeader function type seems to agree with the type signature the way I think about it. I am definitely missing something here or it won't error out like this.

Answer 1

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

import Network.Wai.Middleware.Cors

[...]

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

---

For your actual response, I guess you need to use addHeader to turn a value of type Text into a value of type Headers '[Header "Access-Control-Allow-Origin" T.Text.

Answer 2

madjar already suggested this, but to expand upon 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 you have to update the type of the users where binding to return Either ServantErr IO (Headers '[Header "Access-Control-Allow-Origin" T.Text] Token

More generally, you can use :kind! Server UserAPI in ghci to see what the type synonym expands to - that's often helpful with servant!