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

Replace lift . notFound to avoid a segfault bug

Browse Source
This commit is contained in:
Michael Snoyman 2013-11-12 19:28:18 +02:00
parent c876974656
commit 4d25fd2be1
1 changed files with 9 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
yesod-persistent/Yesod/Persist/Core.hs
View File

@ -28,6 +28,8 @@ import Blaze.ByteString.Builder (Builder)
import Data.IORef.Lifted import Data.IORef.Lifted
import Data.Conduit.Pool import Data.Conduit.Pool
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Control.Exception (throwIO)
import Yesod.Core.Types (HandlerContents (HCError))
import qualified Database.Persist.Sql as SQL import qualified Database.Persist.Sql as SQL
type YesodDB site = YesodPersistBackend site (HandlerT site IO) type YesodDB site = YesodPersistBackend site (HandlerT site IO)
@ -132,7 +134,7 @@ get404 :: ( PersistStore (t m)
get404 key = do get404 key = do
mres <- get key mres <- get key
case mres of case mres of
Nothing -> lift notFound Nothing -> notFound'
Just res -> return res Just res -> return res
-- | Get the given entity by unique key, or return a 404 not found if it doesn't -- | Get the given entity by unique key, or return a 404 not found if it doesn't
@ -148,9 +150,14 @@ getBy404 :: ( PersistUnique (t m)
getBy404 key = do getBy404 key = do
mres <- getBy key mres <- getBy key
case mres of case mres of
Nothing -> lift notFound Nothing -> notFound'
Just res -> return res Just res -> return res
-- | Should be equivalent to @lift . notFound@, but there's an apparent bug in
-- GHC 7.4.2 that leads to segfaults. This is a workaround.
notFound' :: MonadIO m => m a
notFound' = liftIO $ throwIO $ HCError NotFound
instance MonadHandler m => MonadHandler (SqlPersistT m) where instance MonadHandler m => MonadHandler (SqlPersistT m) where
type HandlerSite (SqlPersistT m) = HandlerSite m type HandlerSite (SqlPersistT m) = HandlerSite m
liftHandlerT = lift . liftHandlerT liftHandlerT = lift . liftHandlerT