OPTIONS support

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)