{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} -- | -- Module: Network.Wai.Middleware.Cors -- Description: Cross-Origin resource sharing (CORS) for WAI -- Copyright: -- © 2015 Lars Kuhtz <lkuhtz@gmail.com, -- © 2014 AlephCloud Systems, Inc. -- License: MIT -- Maintainer: Lars Kuhtz <lakuhtz@gmail.com> -- Stability: stable -- -- An implemenation of Cross-Origin resource sharing (CORS) for WAI that -- aims to be compliant with <http://www.w3.org/TR/cors>. -- -- The function 'simpleCors' enables support of simple cross-origin requests. More -- advanced CORS policies can be enabled by passing a 'CorsResourcePolicy' to the -- 'cors' middleware. -- -- = Note On Security -- -- This implementation doens't include any server side enforcement. By -- complying with the CORS standard it enables the client (i.e. the web -- browser) to enforce the CORS policy. For application authors it is strongly -- recommended to take into account the security considerations in section 6.3 -- of <http://www.w3.org/TR/cors>. In particular the application should check -- that the value of the @Origin@ header matches it's expectations. -- -- = Websockets -- -- Websocket connections don't support CORS and are ignored by this CORS -- implementation. However Websocket requests usually (at least for some -- browsers) include the @Origin@ header. Applications are expected to check -- the value of this header and respond with an error in case that its content -- doesn't match the expectations. -- -- = Example -- -- The following is an example how to enable support for simple cross-origin requests -- for a <http://hackage.haskell.org/package/scotty scotty> application. -- -- > {-# LANGUAGE UnicodeSyntax #-} -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > module Main -- > ( main -- > ) where -- > -- > import Network.Wai.Middleware.Cors -- > import Web.Scotty -- > -- > main ∷ IO () -- > main = scotty 8080 $ do -- > middleware simpleCors -- > matchAny "/" $ text "Success" -- -- The result of following curl command will include the HTTP response header -- @Access-Control-Allow-Origin: *@. -- -- > curl -i http://127.0.0.1:8888 -H 'Origin: 127.0.0.1' -v -- module Network.Wai.Middleware.Cors ( Origin , CorsResourcePolicy(..) , simpleCorsResourcePolicy , cors , simpleCors -- * Utils , isSimple , simpleResponseHeaders , simpleHeaders , simpleContentTypes , simpleMethods ) where #ifndef MIN_VESION_base #define MIN_VESION_base(x,y,z) 1 #endif #ifndef MIN_VESION_wai #define MIN_VESION_wai(x,y,z) 1 #endif #if ! MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Monad.Error.Class import Control.Monad.Trans.Except #if ! MIN_VERSION_wai(2,0,0) import Control.Monad.Trans.Resource #endif import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as LB8 import qualified Data.CaseInsensitive as CI import Data.List (intersect, (\\), union) import Data.Maybe (catMaybes) #if ! MIN_VERSION_base(4,8,0) import Data.Monoid (mempty) #endif import Data.Monoid.Unicode import Data.String import qualified Network.HTTP.Types as HTTP import qualified Network.Wai as WAI import Prelude.Unicode {- #if MIN_VERSION_wai(2,0,0) type ReqMonad = IO #else type ReqMonad = ResourceT IO #endif -} -- | Origins are expected to be formated as described in -- <https://www.ietf.org/rfc/rfc6454.txt RFC6454> (section 6.2). -- In particular the string @*@ is not a valid origin (but the string -- @null@ is). -- type Origin = B8.ByteString data CorsResourcePolicy = CorsResourcePolicy { -- | HTTP origins that are allowed in CORS requests. -- -- A value of 'Nothing' indicates unrestricted cross-origin sharing and -- results in @*@ as value for the @Access-Control-Allow-Origin@ HTTP -- response header. Note if you send @*@, credentials cannot be sent with the request. -- -- A value other than 'Nothing' is a tuple that consists of a list of -- origins each with a Boolean flag that indicates if credentials are used -- to access the resource via CORS. -- -- Origins must be formated as described in -- <https://www.ietf.org/rfc/rfc6454.txt RFC6454> (section 6.2). In -- particular the string @*@ is not a valid origin (but the string @null@ -- is). -- -- Credentials include cookies, authorization headers and TLS client certificates. -- For credentials to be sent with requests, the @withCredentials@ setting of -- @XmlHttpRequest@ in the browser must be set to @true@. -- corsOrigins ∷ !(Maybe ([Origin], Bool)) -- | HTTP methods that are allowed in CORS requests. -- , corsMethods ∷ ![HTTP.Method] -- | Field names of HTTP request headers that are allowed in CORS requests. -- Header names that are included in 'simpleHeaders', except for -- @content-type@, are implicitly included and thus optional in this list. -- , corsRequestHeaders ∷ ![HTTP.HeaderName] -- | Field names of HTTP headers that are exposed to the client in the response. -- , corsExposedHeaders ∷ !(Maybe [HTTP.HeaderName]) -- | Number of seconds that the OPTIONS preflight response may be cached by the client. -- -- Tip: Set this to 'Nothing' while testing your CORS implementation, then increase -- it once you deploy to production. -- , corsMaxAge ∷ !(Maybe Int) -- | If the resource is shared by multiple origins but -- @Access-Control-Allow-Origin@ is not set to @*@ this may be set to -- 'True' to cause the server to include a @Vary: Origin@ header in the -- response, thus indicating that the value of the -- @Access-Control-Allow-Origin@ header may vary between different requests -- for the same resource. This prevents caching of the responses which may -- not apply accross different origins. -- , corsVaryOrigin ∷ !Bool -- | If this is 'True' and the request does not include an @Origin@ header -- the response has HTTP status 400 (bad request) and the body contains -- a short error message. -- -- If this is 'False' and the request does not include an @Origin@ header -- the request is passed on unchanged to the application. -- -- @since 0.2 , corsRequireOrigin ∷ !Bool -- | In the case that -- -- * the request contains an @Origin@ header and -- -- * the client does not conform with the CORS protocol -- (/request is out of scope/) -- -- then -- -- * the request is passed on unchanged to the application if this field is -- 'True' or -- -- * an response with HTTP status 400 (bad request) and short -- error message is returned if this field is 'False'. -- -- Note: Your application needs to will receive preflight OPTIONS requests if set to 'True'. -- -- @since 0.2 -- , corsIgnoreFailures ∷ !Bool } deriving (Show,Read,Eq,Ord) -- | A 'CorsResourcePolicy' that supports /simple cross-origin requests/ as defined -- in <http://www.w3.org/TR/cors/>. -- -- * The HTTP header @Access-Control-Allow-Origin@ is set to @*@. -- -- * Request methods are constraint to /simple methods/ (@GET@, @HEAD@, @POST@). -- -- * Request headers are constraint to /simple request headers/ -- (@Accept@, @Accept-Language@, @Content-Language@, @Content-Type@). -- -- * If the request is a @POST@ request the content type is constraint to -- /simple content types/ -- (@application/x-www-form-urlencoded@, @multipart/form-data@, @text/plain@), -- -- * Only /simple response headers/ may be exposed on the client -- (@Cache-Control@, @Content-Language@, @Content-Type@, @Expires@, @Last-Modified@, @Pragma@) -- -- * The @Vary-Origin@ header is left unchanged (possibly unset). -- -- * If the request doesn't include an @Origin@ header the request is passed unchanged to -- the application. -- -- * If the request includes an @Origin@ header but does not conform to the CORS -- protocol (/request is out of scope/) an response with HTTP status 400 (bad request) -- and a short error message is returned. -- -- For /simple cross-origin requests/ a preflight request is not required. However, if -- the client chooses to make a preflight request it is answered in accordance with -- the policy for /simple cross-origin requests/. -- simpleCorsResourcePolicy ∷ CorsResourcePolicy simpleCorsResourcePolicy = CorsResourcePolicy { corsOrigins = Nothing , corsMethods = simpleMethods , corsRequestHeaders = [] , corsExposedHeaders = Nothing , corsMaxAge = Nothing , corsVaryOrigin = False , corsRequireOrigin = False , corsIgnoreFailures = False } -- | A Cross-Origin resource sharing (CORS) middleware. -- -- The middleware is given a function that serves as a pattern to decide -- whether a requested resource is available for CORS. If the match fails with -- 'Nothing' the request is passed unmodified to the inner application. -- -- The current version of this module does only aim at compliance with the CORS -- protocol as specified in <http://www.w3.org/TR/cors/>. In accordance with -- that standard the role of the server side is to support the client to -- enforce CORS restrictions. This module does not implement any enforcement of -- authorization policies that are possibly implied by the -- 'CorsResourcePolicy'. It is up to the inner WAI application to enforce such -- policy and make sure that it is in accordance with the configuration of the -- 'cors' middleware. -- -- Matches are done as follows: @*@ matches every origin. For all other cases a -- match succeeds if and only if the ASCII serializations (as described in -- RCF6454 section 6.2) are equal. -- -- The OPTIONS method may return options for resources that are not actually -- available. In particular for preflight requests the implementation returns -- for the HTTP response headers @Access-Control-Allow-Headers@ and -- @Access-Control-Allow-Methods@ all values specified in the -- 'CorsResourcePolicy' together with the respective values for simple requests -- (except @content-type@). This does not imply that the application actually -- supports the respective values are for the requested resource. Thus, -- depending on the application, an actual request may still fail with 404 even -- if the preflight request /supported/ the usage of the HTTP method with CORS. -- -- The implementation does not distinguish between simple requests and requests -- that require preflight. The client is free to omit a preflight request or do -- a preflight request in cases when it wouldn't be required. -- -- For application authors it is strongly recommended to take into account the -- security considerations in section 6.3 of <http://www.w3.org/TR/cors>. -- -- /TODO/ -- -- * We may consider adding optional enforcment aspects to this module: we may -- check if a request respects our origin restrictions and we may check that a -- CORS request respects the restrictions that we publish in the preflight -- responses. -- -- * Even though slightly out of scope we may (optionally) check if -- host header matches the actual host of the resource, since clients -- using CORS may expect this, since this check is recommended in -- <http://www.w3.org/TR/cors>. -- -- * We may consider integrating CORS policy handling more closely with the -- handling of the source, for instance by integrating with 'ActionM' from -- scotty. -- cors ∷ (WAI.Request → Maybe CorsResourcePolicy) -- ^ A value of 'Nothing' indicates that the resource is not available for CORS → WAI.Middleware #if MIN_VERSION_wai(3,0,0) cors policyPattern app r respond #else cors policyPattern app r #endif -- We don't handle websockets, even if they include an @Origin@ header | isWebSocketsReq r = runApp | Just policy ← policyPattern r = case hdrOrigin of -- No origin header: requect request Nothing → if corsRequireOrigin policy then res $ corsFailure "Origin header is missing" else runApp -- Origin header: apply CORS policy to request Just origin → applyCorsPolicy policy origin | otherwise = runApp where #if MIN_VERSION_wai(3,0,0) res = respond runApp = app r respond #else res = return runApp = app r #endif -- Lookup the HTTP origin request header -- hdrOrigin = lookup "origin" (WAI.requestHeaders r) -- Process a CORS request -- applyCorsPolicy policy origin = do -- The error continuation let err e = if corsIgnoreFailures policy then runApp else res $ corsFailure (B8.pack e) -- Match request origin with corsOrigins from policy let respOriginOrErr = case corsOrigins policy of Nothing → return Nothing Just (originList, withCreds) → if origin `elem` originList then Right $ Just (origin, withCreds) else Left $ "Unsupported origin: " ⊕ B8.unpack origin case respOriginOrErr of Left e → err e Right respOrigin → do -- Determine headers that are common to actuall responses and preflight responses let ch = commonCorsHeaders respOrigin (corsVaryOrigin policy) case WAI.requestMethod r of -- Preflight CORS request "OPTIONS" → runExceptT (preflightHeaders policy) >>= \case Left e → err e Right headers → res $ WAI.responseLBS HTTP.ok200 (ch ⊕ headers) "" -- Actual CORS request #if MIN_VERSION_wai(3,0,0) _ → addHeaders (ch ⊕ respCorsHeaders policy) app r respond #else _ → addHeaders (ch ⊕ respCorsHeaders policy) app r #endif -- Compute HTTP response headers for a preflight request -- preflightHeaders ∷ (Functor μ, Monad μ) ⇒ CorsResourcePolicy → ExceptT String μ HTTP.ResponseHeaders preflightHeaders policy = concat <$> sequence [ hdrReqMethod policy , hdrRequestHeader policy , hdrMaxAge policy ] hdrMaxAge ∷ Monad μ ⇒ CorsResourcePolicy → ExceptT String μ HTTP.ResponseHeaders hdrMaxAge policy = case corsMaxAge policy of Nothing → return [] Just secs → return [("Access-Control-Max-Age", sshow secs)] hdrReqMethod ∷ Monad μ ⇒ CorsResourcePolicy → ExceptT String μ HTTP.ResponseHeaders hdrReqMethod policy = case lookup "Access-Control-Request-Method" (WAI.requestHeaders r) of Nothing → throwError "Access-Control-Request-Method header is missing in CORS preflight request" Just x → if x `elem` supportedMethods then return [("Access-Control-Allow-Methods", hdrL supportedMethods)] else throwError $ "Method requested in Access-Control-Request-Method of CORS request is not supported; requested: " ⊕ B8.unpack x ⊕ "; supported are " ⊕ B8.unpack (hdrL supportedMethods) ⊕ "." where supportedMethods = corsMethods policy `union` simpleMethods hdrRequestHeader ∷ Monad μ ⇒ CorsResourcePolicy → ExceptT String μ HTTP.ResponseHeaders hdrRequestHeader policy = case lookup "Access-Control-Request-Headers" (WAI.requestHeaders r) of Nothing → return [] Just hdrsBytes → do hdrs ← either throwError return $ P.parseOnly httpHeaderNameListParser hdrsBytes if hdrs `isSubsetOf` supportedHeaders then return [("Access-Control-Allow-Headers", hdrLI supportedHeaders)] else throwError $ "HTTP header requested in Access-Control-Request-Headers of CORS request is not supported; requested: " ⊕ B8.unpack (hdrLI hdrs) ⊕ "; supported are " ⊕ B8.unpack (hdrLI supportedHeaders) ⊕ "." where supportedHeaders = corsRequestHeaders policy `union` simpleHeadersWithoutContentType simpleHeadersWithoutContentType = simpleHeaders \\ ["content-type"] -- HTTP response headers that are common to normal and preflight CORS responses -- commonCorsHeaders ∷ Maybe (Origin, Bool) → Bool → HTTP.ResponseHeaders commonCorsHeaders Nothing _ = [("Access-Control-Allow-Origin", "*")] commonCorsHeaders (Just (o, creds)) vary = [] ⊕ (True ?? ("Access-Control-Allow-Origin", o)) ⊕ (creds ?? ("Access-Control-Allow-Credentials", "true")) ⊕ (vary ?? ("Vary", "Origin")) where (??) a b = if a then pure b else mempty -- HTTP response headers that are only used with normal CORS responses -- respCorsHeaders ∷ CorsResourcePolicy → HTTP.ResponseHeaders respCorsHeaders policy = catMaybes [ fmap (\x → ("Access-Control-Expose-Headers", hdrLI x)) (corsExposedHeaders policy) ] -- | A CORS middleware that supports simple cross-origin requests for all -- resources. -- -- This middleware does not check if the resource corresponds to the -- restrictions for simple requests. This is in accordance with -- <http://www.w3.org/TR/cors/>. It is the responsibility of the -- client (user-agent) to enforce CORS policy. The role of the server -- is to provide the client with the respective policy constraints. -- -- It is out of the scope of the this module if the server chooses to -- enforce rules on its resources in relation to CORS policy itself. -- simpleCors ∷ WAI.Middleware simpleCors = cors (const $ Just simpleCorsResourcePolicy) -- -------------------------------------------------------------------------- -- -- Definition from Standards -- | Simple HTTP response headers as defined in <https://www.w3.org/TR/cors/#simple-response-header> -- simpleResponseHeaders ∷ [HTTP.HeaderName] simpleResponseHeaders = [ "Cache-Control" , "Content-Language" , "Content-Type" , "Expires" , "Last-Modified" , "Pragma" ] -- | Simple HTTP headers are defined in <https://www.w3.org/TR/cors/#simple-header> simpleHeaders ∷ [HTTP.HeaderName] simpleHeaders = [ "Accept" , "Accept-Language" , "Content-Language" , "Content-Type" ] -- | Simple content types are defined in <https://www.w3.org/TR/cors/#simple-header> simpleContentTypes ∷ [CI.CI B8.ByteString] simpleContentTypes = [ "application/x-www-form-urlencoded" , "multipart/form-data" , "text/plain" ] -- | Simple HTTP methods as defined in <https://www.w3.org/TR/cors/#simple-method> -- simpleMethods ∷ [HTTP.Method] simpleMethods = [ "GET" , "HEAD" , "POST" ] -- | Whether the given method and headers constitute a simple request, -- i.e. the method is simple, all headers are simple, and, if a POST request, -- the content-type is simple. isSimple ∷ HTTP.Method → HTTP.RequestHeaders → Bool isSimple method headers = method `elem` simpleMethods ∧ map fst headers `isSubsetOf` simpleHeaders ∧ case (method, lookup "content-type" headers) of ("POST", Just x) → CI.mk x `elem` simpleContentTypes _ → True -- | Valid characters for HTTP header names according to RFC2616 (section 4.2) -- isHttpHeaderNameChar ∷ Char → Bool isHttpHeaderNameChar c = (c ≥ toEnum 33) && (c ≤ toEnum 126) && P.notInClass "()<>@,;:\\\"/[]?={}" c httpHeaderNameParser ∷ P.Parser HTTP.HeaderName httpHeaderNameParser = fromString <$> P.many1 (P.satisfy isHttpHeaderNameChar) P.<?> "HTTP Header Name" -- -------------------------------------------------------------------------- -- -- Generic Tools -- | A comma separated list of whitespace surounded HTTP header names. -- -- Note that 'P.space' includes @SP@ (32), @HT@ (9), @LF@ (10), @VT@ (11), -- @NP@ (12), and @CR@ (13). RFC 2616 (2.2) only defines @SP@ (32) and -- @LWS = [CRLF] 1*(SP | HT)@ as whitespace. That's fine here since neither -- of these characters is allowed in header names. -- httpHeaderNameListParser ∷ P.Parser [HTTP.HeaderName] httpHeaderNameListParser = spaces *> P.sepBy (httpHeaderNameParser <* spaces) (P.char ',') <* spaces where spaces = P.many' P.space sshow ∷ (IsString α, Show β) ⇒ β → α sshow = fromString ∘ show isSubsetOf ∷ Eq α ⇒ [α] → [α] → Bool isSubsetOf l1 l2 = intersect l1 l2 ≡ l1 -- | Add HTTP headers to a WAI response -- #if MIN_VERSION_wai(3,0,0) addHeaders ∷ HTTP.ResponseHeaders → WAI.Middleware addHeaders hdrs app req respond = app req $ \response → do let (st, headers, streamHandle) = WAI.responseToStream response streamHandle $ \streamBody → respond $ WAI.responseStream st (headers ⊕ hdrs) streamBody #elif MIN_VERSION_wai(2,0,0) addHeaders ∷ HTTP.ResponseHeaders → WAI.Middleware addHeaders hdrs app req = do (st, headers, src) ← WAI.responseToSource <$> app req WAI.responseSource st (headers ⊕ hdrs) <$> src return #else addHeaders ∷ HTTP.ResponseHeaders → WAI.Middleware addHeaders hdrs app req = do (st, headers, src) ← WAI.responseSource <$> app req return $ WAI.ResponseSource st (headers ⊕ hdrs) src #endif -- | Format a list of 'HTTP.HeaderName's such that it can be used as -- an HTTP header value -- hdrLI ∷ [HTTP.HeaderName] → B8.ByteString hdrLI l = B8.intercalate ", " (map CI.original l) -- | Format a list of 'B8.ByteString's such that it can be used as -- an HTTP header value -- hdrL ∷ [B8.ByteString] → B8.ByteString hdrL l = B8.intercalate ", " l corsFailure ∷ B8.ByteString -- ^ body → WAI.Response corsFailure msg = WAI.responseLBS HTTP.status400 [("Content-Type", "text/html; charset-utf-8")] (LB8.fromStrict msg) -- Copied from the [wai-websocket package](https://github.com/yesodweb/wai/blob/master/wai-websockets/Network/Wai/Handler/WebSockets.hs#L21) -- isWebSocketsReq ∷ WAI.Request → Bool isWebSocketsReq req = fmap CI.mk (lookup "upgrade" $ WAI.requestHeaders req) == Just "websocket"