snap-server 0.3.1 → 0.3.1.1
raw patch · 3 files changed
+63/−3 lines, 3 files
Files
- snap-server.cabal +1/−1
- src/Snap/Internal/Http/Server.hs +23/−1
- test/suite/Snap/Internal/Http/Server/Tests.hs +39/−1
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.3.1+version: 0.3.1.1 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
src/Snap/Internal/Http/Server.hs view
@@ -26,6 +26,7 @@ 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 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 @@ -- 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 @@ --------------------------------------------------------------------------+ 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@@ -814,6 +824,18 @@ where kvps' = map (first toCI . second (:[])) kvps f m (k,v) = Map.insertWith' (flip (++)) k v m+++------------------------------------------------------------------------------+-- | 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" ------------------------------------------------------------------------------
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -65,6 +65,7 @@ , testHttpResponse2 , testHttpResponse3 , testHttpResponse4+ , testHttpResponseCookies , testHttp1 , testHttp2 , testHttp100@@ -469,7 +470,44 @@ 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 -> Iteratee ByteString IO (Request,Response)@@ -489,7 +527,7 @@ 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