91 lines
3.2 KiB
Haskell
91 lines
3.2 KiB
Haskell
module Foundation.Yesod.ErrorHandler
|
|
( errorHandler
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (errorHandler)
|
|
|
|
import Utils.Form
|
|
|
|
import Foundation.Type
|
|
import Foundation.I18n
|
|
import Foundation.Authorization
|
|
import Foundation.SiteLayout
|
|
import Foundation.Routes
|
|
|
|
import qualified Data.Aeson as JSON
|
|
import qualified Data.Text as Text
|
|
|
|
|
|
errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
|
|
, MonadSecretBox (WidgetFor UniWorX)
|
|
, BearerAuthSite UniWorX
|
|
, Button UniWorX ButtonSubmit
|
|
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
|
)
|
|
=> ErrorResponse -> HandlerFor UniWorX TypedContent
|
|
errorHandler err = do
|
|
shouldEncrypt <- do
|
|
canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
|
|
shouldEncrypt <- getsYesod $ view _appEncryptErrors
|
|
return $ shouldEncrypt && not canDecrypt
|
|
|
|
sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
|
|
setSessionJson SessionError sessErr
|
|
|
|
selectRep $ do
|
|
provideRep $ do
|
|
mr <- getMessageRender
|
|
let
|
|
encrypted :: ToJSON a => a -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
|
|
encrypted plaintextJson plaintext = do
|
|
if
|
|
| shouldEncrypt -> do
|
|
ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
|
|
|
|
[whamlet|
|
|
<p>_{MsgErrorResponseEncrypted}
|
|
<pre .errMsg>
|
|
#{ciphertext}
|
|
|]
|
|
| otherwise -> plaintext
|
|
|
|
errPage = case err of
|
|
NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
|
|
InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
|
|
InvalidArgs errs -> [whamlet|
|
|
<ul>
|
|
$forall err' <- errs
|
|
<li .errMsg>#{err'}
|
|
|]
|
|
NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
|
|
PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
|
|
BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
|
|
siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
|
|
toWidget
|
|
[cassius|
|
|
.errMsg
|
|
white-space: pre-wrap
|
|
font-family: monospace
|
|
|]
|
|
errPage
|
|
provideRep . fmap PrettyValue $ case err of
|
|
PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
|
|
InternalError err'
|
|
| shouldEncrypt -> do
|
|
ciphertext <- encodedSecretBox SecretBoxShort err'
|
|
return $ object [ "message" JSON..= ciphertext
|
|
, "encrypted" JSON..= True
|
|
]
|
|
| otherwise -> return $ object [ "message" JSON..= err' ]
|
|
InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
|
|
_other -> return $ object []
|
|
provideRep $ case err of
|
|
PermissionDenied err' -> return err'
|
|
InternalError err'
|
|
| shouldEncrypt -> do
|
|
addHeader "Encrypted-Error-Message" "True"
|
|
encodedSecretBox SecretBoxPretty err'
|
|
| otherwise -> return err'
|
|
InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
|
|
_other -> return Text.empty
|