snap-cors 1.2.11 → 1.3.0
raw patch · 3 files changed
+29/−335 lines, 3 filesdep +snap-coredep −attoparsecdep −basedep −bytestring
Dependencies added: snap-core
Dependencies removed: attoparsec, base, bytestring, case-insensitive, hashable, network, network-uri, snap, text, unordered-containers
Files
- Changelog.md +4/−0
- snap-cors.cabal +25/−48
- src/Snap/CORS.hs +0/−287
Changelog.md view
@@ -1,3 +1,7 @@+# 1.3.0++* Now just re-exports `Snap.Util.CORS`.+ # 1.2.11 * Dropped dependency on `transformers`.
snap-cors.cabal view
@@ -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+
− src/Snap/CORS.hs
@@ -1,287 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Add <http://www.w3.org/TR/cors/ CORS> (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