snap-core 1.0.1.1 → 1.0.2.0

raw patch · 5 files changed

+327/−4 lines, 5 filesdep +networkdep +network-uridep ~hashabledep ~io-streamsdep ~timePVP ok

version bump matches the API change (PVP)

Dependencies added: network, network-uri

Dependency ranges changed: hashable, io-streams, time

API changes (from Hackage documentation)

Files

• snap-core.cabal +23/−2
• src/Snap/Internal/Parsing.hs +9/−1
• src/Snap/Util/CORS.hs +281/−0
• test/Snap/Internal/Parsing/Tests.hs +11/−1
• test/TestSuite.hs +3/−0

@@ -1,5 +1,5 @@ name:           snap-core-version:        1.0.1.1+version:        1.0.2.0 synopsis:       Snap: A Haskell Web Framework (core interfaces and types)  description:@@ -85,6 +85,11 @@   Default: False  +Flag network-uri+  Description: Get Network.URI from the network-uri package+  Default: True++ Library   Default-language:  Haskell2010   hs-source-dirs: src@@ -108,6 +113,7 @@     Snap.Internal.Parsing,     Snap.Test,     Snap.Types.Headers,+    Snap.Util.CORS,     Snap.Util.FileServe,     Snap.Util.FileUploads,     Snap.Util.GZip,@@ -134,13 +140,14 @@     filepath                  >= 1.1     && < 2.0,     lifted-base               >= 0.1     && < 0.3,     io-streams                >= 1.3     && < 1.4,+    hashable                  >= 1.2.0.6 && < 1.3,     monad-control             >= 1.0     && < 1.1,     mtl                       >= 2.0     && < 2.3,     random                    >= 1       && < 2,     readable                  >= 0.1     && < 0.4,     regex-posix               >= 0.95    && < 1,     text                      >= 0.11    && < 1.3,-    time                      >= 1.0     && < 1.7,+    time                      >= 1.0     && < 1.9,     transformers              >= 0.3     && < 0.6,     transformers-base         >= 0.4     && < 0.5,     unix-compat               >= 0.3     && < 0.5,@@ -170,7 +177,14 @@   else     ghc-options: -Wall -fwarn-tabs +  if flag(network-uri)+    build-depends: network-uri >= 2.6 && < 2.7,+                   network     >= 2.6 && < 2.7+  else+    build-depends: network-uri >= 2.5 && < 2.6,+                   network     >= 2.3 && < 2.6 + Test-suite testsuite   hs-source-dirs: src test   Type:              exitcode-stdio-1.0@@ -249,6 +263,13 @@     test-framework-hunit       >= 0.2.7    && <0.4,     test-framework-quickcheck2 >= 0.2.12.1 && <0.4,     zlib                       >= 0.5      && <0.7++  if flag(network-uri)+    build-depends: network-uri >= 2.6 && < 2.7,+                   network     >= 2.6 && < 2.7+  else+    build-depends: network-uri >= 2.5 && < 2.6,+                   network     >= 2.3 && < 2.6    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded                -fno-warn-unused-do-bind

@@ -9,7 +9,7 @@ import           Control.Applicative              (Alternative ((<|>)), Applicative (pure, (*>), (<*)), liftA2, (<$>)) import           Control.Arrow                    (first, second) import           Control.Monad                    (Monad (return), MonadPlus (mzero), liftM, when)-import           Data.Attoparsec.ByteString.Char8 (IResult (Done, Fail, Partial), Parser, Result, anyChar, char, choice, decimal, endOfInput, feed, inClass, isDigit, isSpace, letter_ascii, many', match, option, parse, satisfy, skipSpace, skipWhile, string, take, takeTill, takeWhile)+import           Data.Attoparsec.ByteString.Char8 (IResult (Done, Fail, Partial), Parser, Result, anyChar, char, choice, decimal, endOfInput, feed, inClass, isDigit, isSpace, letter_ascii, many', match, option, parse, satisfy, skipSpace, skipWhile, string, take, takeTill, takeWhile, sepBy') import qualified Data.Attoparsec.ByteString.Char8 as AP import           Data.Bits                        (Bits (unsafeShiftL, (.&.), (.|.))) import           Data.ByteString.Builder          (Builder, byteString, char8, toLazyByteString, word8)@@ -269,6 +269,14 @@                                    , ':', '\\', '\"', '/', '[', ']'                                    , '?', '=', '{', '}' ]                  ]+++------------------------------------------------------------------------------+{-# INLINE pTokens #-}+-- | Used for "#field-name", and field-name = token, so "#token":+-- comma-separated tokens/field-names, like a header field list.+pTokens :: Parser [ByteString]+pTokens = (skipSpace *> pToken <* skipSpace) `sepBy'` char ','                                 ------------------

@@ -0,0 +1,281 @@+{-# 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.+--+-- To use in a snaplet, simply use 'wrapSite':+--+-- @+-- wrapSite $ applyCORS defaultOptions+-- @+module Snap.Util.CORS+  ( -- * 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.ByteString.Char8 as Attoparsec+import qualified Data.ByteString.Char8 as S+import qualified Data.CaseInsensitive as CI+import qualified Data.HashSet as HashSet+import qualified Data.Text as Text++import qualified Snap.Core as Snap+import Snap.Internal.Parsing (pTokens)++-- | 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 S.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 S.ByteString -> m (HashSet.HashSet S.ByteString)+  -- ^ 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 $! defaultAllowedMethods+  , corsAllowedHeaders = return+  }++defaultAllowedMethods :: HashSet.HashSet HashableMethod+defaultAllowedMethods = HashSet.fromList $ map HashableMethod+        [ Snap.GET, Snap.POST, Snap.PUT, Snap.DELETE, Snap.HEAD ]+++-- | 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 . S.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"+                       id (HashSet.toList allowedHeaders)++                     commaSepHeader+                       "Access-Control-Allow-Methods"+                       (S.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 :: S.ByteString -> Maybe URI+  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 $ S.intercalate ", " (map f vs)++  getHeader = Snap.getsRequest . Snap.getHeader++  splitHeaders = either (const Nothing) (Just . HashSet.fromList) .+    Attoparsec.parseOnly pTokens++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 (S.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

@@ -10,7 +10,7 @@ import qualified Data.Map                         as Map (fromList) import           Data.Word                        (Word8) import           Snap.Internal.Http.Types         (Cookie (Cookie, cookieDomain, cookieExpires, cookieHttpOnly, cookieName, cookiePath, cookieSecure, cookieValue))-import           Snap.Internal.Parsing            (crlf, finish, fullyParse, fullyParse', pAvPairs, pHeaders, pQuotedString, parseCookie, parseToCompletion, parseUrlEncoded, unsafeFromHex, unsafeFromNat)+import           Snap.Internal.Parsing            (crlf, finish, fullyParse, fullyParse', pAvPairs, pHeaders, pQuotedString, parseCookie, parseToCompletion, parseUrlEncoded, unsafeFromHex, unsafeFromNat, pTokens) import           Snap.Test.Common                 (expectExceptionH) import           System.Random                    (Random (random, randomR)) import           Test.Framework                   (Test)@@ -28,6 +28,7 @@         , testUnsafeFromInt         , testUrlEncoded         , testFailParse+        , testTokens         ]  @@ -154,3 +155,12 @@      return $! length a `seq` length b `seq` length c `seq` length d `seq` e                        `seq` length g `seq` z `seq` ()+++------------------------------------------------------------------------------+testTokens :: Test+testTokens = testCase "parsing/tokens" $ do+  assertEqual "without whitespace" (Right ["Foo","Bar"]) $+    fullyParse "Foo,Bar" pTokens+  assertEqual "with whitespace" (Right ["Foo","Bar"]) $+    fullyParse " Foo  ,Bar " pTokens

@@ -13,6 +13,7 @@ import qualified Snap.Util.FileUploads.Tests import qualified Snap.Util.GZip.Tests import qualified Snap.Util.Proxy.Tests+import qualified Snap.Util.CORS.Tests   ------------------------------------------------------------------------------@@ -37,6 +38,8 @@                         Snap.Util.GZip.Tests.tests             , testGroup "Snap.Util.Proxy.Tests"                         Snap.Util.Proxy.Tests.tests+            , testGroup "Snap.Util.CORS.Tests"+                        Snap.Util.CORS.Tests.tests             , testGroup "Snap.Test.Tests"                         Snap.Test.Tests.tests             ]