diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +0.1.0 +===== + +* Initial version + diff --git a/Confirmed-Constraints b/Confirmed-Constraints new file mode 100644 --- /dev/null +++ b/Confirmed-Constraints @@ -0,0 +1,69 @@ +constraints: MonadRandom == 0.1.12 + , aeson == 0.7.0.2 + , array == 0.4.0.1 + , attoparsec == 0.11.2.1 + , base == 4.6.0.1 + , base-unicode-symbols == 0.2.2.4 + , bifunctors == 4.1.1 + , blaze-builder == 0.3.3.2 + , bytestring == 0.10.4.0 + , case-insensitive == 1.1.0.3 + , charset == 0.3.7 + , comonad == 4.0 + , conduit == 1.0.15.1 + , constraints == 0.3.4.2 + , containers == 0.5.0.0 + , contravariant == 0.4.4 + , deepseq == 1.3.0.1 + , directory == 1.2.0.1 + , distributive == 0.4 + , dlist == 0.6.0.1 + , either == 4.1.1 + , errors == 1.4.5 + , exceptions == 0.3.3 + , filepath == 1.3.0.1 + , ghc-prim == 0.3.0.0 + , hashable == 1.2.1.0 + , http-types == 0.8.3 + , integer-gmp == 0.5.0.0 + , lens == 4.0.5 + , lifted-base == 0.2.1.1 + , mmorph == 1.0.2 + , monad-control == 0.3.2.2 + , mtl == 2.1.2 + , nats == 0.1.2 + , network == 2.4.2.2 + , newtype == 0.2 + , old-locale == 1.0.0.5 + , parallel == 3.2.0.4 + , parsec == 3.1.5 + , parsers == 0.11 + , pretty == 1.1.1.0 + , primitive == 0.5.1.0 + , profunctors == 4.0.2 + , random == 1.0.1.1 + , reflection == 1.3.2 + , resourcet == 0.4.10 + , rts == 1.0 + , safe == 0.3.3 + , scientific == 0.2.0.2 + , semigroupoids == 4.0 + , semigroups == 0.12.2 + , split == 0.2.2 + , syb == 0.4.1 + , tagged == 0.7 + , template-haskell == 2.8.0.0 + , text == 1.1.0.1 + , text-stream-decode == 0.1.0.4 + , time == 1.4.0.1 + , transformers == 0.3.0.0 + , transformers-base == 0.4.1 + , transformers-compat == 0.1.1.1 + , unix == 2.7.0.0 + , unordered-containers == 0.2.3.3 + , utf8-string == 0.3.7 + , vault == 0.3.0.3 + , vector == 0.10.9.1 + , void == 0.6.1 + , wai == 1.4.1 + , zlib == 0.5.4.1 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 AlephCloud Systems, Inc. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +Cross-Origin Resource Sharing (CORS) For Wai +============================================ + +This package provides a Haskell implemenation of CORS for +[WAI](http://hackage.haskell.org/package/wai) +that aims to be compliant with +[http://www.w3.org/TR/cors](http://www.w3.org/TR/cors). + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Network/Wai/Middleware/Cors.hs b/src/Network/Wai/Middleware/Cors.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Cors.hs @@ -0,0 +1,374 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2014 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE CPP #-} + +-- | An implemenation of Cross-Origin resource sharing (CORS) for WAI that +-- aims to be compliant with . +-- +module Network.Wai.Middleware.Cors +( CorsResourcePolicy(..) +, cors + +-- * Utils +, isSimple +, simpleResponseHeaders +, simpleHeaders +, simpleContentTypes +, simpleMethods +) where + +import Control.Applicative +import Control.Error +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource + +import qualified Data.Attoparsec as AttoParsec +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as LB8 +import qualified Data.CaseInsensitive as CI +import qualified Data.CharSet as CS +import Data.List (intersect, (\\), union) +import Data.Monoid.Unicode +import Data.String + +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as WAI + +import Prelude.Unicode + +import qualified Text.Parser.Char as P +import qualified Text.Parser.Combinators as P + +#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 RFC 6454 (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. + -- + -- 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 RFC6454 (section 6.2). In + -- particular the string @*@ is not a valid origin (but the string @null@ + -- is). + -- + 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 implicitely included an thus optional in this list. + -- + , corsRequestHeaders ∷ ![HTTP.HeaderName] + + -- | Field names of HTTP headers that are exposed on the client. + -- + , corsExposedHeaders ∷ !(Maybe [HTTP.HeaderName]) + + -- | Number of seconds that the response may be cached by the client. + -- + , 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'. + -- + , corsVaryOrigin ∷ !Bool + + -- | If this is 'True' verbose responses with HTTP status 400 (bad request) + -- are returned in case of a failure. Otherwise status 200 is used along + -- with an empty body. + -- + , corsVerboseResponse ∷ !Bool + } + deriving (Show,Read,Eq,Ord) + +-- | 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 . It 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 respective values are +-- actually supported for the Resource by the application. 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 . +-- +-- /TODO/ +-- +-- * We may consider adding 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 +-- . +-- +-- * 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 +cors policyPattern app r + | Just policy ← policyPattern r = case hdrOrigin of + + -- No origin header: requect request + Nothing → return $ corsFailure (corsVerboseResponse policy) "Origin header is missing" + + -- Origin header: apply CORS policy to request + Just origin → runEitherT (applyCorsPolicy policy origin) >>= \case + Left e → return $ corsFailure (corsVerboseResponse policy) (B8.pack e) + Right response → return response + + | otherwise = app r + + where + + -- Lookup the HTTP origin request header + -- + hdrOrigin = lookup "origin" (WAI.requestHeaders r) + + -- Process a CORS request + -- + applyCorsPolicy + ∷ CorsResourcePolicy + → Origin + → EitherT String ReqMonad WAI.Response + applyCorsPolicy policy origin = do + + -- Match request origin with corsOrigins from policy + respOrigin ← case corsOrigins policy of + Nothing → return Nothing + Just (originList, withCreds) → if origin `elem` originList + then return $ Just (origin, withCreds) + else left $ "Unsupported origin: " ⊕ B8.unpack origin + + -- 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" → do + headers ← (⊕) <$> pure ch <*> preflightHeaders policy + return $ WAI.responseLBS HTTP.ok200 headers "" + + -- Actual CORS request + _ → lift $ app r >>= addHeaders (ch ⊕ respCorsHeaders policy) + + -- Compute HTTP response headers for a preflight request + -- + preflightHeaders ∷ Monad μ ⇒ CorsResourcePolicy → EitherT String μ HTTP.ResponseHeaders + preflightHeaders policy = concat <$> sequence + [ hdrReqMethod policy + , hdrRequestHeader policy + , hdrMaxAge policy + ] + + hdrMaxAge ∷ Monad μ ⇒ CorsResourcePolicy → EitherT String μ HTTP.ResponseHeaders + hdrMaxAge policy = case corsMaxAge policy of + Nothing → return [] + Just secs → return [("Access-Control-Max-Age", sshow secs)] + + hdrReqMethod ∷ Monad μ ⇒ CorsResourcePolicy → EitherT String μ HTTP.ResponseHeaders + hdrReqMethod policy = case lookup "Access-Control-Request-Method" (WAI.requestHeaders r) of + Nothing → left "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 left + $ "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 → EitherT String μ HTTP.ResponseHeaders + hdrRequestHeader policy = case lookup "Access-Control-Request-Headers" (WAI.requestHeaders r) of + Nothing → return [] + Just hdrsBytes → do + hdrs ← hoistEither $ AttoParsec.parseOnly httpHeaderNameListParser hdrsBytes + if hdrs `isSubsetOf` supportedHeaders + then return [("Access-Control-Allow-Headers", hdrLI supportedHeaders)] + else left + $ "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 True = [("Access-Control-Allow-Origin", "*"), ("Vary", "Origin")] + commonCorsHeaders Nothing False = [("Access-Control-Allow-Origin", "*")] + commonCorsHeaders (Just (o, False)) _ = [("Access-Control-Allow-Origin", o)] + commonCorsHeaders (Just (o, True)) _ = [("Access-Control-Allow-Origin", o), ("Acdess-Control-Allow-Credentials", "true")] + + -- 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) + ] + +-- -------------------------------------------------------------------------- -- +-- Definition from Standards + +-- | Simple HTTP response headers as defined in +-- +simpleResponseHeaders ∷ [HTTP.HeaderName] +simpleResponseHeaders = + [ "Cache-Control" + , "Content-Language" + , "Content-Type" + , "Expires" + , "Last-Modified" + , "Pragma" + ] + +simpleHeaders ∷ [HTTP.HeaderName] +simpleHeaders = + [ "Accept" + , "Accept-Language" + , "Content-Language" + , "Content-Type" + ] + +simpleContentTypes ∷ [CI.CI B8.ByteString] +simpleContentTypes = + [ "application/x-www-form-urlencoded" + , "multipart/form-data" + , "text/plain" + ] + + +-- | Simple HTTP methods as defined in +-- +simpleMethods ∷ [HTTP.Method] +simpleMethods = + [ "GET" + , "HEAD" + , "POST" + ] + +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) +-- +httpHeaderNameCharSet ∷ CS.CharSet +httpHeaderNameCharSet = CS.range (toEnum 33) (toEnum 126) CS.\\ CS.fromList "()<>@,;:\\\"/[]?={}" + +httpHeaderNameParser ∷ P.CharParsing μ ⇒ μ HTTP.HeaderName +httpHeaderNameParser = fromString <$> P.some (P.oneOfSet httpHeaderNameCharSet) P. "HTTP Header Name" + +-- -------------------------------------------------------------------------- -- +-- Generic Tools + +httpHeaderNameListParser ∷ P.CharParsing μ ⇒ μ [HTTP.HeaderName] +httpHeaderNameListParser = P.spaces *> P.sepBy1 (httpHeaderNameParser <* P.spaces) (P.char ',') <* P.spaces + +sshow ∷ (IsString α, Show β) ⇒ β → α +sshow = fromString ∘ show + +isSubsetOf ∷ Eq α ⇒ [α] → [α] → Bool +isSubsetOf l1 l2 = intersect l1 l2 ≡ l1 + +-- Add HTTP headers to a WAI response +-- +addHeaders ∷ HTTP.ResponseHeaders → WAI.Response → ReqMonad WAI.Response +addHeaders hdrs res = do +#if MIN_VERSION_wai(2,0,0) + let (st, headers, src) = WAI.responseToSource res + WAI.responseSource st (headers ⊕ hdrs) <$> src return +#else + let (st, headers, src) = WAI.responseSource res + 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 + ∷ Bool -- ^ whether to generate a verbose 400 response + → B8.ByteString -- ^ body + → WAI.Response +corsFailure True msg = WAI.responseLBS HTTP.status400 [("Content-Type", "text/html; charset-utf-8")] (LB8.fromStrict msg) +corsFailure False _ = WAI.responseLBS HTTP.ok200 [] "" + diff --git a/wai-cors.cabal b/wai-cors.cabal new file mode 100644 --- /dev/null +++ b/wai-cors.cabal @@ -0,0 +1,55 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2014 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +Name: wai-cors +Version: 0.1.0 +Synopsis: CORS for WAI + +Description: + This package provides an implemenation of + Cross-Origin resource sharing (CORS) for Wai that aims to be + compliant with . + +Homepage: https://github.com/alephcloud/wai-cors +License: MIT +License-file: LICENSE +Author: Lars Kuhtz +Maintainer: lars@alephcloud.com +Copyright: Copyright (c) 2014 AlephCloud Systems, Inc. +Category: Web +Build-type: Simple +Cabal-version: >= 1.14.0 + +data-files: + README.md + CHANGELOG.md + Confirmed-Constraints + +source-repository head + type: git + location: https://github.com/alephcloud/wai-cors + +Library + default-language: Haskell2010 + hs-source-dirs: src + + exposed-modules: + Network.Wai.Middleware.Cors + + build-depends: + attoparsec >= 0.10.4.0, + base == 4.*, + base-unicode-symbols >= 0.2.2.3, + bytestring >= 0.10.0.2, + case-insensitive >= 1.0.0.1, + charset >= 0.3.7, + errors >= 1.4.1, + ghc-prim, + http-types >= 0.8.0, + lens >= 0.4, + parsers >= 0.11, + resourcet >= 0.4, + transformers >= 0.3, + wai >= 1.4.0 +