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