Adding response header in Servant

Sal

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.

user2141650

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!

Collected from the Internet

Please contact [email protected] to delete if infringement.

edited at
0

Comments

0 comments
Login to comment

Related

From Dev

Adding header in response in filter?

From Dev

adding http response header

From Dev

Adding header to response for specific URLs with HAproxy

From Dev

ASP.NET 5 Middleware "no response received" after adding header

From Dev

Adding X-Robot-Tag to response header in Sitecore 8

From Dev

WCF adding additional HTTP header to HTTP response for transporting SOAP message

From Dev

Adding X-Robot-Tag to response header in Sitecore 8

From Dev

Angularjs: Why does adding an authorization header cause a -1 status response?

From Dev

not getting success response when adding custom headers with Authorization header in get header() volley

From Dev

not getting success response when adding custom headers with Authorization header in get header() volley

From Dev

How to response with HTTP status in custom servant handler?

From Dev

response header to cache the response?

From Dev

Spring WS how to get server side soap response xml for adding soap header with sign

From Dev

Adding header and footer in graphviz

From Dev

Adding JsessionID in Request Header

From Java

Adding header for HttpURLConnection

From Dev

Adding custom request header

From Dev

Adding a header to UITableview programmatically

From Dev

Adding SOAP Header to request

From Dev

Adding Header moves Div

From Dev

Adding a table header on this code?

From Dev

Adding Security Header

From Dev

Adding header files in Verilog

From Dev

Adding header authorisation with Jersey

From Dev

Adding Header moves Div

From Dev

Adding header authorisation with Jersey

From Dev

Adding a BMP grayscale header

From Dev

Jquery Filer adding header

From Dev

Adding Header to a Laravel view

Related Related

HotTag

Archive