Provide JSON reps for default error message handler (fixes #478)

yesod-core/Yesod/Core/Class.hs

@@ -19,6 +19,7 @@ import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelO
                                                      LogSource)
 import qualified Data.ByteString.Char8              as S8
 import qualified Data.ByteString.Lazy               as L
+import Data.Aeson (object, (.=))
 import           Data.List                          (foldl')
 import           Data.List                          (nub)
 import qualified Data.Map                           as Map
@@ -54,6 +55,7 @@ import           Web.Cookie                         (SetCookie (..))
 import           Yesod.Core.Types
 import           Yesod.Internal.Session
 import           Yesod.Widget
+import           Yesod.Core.Trans.Class (lift)
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -401,57 +403,54 @@ $newline never
     runUniqueList :: Eq x => UniqueList x -> [x]
     runUniqueList (UniqueList x) = nub $ x []
 
--- | Helper function for 'defaultErrorHandler'.
-applyLayout' :: Yesod master
-             => Html -- ^ title
-             -> HtmlUrl (Route master) -- ^ body
-             -> GHandler sub master TypedContent
-applyLayout' title body = fmap toTypedContent $ defaultLayout $ do
-    setTitle title
-    toWidget body
-
 -- | The default error handler for 'errorHandler'.
 defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y TypedContent
-defaultErrorHandler NotFound = do
+defaultErrorHandler NotFound = selectRep $ do
-    r <- waiRequest
+    provideRep $ defaultLayout $ do
-    let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
+        r <- lift waiRequest
-    applyLayout' "Not Found"
+        let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
-        [hamlet|
+        setTitle "Not Found"
-$newline never
+        toWidget [hamlet|
-<h1>Not Found
+            <h1>Not Found
-<p>#{path'}
+            <p>#{path'}
-|]
+        |]
-defaultErrorHandler (PermissionDenied msg) =
+    provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
-    applyLayout' "Permission Denied"
+defaultErrorHandler (PermissionDenied msg) = selectRep $ do
-        [hamlet|
+    provideRep $ defaultLayout $ do
-$newline never
+        setTitle "Permission Denied"
-<h1>Permission denied
+        toWidget [hamlet|
-<p>#{msg}
+            <h1>Permission denied
-|]
+            <p>#{msg}
-defaultErrorHandler (InvalidArgs ia) =
+        |]
-    applyLayout' "Invalid Arguments"
+    provideRep $ return $ object ["message" .= ("Permission Denied" :: Text)]
-        [hamlet|
+defaultErrorHandler (InvalidArgs ia) = selectRep $ do
-$newline never
+    provideRep $ defaultLayout $ do
-<h1>Invalid Arguments
+        setTitle "Invalid Arguments"
-<ul>
+        toWidget [hamlet|
-    $forall msg <- ia
+            <h1>Invalid Arguments
-        <li>#{msg}
+            <ul>
-|]
+                $forall msg <- ia
+                    <li>#{msg}
+        |]
+    provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]
 defaultErrorHandler (InternalError e) = do
     $logErrorS "yesod-core" e
-    applyLayout' "Internal Server Error"
+    selectRep $ do
-        [hamlet|
+        provideRep $ defaultLayout $ do
-$newline never
+            setTitle "Internal Server Error"
-<h1>Internal Server Error
+            toWidget [hamlet|
-<pre>#{e}
+                <h1>Internal Server Error
-|]
+                <pre>#{e}
-defaultErrorHandler (BadMethod m) =
+            |]
-    applyLayout' "Bad Method"
+        provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]
-        [hamlet|
+defaultErrorHandler (BadMethod m) = selectRep $ do
-$newline never
+    provideRep $ defaultLayout $ do
-<h1>Method Not Supported
+        setTitle"Bad Method"
-<p>Method <code>#{S8.unpack m}</code> not supported
+        toWidget [hamlet|
-|]
+            <h1>Method Not Supported
+            <p>Method <code>#{S8.unpack m}</code> not supported
+        |]
+    provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= m]
 
 asyncHelper :: (url -> [x] -> Text)
          -> [Script (url)]

yesod-core/Yesod/Core/Json.hs

@@ -48,11 +48,11 @@ import Data.Maybe (listToMaybe)
 -- /Since: 0.3.0/
 defaultLayoutJson :: (Yesod master, J.ToJSON a)
                   => GWidget sub master ()  -- ^ HTML
-                  -> a                      -- ^ JSON
+                  -> GHandler sub master a  -- ^ JSON
                   -> GHandler sub master TypedContent
 defaultLayoutJson w json = selectRep $ do
     provideRep $ defaultLayout w
-    provideRep $ return $ J.toJSON json
+    provideRep $ fmap J.toJSON json
 
 -- | Wraps a data type in a 'RepJson'.  The data type must
 -- support conversion to JSON via 'J.ToJSON'.