From db7dfcbefde3fa5f0c7ba4470ad4ea4582bc3bab Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 13 Jul 2010 11:17:25 +0300
Subject: [PATCH] Added Html' and get404

---
 Yesod/Form.hs  |  3 +++
 Yesod/Yesod.hs | 14 ++++++++++++++
 2 files changed, 17 insertions(+)

diff --git a/Yesod/Form.hs b/Yesod/Form.hs
index e2870883..ec18b046 100644
--- a/Yesod/Form.hs
+++ b/Yesod/Form.hs
@@ -20,6 +20,7 @@ module Yesod.Form
       -- * Newtype wrappers
     , JqueryDay (..)
     , NicHtml (..)
+    , Html'
       -- * Unwrapping functions
     , runFormGet
     , runFormPost
@@ -551,6 +552,8 @@ instance ToFormField (Maybe (Html ())) where
 newtype NicHtml = NicHtml { unNicHtml :: Html () }
     deriving PersistField
 
+type Html' = Html ()
+
 nicHtmlField :: Html () -> Html () -> FormletField sub y (Html ())
 nicHtmlField label tooltip = requiredFieldHelper nicHtmlFieldProfile
     { fpLabel = label
diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs
index 5fbfb233..9b800dfa 100644
--- a/Yesod/Yesod.hs
+++ b/Yesod/Yesod.hs
@@ -12,6 +12,7 @@ module Yesod.Yesod
       -- ** Persistence
     , YesodPersist (..)
     , module Database.Persist
+    , get404
       -- ** Breadcrumbs
     , YesodBreadcrumbs (..)
     , breadcrumbs
@@ -38,6 +39,8 @@ import Data.Monoid (mempty)
 import Data.ByteString.UTF8 (toString)
 import Database.Persist
 import Web.Routes.Site (Site)
+import Control.Monad.Trans.Class (MonadTrans (..))
+import Control.Monad.Attempt (Failure)
 
 -- | This class is automatically instantiated when you use the template haskell
 -- mkYesod function. You should never need to deal with it directly.
@@ -218,6 +221,17 @@ class YesodPersist y where
     type YesodDB y :: (* -> *) -> * -> *
     runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a
 
+
+-- Get the given entity by ID, or return a 404 not found if it doesn't exist.
+get404 :: (PersistBackend (t m), PersistEntity val, Monad (t m),
+           Failure ErrorResponse m, MonadTrans t)
+       => Key val -> t m val
+get404 key = do
+    mres <- get key
+    case mres of
+        Nothing -> lift notFound
+        Just res -> return res
+
 -- | Return the same URL if the user is authorized to see it.
 --
 -- Built on top of 'isAuthorized'. This is useful for building page that only