在Yesod中允许跨源请求

Question

我的应用程序使用bookmarklet,我需要允许CORS,MyRouteR因此我的bookmarklet代码可以使用此路由进行AJAX请求.

在我的配置/路由初稿中,我MyRouteR只支持一种请求方法PUT.但事实证明,我还需要支持OPTIONS方法,这些浏览器用于CORS预检请求.

我在config/routes中得到了以下结果:

/myroute MyRouteR PUT OPTIONS

我有点希望在模板Haskell中有一些相关的机制来处理配置/路由,这样在这个路由的方法列表中添加OPTIONS会自动导致CORS支持,但没有骰子.不是世界末日,但它会有意义并且感觉优雅.

为了使CORS工作,我给路由一个OPTIONS处理程序:

optionsMyRouteR :: Handler RepPlain
optionsMyRouteR = do
    addHeader "Access-Control-Allow-Origin" "*"
    addHeader "Access-Control-Allow-Methods" "PUT, OPTIONS"
    return $ RepPlain $ toContent ("" :: Text)

putMyRouteR :: Handler RepJson
putMyRouteR = do
    addHeader "Access-Control-Allow-Origin" "*"
    -- more stuff ...

这是有效的,但感觉有点不太正常,因为它是如此的样板.那么,有两个问题:

1. 我们有比Yesodic更好的形容词吗？
2. 还有另一种更好的方法让路由支持跨源请求吗？

Answer 1

更新： 其他人为此发布了一些通用中间件：http://hackage.haskell.org/package/wai-cors。

我目前正在研究同样的事情，但尚未实现解决方案，但我想它可以通过Middleware类似于 wiki 页面上的示例代码的WAI 来完成，允许从其他域 (CORS) 访问 WOFF 字体。这应该允许您编写一次 CORS 代码而无需重复编写。

上面链接中的示例代码用于添加 WOFF 字体的跨域访问：

addCORStoWOFF :: W.Middleware
addCORStoWOFF app = fmap updateHeaders . app
  where
    updateHeaders (W.ResponseFile    status headers fp mpart) = W.ResponseFile    status (new headers) fp mpart
    updateHeaders (W.ResponseBuilder status headers builder)  = W.ResponseBuilder status (new headers) builder
    updateHeaders (W.ResponseSource  status headers src)      = W.ResponseSource  status (new headers) src
    new headers | woff      = cors : headers
                | otherwise =        headers
      where woff = lookup HT.hContentType headers == Just "application/font-woff"
            cors = ("Access-Control-Allow-Origin", "*")