{-|
Module      : Gargantext.API.ThrowAll
Description : ThrowAll class and instance
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MonoLocalBinds         #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}

module Gargantext.API.ThrowAll (
    throwAllRoutes
  , serverPrivateGargAPI
  ) where

import Control.Lens ((#))
import Data.ByteString.Char8 qualified as C8
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..))
import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Errors.Types (BackendInternalError)
import Gargantext.API.Prelude (GargM, _ServerError)
import Gargantext.API.Routes.Named.Private qualified as Named
import Gargantext.API.Routes.Named.Remote () -- instance MimeUnrenderer
import Gargantext.API.Server.Named.Private qualified as Named
import Gargantext.Database.Admin.Types.Node (UserId (..))
import Gargantext.Prelude hiding (Handler)
import Network.HTTP.Types.Status (Status(..))
import Network.Wai (responseLBS)
import Servant
import Servant.Auth.Server (AuthResult(..))
import Servant.Conduit ()
import Servant.Server.Generic (AsServerT)

-- | Slightly more general version of the 'ThrowAll' typeclass from Servant,
-- that works on a generic error.
class ThrowAll' e a where
  throwAll' :: e -> a -> a

instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
  throwAll' e (s1 :<|> s2) = throwAll' e s1 :<|> throwAll' e s2

instance ThrowAll' e b => ThrowAll' e (a -> b) where
  throwAll' e f = \x -> throwAll' e (f x)

instance ( MonadError e m
         , GenericServant routes (AsServerT m)
         , HasServer (NamedRoutes routes) '[]
         , Generic (routes (AsServerT m))
         ) => ThrowAll' e (routes (AsServerT m)) where
  throwAll' errCode server = hoistServer (Proxy @(NamedRoutes routes)) f server
    where
      f :: forall a. m a -> m a
      f = const (throwError errCode)

-- Common instances

instance (ThrowAll' ServerError (Handler a)) where
  throwAll' e _ = throwError e
instance (ThrowAll' ServerError (Tagged Handler Application)) where
  throwAll' ServerError{..} (Tagged _) =
    Tagged $ \_ mkResponse -> mkResponse (responseLBS (Status errHTTPCode (C8.pack errReasonPhrase)) errHeaders errBody)


throwAllRoutes :: ( MonadError e m
            , Generic (routes (AsServerT m))
            , GenericServant routes (AsServerT m)
            , ThrowAll' e (routes (AsServerT m))
            , ThrowAll' e (ToServant routes (AsServerT m))
            )
         => e
         -> routes (AsServerT m)
         -> routes (AsServerT m)
throwAllRoutes err = fromServant . throwAll' err . toServant

serverPrivateGargAPI :: Named.GargPrivateAPI (AsServerT (GargM Env BackendInternalError))
serverPrivateGargAPI = Named.GargPrivateAPI $ \case
  (Authenticated auser) -> Named.serverPrivateGargAPI' auser
  -- In the code below we just needed a mock 'AuthenticatedUser' to make the type check, but
  -- they will never be evaluated.
  _                     -> throwAllRoutes (_ServerError # err401)
                             $ Named.serverPrivateGargAPI' (AuthenticatedUser 0 (UnsafeMkUserId 0))
-- Here throwAll' requires a concrete type for the monad.