135 lines
5.3 KiB
Haskell
135 lines
5.3 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
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
|
|
|
|
-- import System.Exit -- DEBUG: just for testing
|
|
-- import System.Posix.Process -- DEBUG: just for testing
|
|
|
|
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'
|
|
-- | "Crash Button" `isPrefixOf` err' -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
|
|
-- | otherwise -> 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 $ 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
|
|
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 []
|