{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}

module Gargantext.API.Server.Named (
  server
  ) where

import Control.Monad.Catch (catch, throwM)
import Data.ByteString.Lazy qualified as BL
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Version (showVersion)
import Gargantext.API.Admin.Auth (auth, forgotPassword, forgotPasswordAsync)
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Admin.FrontEnd (frontEndServer)
import Gargantext.API.Auth.PolicyCheck ()
import Gargantext.API.Errors
import Gargantext.API.GraphQL as GraphQL
import Gargantext.API.Prelude (GargM)
import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
import Gargantext.API.Routes.Named
import Gargantext.API.Swagger (swaggerDoc)
import Gargantext.API.ThrowAll (serverPrivateGargAPI)
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Prelude hiding (Handler, catch)
import Gargantext.Core.Config (gc_url_backend_api)
import Gargantext.System.Logging (logLocM, LogLevel(..))
import Paths_gargantext qualified as PG -- cabal magic build module
import Servant
import Servant.Server.Generic
import Servant.Swagger.UI (swaggerSchemaUIServer)

serverGargAPI :: Env -> BackEndAPI (AsServerT (GargM Env BackendInternalError))
serverGargAPI env
       =  BackEndAPI $ MkBackEndAPI $ GargAPIVersion $ GargAPI'
            { gargAuthAPI                = AuthAPI auth
            , gargForgotPasswordAPI      = forgotPassword
            , gargForgotPasswordAsyncAPI = forgotPasswordAsync
            , gargVersionAPI             = gargVersion
            , gargPrivateAPI             = serverPrivateGargAPI
            , gargPublicAPI              = serverPublicGargAPI (env ^. hasConfig . gc_url_backend_api)
            }
  where
    gargVersion :: GargVersion (AsServerT (GargM Env BackendInternalError))
    gargVersion = GargVersion $ pure (cs $ showVersion PG.version)

-- | Server declarations
server :: Env -> API AsServer
server env =
  API $ \errScheme -> NamedAPI
     { swaggerAPI = swaggerSchemaUIServer swaggerDoc
     , backendAPI = hoistServerWithContext
                      (Proxy :: Proxy (NamedRoutes BackEndAPI))
                      (Proxy :: Proxy AuthContext)
                      (transformJSON errScheme)
                      (serverGargAPI env)
     , graphqlAPI = hoistServerWithContext
                      (Proxy :: Proxy (NamedRoutes GraphQLAPI))
                      (Proxy :: Proxy AuthContext)
                      (transformJSONGQL errScheme)
                      GraphQL.api
     , frontendAPI = frontEndServer
     }
  where
    transformJSON :: forall a. GargErrorScheme -> GargM Env BackendInternalError a -> Handler a
    transformJSON GES_old = Handler . withExceptT showAsServantJSONErr . (`runReaderT` env) . logPanicErrors
    transformJSON GES_new = Handler . withExceptT (frontendErrorToServerError . backendErrorToFrontendError) . (`runReaderT` env) . handlePanicErrors
    transformJSONGQL :: forall a. GargErrorScheme -> GargM Env BackendInternalError a -> Handler a
    transformJSONGQL GES_old = Handler . withExceptT showAsServantJSONErr . (`runReaderT` env) . logPanicErrors
    transformJSONGQL GES_new = Handler . withExceptT (frontendErrorToGQLServerError . backendErrorToFrontendError) . (`runReaderT` env) . handlePanicErrors

handlePanicErrors :: GargM Env BackendInternalError a -> GargM Env BackendInternalError a
handlePanicErrors h = h `catch` handleSomeException
  where
    handleSomeException :: SomeException -> GargM Env BackendInternalError a
    handleSomeException se
      | Just ex@(WithStacktrace _ (_ :: UnexpectedPanic)) <- fromException se
      = do
        $(logLocM) ERROR $ T.pack $ displayException ex
        ReaderT $ \_ -> ExceptT $ pure $ Left $ InternalUnexpectedError se
      | Just (ber :: BackendInternalError) <- fromException se
      = throwError ber -- re-throw the uncaught exception via the 'MonadError' instance
      | otherwise
      = throwM se -- re-throw the uncaught exception.

-- | Old compat-shim for the old error format, it just logs the exception properly
-- but otherwise rethrows it /without/ the stacktrace (to not leak internal details).
logPanicErrors :: GargM Env BackendInternalError a -> GargM Env BackendInternalError a
logPanicErrors h = h `catch` handleSomeException
  where
    handleSomeException :: SomeException -> GargM Env BackendInternalError a
    handleSomeException se
      | Just ex@(WithStacktrace _ (UnexpectedPanic uex)) <- fromException se
      = do
        $(logLocM) ERROR $ T.pack $ displayException ex
        throwError $ InternalServerError $ err500 { errBody = BL.fromStrict $ TE.encodeUtf8 uex }
      | Just (ber :: BackendInternalError) <- fromException se
      = throwError ber -- re-throw the uncaught exception via the 'MonadError' instance
      | otherwise
      = throwM se -- re-throw the uncaught exception.

