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