Allowing cross-origin requests in Yesod

Question

My application uses a bookmarklet, and I need to allow CORS for MyRouteR so my bookmarklet code can use this route for AJAX requests.

In my first draft of config/routes I gave MyRouteR support for only one request method, PUT. But it turned out (duh) that I'd need to support the OPTIONS method as well, which browsers use for CORS preflight requests.

I ended up with the following in config/routes:

/myroute MyRouteR PUT OPTIONS

I was kind of hoping there would be some relevant machinery in the Template Haskell that processes config/routes so that the addition of OPTIONS to this route's method list would automagically result in CORS support, but no dice. Not the end of the world, but it would have made sense and felt elegant that way.

To make CORS work, I gave the route an OPTIONS handler:

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 ...

This works, but it feels slightly un-Yesodic because it's so boilerplate. So, two questions:

1. Do we have a better adjective than Yesodic?
2. Is there another, better way to let a route support cross-origin requests?

Answer 1

UPDATE: Someone else published some generic middleware for this: http://hackage.haskell.org/package/wai-cors.

---

I am currently working on the same thing and haven't yet implemented a solution, however I imagine it can be done via a WAI Middleware similar to the sample code on the wiki page Allowing WOFF fonts to be accessed from other domains (CORS). This should allow you from writing the CORS code once without repeating yourself.

Sample code from the link above to add cross-origin access for WOFF fonts:

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", "*")