diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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` diff --git a/Example.hs b/Example.hs new file mode 100644 --- /dev/null +++ b/Example.hs @@ -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 diff --git a/snap-cors.cabal b/snap-cors.cabal --- a/snap-cors.cabal +++ b/snap-cors.cabal @@ -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 diff --git a/src/Snap/CORS.hs b/src/Snap/CORS.hs --- a/src/Snap/CORS.hs +++ b/src/Snap/CORS.hs @@ -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