diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index 769f65faf..6d11826dc 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -9,9 +9,9 @@ module Foundation.Yesod.ErrorHandler import Import.NoFoundation hiding (errorHandler) import Foundation.Type --- import Foundation.I18n +import Foundation.I18n import Foundation.Authorization --- import Foundation.SiteLayout +import Foundation.SiteLayout import Foundation.Routes import Foundation.DB @@ -20,15 +20,15 @@ import qualified Data.Text as Text import qualified Network.Wai as W --- import System.Exit -- DEBUG: just for testing --- import System.Posix.Process -- DEBUG: just for testing +import System.Exit -- DEBUG: just for testing +import System.Posix.Process -- DEBUG: just for testing errorHandler :: ( MonadSecretBox (HandlerFor UniWorX) - -- , MonadSecretBox (WidgetFor UniWorX) + , MonadSecretBox (WidgetFor UniWorX) , MonadSecretBox (ExceptT EncodedSecretBoxException (HandlerFor UniWorX)) , MonadAuth (HandlerFor UniWorX) , BearerAuthSite UniWorX - -- , YesodPersistBackend UniWorX ~ SqlBackend + , YesodPersistBackend UniWorX ~ SqlBackend ) => ErrorResponse -> HandlerFor UniWorX TypedContent errorHandler err = do @@ -72,39 +72,39 @@ errorHandler err = do setSessionJson SessionError sessErr selectRep $ do - -- provideRep $ do - -- mr <- getMessageRender - -- let - -- encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX () - -- encrypted plaintextJson plaintext = do - -- let displayEncrypted ciphertext = - -- [whamlet| - -- $newline never - --
_{MsgErrorResponseEncrypted} - --
- -- #{ciphertext}
- -- |]
- -- if
- -- | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
- -- | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
- -- | otherwise -> plaintext
+ provideRep $ do
+ mr <- getMessageRender
+ let
+ encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+ encrypted plaintextJson plaintext = do
+ let displayEncrypted ciphertext =
+ [whamlet|
+ $newline never
+ _{MsgErrorResponseEncrypted}
+
+ #{ciphertext}
+ |]
+ if
+ | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
+ | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
+ | otherwise -> plaintext
- -- errPage = case err of
- -- NotFound -> [whamlet|_{MsgErrorResponseNotFound}|]
- -- InternalError err'
- -- | "Crash Button" `isPrefixOf` err' -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
- -- | otherwise -> encrypted err' [whamlet|
#{fromMaybe err' decrypted}|]
- -- InvalidArgs errs -> [whamlet|
- --
_{MsgErrorResponseNotAuthenticated}|] - -- PermissionDenied err' -> [whamlet|
#{err'}|] - -- BadMethod method -> [whamlet|
_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] - -- siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do - -- errPage + errPage = case err of + NotFound -> [whamlet|
_{MsgErrorResponseNotFound}|] + InternalError err' + | "Crash Button" `isPrefixOf` err' -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing + | otherwise -> encrypted err' [whamlet|
#{fromMaybe err' decrypted}|] + InvalidArgs errs -> [whamlet| +
_{MsgErrorResponseNotAuthenticated}|] + PermissionDenied err' -> [whamlet|
#{err'}|] + BadMethod method -> [whamlet|
_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] + siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do + errPage provideRep $ case err of PermissionDenied err' -> return err' InternalError err'