OPTIONS support

[tel]

Hi all,

I was interested in seeing what it would take to hack together some options support (eventually in order to get fine-grained CORS support). This is what I came up with and I'd like some feedback.

First we provide the Options data type. It's parameterized by a list of allowed methods

-- | Endpoint for OPTIONS requests.
data Options (allowedMethods :: [*])
  deriving Typeable

Allowed methods arise from the standard types using another type

data Allow (a :: [*] -> * -> *) :: *

and then a type family allows us to automatically compute the Options type from the type of your API

type family GetAllowed api :: [*]

type instance GetAllowed (a :<|> b) = GetAllowed a ++ GetAllowed b
type instance GetAllowed (a :> b) = '[]
type instance GetAllowed (Get a b) = '[ Allow Get ]
type instance GetAllowed (Put a b) = '[ Allow Put ]
type instance GetAllowed (Post a b) = '[ Allow Post ]
type instance GetAllowed (Patch a b) = '[ Allow Patch ]
type instance GetAllowed (Delete a b) = '[ Allow Delete ]

type OptionsFor others api = Options (others ++ GetAllowed api) :<|> api

The server implementation is simple, too. Options does not support a body (though perhaps it could) so the implementation is trivial

data ProvideOptions = ProvideOptions

instance AllowHeader allowedMethods => HasServer (Options allowedMethods) where
  type ServerT (Options allowedMethods) m = ProvideOptions

I don't choose to use () as the implementation since (a) this requires importing the module and thus sidesteps orphan instance issues when the API and implementation modules are separate like mine are and (b) this is more semantically obvious.

Before describing route I need to be able to analyze allowedMethods so I write

class AllowHeader allowedMethods where
  allowedMethods :: Proxy allowedMethods -> [S8.ByteString]

allowHeader :: AllowHeader ms => Proxy ms -> Header.Header
allowHeader p = ("Allow", S8.intercalate "," (allowedMethods p))

with instances like

instance AllowHeader rs => AllowHeader (Allow Get ': rs) where
  allowedMethods Proxy = "GET" : allowedMethods (Proxy :: Proxy rs)

and now route is trivial

  route Proxy ProvideOptions request respond
    | pathIsEmpty request
      && Wai.requestMethod request == methodOptions =
        respond . succeedWith $
          Wai.responseLBS ok200 [allowHeader (Proxy :: Proxy allowedMethods)] ""
    | pathIsEmpty request
      && Wai.requestMethod request /= methodOptions =
        respond $ failWith WrongMethod
    | otherwise = respond $ failWith NotFound

So with all this machinery out of the way, I can augment an API with OPTIONS support by

type OptionsAPI = OptionsFor '[] NormalAPI

run optionsApiProxy (ProvideOptions :<|> normalApiServer)

[jkarni]

Thanks a lot for this!

What users actually are exposed to seems like the right direction to me. Some notes:

• From what I can tell, the above will only respond with OPTIONS at the top-level - if normalApiServer has further paths, those won't handle OPTIONS, no? That seems to be the idea, given the :> instance for GetAllowed, but this behaviour may be a little surprising.
• What about allowed headers (i.e. Access-Control-Allow-Header)? Relatedly, one thing that might become troubling is that the OPTIONS preflight request does not have the headers that the underlying POST or whatever is expected to have, so that if we have

type MyAPI = Header "MyHeader" HeaderData :> OptionFor (Post ...)

we have to make sure this would not cause the OPTIONS request to fail. This would have been true in 0.4, but I think in the current master that problem is much more easily solved. Something to keep in mind though.

• Another point to consider is that we're probably going to turn the HTTP methods into type synonyms. This doesn't change the feasibility of your approach, but it does open up another one - just having another type parameter in Verb that would represent the information needed for OPTIONS. Something like

data Verb method status cors ctypes a

class KnownCors cors where
    getCors :: Proxy cors -> WhateverDataWeNeed

instance (..., KnownCors cors ) => HasServer (Verb method status cors ctypes a) where
    route ... | requestMethod request == methodOptions = doTheRightThing

Where WhateverDataWeNeed

This will still run into the same issue with headers preceding the Verb having to be considered more carefully. KnownCors as it stands is a little to manual, but there may be better ways about it.

Thoughts?

[tel]

• My design so far was to have the user specify options at each leaf node where options are available. We could attempt to do it all in one go by analyzing the whole tree and inserting Options where necessary, but since I'm aiming at fine-grained control anyway, it seems more meaningful to sprinkle metadata inside the tree.
• I'm honestly still researching what all it takes to do "the right thing" with CORS, so responding to the preflight messages more completely is still up in the air. I'd like to hear ideas for what data should be specified. I think it'd be very possible (and then I could kill off double-specifying this data in the wai-cors middleware).

I think I should take a look at that Verb idea after I finish the second bullet point above. :)

The honest to goodness goal here really is CORS less than HATEOAS, but I hadn't yet moved to really understanding what CORS will take.

[jkarni]

CORS is pretty messy...

One issue with the Verb design, I now realize, is that it doesn't work if the browser doesn't send an Access-Control-Request-Method, since the leaf can't look around itself to siblings easily. I don't know if that's fatal to the idea, since I don't really know how all of the browsers behave.

For simplicity, I think it'd also be okay to limit configuration to Origin at first (and if course method, though that might work differently).

The honest to goodness goal here really is CORS less than HATEOAS

As in, HATEOAS is the real goal? It might be an easier one, since there we don't need any extra data to figure out what to allow besides what's already in the API. We do need to make sure the Origin is what we expect though, so that we don't accidentally allow everything on CORS.

[tel]

Oh, as in I'm not personally motivated to have Options bear the whole HATEOAS burden. It just needs to do CORS.

My understanding is that what you'd want in an API spec is a description of what verbs and endpoints will support CORs, what headers and verbs are acceptable, and then have some exterior notion (maybe!) of allowable origins. A lot of the time the origin filter will just be * anyway.

[tel]

So I have a partial expanded design which includes room for some CORS. It's kind of nice but I'm a little stuck on the type level stuff in one part. In particular, it is difficult to recurse on API types due to the fact that symbols are "bare" instead of being something like Segment "user" :> Capture "id" Int etc etc.

Anyway, here's the code

-- | A "fully-loaded" Options method specifier.
--
-- Associated information describes the complete CORS policy for a given
-- endpoint, and, importantly, nothing below it.
data
  Options
  (allowedOrigins :: OriginSpec *)
  (allowedHeaders :: [*])
  (allowedMethods :: [*])
  (exposedHeaders :: [*])
  deriving Typeable

-- | When specifying allowed origins, the wildcard supercedes all other origin specification
-- and prohibits allowing credentialed requests. If not a wildcard then we
-- specify whether we allow credentials and a list of origin specifiers.
data OriginSpec a
  = SameOrigin -- ^ Disable CORS for this resource
  | Wildcard -- ^ Enable CORS for all origins
  | AllowCredentials Bool [a] -- ^ Enable CORS for some origins, possibly with credentials

-- | A wrapper letting us access HTTP methods as direct data types.
-- Used in specifying the Options "allowedMethods" parameter
data Method (a :: [*] -> * -> *) :: *

-- | Analyzes a "local" endpoint gathering method information furnished.
type family GatherMethods api :: [*]

type instance GatherMethods (a :<|> b) = GatherMethods a ++ GatherMethods b
type instance GatherMethods (a :> b) = '[]
type instance GatherMethods (Get a b) = '[ Method Get ]
type instance GatherMethods (Put a b) = '[ Method Put ]
type instance GatherMethods (Post a b) = '[ Method Post ]
type instance GatherMethods (Patch a b) = '[ Method Patch ]
type instance GatherMethods (Delete a b) = '[ Method Delete ]

-- | Analyzes a "local" endpoint gathering response header information furnished.
type family GatherHeaders api :: [*]

type instance GatherHeaders (a :<|> b) = GatherHeaders a ++ GatherHeaders b
type instance GatherHeaders (a :> b) = '[]
type instance GatherHeaders (Get a (Headers hs b)) = hs
type instance GatherHeaders (Put a (Headers hs b)) = hs
type instance GatherHeaders (Post a (Headers hs b)) = hs
type instance GatherHeaders (Patch a (Headers hs b)) = hs
type instance GatherHeaders (Delete a (Headers hs b)) = hs

-- Compute Options API endpoint from the passed API endpoint "locally"
type AutoOptions cors headers api
  = Options
    cors
    headers
    (GatherMethods api)
    (GatherHeaders api)

-- Extend an API locally with automatically computed options data
type WithOptions cors headers api
  = AutoOptions cors headers api :<|> api

type family Finalize (gather :: [*]) api

type instance Finalize gather (Options cors reqHeaders reqMethods respHeaders) =
  Options cors (reqHeaders ++ gather) reqMethods respHeaders
type instance Finalize gather (a :<|> b) =
  Finalize gather a :<|> Finalize gather b
type instance Finalize gather (a :> b) =
  a :> Finalize (CaptureHeaders a ++ gather) b

type family CaptureHeaders a :: [*]
type instance CaptureHeaders (Header name ty) = '[Header name ty]

The final bit, Finalize, is most interesting. It sweeps through the API type gathering up request headers and pushing them down into the Options constructors.

Unfortunately, it needs a companion, CaptureHeaders, which extracts header information, if it exists, from segments in the type specification tree. Type families cannot overlap so we can't use specificity tricks to get by. At best this is annoying since everything in the tree must now instantiate Finalize and CaptureHeaders. Right now, though, it's totally non-functional. :sob:

[tel]

This is mostly a POC again, btw. To really specify this correctly we need to differentiate between analysis which should be totally automated and CORS which is up to the API designer. For instance, it might be the case that one wishes to disable cross origin work on a given endpoint only partially. Allow versus Access-Control-Allow-Method.

Ultimately, I think there needs to be some other constructor to indicate CORS data. If a design for Finalize could work that kind of analysis could be used.

[tel]

The other trick is that CORS data should be non-specific to Options headers but instead to endpoints in the tree, which don't really have direct representation in Servant. Options just reflects the nature of the endpoint.

[tel]

So perhaps that's the way to go.

Segment "user" :>
  Endpoint
  '[ Cors Wildcard (Method Get '[JSON] User)
   , Cors (WithCredentials 'True '[OriginSetA]) (Method Post '[JSON] User)
   , Method Put '[JSON] UserUpdate
   , Method Delete ()
   ]

[jkarni]

The other trick is that CORS data should be non-specific to Options headers but instead to endpoints in the tree, which don't really have direct representation in Servant. Options just reflects the nature of the endpoint.

Can you explain this? Do you mean by endpoints in the tree not having a direct representation that we can't be sure we captured the entirety of the endpoint by a type family unless we know the type family was applied at the root of the API?

[tel]

Yeah, precisely. You could perhaps do a bottom up analysis to grab headers and methods that dumps all of it's information whenever it passes a url-changing element of the API tree, but otherwise you won't be able to do pre-flighting at an endpoint since it'll be hard to say if you're capturing all of the right methods.

I suppose it's possible by searching through the (:<|>) shallowly, but that seems hard to execute at the type level.

[tel]

Also, for interest I've been experimenting with these ideas at https://github.com/tel/serv. It has an Endpoint type like above (as well as more regular API types that are a bit easier to pass type functions over).

[cdupont]

I'm having this problem. Issuing POST requests with Swagger-ui (button "Try it out!") fails with:

 Request URL:   http://127.0.0.1:8001/players
 Request Method:    OPTIONS
 Status Code:   HTTP/1.1 400 Bad Request
 Cross-Origin Request Blocked: The Same Origin Policy disallows reading the remote resource at http://127.0.0.1:8001/players. (Reason: CORS header 'Access-Control-Allow-Origin' missing).

There is no workaround at the moment, right? I thought that starting Swagger-UI on the same machine then the API server would help, but no. The only way is to cut the curl command generated from Swagger and paste it on a shell.

[fizruk]

@cdupont I know I'm late, but see https://github.com/haskell-servant/servant-swagger/issues/45#issuecomment-219148710 (in a nutshell, you just need simpleCors middleware).

[lthms]

I did that for one of my project and it works just fine.

[leshow]

simpleCors doesn't work for me, on simple get requests it's fine, however when i POST or PUT to a resource, servant still does a 400 on the OPTIONS

[leshow]

I have a full test project you can see the issue https://github.com/leshow/elm-tut/tree/master/app

try updating a player level

[sordina]

For those of you who are blocked on the options functionality I've made what I think is a reasonable workaround. I've created a WAI middleware that reflects on your servant app api to return options for requests: https://github.com/sordina/freewill.it/blob/20ad7348e0841a757abb2a8bbce6a39f6cf21ad3/src/Network/Wai/Middleware/Servant/Options.hs#L10#L10

This can then be used in conjunction with the wai-cors middleware like so: https://github.com/sordina/freewill.it/blob/20ad7348e0841a757abb2a8bbce6a39f6cf21ad3/src/Enhancements.hs#L31

If there's interest I might turn the options module into a package on Hackage.

[sordina]

@leshow

[alpmestan]

@sordina Looks very simple to use, I like that. I definitely think it can't hurt to upload this to hackage, as it will allow us to point people to it. OTOH I've not needed any of this in a long while, so I hope other people will jump in and give some feedback.

[leshow]

@sordina I'll take a look at it this later today, thank you

[sordina]

@alpmestan https://hackage.haskell.org/package/servant-options

[alpmestan]

@haskell-servant/maintainers Can we consider this issue closed and delegate everything OPTIONS related to @sordina? =)

[sordina]

@alpmestan I do feel like OPTIONS responses are fairly standard REST-server behaviour. It should probably be folded into servant-server if this is going to be the recommended solution.

[fizruk]

@sordina if someone were to use cors from wai-cors together with provideOptions from servant-options, then one would override the other, right?

[sordina]

@fizruk Nope, if you want to do CORS you probably want to use both like so:

import App
import Servant
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.Servant.Options

app :: Application
app = logStdoutDev
    $ cors (const $ Just policy)
    $ provideOptions apiProxy
    $ serve apiProxy apiServer
  where
  policy = simpleCorsResourcePolicy
           { corsRequestHeaders = [ "content-type" ] }

[leshow]

@sordina I was going to give this a shot but your middleware link is returning not found.

Edit: sorry forgot to refresh the thread

[sordina]

@leshow Ah sorry, I've created a seperate library on Hackage now, so I deleted the original source from the project that it was developed in. I'll hard code a commit into the links. Try again!

[fizruk]

@sordina ok, I must be missing something, but it seems to me that cors overrides responses for OPTIONS completely, rendering provideOptions effectless. No?

[leshow]

@sordina This is the error I get when I try to replicate your example

 No instance for (Servant.Foreign.Internal.HasForeignType
                       Servant.Foreign.Internal.NoTypes
                       Servant.API.ContentTypes.NoContent
                       Integer)
      arising from a use of ‘provideOptions’
    In the expression: provideOptions api
    In the second argument of ‘($)’, namely
      ‘provideOptions api $ serve api s’
    In the second argument of ‘($)’, namely
      ‘corsWithContentType $ provideOptions api $ serve api s’

I've got servant-options added as a dependency, and my main app:

app :: IO Application
app = do
    s <- getServer
    return
        $ logStdoutDev
        $ corsWithContentType
        $ provideOptions api
        $ serve api s
    where
        corsWithContentType :: Middleware
        corsWithContentType = cors (const $ Just policy)
            where
              policy = simpleCorsResourcePolicy
                { corsRequestHeaders = ["Content-Type"] }

Am I missing something? Adding servant-foreign as a dependency didn't seem to fix the issue either.

[sordina]

@fizruk

Interesting, I just had another look at wai-cors, and it seems that you're right:

                -- Preflight CORS request
                "OPTIONS" → runExceptT (preflightHeaders policy) >>= \case
                    Left e → err e
                    Right headers → res $ WAI.responseLBS HTTP.ok200 (ch ⊕ headers) ""

But I when I was performing testing it seemed to require both wai-cors, and servant-options...

Hmm, well if it works just with wai-cors, then go with that I guess! Maybe there's still some other utility to servant-options when not using wai-cors though!