diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +0.2.4 +===== + +* Fix [bug #1](https://github.com/larskuhtz/wai-cors/issues/1). + Response header `Vary: Origin` is now included when `corsVaryOrigin` + is `True` and `corsOrigins` does not equal `Nothing`. + 0.2.3 ===== diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,4 @@ +Copyright (c) 2015 Lars Kuhtz Copyright (c) 2014 AlephCloud Systems, Inc. Permission is hereby granted, free of charge, to any person obtaining diff --git a/constraints b/constraints --- a/constraints +++ b/constraints @@ -1,30 +1,82 @@ -constraints: array ==0.5.1.0, +constraints: SHA ==1.6.4.2, + ansi-terminal ==0.6.2.1, + ansi-wl-pprint ==0.6.7.2, + appar ==0.1.4, + array ==0.5.1.0, + async ==2.0.2, attoparsec ==0.13.0.0, + auto-update ==0.1.2.1, base ==4.8.0.0, base-unicode-symbols ==0.2.2.4, + base64-bytestring ==1.0.0.1, binary ==0.7.3.0, blaze-builder ==0.4.0.1, + byteorder ==1.0.4, bytestring ==0.10.6.0, + bytestring-builder ==0.10.6.0.0, case-insensitive ==1.2.0.4, charset ==0.3.7.1, containers ==0.5.6.2, + cookie ==0.4.1.5, + data-default-class ==0.0.1, deepseq ==1.4.1.1, + directory ==1.2.2.0, + easy-file ==0.2.1, + entropy ==0.3.6, + exceptions ==0.8.0.2, + fast-logger ==2.3.1, + filepath ==1.4.0.0, ghc-prim ==0.4.0.0, hashable ==1.2.3.2, + http-date ==0.0.6.1, http-types ==0.8.6, integer-gmp ==1.0.0.0, + iproute ==1.4.0, + lifted-base ==0.2.3.6, + mmorph ==1.0.4, + monad-control ==1.0.0.4, mtl ==2.2.1, nats ==1, network ==2.6.1.0, + old-locale ==1.0.0.7, + old-time ==1.1.0.3, + optparse-applicative ==0.11.0.2, parsec ==3.1.9, parsers ==0.12.2.1, + pretty ==1.1.2.0, + process ==1.2.3.0, + random ==1.1, + regex-base ==0.93.2, + regex-tdfa-rc ==1.1.8.3, + resourcet ==1.1.5, rts ==1.0, scientific ==0.3.3.8, semigroups ==0.16.2.2, + simple-sendfile ==0.2.20, + stm ==2.4.4, + streaming-commons ==0.1.12.1, + stringsearch ==0.3.6.6, + tagged ==0.8.0.1, + tasty ==0.10.1.2, + tasty-hunit ==0.9.2, + template-haskell ==2.10.0.0, text ==1.2.1.0, time ==1.5.0.1, transformers ==0.4.2.0, + transformers-base ==0.4.4, + transformers-compat ==0.4.0.4, + unbounded-delays ==0.1.0.9, unix ==2.7.1.0, + unix-compat ==0.4.1.4, + unix-time ==0.3.5, unordered-containers ==0.2.5.1, vault ==0.3.0.4, - wai ==3.0.2.3 + void ==0.7, + wai ==3.0.2.3, + wai-extra ==3.0.7.1, + wai-logger ==2.2.4, + wai-websockets ==3.0.0.5, + warp ==3.0.13.1, + websockets ==0.9.5.0, + word8 ==0.1.2, + zlib ==0.5.4.2 diff --git a/src/Network/Wai/Middleware/Cors.hs b/src/Network/Wai/Middleware/Cors.hs --- a/src/Network/Wai/Middleware/Cors.hs +++ b/src/Network/Wai/Middleware/Cors.hs @@ -1,8 +1,3 @@ --- ------------------------------------------------------ -- --- Copyright © 2015 Lars Kuhtz --- Copyright © 2014 AlephCloud Systems, Inc. --- ------------------------------------------------------ -- - {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,7 +7,17 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} --- | An implemenation of Cross-Origin resource sharing (CORS) for WAI that +-- | +-- Module: Network.Wai.Middleware.Cors +-- Description: Cross-Origin resource sharing (CORS) for WAI +-- Copyright: +-- © 2015 Lars Kuhtz +-- Stability: stable +-- +-- An implemenation of Cross-Origin resource sharing (CORS) for WAI that -- aims to be compliant with . -- -- The function 'simpleCors' enables support of simple cross-origin requests. More @@ -100,6 +105,9 @@ import qualified Data.CharSet as CS 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 @@ -111,14 +119,17 @@ 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 +-- | Origins are expected to be formated as described in +-- (section 6.2). +-- In particular the string @*@ is not a valid origin (but the string -- @null@ is). -- type Origin = B8.ByteString @@ -136,7 +147,8 @@ -- 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 + -- Origins must be formated as described in + -- (section 6.2). In -- particular the string @*@ is not a valid origin (but the string @null@ -- is). -- @@ -162,7 +174,11 @@ -- | If the resource is shared by multiple origins but -- @Access-Control-Allow-Origin@ is not set to @*@ this may be set to - -- 'True'. + -- '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 @@ -337,13 +353,13 @@ else res $ corsFailure (B8.pack e) -- Match request origin with corsOrigins from policy - let respOrigin = case corsOrigins policy of + 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 respOrigin of + case respOriginOrErr of Left e → err e Right respOrigin → do @@ -413,10 +429,13 @@ -- 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), ("Access-Control-Allow-Credentials", "true")] + 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 -- diff --git a/test/PhantomJS.hs b/test/PhantomJS.hs --- a/test/PhantomJS.hs +++ b/test/PhantomJS.hs @@ -35,7 +35,7 @@ phantomJsArgs ∷ IsString a ⇒ [a] phantomJsArgs = ["--ignore-ssl-errors=true"] ---phantomJsArgs = ["--ignore-ssl-errors=true", "--debug=true"] +-- phantomJsArgs = ["--ignore-ssl-errors=true", "--debug=true"] phantomJsScriptPath ∷ FilePath phantomJsScriptPath = "test/phantomjs.js" diff --git a/test/Server.hs b/test/Server.hs --- a/test/Server.hs +++ b/test/Server.hs @@ -35,19 +35,37 @@ import qualified Data.Text as T main ∷ IO () -main = withSocketsDo $ - WARP.run 8080 $ simpleCors waiapp +main = withSocketsDo . WARP.run 8080 $ server -waiapp ∷ WAI.Application -waiapp = WS.websocketsOr WS.defaultConnectionOptions wsserver $ \_ → app +-- -------------------------------------------------------------------------- -- +-- Server application + +server ∷ WAI.Application +server = cors corsPolicy $ \request → + case WAI.pathInfo request of + "cors":_ → corsapp request + _ → testapp where #if MIN_VERSION_wai(2,0,0) - app respond = respond $ WAI.responseLBS HTTP.status200 [] "Success" + testapp respond = respond $ WAI.responseFile HTTP.status200 [] "index.html" Nothing + corsapp = WS.websocketsOr WS.defaultConnectionOptions wsserver $ \_ respond → + respond $ WAI.responseLBS HTTP.status200 [] "Success" #else - app = WAI.responseLBS HTTP.status200 [] "Success" + testapp = WAI.responseFile HTTP.status200 [] "index.html" Nothing + corsapp = WS.websocketsOr WS.defaultConnectionOptions wsserver $ \_ → + WAI.responseLBS HTTP.status200 [] "Success" #endif -- -------------------------------------------------------------------------- -- +-- CORS Policy + +corsPolicy ∷ WAI.Request → Maybe CorsResourcePolicy +corsPolicy request = case WAI.pathInfo request of + "cors" : "non-simple":_ → Just nonSimplePolicy + "cors" : "simple":_ → Just simpleCorsResourcePolicy + _ → Nothing + +-- -------------------------------------------------------------------------- -- -- Websockets Server wsserver ∷ WS.ServerApp @@ -60,4 +78,33 @@ go c = do msg ← WS.receiveDataMessage c forkIO $ WS.sendDataMessage c msg + +-- -------------------------------------------------------------------------- -- +-- Non Simple Policy + +-- | Perform the following tests the following with this policy: +-- +-- * @Variy: Origin@ header is set on responses +-- * @X-cors-test@ header is accepted +-- * @X-cors-test@ header is exposed on response +-- * @Access-Control-Allow-Origin@ header is set on responses to the request host +-- * @DELETE@ requests are not allowed +-- * @PUT@ requests are allowed +-- * Requests that don't include an @Origin@ header result in 400 responses +-- (it's not clear how to test this with a browser client) +-- +-- Note that Chrome sends @Origin: null@ when loaded from a "file://..." URL, +-- PhantomJS sends "file://". +-- +nonSimplePolicy :: CorsResourcePolicy +nonSimplePolicy = CorsResourcePolicy + { corsOrigins = Just (["http://localhost:8080", "null", "file://"], False) + , corsMethods = ["PUT"] + , corsRequestHeaders = ["X-cors-test"] + , corsExposedHeaders = Just ["X-cors-test", "Vary"] + , corsMaxAge = Nothing + , corsVaryOrigin = True + , corsRequireOrigin = True + , corsIgnoreFailures = False + } diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/UnitTests.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnicodeSyntax #-} + +-- | +-- Module: UnitTests +-- Description: Unit Tests for wai-cors +-- Copyright: © 2015 Lars Kuhtz . +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Main +( main + +, post +, patch +, delete +, put +, get +, options +, head +) where + +#ifndef MIN_VERSION_wai +#define MIN_VERSION_wai(a,b,c) 1 +#endif + +import Network.Wai.Middleware.Cors +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as WAI +import Network.Wai.Test + +import Prelude hiding (head) + +import Test.Tasty +import Test.Tasty.HUnit + +-- -------------------------------------------------------------------------- -- +-- Unit tests + +main ∷ IO () +main = defaultMain tests + +tests ∷ TestTree +tests = testGroup "unit tests" + [ testCase "Origins any" test_originsAny + , testCase "Origins null" test_originsNull + , testCase "Any Origin" test_anyOrigin + , testCase "Require Origin" test_requireOrigin + , testCase "Missing Require Origin" test_missingRequireOrigin + , testCase "Vary Origin Header" test_varyOriginHeader + , testCase "Vary Origin No Header" test_varyOriginNoHeader + ] + +test_originsAny ∷ Assertion +test_originsAny = corsSession policy $ do + resp <- request get + assertHeader "Access-Control-Allow-Origin" "*" resp + assertStatus 200 resp + where + policy = simpleCorsResourcePolicy + { corsOrigins = Nothing + } + +test_originsNull ∷ Assertion +test_originsNull = corsSession policy $ do + resp <- request get + assertHeader "Access-Control-Allow-Origin" "null" resp + assertStatus 200 resp + where + policy = simpleCorsResourcePolicy + { corsOrigins = Just (["null"], False) + } + +test_missingRequireOrigin ∷ Assertion +test_missingRequireOrigin = corsSession policy $ do + resp <- request $ defaultRequest { WAI.requestMethod = "GET" } + assertStatus 400 resp + where + policy = simpleCorsResourcePolicy + { corsRequireOrigin = True + } + +test_requireOrigin ∷ Assertion +test_requireOrigin = corsSession policy $ do + resp <- request get + assertStatus 200 resp + where + policy = simpleCorsResourcePolicy + { corsRequireOrigin = True + } + +test_anyOrigin ∷ Assertion +test_anyOrigin = corsSession policy $ do + resp <- request get + assertStatus 200 resp + where + policy = simpleCorsResourcePolicy + { corsOrigins = Nothing + } + +test_varyOriginHeader ∷ Assertion +test_varyOriginHeader = corsSession policy $ do + resp <- request put + assertStatus 200 resp + assertHeader "Vary" "Origin" resp + where + policy = simpleCorsResourcePolicy + { corsOrigins = Just (["null"], False) + , corsVaryOrigin = True + } + +test_varyOriginNoHeader ∷ Assertion +test_varyOriginNoHeader = corsSession policy $ do + resp <- request put + assertStatus 200 resp + assertNoHeader "Vary" resp + where + policy = simpleCorsResourcePolicy + { corsOrigins = Nothing + , corsVaryOrigin = True + } + +-- -------------------------------------------------------------------------- -- +-- Test Requests + +corsSession ∷ CorsResourcePolicy → Session () → Assertion +corsSession policy session = runSession session . cors (const $ Just policy) $ app + +corsRequest ∷ WAI.Request +corsRequest = WAI.defaultRequest + { WAI.pathInfo = ["cors"] + , WAI.requestHeaders = [("Origin", "null")] + } + +get, post, put, patch, delete, head, options ∷ WAI.Request +get = corsRequest { WAI.requestMethod = "GET" } +post = corsRequest { WAI.requestMethod = "POST" } +put = corsRequest { WAI.requestMethod = "PUT" } +patch = corsRequest { WAI.requestMethod = "PATCH" } +delete = corsRequest { WAI.requestMethod = "DELETE" } +head = corsRequest { WAI.requestMethod = "HEAD" } +options = corsRequest { WAI.requestMethod = "OPTIONS" } + +app ∷ WAI.Application +#if MIN_VERSION_wai(2,0,0) +app _ respond = respond $ WAI.responseLBS HTTP.status200 [] "Success" +#else +app _ = WAI.responseLBS HTTP.status200 [] "Success" +#endif + diff --git a/test/index.html b/test/index.html --- a/test/index.html +++ b/test/index.html @@ -1,7 +1,7 @@ - +