From 4d25fd2be18a5a2e9a8530c9a00804d116985993 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 12 Nov 2013 19:28:18 +0200
Subject: [PATCH 1/2] Replace lift . notFound to avoid a segfault bug

---
 yesod-persistent/Yesod/Persist/Core.hs | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

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

From dce5ea942e222c5c2413a4bf069a207e3f762b6d Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 12 Nov 2013 19:29:18 +0200
Subject: [PATCH 2/2] Fix a faulty rewrite rule

---
 yesod-core/Yesod/Core/Class/Handler.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

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