This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, master has been updated
via a352cd77445a225f136dee3b9f1ed1d0a89999d5 (commit)
via 739b806ffcc9351306b8f844475309b62dbf94cc (commit)
via 46c1447bb83b0f6d4945bcb9af479a11fe096bae (commit)
via a250174191cebeb2f6a1d4da2683ce811a688dd1 (commit)
via d671512541fcc8735d55e3751c7ab6df51dd9425 (commit)
from 0beeba44088c30faecf27537ad1089209e426a0b (commit)
Summary of changes:
src/Snap/Internal/Http/Types.hs | 71 +++++++++++++++++++++-----
src/Snap/Internal/Types.hs | 7 +++
src/Snap/Types.hs | 6 ++
test/suite/Snap/Internal/Http/Types/Tests.hs | 58 ++++++++++++++++-----
4 files changed, 116 insertions(+), 26 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit a352cd77445a225f136dee3b9f1ed1d0a89999d5
Author: Ozgun Ataman <[email protected]>
Date: Wed Dec 22 00:35:47 2010 +0200
Alias addCookie to addResponseCookie and deprecate it for removal in 0.4.
diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs
index 04688d2..5f4a356 100644
--- a/src/Snap/Internal/Http/Types.hs
+++ b/src/Snap/Internal/Http/Types.hs
@@ -521,7 +521,16 @@ setContentType = setHeader "Content-Type"
------------------------------------------------------------------------------
--- | Adds an HTTP 'Cookie' to the 'Response' headers.
+-- | addCookie has been deprecated and will be removed in 0.4. Please use
+-- 'addResponseCookie' instead.
+addCookie :: Cookie -- ^ cookie value
+ -> Response -- ^ response to modify
+ -> Response
+addCookie = addResponseCookie
+
+
+------------------------------------------------------------------------------
+-- | Adds an HTTP 'Cookie' to 'Response' headers.
addResponseCookie :: Cookie -- ^ cookie value
-> Response -- ^ response to modify
-> Response
@@ -548,7 +557,7 @@ getResponseCookies = Map.elems . rspCookies
------------------------------------------------------------------------------
--- | Delete an HTTP 'Cookie' from the 'Response' headers.
+-- | Deletes an HTTP 'Cookie' from the 'Response' headers.
deleteResponseCookie :: ByteString -- ^ cookie name
-> Response -- ^ response to modify
-> Response
@@ -560,7 +569,7 @@ deleteResponseCookie cn r = r { rspCookies = cks' }
------------------------------------------------------------------------------
-- | Modifies an HTTP 'Cookie' with given name in 'Response' headers.
--- Nothing will happen if a matching 'Cookie' is not present in 'Response'.
+-- Nothing will happen if a matching 'Cookie' can not be found in 'Response'.
modifyResponseCookie :: ByteString -- ^ cookie name
-> (Cookie -> Cookie) -- ^ modifier function
-> Response -- ^ response to modify
diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs
index 1b8be8c..9e47874 100644
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -94,6 +94,7 @@ module Snap.Types
, rspStatus
, rspStatusReason
, setContentType
+ , addCookie
, addResponseCookie
, getResponseCookie
, getResponseCookies
commit 739b806ffcc9351306b8f844475309b62dbf94cc
Author: Ozgun Ataman <[email protected]>
Date: Tue Dec 21 10:52:20 2010 +0200
Add getParams function to directly return request parameters inside of a
Snap monad
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index 06c679f..0226fb1 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -727,6 +727,13 @@ getParam k = do
------------------------------------------------------------------------------
+-- | See 'rqParams'. Convenience function to return 'Params' from the 'Request'
+-- inside of a 'MonadSnap' instance.
+getParams :: MonadSnap m => m Params
+getParams = getRequest >>= return . rqParams
+
+
+------------------------------------------------------------------------------
-- | Gets the HTTP 'Cookie' with the specified name.
getCookie :: MonadSnap m
=> ByteString
diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs
index 327a9d0..1b8be8c 100644
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -83,6 +83,7 @@ module Snap.Types
, rqParams
, rqParam
, getParam
+ , getParams
, rqModifyParams
, rqSetParam
commit 46c1447bb83b0f6d4945bcb9af479a11fe096bae
Author: Ozgun Ataman <[email protected]>
Date: Thu Dec 16 08:33:32 2010 -0500
Add tests for all new cookie functionality
diff --git a/test/suite/Snap/Internal/Http/Types/Tests.hs
b/test/suite/Snap/Internal/Http/Types/Tests.hs
index 31e1cd3..893c4dc 100644
--- a/test/suite/Snap/Internal/Http/Types/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Types/Tests.hs
@@ -25,6 +25,7 @@ import Snap.Iteratee
tests :: [Test]
tests = [ testTypes
+ , testCookies
, testUrlDecode
, testFormatLogTime
, testAddHeader ]
@@ -84,11 +85,6 @@ testTypes = testCase "show" $ do
assertEqual "rqParam" (Just ["bar"]) (rqParam "foo" req)
assertEqual "lookup" (Just ["bbb"]) (Map.lookup "zzz" $ rqParams req)
assertEqual "lookup 2" (Just ["bbb"]) (Map.lookup "zzz" $ headers req)
- assertEqual "cookie" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com"]) cookieHeader
-
- assertEqual "cookie2" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com", "foo=baz; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com"]) (liftM sort cookieHeader2)
-
- assertEqual "cookie3" (Just ["foo=baz"]) cookieHeader3
assertEqual "response status" 555 $ rspStatus resp
assertEqual "response status reason" "bogus" $ rspStatusReason resp
@@ -108,7 +104,7 @@ testTypes = testCase "show" $ do
return ()
where
- resp = addCookie cook $
+ resp = addResponseCookie cook $
setContentLength 4 $
modifyResponseBody id $
setResponseBody (enumBS "PING") $
@@ -117,16 +113,52 @@ testTypes = testCase "show" $ do
emptyResponse
!b = show resp `using` rdeepseq
- resp2 = addCookie cook2 resp
- resp3 = addCookie cook3 emptyResponse
+ resp2 = addResponseCookie cook2 resp
+
+ utc = UTCTime (ModifiedJulianDay 55226) 0
+ cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")
+ cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/")
+
+
+testCookies :: Test
+testCookies = testCase "cookies" $ do
+ assertEqual "cookie" (Just cook) rCook
+ assertEqual "cookie2" (Just cook2) rCook2
+ assertEqual "cookie3" (Just cook3) rCook3
+ assertEqual "empty response cookie3" (Just cook3) rCook3e
+ assertEqual "removed cookie" Nothing nilCook
+ assertEqual "multiple cookies" [cook, cook2] cks
+ assertEqual "cookie modification" (Just cook3) rCook3Mod
+
+ return ()
+
+ where
+ resp = addResponseCookie cook $
+ setContentType "text/plain" $
+ emptyResponse
+
+ f _ = cook3
+ resp' = deleteResponseCookie "foo" resp
+ resp'' = modifyResponseCookie "foo" f resp
+ resp2 = addResponseCookie cook2 resp
+ resp3 = addResponseCookie cook3 resp2
+ resp4 = addResponseCookie cook3 emptyResponse
utc = UTCTime (ModifiedJulianDay 55226) 0
cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")
- cook2 = Cookie "foo" "baz" (Just utc) (Just ".foo.com") (Just "/")
- cook3 = Cookie "foo" "baz" Nothing Nothing Nothing
+ cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/")
+ cook3 = Cookie "boo" "baz" Nothing Nothing Nothing
+
+ rCook = getResponseCookie "foo" resp
+ nilCook = getResponseCookie "foo" resp'
+ rCook2 = getResponseCookie "zoo" resp2
+ rCook3 = getResponseCookie "boo" resp3
+ rCook3e = getResponseCookie "boo" resp4
+ rCook3Mod = getResponseCookie "boo" resp''
+
+ cks = getResponseCookies resp2
+
+
- cookieHeader = Map.lookup "Set-Cookie" $ headers resp
- cookieHeader2 = Map.lookup "Set-Cookie" $ headers resp2
- cookieHeader3 = Map.lookup "Set-Cookie" $ headers resp3
commit a250174191cebeb2f6a1d4da2683ce811a688dd1
Author: Ozgun Ataman <[email protected]>
Date: Thu Dec 16 08:33:14 2010 -0500
getResponseCookies to get all cookies as a list
diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs
index 6d3b26c..04688d2 100644
--- a/src/Snap/Internal/Http/Types.hs
+++ b/src/Snap/Internal/Http/Types.hs
@@ -540,6 +540,13 @@ getResponseCookie cn r = Map.lookup cn $ rspCookies r
{-# INLINE getResponseCookie #-}
+-- | Returns a list of 'Cookie's present in 'Response'
+getResponseCookies :: Response -- ^ response to query
+ -> [Cookie]
+getResponseCookies = Map.elems . rspCookies
+{-# INLINE getResponseCookies #-}
+
+
------------------------------------------------------------------------------
-- | Delete an HTTP 'Cookie' from the 'Response' headers.
deleteResponseCookie :: ByteString -- ^ cookie name
diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs
index d059261..327a9d0 100644
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -95,6 +95,7 @@ module Snap.Types
, setContentType
, addResponseCookie
, getResponseCookie
+ , getResponseCookies
, deleteResponseCookie
, modifyResponseCookie
, getCookie
commit d671512541fcc8735d55e3751c7ab6df51dd9425
Author: Ozgun Ataman <[email protected]>
Date: Tue Dec 14 22:34:42 2010 -0500
Make cookies in Response Map-based and add support for programmatical
manipulation
diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs
index 69d72ec..6d3b26c 100644
--- a/src/Snap/Internal/Http/Types.hs
+++ b/src/Snap/Internal/Http/Types.hs
@@ -378,6 +378,7 @@ rspBodyToEnum (SendFile fp (Just s)) = I.enumFilePartial fp
s
-- | Represents an HTTP response.
data Response = Response
{ rspHeaders :: Headers
+ , rspCookies :: Map ByteString Cookie
, rspHttpVersion :: !HttpVersion
-- | We will need to inspect the content length no matter what, and
@@ -465,8 +466,8 @@ rqSetParam k v = rqModifyParams $ Map.insert k v
-- | An empty 'Response'.
emptyResponse :: Response
-emptyResponse = Response Map.empty (1,1) Nothing (Enum (I.enumBS "")) 200
- "OK" False
+emptyResponse = Response Map.empty Map.empty (1,1) Nothing (Enum (I.enumBS
""))
+ 200 "OK" False
------------------------------------------------------------------------------
@@ -521,18 +522,46 @@ setContentType = setHeader "Content-Type"
------------------------------------------------------------------------------
-- | Adds an HTTP 'Cookie' to the 'Response' headers.
-addCookie :: Cookie -- ^ cookie value
- -> Response -- ^ response to modify
- -> Response
-addCookie (Cookie k v mbExpTime mbDomain mbPath) = updateHeaders f
+addResponseCookie :: Cookie -- ^ cookie value
+ -> Response -- ^ response to modify
+ -> Response
+addResponseCookie ck@(Cookie k _ _ _ _) r = r { rspCookies = cks' }
+ where
+ cks'= Map.insert k ck $ rspCookies r
+{-# INLINE addResponseCookie #-}
+
+
+------------------------------------------------------------------------------
+-- | Gets an HTTP 'Cookie' with the given name from 'Response' headers.
+getResponseCookie :: ByteString -- ^ cookie name
+ -> Response -- ^ response to query
+ -> Maybe Cookie
+getResponseCookie cn r = Map.lookup cn $ rspCookies r
+{-# INLINE getResponseCookie #-}
+
+
+------------------------------------------------------------------------------
+-- | Delete an HTTP 'Cookie' from the 'Response' headers.
+deleteResponseCookie :: ByteString -- ^ cookie name
+ -> Response -- ^ response to modify
+ -> Response
+deleteResponseCookie cn r = r { rspCookies = cks' }
+ where
+ cks'= Map.delete cn $ rspCookies r
+{-# INLINE deleteResponseCookie #-}
+
+
+------------------------------------------------------------------------------
+-- | Modifies an HTTP 'Cookie' with given name in 'Response' headers.
+-- Nothing will happen if a matching 'Cookie' is not present in 'Response'.
+modifyResponseCookie :: ByteString -- ^ cookie name
+ -> (Cookie -> Cookie) -- ^ modifier function
+ -> Response -- ^ response to modify
+ -> Response
+modifyResponseCookie cn f r = maybe r modify $ getResponseCookie cn r
where
- f = Map.insertWith' (++) "Set-Cookie" [cookie]
- cookie = S.concat [k, "=", v, path, exptime, domain]
- path = maybe "" (S.append "; path=") mbPath
- domain = maybe "" (S.append "; domain=") mbDomain
- exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime
- fmt = fromStr .
- formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT"
+ modify ck = addResponseCookie (f ck) r
+{-# INLINE modifyResponseCookie #-}
------------------------------------------------------------------------------
diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs
index d3113d1..d059261 100644
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -93,7 +93,10 @@ module Snap.Types
, rspStatus
, rspStatusReason
, setContentType
- , addCookie
+ , addResponseCookie
+ , getResponseCookie
+ , deleteResponseCookie
+ , modifyResponseCookie
, getCookie
, setContentLength
, clearContentLength
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
