Browse files

Fix cookie reading issue

  • Loading branch information...
1 parent 00c9648 commit c829752b5166fb95f55a9f358e4e79aadc41b057 @gregorycollins gregorycollins committed May 22, 2010
View
42 src/Snap/Internal/Http/Parser.hs
@@ -16,7 +16,7 @@ module Snap.Internal.Http.Parser
------------------------------------------------------------------------------
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 Data.ByteString.Internal (c2w, w2c)
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 @@ pQuotedString = q *> quotedText <* q
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 @@ pAvPair = do
return (key,val)
-parseCookie :: ByteString -> Maybe Cookie
-parseCookie = parseToCompletion pCookie
+parseCookie :: ByteString -> Maybe [Cookie]
+parseCookie = parseToCompletion pCookies
------------------------------------------------------------------------------
-- MULTIPART/FORMDATA
View
3 src/Snap/Internal/Http/Server.hs
@@ -443,7 +443,8 @@ receiveRequest = do
mbContentLength = liftM (Cvt.int . head) $
Map.lookup "content-length" hdrs
- cookies = maybe []
+ cookies = concat $
+ maybe []
(catMaybes . map parseCookie)
(Map.lookup "cookie" hdrs)
View
26 test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -10,17 +10,12 @@ import Control.Exception hiding (try)
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 @@ testBothChunked = testProperty "chunk . unchunk == id" prop
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
View
6 test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -61,7 +61,7 @@ sampleRequest =
, "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 @@ sampleRequest1_0 =
, "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 @@ sampleRequest4 =
, "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" ]

0 comments on commit c829752

Please sign in to comment.