{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeApplications     #-}
module Gargantext.API.Routes.Types where

import Control.Lens
import Data.ByteString (ByteString)
import Data.List qualified as L
import Data.Proxy
import Data.Set qualified as Set
import Gargantext.API.Errors
import Network.Wai hiding (responseHeaders)
import Prelude
import Servant.API.Routes
import Servant.Client hiding (responseHeaders)
import Servant.Ekg
import Servant.Server
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO
import Servant.API.Routes.Route
import Servant.API.Routes.Internal.Response (unResponses)

data WithCustomErrorScheme a

instance (HasServer subApi ctx) => HasServer (WithCustomErrorScheme subApi) ctx where
  type ServerT (WithCustomErrorScheme subApi) m = GargErrorScheme -> ServerT subApi m
  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s
  route Proxy ctx d = route (Proxy :: Proxy subApi) ctx (d `addHeaderCheck` getErrorScheme)
    where
      getErrorScheme :: DelayedIO GargErrorScheme
      getErrorScheme = withRequest $ \rq -> do
        let hdrs = requestHeaders rq
            in case L.lookup "X-Garg-Error-Scheme" hdrs of
                 Nothing     -> pure GES_old
                 Just "new"  -> pure GES_new
                 Just _      -> pure GES_old

instance HasEndpoint sub => HasEndpoint (WithCustomErrorScheme sub) where
  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)

instance HasClient m sub => HasClient m (WithCustomErrorScheme sub) where
  type Client m (WithCustomErrorScheme sub) = GargErrorScheme -> Client m sub
  clientWithRoute m _ req _mgr = clientWithRoute m (Proxy :: Proxy sub) req

  hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl

instance (HasRoutes subApi) => HasRoutes (WithCustomErrorScheme subApi) where
  getRoutes =
    let apiRoutes = getRoutes @subApi
        errHeader = mkHeaderRep @"X-Garg-Error-Scheme" @ByteString
        addHeader rt = rt & routeResponse . unResponses . traversed . responseHeaders %~ Set.insert errHeader
    in  addHeader <$> apiRoutes
