haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add test showing the failures

Browse Source
This commit is contained in:
Jappie Klooster 2022-03-22 14:02:25 -04:00
parent 48d05fd6ab
commit 08d37a1857
1 changed files with 40 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

@ -6,6 +6,10 @@ module YesodCoreTest.ErrorHandling
, Widget , Widget
, resourcesApp , resourcesApp
) where ) where
import qualified System.Mem as Mem
import qualified Control.Concurrent.Async as Async
import Control.Concurrent as Conc
import Yesod.Core import Yesod.Core
import Test.Hspec import Test.Hspec
import Network.Wai import Network.Wai
@ -45,6 +49,9 @@ mkYesod "App" [parseRoutes|
/auth-not-adequate AuthNotAdequateR GET /auth-not-adequate AuthNotAdequateR GET
/args-not-valid ArgsNotValidR POST /args-not-valid ArgsNotValidR POST
/only-plain-text OnlyPlainTextR GET /only-plain-text OnlyPlainTextR GET
/allocation-limit AlocationLimitR GET
/thread-killed ThreadKilledR GET
|] |]
overrideStatus :: Status overrideStatus :: Status
@ -111,6 +118,24 @@ goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n"
getGoodBuilderR :: Handler TypedContent getGoodBuilderR :: Handler TypedContent
getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
getAlocationLimitR :: Handler Html
getAlocationLimitR = do
liftIO $ do
Mem.setAllocationCounter 1 -- very low limit
Mem.enableAllocationLimit
defaultLayout $ [whamlet|
<p> this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded
which we need to catch
|]
-- this handler kills it's own thread
getThreadKilledR :: Handler Html
getThreadKilledR = do
x <- liftIO Conc.myThreadId
liftIO $ Async.withAsync (Conc.killThread x) Async.wait
pure "unreachablle"
getErrorR :: Int -> Handler () getErrorR :: Int -> Handler ()
getErrorR 1 = setSession undefined "foo" getErrorR 1 = setSession undefined "foo"
getErrorR 2 = setSession "foo" undefined getErrorR 2 = setSession "foo" undefined
@ -154,10 +179,13 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
it "accept CSS, permission denied -> 403" caseCssPermissionDenied it "accept CSS, permission denied -> 403" caseCssPermissionDenied
it "accept image, non-existent path -> 404" caseImageNotFound it "accept image, non-existent path -> 404" caseImageNotFound
it "accept video, bad method -> 405" caseVideoBadMethod it "accept video, bad method -> 405" caseVideoBadMethod
it "thread killed = 500" caseThreadKilled500
it "allocation limit = 500" caseAllocationLimit500
runner :: Session a -> IO a runner :: Session a -> IO a
runner f = toWaiApp App >>= runSession f runner f = toWaiApp App >>= runSession f
caseNotFound :: IO () caseNotFound :: IO ()
caseNotFound = runner $ do caseNotFound = runner $ do
res <- request defaultRequest res <- request defaultRequest
@ -291,3 +319,15 @@ caseVideoBadMethod = runner $ do
("accept", "video/webm") : requestHeaders defaultRequest ("accept", "video/webm") : requestHeaders defaultRequest
} }
assertStatus 405 res assertStatus 405 res
caseAllocationLimit500 :: IO ()
caseAllocationLimit500 = runner $ do
res <- request defaultRequest { pathInfo = ["allocation-limit"] }
assertStatus 500 res
assertBodyContains "Internal Server Error" res
caseThreadKilled500 :: IO ()
caseThreadKilled500 = runner $ do
res <- request defaultRequest { pathInfo = ["thread-killed"] }
assertStatus 500 res
assertBodyContains "Internal Server Error" res