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] 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