{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeFamilies         #-}

module Gargantext.API.Routes.Types where

import Control.Lens ((%~), traversed)
import Data.Aeson ((.:), (.=), object, withObject)
import Data.CaseInsensitive qualified as CI
import Data.List qualified as L
import Data.Swagger (ToSchema)
import Data.Set qualified as Set
import Data.Text qualified as T
import Gargantext.API.Errors (GargErrorScheme(..), renderGargErrorScheme)
import Gargantext.Core.Utils (GitHash)
import Gargantext.Prelude
import Network.HTTP.Types (HeaderName)
import Network.Wai (requestHeaders)
import Servant.API.Routes (HasRoutes, getRoutes, mkHeaderRep, responseHeaders)
import Servant.API.Routes.Internal.Response (unResponses)
import Servant.API.Routes.Route (routeResponse)
import Servant.Client (HasClient, Client, clientWithRoute, hoistClientMonad)
import Servant.Client.Core.Request (addHeader)
import Servant.Ekg (HasEndpoint, enumerateEndpoints, getEndpoint)
import Servant.Server (HasServer, ServerT, hoistServerWithContext, route)
import Servant.Server.Internal.Delayed (addHeaderCheck)
import Servant.Server.Internal.DelayedIO (DelayedIO, withRequest)

data WithCustomErrorScheme a

xGargErrorScheme :: HeaderName
xGargErrorScheme = CI.mk "X-Garg-Error-Scheme"

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 xGargErrorScheme 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 _ req0 _mgr =
    let req = addHeader xGargErrorScheme (renderGargErrorScheme $ GES_new) req0
    in 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


data GargVersionResponse =
  GargVersionResponse { _gvr_version    :: T.Text
                      , _gvr_commitHash :: GitHash }
  deriving (Show, Eq, Generic)
instance NFData GargVersionResponse
instance ToJSON GargVersionResponse where
  toJSON GargVersionResponse { .. } = object [
      "version" .= toJSON _gvr_version
    , "commitHash" .= toJSON _gvr_commitHash
    ]
instance FromJSON GargVersionResponse where
  parseJSON = withObject "GargVersionResponse" $ \o -> do
    _gvr_version <- o .: "version"
    _gvr_commitHash <- o .: "commitHash"
    pure GargVersionResponse { .. }
instance ToSchema GargVersionResponse
