diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,7 @@ +# 1.3.0 + +* Now just re-exports `Snap.Util.CORS`. + # 1.2.11 * Dropped dependency on `transformers`. diff --git a/snap-cors.cabal b/snap-cors.cabal --- a/snap-cors.cabal +++ b/snap-cors.cabal @@ -1,55 +1,32 @@ -name: snap-cors -version: 1.2.11 -synopsis: Add CORS headers to Snap applications +name: snap-cors +version: 1.3.0 +cabal-version: 2.0 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: Oliver Charles (c) 2013 +maintainer: ollie@ocharles.org.uk +homepage: https://github.com/ocharles/snap-cors +bug-reports: https://github.com/ocharles/snap-cors/issues +synopsis: Add CORS headers to Snap applications description: - Add CORS (cross-origin resource sharing) headers to Snap applications. This - enables web applications running on other domains to make requests against - another application. - . - Currently this package provides support for setting the - @Access-Control-Allow-Origin@ and @Access-Control-Allow-Credentials@ headers, - it does not yet do pre-flighting. If you need this, please open an issue on - Github and I'll fix it ASAP (otherwise I will add this feature as time permits). - -homepage: http://github.com/ocharles/snap-cors -license: BSD3 -license-file: LICENSE -author: Oliver Charles -maintainer: ollie@ocharles.org.uk -copyright: Oliver Charles (c) 2013 -category: Web -build-type: Simple -cabal-version: >=1.8 + Add CORS (cross-origin resource sharing) headers to Snap applications. This + enables web applications running on other domains to make requests against + another application. + . + Since version 1.3 this library simply re-exports @Snap.Util.CORS@. +category: Web +author: Oliver Charles extra-source-files: - Changelog.md + Changelog.md source-repository head - type: git - location: git://github.com/ocharles/snap-cors.git - -flag network-uri - description: Get Network.URI from the network-uri package - default: True + type: git + location: https://github.com/ocharles/snap-cors library - hs-source-dirs: src - exposed-modules: - Snap.CORS - build-depends: - attoparsec >= 0.10 && <0.14, - base >= 4.5 && < 5, - bytestring >= 0.10 && < 0.11, - case-insensitive >= 1.0 && <1.3, - hashable >= 1.1 && <1.3, - snap >= 0.13 && < 1.1, - text >= 0.11 && < 1.3, - unordered-containers >= 0.2 && <0.3 - ghc-options: -Wall - if flag(network-uri) - build-depends: - network-uri >= 2.6 && <2.7, - network >= 2.6 && <2.7 - else + reexported-modules: snap-core:Snap.Util.CORS as Snap.CORS build-depends: - network-uri < 2.6, - network >= 2.4 && < 2.6 + snap-core ^>=1.0.2 + default-language: Haskell2010 + diff --git a/src/Snap/CORS.hs b/src/Snap/CORS.hs deleted file mode 100644 --- a/src/Snap/CORS.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# 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. -module Snap.CORS - ( -- * Wrappers - wrapCORS - , wrapCORSWithOptions - - -- * 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.Combinator as Attoparsec -import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec -import qualified Data.ByteString.Char8 as Char8 -import qualified Data.CaseInsensitive as CI -import qualified Data.HashSet as HashSet -import qualified Data.Text as Text -import qualified Snap - --- | 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 Char8.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 String -> m (HashSet.HashSet String) - -- ^ 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 $ HashSet.fromList $ map HashableMethod - [ Snap.GET, Snap.POST, Snap.PUT, Snap.DELETE, Snap.HEAD ] - , corsAllowedHeaders = return - } - --- | Apply CORS for every request, unconditionally. --- --- 'wrapCors' ≡ 'wrapCORSWithOptions' 'defaultOptions' -wrapCORS :: Snap.Initializer b v () -wrapCORS = wrapCORSWithOptions defaultOptions - --- | Initialize CORS for all requests with specific options. -wrapCORSWithOptions :: CORSOptions (Snap.Handler b v) -> Snap.Initializer b v () -wrapCORSWithOptions options = Snap.wrapSite (applyCORS options) - --- | 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 . Char8.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" - Char8.pack (HashSet.toList allowedHeaders) - - commaSepHeader - "Access-Control-Allow-Methods" - (Char8.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 = 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 $ Char8.intercalate ", " (map f vs) - - getHeader = Snap.getsRequest . Snap.getHeader - - splitHeaders = - let spaces = Attoparsec.many' Attoparsec.space - headerC = Attoparsec.satisfy (not . (`elem`( " ," :: String))) - headerName = Attoparsec.many' headerC - header = spaces *> headerName <* spaces - parser = HashSet.fromList <$> header `Attoparsec.sepBy` (Attoparsec.char ',') - in either (const Nothing) Just . Attoparsec.parseOnly parser - -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 (Char8.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