diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 1.0.1.1 +version: 1.0.2.0 synopsis: Snap: A Haskell Web Framework (core interfaces and types) description: @@ -85,6 +85,11 @@ Default: False +Flag network-uri + Description: Get Network.URI from the network-uri package + Default: True + + Library Default-language: Haskell2010 hs-source-dirs: src @@ -108,6 +113,7 @@ Snap.Internal.Parsing, Snap.Test, Snap.Types.Headers, + Snap.Util.CORS, Snap.Util.FileServe, Snap.Util.FileUploads, Snap.Util.GZip, @@ -134,13 +140,14 @@ filepath >= 1.1 && < 2.0, lifted-base >= 0.1 && < 0.3, io-streams >= 1.3 && < 1.4, + hashable >= 1.2.0.6 && < 1.3, monad-control >= 1.0 && < 1.1, mtl >= 2.0 && < 2.3, random >= 1 && < 2, readable >= 0.1 && < 0.4, regex-posix >= 0.95 && < 1, text >= 0.11 && < 1.3, - time >= 1.0 && < 1.7, + time >= 1.0 && < 1.9, transformers >= 0.3 && < 0.6, transformers-base >= 0.4 && < 0.5, unix-compat >= 0.3 && < 0.5, @@ -170,7 +177,14 @@ else ghc-options: -Wall -fwarn-tabs + if flag(network-uri) + build-depends: network-uri >= 2.6 && < 2.7, + network >= 2.6 && < 2.7 + else + build-depends: network-uri >= 2.5 && < 2.6, + network >= 2.3 && < 2.6 + Test-suite testsuite hs-source-dirs: src test Type: exitcode-stdio-1.0 @@ -249,6 +263,13 @@ test-framework-hunit >= 0.2.7 && <0.4, test-framework-quickcheck2 >= 0.2.12.1 && <0.4, zlib >= 0.5 && <0.7 + + if flag(network-uri) + build-depends: network-uri >= 2.6 && < 2.7, + network >= 2.6 && < 2.7 + else + build-depends: network-uri >= 2.5 && < 2.6, + network >= 2.3 && < 2.6 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind diff --git a/src/Snap/Internal/Parsing.hs b/src/Snap/Internal/Parsing.hs --- a/src/Snap/Internal/Parsing.hs +++ b/src/Snap/Internal/Parsing.hs @@ -9,7 +9,7 @@ import Control.Applicative (Alternative ((<|>)), Applicative (pure, (*>), (<*)), liftA2, (<$>)) import Control.Arrow (first, second) import Control.Monad (Monad (return), MonadPlus (mzero), liftM, when) -import Data.Attoparsec.ByteString.Char8 (IResult (Done, Fail, Partial), Parser, Result, anyChar, char, choice, decimal, endOfInput, feed, inClass, isDigit, isSpace, letter_ascii, many', match, option, parse, satisfy, skipSpace, skipWhile, string, take, takeTill, takeWhile) +import Data.Attoparsec.ByteString.Char8 (IResult (Done, Fail, Partial), Parser, Result, anyChar, char, choice, decimal, endOfInput, feed, inClass, isDigit, isSpace, letter_ascii, many', match, option, parse, satisfy, skipSpace, skipWhile, string, take, takeTill, takeWhile, sepBy') import qualified Data.Attoparsec.ByteString.Char8 as AP import Data.Bits (Bits (unsafeShiftL, (.&.), (.|.))) import Data.ByteString.Builder (Builder, byteString, char8, toLazyByteString, word8) @@ -269,6 +269,14 @@ , ':', '\\', '\"', '/', '[', ']' , '?', '=', '{', '}' ] ] + + +------------------------------------------------------------------------------ +{-# INLINE pTokens #-} +-- | Used for "#field-name", and field-name = token, so "#token": +-- comma-separated tokens/field-names, like a header field list. +pTokens :: Parser [ByteString] +pTokens = (skipSpace *> pToken <* skipSpace) `sepBy'` char ',' ------------------ diff --git a/src/Snap/Util/CORS.hs b/src/Snap/Util/CORS.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Util/CORS.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Add (cross-origin resource sharing) +-- headers to a Snap application. CORS headers can be added either conditionally +-- or unconditionally to the entire site, or you can apply CORS headers to a +-- single route. +-- +-- To use in a snaplet, simply use 'wrapSite': +-- +-- @ +-- wrapSite $ applyCORS defaultOptions +-- @ +module Snap.Util.CORS + ( -- * Applying CORS to a specific response + applyCORS + + -- * Option Specification + , CORSOptions(..) + , defaultOptions + + -- ** Origin lists + , OriginList(..) + , OriginSet, mkOriginSet, origins + + -- * Internals + , HashableURI(..), HashableMethod (..) + ) where + +import Control.Applicative +import Control.Monad (join, when) +import Data.CaseInsensitive (CI) +import Data.Hashable (Hashable(..)) +import Data.Maybe (fromMaybe) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Network.URI (URI (..), URIAuth (..), parseURI) + +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec +import qualified Data.ByteString.Char8 as S +import qualified Data.CaseInsensitive as CI +import qualified Data.HashSet as HashSet +import qualified Data.Text as Text + +import qualified Snap.Core as Snap +import Snap.Internal.Parsing (pTokens) + +-- | A set of origins. RFC 6454 specifies that origins are a scheme, host and +-- port, so the 'OriginSet' wrapper around a 'HashSet.HashSet' ensures that each +-- 'URI' constists of nothing more than this. +newtype OriginSet = OriginSet { origins :: HashSet.HashSet HashableURI } + +-- | Used to specify the contents of the @Access-Control-Allow-Origin@ header. +data OriginList + = Everywhere + -- ^ Allow any origin to access this resource. Corresponds to + -- @Access-Control-Allow-Origin: *@ + | Nowhere + -- ^ Do not allow cross-origin requests + | Origins OriginSet + -- ^ Allow cross-origin requests from these origins. + +-- | Specify the options to use when building CORS headers for a response. Most +-- of these options are 'Snap.Handler' actions to allow you to conditionally +-- determine the setting of each header. +data CORSOptions m = CORSOptions + { corsAllowOrigin :: m OriginList + -- ^ Which origins are allowed to make cross-origin requests. + + , corsAllowCredentials :: m Bool + -- ^ Whether or not to allow exposing the response when the omit credentials + -- flag is unset. + + , corsExposeHeaders :: m (HashSet.HashSet (CI S.ByteString)) + -- ^ A list of headers that are exposed to clients. This allows clients to + -- read the values of these headers, if the response includes them. + + , corsAllowedMethods :: m (HashSet.HashSet HashableMethod) + -- ^ A list of request methods that are allowed. + + , corsAllowedHeaders :: HashSet.HashSet S.ByteString -> m (HashSet.HashSet S.ByteString) + -- ^ An action to determine which of the request headers are allowed. + -- This action is supplied the parsed contents of + -- @Access-Control-Request-Headers@. + } + +-- | Liberal default options. Specifies that: +-- +-- * All origins may make cross-origin requests +-- * @allow-credentials@ is true. +-- * No extra headers beyond simple headers are exposed. +-- * @GET@, @POST@, @PUT@, @DELETE@ and @HEAD@ are all allowed. +-- * All request headers are allowed. +-- +-- All options are determined unconditionally. +defaultOptions :: Monad m => CORSOptions m +defaultOptions = CORSOptions + { corsAllowOrigin = return Everywhere + , corsAllowCredentials = return True + , corsExposeHeaders = return HashSet.empty + , corsAllowedMethods = return $! defaultAllowedMethods + , corsAllowedHeaders = return + } + +defaultAllowedMethods :: HashSet.HashSet HashableMethod +defaultAllowedMethods = HashSet.fromList $ map HashableMethod + [ Snap.GET, Snap.POST, Snap.PUT, Snap.DELETE, Snap.HEAD ] + + +-- | Apply CORS headers to a specific request. This is useful if you only have +-- a single action that needs CORS headers, and you don't want to pay for +-- conditional checks on every request. +-- +-- You should note that 'applyCORS' needs to be used before you add any +-- 'Snap.method' combinators. For example, the following won't do what you want: +-- +-- > method POST $ applyCORS defaultOptions $ myHandler +-- +-- This fails to work as CORS requires an @OPTIONS@ request in the preflighting +-- stage, but this would get filtered out. Instead, use +-- +-- > applyCORS defaultOptions $ method POST $ myHandler +applyCORS :: Snap.MonadSnap m => CORSOptions m -> m () -> m () +applyCORS options m = + (join . fmap decodeOrigin <$> getHeader "Origin") >>= maybe m corsRequestFrom + + where + corsRequestFrom origin = do + originList <- corsAllowOrigin options + if origin `inOriginList` originList + then Snap.method Snap.OPTIONS (preflightRequestFrom origin) + <|> handleRequestFrom origin + else m + + preflightRequestFrom origin = do + maybeMethod <- fmap (parseMethod . S.unpack) <$> + getHeader "Access-Control-Request-Method" + + case maybeMethod of + Nothing -> m + + Just method -> do + allowedMethods <- corsAllowedMethods options + + if method `HashSet.member` allowedMethods + then do + maybeHeaders <- + fromMaybe (Just HashSet.empty) . fmap splitHeaders + <$> getHeader "Access-Control-Request-Headers" + + case maybeHeaders of + Nothing -> m + Just headers -> do + allowedHeaders <- corsAllowedHeaders options headers + + if not $ HashSet.null $ + headers `HashSet.difference` allowedHeaders + then m + else do + addAccessControlAllowOrigin origin + addAccessControlAllowCredentials + + commaSepHeader + "Access-Control-Allow-Headers" + id (HashSet.toList allowedHeaders) + + commaSepHeader + "Access-Control-Allow-Methods" + (S.pack . show) (HashSet.toList allowedMethods) + + else m + + handleRequestFrom origin = do + addAccessControlAllowOrigin origin + addAccessControlAllowCredentials + + exposeHeaders <- corsExposeHeaders options + when (not $ HashSet.null exposeHeaders) $ + commaSepHeader + "Access-Control-Expose-Headers" + CI.original (HashSet.toList exposeHeaders) + + m + + addAccessControlAllowOrigin origin = + addHeader "Access-Control-Allow-Origin" + (encodeUtf8 $ Text.pack $ show origin) + + addAccessControlAllowCredentials = do + allowCredentials <- corsAllowCredentials options + when (allowCredentials) $ + addHeader "Access-Control-Allow-Credentials" "true" + + decodeOrigin :: S.ByteString -> Maybe URI + decodeOrigin = fmap simplifyURI . parseURI . Text.unpack . decodeUtf8 + + addHeader k v = Snap.modifyResponse (Snap.addHeader k v) + + commaSepHeader k f vs = + case vs of + [] -> return () + _ -> addHeader k $ S.intercalate ", " (map f vs) + + getHeader = Snap.getsRequest . Snap.getHeader + + splitHeaders = either (const Nothing) (Just . HashSet.fromList) . + Attoparsec.parseOnly pTokens + +mkOriginSet :: [URI] -> OriginSet +mkOriginSet = OriginSet . HashSet.fromList . + map (HashableURI . simplifyURI) + +simplifyURI :: URI -> URI +simplifyURI uri = uri { uriAuthority = + fmap simplifyURIAuth (uriAuthority uri) + , uriPath = "" + , uriQuery = "" + , uriFragment = "" + } + where simplifyURIAuth auth = auth { uriUserInfo = "" } + +-------------------------------------------------------------------------------- +parseMethod :: String -> HashableMethod +parseMethod "GET" = HashableMethod Snap.GET +parseMethod "POST" = HashableMethod Snap.POST +parseMethod "HEAD" = HashableMethod Snap.HEAD +parseMethod "PUT" = HashableMethod Snap.PUT +parseMethod "DELETE" = HashableMethod Snap.DELETE +parseMethod "TRACE" = HashableMethod Snap.TRACE +parseMethod "OPTIONS" = HashableMethod Snap.OPTIONS +parseMethod "CONNECT" = HashableMethod Snap.CONNECT +parseMethod "PATCH" = HashableMethod Snap.PATCH +parseMethod s = HashableMethod $ Snap.Method (S.pack s) + +-------------------------------------------------------------------------------- +-- | A @newtype@ over 'URI' with a 'Hashable' instance. +newtype HashableURI = HashableURI URI + deriving (Eq) + +instance Show HashableURI where + show (HashableURI u) = show u + +instance Hashable HashableURI where + hashWithSalt s (HashableURI (URI scheme authority path query fragment)) = + s `hashWithSalt` + scheme `hashWithSalt` + fmap hashAuthority authority `hashWithSalt` + path `hashWithSalt` + query `hashWithSalt` + fragment + + where + hashAuthority (URIAuth userInfo regName port) = + s `hashWithSalt` + userInfo `hashWithSalt` + regName `hashWithSalt` + port + +inOriginList :: URI -> OriginList -> Bool +_ `inOriginList` Nowhere = False +_ `inOriginList` Everywhere = True +origin `inOriginList` (Origins (OriginSet xs)) = + HashableURI origin `HashSet.member` xs + + +-------------------------------------------------------------------------------- +newtype HashableMethod = HashableMethod Snap.Method + deriving (Eq) + +instance Hashable HashableMethod where + hashWithSalt s (HashableMethod Snap.GET) = s `hashWithSalt` (0 :: Int) + hashWithSalt s (HashableMethod Snap.HEAD) = s `hashWithSalt` (1 :: Int) + hashWithSalt s (HashableMethod Snap.POST) = s `hashWithSalt` (2 :: Int) + hashWithSalt s (HashableMethod Snap.PUT) = s `hashWithSalt` (3 :: Int) + hashWithSalt s (HashableMethod Snap.DELETE) = s `hashWithSalt` (4 :: Int) + hashWithSalt s (HashableMethod Snap.TRACE) = s `hashWithSalt` (5 :: Int) + hashWithSalt s (HashableMethod Snap.OPTIONS) = s `hashWithSalt` (6 :: Int) + hashWithSalt s (HashableMethod Snap.CONNECT) = s `hashWithSalt` (7 :: Int) + hashWithSalt s (HashableMethod Snap.PATCH) = s `hashWithSalt` (8 :: Int) + hashWithSalt s (HashableMethod (Snap.Method m)) = + s `hashWithSalt` (9 :: Int) `hashWithSalt` m + +instance Show HashableMethod where + show (HashableMethod m) = show m diff --git a/test/Snap/Internal/Parsing/Tests.hs b/test/Snap/Internal/Parsing/Tests.hs --- a/test/Snap/Internal/Parsing/Tests.hs +++ b/test/Snap/Internal/Parsing/Tests.hs @@ -10,7 +10,7 @@ import qualified Data.Map as Map (fromList) import Data.Word (Word8) import Snap.Internal.Http.Types (Cookie (Cookie, cookieDomain, cookieExpires, cookieHttpOnly, cookieName, cookiePath, cookieSecure, cookieValue)) -import Snap.Internal.Parsing (crlf, finish, fullyParse, fullyParse', pAvPairs, pHeaders, pQuotedString, parseCookie, parseToCompletion, parseUrlEncoded, unsafeFromHex, unsafeFromNat) +import Snap.Internal.Parsing (crlf, finish, fullyParse, fullyParse', pAvPairs, pHeaders, pQuotedString, parseCookie, parseToCompletion, parseUrlEncoded, unsafeFromHex, unsafeFromNat, pTokens) import Snap.Test.Common (expectExceptionH) import System.Random (Random (random, randomR)) import Test.Framework (Test) @@ -28,6 +28,7 @@ , testUnsafeFromInt , testUrlEncoded , testFailParse + , testTokens ] @@ -154,3 +155,12 @@ return $! length a `seq` length b `seq` length c `seq` length d `seq` e `seq` length g `seq` z `seq` () + + +------------------------------------------------------------------------------ +testTokens :: Test +testTokens = testCase "parsing/tokens" $ do + assertEqual "without whitespace" (Right ["Foo","Bar"]) $ + fullyParse "Foo,Bar" pTokens + assertEqual "with whitespace" (Right ["Foo","Bar"]) $ + fullyParse " Foo ,Bar " pTokens diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -13,6 +13,7 @@ import qualified Snap.Util.FileUploads.Tests import qualified Snap.Util.GZip.Tests import qualified Snap.Util.Proxy.Tests +import qualified Snap.Util.CORS.Tests ------------------------------------------------------------------------------ @@ -37,6 +38,8 @@ Snap.Util.GZip.Tests.tests , testGroup "Snap.Util.Proxy.Tests" Snap.Util.Proxy.Tests.tests + , testGroup "Snap.Util.CORS.Tests" + Snap.Util.CORS.Tests.tests , testGroup "Snap.Test.Tests" Snap.Test.Tests.tests ]