-- 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 []