@@ -0,0 +1,91 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Network.Wai.Test
3+ ( -- * Session
4+ Session
5+ , runSession
6+ -- * Requests
7+ , request
8+ , SResponse (..)
9+ -- * Assertions
10+ , assertStatus
11+ , assertContentType
12+ ) where
13+import Network.Wai
14+import qualified Test.HUnit.Base as H
15+import Control.Monad.IO.Class (liftIO)
16+import Control.Monad.Trans.State (StateT, evalStateT, get, put)
17+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
18+import Data.Map (Map)
19+import qualified Data.Map as Map
20+import Data.ByteString (ByteString)
21+import qualified Data.ByteString as S
22+import qualified Data.ByteString.Char8 as S8
23+import Data.Enumerator (joinI, consume, ($$))
24+import Blaze.ByteString.Builder.Enumerator (builderToByteString)
25+import qualified Data.ByteString.Lazy as L
26+
27+type Session = ReaderT Application (StateT ClientState IO)
28+
29+data ClientState = ClientState
30+ { clientCookies :: Map ByteString ByteString
31+ }
32+
33+initState :: ClientState
34+initState = ClientState Map.empty
35+
36+runSession :: Session a -> Application -> IO a
37+runSession session app = evalStateT (runReaderT session app) initState
38+
39+data SResponse = SResponse
40+ { simpleStatus :: Status
41+ , simpleHeaders :: [(CIByteString, ByteString)]
42+ , simpleBody :: L.ByteString
43+ }
44+ deriving (Show, Eq)
45+request :: Request -> Session SResponse
46+request req = do
47+ app <- ask
48+ sres <- liftIO $ app req >>= runResponse
49+ -- FIXME cookie processing
50+ return sres
51+
52+runResponse :: Response -> IO SResponse
53+runResponse res =
54+ responseEnumerator res go
55+ where
56+ go s h = do
57+ bss <- joinI $ builderToByteString $$ consume
58+ return $ SResponse s h $ L.fromChunks bss
59+
60+assertBool :: String -> Bool -> Session ()
61+assertBool s b = liftIO $ H.assertBool s b
62+
63+assertString :: String -> Session ()
64+assertString s = liftIO $ H.assertString s
65+
66+assertContentType :: ByteString -> SResponse -> Session ()
67+assertContentType ct SResponse{simpleHeaders = h} =
68+ case lookup "content-type" h of
69+ Nothing -> assertString $ concat
70+ [ "Expected content type "
71+ , show ct
72+ , ", but no content type provided"
73+ ]
74+ Just ct' -> assertBool (concat
75+ [ "Expected content type "
76+ , show ct
77+ , ", but received "
78+ , show ct'
79+ ]) (go ct == go ct')
80+ where
81+ go = S8.takeWhile (/= ';')
82+
83+assertStatus :: Int -> SResponse -> Session ()
84+assertStatus i SResponse{simpleStatus = s} = assertBool (concat
85+ [ "Expected status code "
86+ , show i
87+ , ", but received "
88+ , show sc
89+ ]) $ i == sc
90+ where
91+ sc = statusCode s