snap-cors (empty) → 1.0.0

raw patch · 5 files changed

+212/−0 lines, 5 filesdep +basedep +hashabledep +networksetup-changed

Dependencies added: base, hashable, network, snap, text, transformers, unordered-containers

Files

Changelog.md +3/−0
LICENSE +30/−0
Setup.hs +2/−0
snap-cors.cabal +38/−0
src/Snap/CORS.hs +139/−0

+ Changelog.md view

@@ -0,0 +1,3 @@+# 1.0.0++* Initial release. Support setting the `Access-Control-Allow-Origin` and `Access-Control-Allow-Credentials` headers.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2013, Oliver Charles++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Oliver Charles nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

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

+ snap-cors.cabal view

@@ -0,0 +1,38 @@+name:                snap-cors+version:             1.0.0+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+extra-source-files:+  Changelog.md++library+  hs-source-dirs: src+  exposed-modules:+    Snap.CORS+  build-depends:+    base >= 4.5 && < 5,+    hashable >= 1.1 && <1.2,+    network >= 2.4 && < 2.5,+    snap >= 0.13 && < 0.14,+    text >= 0.11 && < 0.12,+    transformers >= 0.3 && < 0.4,+    unordered-containers >= 0.2 && <0.3+  ghc-options: -Wall

+ src/Snap/CORS.hs view

@@ -0,0 +1,139 @@+{-# 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(..)+  ) where++import Control.Applicative+import Control.Monad (guard, mzero, void, when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Hashable (Hashable(..))+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Network.URI (URI (..), URIAuth (..),  parseURI)++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.  +  }++-- | Liberal default options. Specifies that all origins may make cross-origin+-- requests, allow-credentials is true. Headers are determined unconditionally.+defaultOptions :: Monad m => CORSOptions m+defaultOptions = CORSOptions+  { corsAllowOrigin = return Everywhere+  , corsAllowCredentials = return True+  }++-- | 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.+applyCORS :: Snap.MonadSnap m => CORSOptions m -> m ()+applyCORS options = void $ runMaybeT $ do+  origin <- MaybeT $ Snap.getsRequest (Snap.getHeader "Origin")+  originUri <- MaybeT $ pure $+    fmap simplifyURI $ parseURI $ Text.unpack $ decodeUtf8 origin++  originList <- lift $ corsAllowOrigin options++  case originList of+    Everywhere -> return ()+    Nowhere -> mzero+    (Origins (OriginSet xs)) ->+      guard (HashableURI originUri `HashSet.member` xs)++  lift $ do+    addHeader "Access-Control-Allow-Origin"+              (encodeUtf8 $ Text.pack $ show originUri)+    allowCredentials <- corsAllowCredentials options+    when (allowCredentials) $+      addHeader "Access-Control-Allow-Credentials" "true"++ where+  addHeader k v = Snap.modifyResponse (Snap.addHeader k v)++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 = "" }++-- | A @newtype@ over 'URI' with a 'Hashable' instance.+newtype HashableURI = HashableURI URI+  deriving (Eq, Show)++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