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-server".
The branch, master has been updated
via ba50a098f0ff8f569f07fd1d3ba5f1277c9d95d4 (commit)
via 065569533b6b90b802b61d9da26a3f808071de8a (commit)
from 1401b65337c04d0cbc02092ba4d8ef3a13f5ad69 (commit)
Summary of changes:
src/Snap/Internal/Http/Server.hs | 24 ++++++++++++++-
test/suite/Snap/Internal/Http/Server/Tests.hs | 40 ++++++++++++++++++++++++-
2 files changed, 62 insertions(+), 2 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 ba50a098f0ff8f569f07fd1d3ba5f1277c9d95d4
Author: Ozgun Ataman <[email protected]>
Date: Thu Dec 16 13:13:58 2010 -0500
Add tests for cookie output
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 284cad4..9b5bcbb 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -65,6 +65,7 @@ tests = [ testHttpRequest1
, testHttpResponse2
, testHttpResponse3
, testHttpResponse4
+ , testHttpResponseCookies
, testHttp1
, testHttp2
, testHttp100
@@ -469,6 +470,43 @@ testHttpResponse4 = testCase "server/HttpResponse4" $ do
emptyResponse { rspHttpVersion = (1,0) }
+testHttpResponseCookies :: Test
+testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do
+ sstep <- runIteratee copyingStream2Stream
+ req <- mkRequest sampleRequest
+ b <- run_ $ rsm $
+ sendResponse req rsp2 sstep testOnSendFile >>=
+ return . snd
+ b2 <- run_ $ rsm $
+ sendResponse req rsp3 sstep testOnSendFile >>=
+ return . snd
+
+ assertEqual "http response cookie" (L.concat [
+ "HTTP/1.0 304 Test\r\n"
+ , "Content-Length: 0\r\n"
+ , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com\r\n\r\n"
+ ]) b
+
+
+ assertEqual "http response multi-cookies" (L.concat [
+ "HTTP/1.0 304 Test\r\n"
+ , "Content-Length: 0\r\n"
+ , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com\r\n"
+ , "Set-Cookie: zoo=baz; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com\r\n\r\n"
+ ]) b2
+
+ where
+ rsp1 = setResponseStatus 304 "Test" $
+ emptyResponse { rspHttpVersion = (1,0) }
+ rsp2 = addResponseCookie cook rsp1
+ rsp3 = addResponseCookie cook2 rsp2
+
+ 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 "/")
+ cook3 = Cookie "boo" "baz" Nothing Nothing Nothing
+
+
echoServer :: (ByteString -> IO ())
-> Request
@@ -489,7 +527,7 @@ echoServer _ req = do
echoServer2 :: ServerHandler
echoServer2 _ req = do
(rq,rsp) <- echoServer (const $ return ()) req
- return (rq, addCookie cook rsp)
+ return (rq, addResponseCookie cook rsp)
where
cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")
utc = UTCTime (ModifiedJulianDay 55226) 0
commit 065569533b6b90b802b61d9da26a3f808071de8a
Author: Ozgun Ataman <[email protected]>
Date: Tue Dec 14 22:15:44 2010 -0500
Add support for Map-based cookies in Response
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 31458ba..e17864a 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -26,6 +26,7 @@ import qualified Data.Map as Map
import Data.Maybe (fromJust, catMaybes, fromMaybe)
import Data.Monoid
import Data.Version
+import Data.Time
import Foreign.C.Types
import Foreign.ForeignPtr
import GHC.Conc
@@ -33,6 +34,7 @@ import Prelude hiding (catch, show, Show)
import qualified Prelude
import System.PosixCompat.Files hiding (setFileSize)
import System.Posix.Types (FileOffset)
+import System.Locale
import Text.Show.ByteString hiding (runPut)
------------------------------------------------------------------------------
import System.FastLogger
@@ -600,7 +602,8 @@ sendResponse :: forall a . Request
-- sendfile
-> ServerMonad (Int64, a)
sendResponse req rsp' writeEnd onSendFile = do
- rsp <- fixupResponse rsp'
+ let rsp'' = renderCookies rsp'
+ rsp <- fixupResponse rsp''
let !headerString = mkHeaderString rsp
(!x,!bs) <- case (rspBody rsp) of
@@ -744,6 +747,13 @@ sendResponse req rsp' writeEnd onSendFile = do
--------------------------------------------------------------------------
+ renderCookies :: Response -> Response
+ renderCookies r = updateHeaders f r
+ where
+ f h = Map.insert "Set-Cookie" cookies h
+ cookies = fmap cookieToBS . Map.elems $ rspCookies r
+
+ --------------------------------------------------------------------------
fixupResponse :: Response -> ServerMonad Response
fixupResponse r = {-# SCC "fixupResponse" #-} do
let r' = deleteHeader "Content-Length" r
@@ -817,6 +827,18 @@ toHeaders kvps = foldl' f Map.empty kvps'
------------------------------------------------------------------------------
+-- | Convert 'Cookie' into 'ByteString' for output.
+cookieToBS :: Cookie -> ByteString
+cookieToBS (Cookie k v mbExpTime mbDomain mbPath) = cookie
+ where
+ 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"
+
+
+------------------------------------------------------------------------------
getFileSize :: FilePath -> IO FileOffset
getFileSize fp = liftM fileSize $ getFileStatus fp
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
