-
Notifications
You must be signed in to change notification settings - Fork 68
/
Tests.hs
340 lines (269 loc) · 12.7 KB
/
Tests.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Blackbox.Tests
( tests
, remove
, removeDir
) where
------------------------------------------------------------------------------
import Control.Exception (catch, finally, throwIO)
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Monoid
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T
import Network.Http.Client
import Prelude hiding (catch)
import System.Directory
import System.FilePath
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test, path)
------------------------------------------------------------------------------
------------------------------------------------------------------------------
testServer :: String
testServer = "http://127.0.0.1"
------------------------------------------------------------------------------
testPort :: String
testPort = "9753"
------------------------------------------------------------------------------
-- | The server uri, without the leading slash.
testServerUri :: String
testServerUri = testServer ++ ":" ++ testPort
------------------------------------------------------------------------------
-- | The server url, with the leading slash.
testServerUrl :: String
testServerUrl = testServerUri ++ "/"
--------------------
-- TEST LOADER --
--------------------
------------------------------------------------------------------------------
tests :: Test
tests = testGroup "non-cabal-tests"
[ requestTest "hello" "hello world"
, requestTest "index" "index page\n"
, requestTest "" "index page\n"
, requestTest "splicepage" "splice page contents of the app splice\n"
, requestTest "routeWithSplice" "routeWithSplice: foo snaplet data stringz"
, requestTest "routeWithConfig" "routeWithConfig: topConfigValue"
, requestTest "foo/foopage" "foo template page\n"
, requestTest "foo/fooConfig" "fooValue"
, requestTest "foo/fooRootUrl" "foo"
, requestTest "barconfig" "barValue"
, requestTest "bazpage" "baz template page <barsplice></barsplice>\n"
, requestTest "bazpage2" "baz template page contents of the bar splice\n"
, requestTest "bazpage3" "baz template page <barsplice></barsplice>\n"
, requestTest "bazpage4" "baz template page <barsplice></barsplice>\n"
, requestTest "barrooturl" "url"
, requestExpectingErrorPrefix "bazbadpage" 500 "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found."
, requestTest "foo/fooSnapletName" "foosnaplet"
, fooConfigPathTest
-- Test the embedded snaplet
, requestTest "embed/heist/embeddedpage" "embedded snaplet page <asplice></asplice>\n"
, requestTest "embed/aoeuhtns" "embedded snaplet page splice value42\n"
, requestTest "embed/heist/onemoredir/extra" "This is an extra template\n"
-- This set of tests highlights the differences in the behavior of the
-- get... functions from MonadSnaplet.
, fooHandlerConfigTest
, barHandlerConfigTest
, bazpage5Test
, bazConfigTest
, requestTest "sessionDemo" "[(\"foo\",\"bar\")]\n"
, reloadTest
]
------------------------------------------------------------------------------
testName :: String -> String
testName uri = "internal/" ++ uri
--testName = id
------------------------------------------------------------------------------
requestTest :: String -> Text -> Test
requestTest url desired = testCase (testName url) $ requestTest' url desired
------------------------------------------------------------------------------
requestTest' :: String -> Text -> IO ()
requestTest' url desired = do
actual <- get (S.pack $ testServerUrl ++ url) concatHandler
assertEqual url desired (T.decodeUtf8 $ L.fromChunks [actual])
------------------------------------------------------------------------------
requestExpectingErrorPrefix :: String -> Int -> Text -> Test
requestExpectingErrorPrefix url status desired =
testCase (testName url) $ requestExpectingErrorPrefix' url status desired
------------------------------------------------------------------------------
requestExpectingErrorPrefix' :: String -> Int -> Text -> IO ()
requestExpectingErrorPrefix' url status desired = do
let fullUrl = testServerUrl ++ url
get (S.pack fullUrl) $ \resp is -> do
assertEqual ("Status code: "++fullUrl) status
(getStatusCode resp)
res <- concatHandler resp is
assertBool fullUrl $ desired `T.isPrefixOf` (T.decodeUtf8 $ L.fromChunks [res])
------------------------------------------------------------------------------
fooConfigPathTest :: Test
fooConfigPathTest = testCase (testName "foo/fooFilePath") $ do
b <- liftM L.unpack $ grab "/foo/fooFilePath"
assertRelativelyTheSame b "snaplets/foosnaplet"
------------------------------------------------------------------------------
assertRelativelyTheSame :: FilePath -> FilePath -> IO ()
assertRelativelyTheSame p expected = do
b <- makeRelativeToCurrentDirectory p
assertEqual ("expected " ++ expected) expected b
------------------------------------------------------------------------------
grab :: MonadIO m => String -> m L.ByteString
grab path = liftIO $ liftM (L.fromChunks . (:[])) $
get (S.pack $ testServerUri ++ path) concatHandler
------------------------------------------------------------------------------
testWithCwd :: String
-> (String -> L.ByteString -> Assertion)
-> Test
testWithCwd uri f = testCase (testName uri) $
testWithCwd' uri f
------------------------------------------------------------------------------
testWithCwd' :: String
-> (String -> L.ByteString -> Assertion)
-> Assertion
testWithCwd' uri f = do
b <- grab slashUri
cwd <- getCurrentDirectory
f cwd b
where
slashUri = '/' : uri
------------------------------------------------------------------------------
fooHandlerConfigTest :: Test
fooHandlerConfigTest = testWithCwd "foo/handlerConfig" $ \cwd b -> do
let response = L.fromChunks [ "([\"app\"],\""
, S.pack cwd
, "/snaplets/foosnaplet\","
, "Just \"foosnaplet\",\"A demonstration "
, "snaplet called foo.\",\"foo\")" ]
assertEqual "" response b
------------------------------------------------------------------------------
barHandlerConfigTest :: Test
barHandlerConfigTest = testWithCwd "bar/handlerConfig" $ \cwd b -> do
let response = L.fromChunks [ "([\"app\"],\""
, S.pack cwd
, "/snaplets/baz\","
, "Just \"baz\",\"An example snaplet called "
, "bar.\",\"\")" ]
assertEqual "" response b
------------------------------------------------------------------------------
-- bazpage5 uses barsplice bound by renderWithSplices at request time
bazpage5Test :: Test
bazpage5Test = testWithCwd "bazpage5" $ \cwd b -> do
let response = L.fromChunks [ "baz template page ([\"app\"],\""
, S.pack cwd
, "/snaplets/baz\","
, "Just \"baz\",\"An example snaplet called "
, "bar.\",\"\")\n" ]
assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b)
------------------------------------------------------------------------------
-- bazconfig uses two splices, appconfig and fooconfig. appconfig is bound with
-- the non type class version of addSplices in the main app initializer.
-- fooconfig is bound by addSplices in fooInit.
bazConfigTest :: Test
bazConfigTest = testWithCwd "bazconfig" $ \cwd b -> do
let response = L.fromChunks [
"baz config page ([],\""
, S.pack cwd
, "\",Just \"app\"," -- TODO, right?
, "\"Test application\",\"\") "
, "([\"app\"],\""
, S.pack cwd
, "/snaplets/foosnaplet\","
, "Just \"foosnaplet\",\"A demonstration snaplet "
, "called foo.\",\"foo\")\n"
]
assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b)
------------------------------------------------------------------------------
expect404 :: String -> IO ()
expect404 url = do
get (S.pack $ testServerUrl ++ url) $ \resp i -> do
case getStatusCode resp of
404 -> return ()
_ -> assertFailure "expected 404"
------------------------------------------------------------------------------
request404Test :: String -> Test
request404Test url = testCase (testName url) $ expect404 url
remove :: FilePath -> IO ()
remove f = do
exists <- doesFileExist f
when exists $ removeFile f
removeDir :: FilePath -> IO ()
removeDir d = do
exists <- doesDirectoryExist d
when exists $ removeDirectoryRecursive "snaplets/foosnaplet"
------------------------------------------------------------------------------
reloadTest :: Test
reloadTest = testCase "internal/reload-test" $ do
let goodTplOrig = "good.tpl"
let badTplOrig = "bad.tpl"
let goodTplNew = "snaplets" </> "heist"
</> "templates" </> "good.tpl"
let badTplNew = "snaplets" </> "heist"
</> "templates" </> "bad.tpl"
goodExists <- doesFileExist goodTplNew
badExists <- doesFileExist badTplNew
assertBool "good.tpl exists" (not goodExists)
assertBool "bad.tpl exists" (not badExists)
expect404 "bad"
copyFile badTplOrig badTplNew
expect404 "good"
expect404 "bad"
flip finally (remove badTplNew) $
testWithCwd' "admin/reload" $ \cwd' b -> do
let cwd = T.pack cwd'
let prefix = T.intercalate "\n"
[ "Error reloading site!"
, ""
, "Initializer threw an exception..."
, T.concat
[ cwd, "/snaplets/heist/templates/bad.tpl \""
, cwd, "/snaplets/heist/templates/bad.tpl\" (line 2, column 1):"
]
, "unexpected end of input"
, "expecting \"=\", \"/\" or \">\""
-- Building with the latest dependency versions produces the following:
-- "CallStack (from HasCallStack):"
-- " error, called at src/Snap/Snaplet/Heist/Internal.hs:75:35 in main:Snap.Snaplet.Heist.Internal"
]
let suffix = T.intercalate "\n"
[ "...but before it died it generated the following output:"
, "Initializing app @ /"
, "Initializing heist @ /heist"
, ""
, ""
]
let response = T.decodeUtf8 b
assertEqual "admin/reload" prefix (T.take (T.length prefix) response)
assertEqual "admin/reload" suffix (T.takeEnd (T.length suffix) response)
copyFile goodTplOrig goodTplNew
testWithCwd' "admin/reload" $ \cwd' b -> do -- TODO/NOTE: Needs cleanup
let cwd = S.pack cwd'
let response = L.fromChunks [
"Initializing app @ /\nInitializing heist @ ",
"/heist\n...loaded 9 templates from ",
cwd,
"/snaplets/heist/templates\nInitializing CookieSession ",
"@ /session\nInitializing foosnaplet @ /foo\n...adding 1 ",
"templates from ",
cwd,
"/snaplets/foosnaplet/templates with route prefix ",
"foo/\nInitializing baz @ /\n...adding 2 templates from ",
cwd,
"/snaplets/baz/templates with route prefix /\nInitializing ",
"embedded @ /\nInitializing heist @ /heist\n...loaded ",
"1 templates from ",
cwd,
"/snaplets/embedded/snaplets/heist/templates\n...adding ",
"1 templates from ",
cwd,
"/snaplets/embedded/extra-templates with route prefix ",
"onemoredir/\n...adding 0 templates from ",
cwd,
"/templates with route prefix extraTemplates/\n",
"Initializing JsonFileAuthManager @ ",
"/auth\nSite successfully reloaded.\n"
]
assertEqual "admin/reload" response b
requestTest' "good" "Good template\n"