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

Disable the allocation limit within the test instead

Browse Source 
I don't think we should add that to the function
seems odly specific
This commit is contained in:
Jappie Klooster 2022-03-22 15:15:49 -04:00
parent eb7405765d
commit 4c1719cb6e
2 changed files with 8 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
yesod-core/src/Yesod/Core/Internal/Run.hs
View File

@ -70,7 +70,6 @@ unsafeAsyncCatch
-> (e -> m a) -- ^ handler -> (e -> m a) -- ^ handler
-> m a -> m a
unsafeAsyncCatch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do unsafeAsyncCatch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do
liftIO Sync.disableAllocationLimit -- otherwise it can throw again on rendering the 500 page
run (g e) run (g e)
-- | Convert a synchronous exception into an ErrorResponse -- | Convert a synchronous exception into an ErrorResponse
@ -97,7 +96,7 @@ basicRunHandler :: ToTypedContent c
-> YesodRequest -> YesodRequest
-> InternalState -> InternalState
-> IO (GHState, HandlerContents) -> IO (GHState, HandlerContents)
basicRunHandler rhe handler yreq resState = do basicRunHandler rhe handler yreq resState = mask $ \unmask -> do
-- Create a mutable ref to hold the state. We use mutable refs so -- Create a mutable ref to hold the state. We use mutable refs so
-- that the updates will survive runtime exceptions. -- that the updates will survive runtime exceptions.
istate <- I.newIORef defState istate <- I.newIORef defState
@ -105,7 +104,7 @@ basicRunHandler rhe handler yreq resState = do
-- Run the handler itself, capturing any runtime exceptions and -- Run the handler itself, capturing any runtime exceptions and
-- converting them into a @HandlerContents@ -- converting them into a @HandlerContents@
contents' <- unsafeAsyncCatch contents' <- unsafeAsyncCatch
(do (unmask $ do
res <- unHandlerFor handler (hd istate) res <- unHandlerFor handler (hd istate)
tc <- evaluate (toTypedContent res) tc <- evaluate (toTypedContent res)
-- Success! Wrap it up in an @HCContent@ -- Success! Wrap it up in an @HCContent@
@ -219,9 +218,9 @@ runHandler :: ToTypedContent c
=> RunHandlerEnv site site => RunHandlerEnv site site
-> HandlerFor site c -> HandlerFor site c
-> YesodApp -> YesodApp
runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> mask $ \unmask -> do
-- Get the raw state and original contents -- Get the raw state and original contents
(state, contents0) <- basicRunHandler rhe handler yreq resState (state, contents0) <- unmask $ basicRunHandler rhe handler yreq resState
-- Evaluate the unfortunately-lazy session and headers, -- Evaluate the unfortunately-lazy session and headers,
-- propagating exceptions into the contents -- propagating exceptions into the contents

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

@ -17,6 +17,7 @@ import Network.Wai.Test
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Control.Exception (SomeException, try) import Control.Exception (SomeException, try)
import UnliftIO.Exception(finally)
import Network.HTTP.Types (Status, mkStatus) import Network.HTTP.Types (Status, mkStatus)
import Data.ByteString.Builder (Builder, toLazyByteString) import Data.ByteString.Builder (Builder, toLazyByteString)
import Data.Monoid (mconcat) import Data.Monoid (mconcat)
@ -119,14 +120,15 @@ getGoodBuilderR :: Handler TypedContent
getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
getAlocationLimitR :: Handler Html getAlocationLimitR :: Handler Html
getAlocationLimitR = do getAlocationLimitR =
(do
liftIO $ do liftIO $ do
Mem.setAllocationCounter 1 -- very low limit Mem.setAllocationCounter 1 -- very low limit
Mem.enableAllocationLimit Mem.enableAllocationLimit
defaultLayout $ [whamlet| defaultLayout $ [whamlet|
<p> this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded <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 which we need to catch
|] |]) `finally` (liftIO $ Mem.disableAllocationLimit)
-- this handler kills it's own thread -- this handler kills it's own thread
getThreadKilledR :: Handler Html getThreadKilledR :: Handler Html