diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index 370956b8..10d85e5d 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -41,7 +41,7 @@ replaceToParent hd = hd { handlerToParent = const () } instance MonadResourceBase m => MonadHandler (HandlerT site m) where type HandlerSite (HandlerT site m) = site liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent -{-# RULES "liftHandlerT (HandlerT site IO)" forall action. liftHandlerT action = id #-} +{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-} instance MonadResourceBase m => MonadHandler (WidgetT site m) where type HandlerSite (WidgetT site m) = site diff --git a/yesod-persistent/Yesod/Persist/Core.hs b/yesod-persistent/Yesod/Persist/Core.hs index de5e3f1c..1463fada 100644 --- a/yesod-persistent/Yesod/Persist/Core.hs +++ b/yesod-persistent/Yesod/Persist/Core.hs @@ -28,6 +28,8 @@ import Blaze.ByteString.Builder (Builder) import Data.IORef.Lifted import Data.Conduit.Pool import Control.Monad.Trans.Resource +import Control.Exception (throwIO) +import Yesod.Core.Types (HandlerContents (HCError)) import qualified Database.Persist.Sql as SQL type YesodDB site = YesodPersistBackend site (HandlerT site IO) @@ -132,7 +134,7 @@ get404 :: ( PersistStore (t m) get404 key = do mres <- get key case mres of - Nothing -> lift notFound + Nothing -> notFound' Just res -> return res -- | 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 mres <- getBy key case mres of - Nothing -> lift notFound + Nothing -> notFound' 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 type HandlerSite (SqlPersistT m) = HandlerSite m liftHandlerT = lift . liftHandlerT