diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 3.0.6 + +* Add Cookie Handling to Network.Wai.Test [#356](https://github.com/yesodweb/wai/pull/356) + ## 3.0.5 * add functions to extract authentication data from Authorization header [#352](add functions to extract authentication data from Authorization header #352) diff --git a/Network/Wai/Test.hs b/Network/Wai/Test.hs --- a/Network/Wai/Test.hs +++ b/Network/Wai/Test.hs @@ -5,6 +5,12 @@ ( -- * Session Session , runSession + -- * Client Cookies + , ClientCookies + , getClientCookies + , modifyClientCookies + , setClientCookie + , deleteClientCookie -- * Requests , request , srequest @@ -20,13 +26,18 @@ , assertBodyContains , assertHeader , assertNoHeader + , assertClientCookieExists + , assertNoClientCookieExists + , assertClientCookieValue , WaiTestFailure (..) ) where import Network.Wai import Network.Wai.Internal (ResponseReceived (ResponseReceived)) +import Control.Applicative ((<$>)) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.State (StateT, evalStateT) +import Control.Monad.Trans.Class (lift) +import qualified Control.Monad.Trans.State as ST import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) import Control.Monad (unless) import Control.DeepSeq (deepseq) @@ -34,9 +45,10 @@ import Data.Typeable (Typeable) import Data.Map (Map) import qualified Data.Map as Map +import qualified Web.Cookie as Cookie import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 -import Blaze.ByteString.Builder (toLazyByteString) +import Blaze.ByteString.Builder (toLazyByteString, toByteString) import qualified Blaze.ByteString.Builder as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 @@ -47,18 +59,53 @@ import qualified Data.Text.Encoding as TE import Data.IORef import Data.Monoid (mempty, mappend) +import Data.Time.Clock (getCurrentTime) -type Session = ReaderT Application (StateT ClientState IO) +type Session = ReaderT Application (ST.StateT ClientState IO) +-- | +-- +-- Since 3.0.6 +type ClientCookies = Map ByteString Cookie.SetCookie + data ClientState = ClientState - { _clientCookies :: Map ByteString ByteString + { clientCookies :: ClientCookies } +-- | +-- +-- Since 3.0.6 +getClientCookies :: Session ClientCookies +getClientCookies = clientCookies <$> lift ST.get + +-- | +-- +-- Since 3.0.6 +modifyClientCookies :: (ClientCookies -> ClientCookies) -> Session () +modifyClientCookies f = + lift (ST.modify (\cs -> cs { clientCookies = f $ clientCookies cs })) + +-- | +-- +-- Since 3.0.6 +setClientCookie :: Cookie.SetCookie -> Session () +setClientCookie c = + modifyClientCookies + (Map.insert (Cookie.setCookieName c) c) + +-- | +-- +-- Since 3.0.6 +deleteClientCookie :: ByteString -> Session () +deleteClientCookie cookieName = + modifyClientCookies + (Map.delete cookieName) + initState :: ClientState initState = ClientState Map.empty runSession :: Session a -> Application -> IO a -runSession session app = evalStateT (runReaderT session app) initState +runSession session app = ST.evalStateT (runReaderT session app) initState data SRequest = SRequest { simpleRequest :: Request @@ -93,6 +140,40 @@ dropFrontSlash ("":path) = path dropFrontSlash path = path +addCookiesToRequest :: Request -> Session Request +addCookiesToRequest req = do + oldClientCookies <- getClientCookies + let requestPath = "/" `T.append` T.intercalate "/" (pathInfo req) + currentUTCTime <- liftIO getCurrentTime + let cookiesForRequest = + Map.filter + (\c -> checkCookieTime currentUTCTime c + && checkCookiePath requestPath c) + oldClientCookies + let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c) + | c <- map snd $ Map.toList cookiesForRequest + ] + let cookieValue = toByteString $ Cookie.renderCookies cookiePairs + return $ req { requestHeaders = ("Cookie", cookieValue):requestHeaders req } + where checkCookieTime t c = + case Cookie.setCookieExpires c of + Nothing -> True + Just t' -> t < t' + checkCookiePath p c = + case Cookie.setCookiePath c of + Nothing -> True + Just p' -> p' `S8.isPrefixOf` TE.encodeUtf8 p + +extractSetCookieFromSResponse :: SResponse -> Session SResponse +extractSetCookieFromSResponse response = do + let setCookieHeaders = + filter (("Set-Cookie"==) . fst) $ simpleHeaders response + let newClientCookies = map (Cookie.parseSetCookie . snd) setCookieHeaders + modifyClientCookies + (Map.union + (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ])) + return response + srequest :: SRequest -> Session SResponse srequest (SRequest req bod) = do app <- ask @@ -103,12 +184,12 @@ [] -> ([], S.empty) x:y -> (y, x) } - liftIO $ do + req'' <- addCookiesToRequest req' + response <- liftIO $ do ref <- newIORef $ error "runResponse gave no result" - ResponseReceived <- app req' (runResponse ref) + ResponseReceived <- app req'' (runResponse ref) readIORef ref - -- FIXME cookie processing - --return sres + extractSetCookieFromSResponse response runResponse :: IORef SResponse -> Response -> IO ResponseReceived runResponse ref res = do @@ -212,3 +293,42 @@ , " containing " , show s ] + +-- | +-- +-- Since 3.0.6 +assertClientCookieExists :: String -> ByteString -> Session () +assertClientCookieExists s cookieName = do + cookies <- getClientCookies + assertBool s $ Map.member cookieName cookies + +-- | +-- +-- Since 3.0.6 +assertNoClientCookieExists :: String -> ByteString -> Session () +assertNoClientCookieExists s cookieName = do + cookies <- getClientCookies + assertBool s $ not $ Map.member cookieName cookies + +-- | +-- +-- Since 3.0.6 +assertClientCookieValue :: String -> ByteString -> ByteString -> Session () +assertClientCookieValue s cookieName cookieValue = do + cookies <- getClientCookies + case Map.lookup cookieName cookies of + Nothing -> + assertFailure (s ++ " (cookie does not exist)") + Just c -> + assertBool + (concat + [ s + , " (actual value " + , show $ Cookie.setCookieValue c + , " expected value " + , show cookieValue + , ")" + ] + ) + (Cookie.setCookieValue c == cookieValue) + diff --git a/test/Network/Wai/TestSpec.hs b/test/Network/Wai/TestSpec.hs --- a/test/Network/Wai/TestSpec.hs +++ b/test/Network/Wai/TestSpec.hs @@ -1,11 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Wai.TestSpec (main, spec) where +import Control.Monad (void) + +import qualified Data.Text.Encoding as TE + +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime(..)) + import Test.Hspec import Network.Wai import Network.Wai.Test +import Network.HTTP.Types (status200) + +import qualified Data.ByteString.Lazy.Char8 as L8 +import Blaze.ByteString.Builder (toByteString) + +import qualified Web.Cookie as Cookie + main :: IO () main = hspec spec @@ -34,3 +48,146 @@ context "when path has no query string" $ do it "sets rawQueryString to empty string" $ do rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` "" + + describe "request" $ do + + let simpleApp _req respond = + respond $ + responseLBS + status200 + [("foo", "bar")] + "simple" + + it "returns the status code of a simple app on default request" $ do + sresp <- runSession (request defaultRequest) simpleApp + simpleStatus sresp `shouldBe` status200 + + it "returns the response body of a simple app on default request" $ do + sresp <- runSession (request defaultRequest) simpleApp + simpleBody sresp `shouldBe` "simple" + + it "returns the response headers of a simple app on default request" $ do + sresp <- runSession (request defaultRequest) simpleApp + simpleHeaders sresp `shouldBe` [("foo", "bar")] + + let cookieApp req respond = + case pathInfo req of + ["set", name, val] -> + respond $ + responseLBS + status200 + [( "Set-Cookie" + , toByteString $ Cookie.renderSetCookie $ + Cookie.def { Cookie.setCookieName = TE.encodeUtf8 name + , Cookie.setCookieValue = TE.encodeUtf8 val + } + ) + ] + "set_cookie_body" + ["delete", name] -> + respond $ + responseLBS + status200 + [( "Set-Cookie" + , toByteString $ Cookie.renderSetCookie $ + Cookie.def { Cookie.setCookieName = + TE.encodeUtf8 name + , Cookie.setCookieExpires = + Just $ UTCTime (fromGregorian 1970 1 1) 0 + } + ) + ] + "set_cookie_body" + _ -> + respond $ + responseLBS + status200 + [] + ( L8.pack + $ show + $ map snd + $ filter ((=="Cookie") . fst) + $ requestHeaders req + ) + + it "sends a Cookie header with correct value after receiving a Set-Cookie header" $ do + sresp <- flip runSession cookieApp $ do + void $ request $ + setPath defaultRequest "/set/cookie_name/cookie_value" + request $ + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" + + it "sends a Cookie header with updated value after receiving a Set-Cookie header update" $ do + sresp <- flip runSession cookieApp $ do + void $ request $ + setPath defaultRequest "/set/cookie_name/cookie_value" + void $ request $ + setPath defaultRequest "/set/cookie_name/cookie_value2" + request $ + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]" + + it "handles multiple cookies" $ do + sresp <- flip runSession cookieApp $ do + void $ request $ + setPath defaultRequest "/set/cookie_name/cookie_value" + void $ request $ + setPath defaultRequest "/set/cookie_name2/cookie_value2" + request $ + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value;cookie_name2=cookie_value2\"]" + + it "removes a deleted cookie" $ do + sresp <- flip runSession cookieApp $ do + void $ request $ + setPath defaultRequest "/set/cookie_name/cookie_value" + void $ request $ + setPath defaultRequest "/set/cookie_name2/cookie_value2" + void $ request $ + setPath defaultRequest "/delete/cookie_name2" + request $ + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" + + it "sends a cookie set with setClientCookie to server" $ do + sresp <- flip runSession cookieApp $ do + setClientCookie + (Cookie.def { Cookie.setCookieName = "cookie_name" + , Cookie.setCookieValue = "cookie_value" + } + ) + request $ + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" + + it "sends a cookie updated with setClientCookie to server" $ do + sresp <- flip runSession cookieApp $ do + setClientCookie + (Cookie.def { Cookie.setCookieName = "cookie_name" + , Cookie.setCookieValue = "cookie_value" + } + ) + setClientCookie + (Cookie.def { Cookie.setCookieName = "cookie_name" + , Cookie.setCookieValue = "cookie_value2" + } + ) + request $ + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]" + + it "does not send a cookie deleted with deleteClientCookie to server" $ do + sresp <- flip runSession cookieApp $ do + setClientCookie + (Cookie.def { Cookie.setCookieName = "cookie_name" + , Cookie.setCookieValue = "cookie_value" + } + ) + deleteClientCookie "cookie_name" + request $ + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"\"]" + + + diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -1,5 +1,5 @@ Name: wai-extra -Version: 3.0.5 +Version: 3.0.6 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality: @@ -108,6 +108,7 @@ , deepseq , streaming-commons , unix-compat + , cookie if os(windows) cpp-options: -DWINDOWS @@ -157,6 +158,9 @@ , resourcet , bytestring , HUnit + , blaze-builder + , cookie + , time ghc-options: -Wall -Werror source-repository head