wai-cors (empty) → 0.1.0

raw patch · 7 files changed

+533/−0 lines, 7 filesdep +attoparsecdep +basedep +base-unicode-symbolssetup-changed

Dependencies added: attoparsec, base, base-unicode-symbols, bytestring, case-insensitive, charset, errors, ghc-prim, http-types, lens, parsers, resourcet, transformers, wai

Files

• CHANGELOG.md +5/−0
• Confirmed-Constraints +69/−0
• LICENSE +20/−0
• README.md +8/−0
• Setup.hs +2/−0
• src/Network/Wai/Middleware/Cors.hs +374/−0
• wai-cors.cabal +55/−0

@@ -0,0 +1,5 @@+0.1.0+=====++*   Initial version+

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

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

@@ -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).+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <http://www.w3.org/TR/cors>.+--+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 <http://www.w3.org/TR/cors/>. 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 <http://wwww.w3.org/TR/cors>.+--+-- /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+--   <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+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 <http://www.w3.org/TR/cors/>+--+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 <http://www.w3.org/TR/cors/>+--+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 [] ""+

@@ -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 <http://www.w3.org/TR/cors>.++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+