snap-cors 1.1.0 → 1.2.0
raw patch · 4 files changed
+184/−28 lines, 4 filesdep +attoparsecdep +snap-coredep +snap-corsnew-component:exe:example
Dependencies added: attoparsec, snap-core, snap-cors, snap-server
Files
- Changelog.md +5/−0
- Example.hs +22/−0
- snap-cors.cabal +11/−1
- src/Snap/CORS.hs +146/−27
Changelog.md view
@@ -1,3 +1,8 @@+# 1.2++* Added support for pre-flight requests+* Previous versions has a bug where the actual request wasn't issue after validating CORS+ # 1.1 * It is now possible to specify `Access-Control-Expose-Headers`
+ Example.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Control.Applicative+import qualified Snap.Http.Server.Config as Snap+import qualified Snap.Snaplet as Snap+import qualified Snap+import qualified Snap.CORS as CORS+import qualified Snap.Util.FileServe as Snap++data App = App++initApp = Snap.makeSnaplet "app" "app" Nothing $ do+ Snap.addRoutes [ ("/foo", Snap.writeText "Foo")+ , ("/", Snap.serveFile "example.html")+ ]+ CORS.wrapCORS+ return App++main :: IO ()+main = Snap.serveSnaplet Snap.defaultConfig initApp
snap-cors.cabal view
@@ -1,5 +1,5 @@ name: snap-cors-version: 1.1.0+version: 1.2.0 synopsis: Add CORS headers to Snap applications description: Add CORS (cross-origin resource sharing) headers to Snap applications. This@@ -32,6 +32,7 @@ exposed-modules: Snap.CORS build-depends:+ attoparsec >= 0.10 && <0.11, base >= 4.5 && < 5, bytestring >= 0.10 && < 0.11, case-insensitive >= 1.0 && <1.1,@@ -42,3 +43,12 @@ transformers >= 0.3 && < 0.4, unordered-containers >= 0.2 && <0.3 ghc-options: -Wall++executable example+ main-is: Example.hs+ build-depends:+ base >= 4.5 && < 5,+ snap-cors,+ snap >= 0.13 && < 0.14,+ snap-server >= 0.9,+ snap-core >= 0.9
src/Snap/CORS.hs view
@@ -18,20 +18,21 @@ -- ** Origin lists , OriginList(..) , OriginSet, mkOriginSet, origins- + -- * Internals- , HashableURI(..)+ , HashableURI(..), HashableMethod (..) ) where import Control.Applicative-import Control.Monad (guard, mzero, void, when)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Maybe (MaybeT(..))+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.Char8 as Attoparsec import qualified Data.ByteString.Char8 as Char8 import qualified Data.CaseInsensitive as CI import qualified Data.HashSet as HashSet@@ -47,9 +48,9 @@ data OriginList = Everywhere -- ^ Allow any origin to access this resource. Corresponds to- -- @Access-Control-Allow-Origin: *@ + -- @Access-Control-Allow-Origin: *@ | Nowhere- -- ^ Do not allow cross-origin requests + -- ^ Do not allow cross-origin requests | Origins OriginSet -- ^ Allow cross-origin requests from these origins. @@ -67,13 +68,23 @@ , 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+-- * 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@@ -81,6 +92,10 @@ { 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.@@ -91,41 +106,101 @@ -- | Initialize CORS for all requests with specific options. wrapCORSWithOptions :: CORSOptions (Snap.Handler b v) -> Snap.Initializer b v ()-wrapCORSWithOptions options = Snap.wrapSite (applyCORS options >>)+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+applyCORS :: Snap.MonadSnap m => CORSOptions m -> m () -> m ()+applyCORS options m =+ (join . fmap decodeOrigin <$> getHeader "Origin") >>= maybe m corsRequestFrom - originList <- lift $ corsAllowOrigin options+ where - case originList of- Everywhere -> return ()- Nowhere -> mzero- (Origins (OriginSet xs)) ->- guard (HashableURI originUri `HashSet.member` xs)+ corsRequestFrom origin = do+ originList <- corsAllowOrigin options+ if origin `inOriginList` originList+ then Snap.method Snap.OPTIONS (preflightRequestFrom origin)+ <|> handleRequestFrom origin+ else m - lift $ do+ 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 originUri)+ (encodeUtf8 $ Text.pack $ show origin)++ addAccessControlAllowCredentials = do allowCredentials <- corsAllowCredentials options when (allowCredentials) $ addHeader "Access-Control-Allow-Credentials" "true" - when (not $ HashSet.null exposeHeaders) $- addHeader "Access-Control-Expose-Headers" $- Char8.intercalate ", " (map CI.original $ HashSet.toList exposeHeaders)+ decodeOrigin = fmap simplifyURI . parseURI . Text.unpack . decodeUtf8 - where 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` " ,"))+ 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) @@ -137,10 +212,27 @@ } 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, Show)+ 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`@@ -156,3 +248,30 @@ 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