git.iko.soy/typeable/wai
on master help sign in
Merge pull request #356 from taladar/master

Add Cookie Handling to Network.Wai.Test

commitc5b21af4d1ec866b1892e854d3af2679daf5136c authorMichael Snoyman <michael@snoyman.com> dateThu 2 Apr 2015, 13:12 (12 years ago) parent27f1df0ee1a6a1
3 files changed+267−9
compare with master
unifiedsplit
wai-extra/Network/Wai/Test.hs+106−9 wai-extra/test/Network/Wai/TestSpec.hs+157 wai-extra/wai-extra.cabal+4
wai-extra/Network/Wai/Test.hs+106−9
@@ -5,6 +5,12 @@ module Network.Wai.Test
55 ( -- * Session
66 Session
77 , runSession
8+ -- * Client Cookies
9+ , ClientCookies
10+ , getClientCookies
11+ , modifyClientCookies
12+ , setClientCookie
13+ , deleteClientCookie
814 -- * Requests
915 , request
1016 , srequest
@@ -20,13 +26,18 @@ module Network.Wai.Test
2026 , assertBodyContains
2127 , assertHeader
2228 , assertNoHeader
29+ , assertClientCookieExists
30+ , assertNoClientCookieExists
31+ , assertClientCookieValue
2332 , WaiTestFailure (..)
2433 ) where
2534
2635import Network.Wai
2736import Network.Wai.Internal (ResponseReceived (ResponseReceived))
37+import Control.Applicative ((<$>))
2838import Control.Monad.IO.Class (liftIO)
29−import Control.Monad.Trans.State (StateT, evalStateT)
39+import Control.Monad.Trans.Class (lift)
40+import qualified Control.Monad.Trans.State as ST
3041import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
3142import Control.Monad (unless)
3243import Control.DeepSeq (deepseq)
@@ -34,9 +45,10 @@ import Control.Exception (throwIO, Exception)
3445import Data.Typeable (Typeable)
3546import Data.Map (Map)
3647import qualified Data.Map as Map
48+import qualified Web.Cookie as Cookie
3749import Data.ByteString (ByteString)
3850import qualified Data.ByteString.Char8 as S8
39−import Blaze.ByteString.Builder (toLazyByteString)
51+import Blaze.ByteString.Builder (toLazyByteString, toByteString)
4052import qualified Blaze.ByteString.Builder as B
4153import qualified Data.ByteString.Lazy as L
4254import qualified Data.ByteString.Lazy.Char8 as L8
@@ -47,18 +59,39 @@ import qualified Data.Text as T
4759import qualified Data.Text.Encoding as TE
4860import Data.IORef
4961import Data.Monoid (mempty, mappend)
62+import Data.Time.Clock (getCurrentTime)
5063
51−type Session = ReaderT Application (StateT ClientState IO)
64+type Session = ReaderT Application (ST.StateT ClientState IO)
65+
66+type ClientCookies = Map ByteString Cookie.SetCookie
5267
5368data ClientState = ClientState
54− { _clientCookies :: Map ByteString ByteString
69+ { clientCookies :: ClientCookies
5570 }
5671
72+getClientCookies :: Session ClientCookies
73+getClientCookies = clientCookies <$> lift ST.get
74+
75+modifyClientCookies :: (ClientCookies -> ClientCookies) -> Session ()
76+modifyClientCookies f =
77+ lift (ST.modify (\cs -> cs { clientCookies = f $ clientCookies cs }))
78+
79+setClientCookie :: Cookie.SetCookie -> Session ()
80+setClientCookie c =
81+ modifyClientCookies
82+ (Map.union
83+ (Map.singleton (Cookie.setCookieName c) c))
84+
85+deleteClientCookie :: ByteString -> Session ()
86+deleteClientCookie cookieName =
87+ modifyClientCookies
88+ (Map.delete cookieName)
89+
5790initState :: ClientState
5891initState = ClientState Map.empty
5992
6093runSession :: Session a -> Application -> IO a
61−runSession session app = evalStateT (runReaderT session app) initState
94+runSession session app = ST.evalStateT (runReaderT session app) initState
6295
6396data SRequest = SRequest
6497 { simpleRequest :: Request
@@ -93,6 +126,40 @@ setRawPathInfo r rawPinfo =
93126 dropFrontSlash ("":path) = path
94127 dropFrontSlash path = path
95128
129+addCookiesToRequest :: Request -> Session Request
130+addCookiesToRequest req = do
131+ oldClientCookies <- getClientCookies
132+ let requestPath = "/" `T.append` T.intercalate "/" (pathInfo req)
133+ currentUTCTime <- liftIO getCurrentTime
134+ let cookiesForRequest =
135+ Map.filter
136+ (\c -> checkCookieTime currentUTCTime c
137+ && checkCookiePath requestPath c)
138+ oldClientCookies
139+ let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
140+ | c <- map snd $ Map.toList cookiesForRequest
141+ ]
142+ let cookieValue = toByteString $ Cookie.renderCookies cookiePairs
143+ return $ req { requestHeaders = ("Cookie", cookieValue):requestHeaders req }
144+ where checkCookieTime t c =
145+ case Cookie.setCookieExpires c of
146+ Nothing -> True
147+ Just t' -> t < t'
148+ checkCookiePath p c =
149+ case Cookie.setCookiePath c of
150+ Nothing -> True
151+ Just p' -> p' `S8.isPrefixOf` TE.encodeUtf8 p
152+
153+extractSetCookieFromSResponse :: SResponse -> Session SResponse
154+extractSetCookieFromSResponse response = do
155+ let setCookieHeaders =
156+ filter (("Set-Cookie"==) . fst) $ simpleHeaders response
157+ let newClientCookies = map (Cookie.parseSetCookie . snd) setCookieHeaders
158+ modifyClientCookies
159+ (Map.union
160+ (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))
161+ return response
162+
96163srequest :: SRequest -> Session SResponse
97164srequest (SRequest req bod) = do
98165 app <- ask
@@ -103,12 +170,12 @@ srequest (SRequest req bod) = do
103170 [] -> ([], S.empty)
104171 x:y -> (y, x)
105172 }
106− liftIO $ do
173+ req'' <- addCookiesToRequest req'
174+ response <- liftIO $ do
107175 ref <- newIORef $ error "runResponse gave no result"
108− ResponseReceived <- app req' (runResponse ref)
176+ ResponseReceived <- app req'' (runResponse ref)
109177 readIORef ref
110− -- FIXME cookie processing
111− --return sres
178+ extractSetCookieFromSResponse response
112179
113180runResponse :: IORef SResponse -> Response -> IO ResponseReceived
114181runResponse ref res = do
@@ -212,3 +279,33 @@ assertNoHeader header SResponse{simpleHeaders = h} =
212279 , " containing "
213280 , show s
214281 ]
282+
283+assertClientCookieExists :: String -> ByteString -> Session ()
284+assertClientCookieExists s cookieName = do
285+ cookies <- getClientCookies
286+ assertBool s $ Map.member cookieName cookies
287+
288+assertNoClientCookieExists :: String -> ByteString -> Session ()
289+assertNoClientCookieExists s cookieName = do
290+ cookies <- getClientCookies
291+ assertBool s $ not $ Map.member cookieName cookies
292+
293+assertClientCookieValue :: String -> ByteString -> ByteString -> Session ()
294+assertClientCookieValue s cookieName cookieValue = do
295+ cookies <- getClientCookies
296+ case Map.lookup cookieName cookies of
297+ Nothing ->
298+ assertFailure (s ++ " (cookie does not exist)")
299+ Just c ->
300+ assertBool
301+ (concat
302+ [ s
303+ , " (actual value "
304+ , show $ Cookie.setCookieValue c
305+ , " expected value "
306+ , show cookieValue
307+ , ")"
308+ ]
309+ )
310+ (Cookie.setCookieValue c == cookieValue)
311+
wai-extra/test/Network/Wai/TestSpec.hs+157
@@ -1,11 +1,25 @@
11{-# LANGUAGE OverloadedStrings #-}
22module Network.Wai.TestSpec (main, spec) where
33
4+import Control.Monad (void)
5+
6+import qualified Data.Text.Encoding as TE
7+
8+import Data.Time.Calendar (fromGregorian)
9+import Data.Time.Clock (UTCTime(..))
10+
411import Test.Hspec
512
613import Network.Wai
714import Network.Wai.Test
815
16+import Network.HTTP.Types (status200)
17+
18+import qualified Data.ByteString.Lazy.Char8 as L8
19+import Blaze.ByteString.Builder (toByteString)
20+
21+import qualified Web.Cookie as Cookie
22+
923main :: IO ()
1024main = hspec spec
1125
@@ -34,3 +48,146 @@ spec = do
3448 context "when path has no query string" $ do
3549 it "sets rawQueryString to empty string" $ do
3650 rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` ""
51+
52+ describe "request" $ do
53+
54+ let simpleApp _req respond =
55+ respond $
56+ responseLBS
57+ status200
58+ [("foo", "bar")]
59+ "simple"
60+
61+ it "returns the status code of a simple app on default request" $ do
62+ sresp <- runSession (request defaultRequest) simpleApp
63+ simpleStatus sresp `shouldBe` status200
64+
65+ it "returns the response body of a simple app on default request" $ do
66+ sresp <- runSession (request defaultRequest) simpleApp
67+ simpleBody sresp `shouldBe` "simple"
68+
69+ it "returns the response headers of a simple app on default request" $ do
70+ sresp <- runSession (request defaultRequest) simpleApp
71+ simpleHeaders sresp `shouldBe` [("foo", "bar")]
72+
73+ let cookieApp req respond =
74+ case pathInfo req of
75+ ["set", name, val] ->
76+ respond $
77+ responseLBS
78+ status200
79+ [( "Set-Cookie"
80+ , toByteString $ Cookie.renderSetCookie $
81+ Cookie.def { Cookie.setCookieName = TE.encodeUtf8 name
82+ , Cookie.setCookieValue = TE.encodeUtf8 val
83+ }
84+ )
85+ ]
86+ "set_cookie_body"
87+ ["delete", name] ->
88+ respond $
89+ responseLBS
90+ status200
91+ [( "Set-Cookie"
92+ , toByteString $ Cookie.renderSetCookie $
93+ Cookie.def { Cookie.setCookieName =
94+ TE.encodeUtf8 name
95+ , Cookie.setCookieExpires =
96+ Just $ UTCTime (fromGregorian 1970 1 1) 0
97+ }
98+ )
99+ ]
100+ "set_cookie_body"
101+ _ ->
102+ respond $
103+ responseLBS
104+ status200
105+ []
106+ ( L8.pack
107+ $ show
108+ $ map snd
109+ $ filter ((=="Cookie") . fst)
110+ $ requestHeaders req
111+ )
112+
113+ it "sends a Cookie header with correct value after receiving a Set-Cookie header" $ do
114+ sresp <- flip runSession cookieApp $ do
115+ void $ request $
116+ setPath defaultRequest "/set/cookie_name/cookie_value"
117+ request $
118+ setPath defaultRequest "/get"
119+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]"
120+
121+ it "sends a Cookie header with updated value after receiving a Set-Cookie header update" $ do
122+ sresp <- flip runSession cookieApp $ do
123+ void $ request $
124+ setPath defaultRequest "/set/cookie_name/cookie_value"
125+ void $ request $
126+ setPath defaultRequest "/set/cookie_name/cookie_value2"
127+ request $
128+ setPath defaultRequest "/get"
129+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]"
130+
131+ it "handles multiple cookies" $ do
132+ sresp <- flip runSession cookieApp $ do
133+ void $ request $
134+ setPath defaultRequest "/set/cookie_name/cookie_value"
135+ void $ request $
136+ setPath defaultRequest "/set/cookie_name2/cookie_value2"
137+ request $
138+ setPath defaultRequest "/get"
139+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value;cookie_name2=cookie_value2\"]"
140+
141+ it "removes a deleted cookie" $ do
142+ sresp <- flip runSession cookieApp $ do
143+ void $ request $
144+ setPath defaultRequest "/set/cookie_name/cookie_value"
145+ void $ request $
146+ setPath defaultRequest "/set/cookie_name2/cookie_value2"
147+ void $ request $
148+ setPath defaultRequest "/delete/cookie_name2"
149+ request $
150+ setPath defaultRequest "/get"
151+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]"
152+
153+ it "sends a cookie set with setClientCookie to server" $ do
154+ sresp <- flip runSession cookieApp $ do
155+ setClientCookie
156+ (Cookie.def { Cookie.setCookieName = "cookie_name"
157+ , Cookie.setCookieValue = "cookie_value"
158+ }
159+ )
160+ request $
161+ setPath defaultRequest "/get"
162+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]"
163+
164+ it "sends a cookie updated with setClientCookie to server" $ do
165+ sresp <- flip runSession cookieApp $ do
166+ setClientCookie
167+ (Cookie.def { Cookie.setCookieName = "cookie_name"
168+ , Cookie.setCookieValue = "cookie_value"
169+ }
170+ )
171+ setClientCookie
172+ (Cookie.def { Cookie.setCookieName = "cookie_name"
173+ , Cookie.setCookieValue = "cookie_value2"
174+ }
175+ )
176+ request $
177+ setPath defaultRequest "/get"
178+ simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]"
179+
180+ it "does not send a cookie deleted with deleteClientCookie to server" $ do
181+ sresp <- flip runSession cookieApp $ do
182+ setClientCookie
183+ (Cookie.def { Cookie.setCookieName = "cookie_name"
184+ , Cookie.setCookieValue = "cookie_value"
185+ }
186+ )
187+ deleteClientCookie "cookie_name"
188+ request $
189+ setPath defaultRequest "/get"
190+ simpleBody sresp `shouldBe` "[\"\"]"
191+
192+
193+
wai-extra/wai-extra.cabal+4
@@ -108,6 +108,7 @@ Library
108108 , deepseq
109109 , streaming-commons
110110 , unix-compat
111+ , cookie
111112
112113 if os(windows)
113114 cpp-options: -DWINDOWS
@@ -157,6 +158,9 @@ test-suite spec
157158 , resourcet
158159 , bytestring
159160 , HUnit
161+ , blaze-builder
162+ , cookie
163+ , time
160164 ghc-options: -Wall -Werror
161165
162166source-repository head