diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.1.2 +version: 0.1.3 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: This is the first developer prerelease of the Snap framework. Snap is a diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs --- a/src/Snap/Internal/Http/Parser.hs +++ b/src/Snap/Internal/Http/Parser.hs @@ -16,7 +16,7 @@ ------------------------------------------------------------------------------ import Control.Applicative -import Control.Arrow (first, second) +import Control.Arrow (second) import Control.Monad (liftM) import Control.Monad.Trans import Data.Attoparsec hiding (many, Result(..)) @@ -28,21 +28,18 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Nums.Careless.Hex as Cvt import Data.Char -import Data.CIByteString import Data.List (foldl') import Data.Int import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (catMaybes, fromMaybe) -import Data.Time.Format (parseTime) +import Data.Maybe (catMaybes) import qualified Data.Vector.Unboxed as Vec import Data.Vector.Unboxed (Vector) import Data.Word (Word8, Word64) import Prelude hiding (take, takeWhile) -import System.Locale (defaultTimeLocale) ------------------------------------------------------------------------------ import Snap.Internal.Http.Types hiding (Enumerator) -import Snap.Iteratee hiding (take, foldl') +import Snap.Iteratee hiding (take, foldl', filter) @@ -349,36 +346,15 @@ qdtext = matchAll [ isRFCText, (/= '\"'), (/= '\\') ] . w2c -pCookie :: Parser Cookie -pCookie = do +pCookies :: Parser [Cookie] +pCookies = do -- grab kvps and turn to strict bytestrings kvps <- pAvPairs - -- kvps guaranteed non-null due to grammar. First avpair specifies - -- name=value mapping. - let ((nm,val):attrs') = kvps - let attrs = map (first toCI) attrs' - - -- and we'll gather the rest of the fields with helper functions. - return $ foldl' field (nullCookie nm val) attrs - + return $ map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps where - nullCookie nm val = Cookie nm val Nothing Nothing Nothing - - fieldFuncs :: [ (CIByteString, Cookie -> ByteString -> Cookie) ] - fieldFuncs = [ ("domain", domain) - , ("expires", expires) - , ("path", path) ] - - domain c d = c { cookieDomain = Just d } - path c p = c { cookiePath = Just p } - expires c e = c { cookieExpires = parseExpires e } - parseExpires e = parseTime defaultTimeLocale - "%a, %d-%b-%Y %H:%M:%S GMT" - (map w2c $ S.unpack e) - - field c (k,v) = fromMaybe c (flip ($ c) v <$> lookup k fieldFuncs) + toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing -- unhelpfully, the spec mentions "old-style" cookies that don't have quotes @@ -400,8 +376,8 @@ return (key,val) -parseCookie :: ByteString -> Maybe Cookie -parseCookie = parseToCompletion pCookie +parseCookie :: ByteString -> Maybe [Cookie] +parseCookie = parseToCompletion pCookies ------------------------------------------------------------------------------ -- MULTIPART/FORMDATA diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -443,7 +443,8 @@ mbContentLength = liftM (Cvt.int . head) $ Map.lookup "content-length" hdrs - cookies = maybe [] + cookies = concat $ + maybe [] (catMaybes . map parseCookie) (Map.lookup "cookie" hdrs) diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs b/test/suite/Snap/Internal/Http/Parser/Tests.hs --- a/test/suite/Snap/Internal/Http/Parser/Tests.hs +++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs @@ -10,17 +10,12 @@ import Control.Monad import Control.Monad.Identity import Control.Parallel.Strategies -import qualified Data.Attoparsec as Atto import Data.Attoparsec hiding (Result(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.ByteString.Internal (c2w, w2c) +import Data.ByteString.Internal (c2w) import qualified Data.Map as Map -import Data.Maybe (fromJust) -import Data.Time.Clock -import Data.Time.Format -import System.Locale import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 @@ -163,31 +158,18 @@ testCookie :: Test testCookie = testCase "parseCookie" $ do - assertEqual "cookie parsing" (Just cv) cv2 + assertEqual "cookie parsing" (Just [cv]) cv2 where - cv = Cookie nm v (Just d) (Just domain) (Just path) + cv = Cookie nm v Nothing Nothing Nothing cv2 = parseCookie ct - - d = (fromJust $ - parseTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S %Z" dts) :: UTCTime - - dt = "Fri, 22-Jan-2010 12:34:56 GMT" - dts = map w2c $ S.unpack dt nm = "foo" v = "bar" - domain = ".foo.com" - path = "/zzz" ct = S.concat [ nm , "=" - , v - , "; expires=" - , dt - , "; domain=" - , domain - , "; path=/zzz; freeform=unparsed" ] + , v ] testFormEncoded :: Test diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -61,7 +61,7 @@ , "Host: www.zabble.com:7777\r\n" , "Content-Length: 10\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" - , "Set-Cookie: foo=\"bar\\\"\"\r\n" + , "Cookie: foo=\"bar\\\"\"\r\n" , "\r\n" , "0123456789" ] @@ -71,7 +71,7 @@ , "Host: www.zabble.com:7777\r\n" , "Content-Length: 10\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" - , "Set-Cookie: foo=\"bar\\\"\"\r\n" + , "Cookie: foo=\"bar\\\"\"\r\n" , "\r\n" , "0123456789" ] @@ -426,7 +426,7 @@ , "Content-Length: 10\r\n" , "Connection: close\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" - , "Set-Cookie: foo=\"bar\\\"\"\r\n" + , "Cookie: foo=\"bar\\\"\"\r\n" , "\r\n" , "0123456789" ]