127 lines
4.8 KiB
Haskell
127 lines
4.8 KiB
Haskell
module Foundation.Yesod.ErrorHandler
|
|
( errorHandler
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (errorHandler)
|
|
|
|
import Foundation.Type
|
|
import Foundation.I18n
|
|
import Foundation.Authorization
|
|
import Foundation.SiteLayout
|
|
import Foundation.Routes
|
|
import Foundation.DB
|
|
|
|
import qualified Data.Aeson as JSON
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Network.Wai as W
|
|
|
|
|
|
errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
|
|
, MonadSecretBox (WidgetFor UniWorX)
|
|
, MonadSecretBox (ExceptT EncodedSecretBoxException (HandlerFor UniWorX))
|
|
, MonadAuth (HandlerFor UniWorX)
|
|
, BearerAuthSite UniWorX
|
|
, YesodPersistBackend UniWorX ~ SqlBackend
|
|
)
|
|
=> ErrorResponse -> HandlerFor UniWorX TypedContent
|
|
errorHandler err = do
|
|
let shouldEncrypt' = getsYesod $ view _appEncryptErrors
|
|
canDecrypt' = runDBRead $ hasWriteAccessTo AdminErrMsgR
|
|
decrypted' <- runMaybeT $ do
|
|
internalErrorContent <- hoistMaybe $ err ^? _InternalError
|
|
exceptTMaybe $ encodedSecretBoxOpen @Text internalErrorContent
|
|
let isEncrypted = is _Just decrypted'
|
|
shouldEncrypt <- andM
|
|
[ shouldEncrypt'
|
|
, return $ not isEncrypted
|
|
, not <$> canDecrypt'
|
|
]
|
|
let decrypted = guardOnM (not shouldEncrypt) decrypted'
|
|
|
|
sessErr <- bool return (traverseOf _InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
|
|
|
|
void . runMaybeT $ do
|
|
reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
|
|
approotHost <- MaybeT . getsYesod $ approotScopeHost ApprootDefault
|
|
when (approotHost /= reqHost) $ do
|
|
authErr <- lift $ encodedAuth sessErr
|
|
redirect (ErrorR, [(toPathPiece GetError, authErr)])
|
|
|
|
when (is _NotAuthenticated err) $ do
|
|
authed <- is _Just <$> maybeAuthId
|
|
unless authed $ do
|
|
mCurrent <- getCurrentRoute
|
|
gets' <- reqGetParams <$> getRequest
|
|
wai <- waiRequest
|
|
maybe clearUltDest setUltDest $ do
|
|
current <- mCurrent
|
|
case current of
|
|
_ | W.requestMethod wai /= "GET" -> Nothing
|
|
ErrorR -> Nothing
|
|
current' -> Just (current', gets')
|
|
$logInfoS "errorHandler" "Redirect to LoginR"
|
|
redirect $ AuthR LoginR
|
|
|
|
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
|
|
<p>_{MsgErrorResponseEncrypted}
|
|
<pre .literal-error>
|
|
#{ciphertext}
|
|
|]
|
|
if
|
|
| isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
|
|
| shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
|
|
| otherwise -> plaintext
|
|
|
|
errPage = case err of
|
|
NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
|
|
InternalError err' -> encrypted err' [whamlet|<p .literal-error>#{fromMaybe err' decrypted}|]
|
|
InvalidArgs errs -> [whamlet|
|
|
<ul>
|
|
$forall err' <- errs
|
|
<li .literal-error>
|
|
#{err'}
|
|
|]
|
|
NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
|
|
PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
|
|
BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
|
|
siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
|
|
errPage
|
|
provideRep . fmap PrettyValue $ case err of
|
|
PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
|
|
InternalError err'
|
|
| isEncrypted && shouldEncrypt
|
|
-> return $ object [ "message" JSON..= err'
|
|
, "encrypted" JSON..= True
|
|
]
|
|
| shouldEncrypt -> do
|
|
ciphertext <- encodedSecretBox SecretBoxShort err'
|
|
return $ object [ "message" JSON..= ciphertext
|
|
, "encrypted" JSON..= True
|
|
]
|
|
| otherwise -> return $ object [ "message" JSON..= fromMaybe err' decrypted ]
|
|
InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
|
|
_other -> return $ object []
|
|
provideRep $ case err of
|
|
PermissionDenied err' -> return err'
|
|
InternalError err'
|
|
| isEncrypted && shouldEncrypt -> do
|
|
addHeader "Encrypted-Error-Message" "True"
|
|
return err'
|
|
| shouldEncrypt -> do
|
|
addHeader "Encrypted-Error-Message" "True"
|
|
encodedSecretBox SecretBoxPretty err'
|
|
| otherwise -> return $ fromMaybe err' decrypted
|
|
InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
|
|
_other -> return Text.empty
|