Selectively enable the new error scheme

This commit makes possible to pass an optional `X-Garg-Error-Scheme`
header in a client request to enable the new error format.

gargantext.cabal

@@ -1048,6 +1048,7 @@ test-suite garg-test-hspec
     , base ^>= 4.14.3.0
     , boolexpr ^>= 0.2
     , bytestring ^>= 0.10.12.0
+    , case-insensitive
     , conduit ^>= 1.3.4.2
     , containers ^>= 0.6.5.1
     , crawlerArxiv

src/Gargantext/API/Errors.hs

@@ -6,6 +6,9 @@ module Gargantext.API.Errors (
     module Types
   , module Class
 
+  -- * Types
+  , GargErrorScheme(..)
+
   -- * Conversion functions
   , backendErrorToFrontendError
   , frontendErrorToServerError
@@ -34,6 +37,13 @@ import qualified Data.Text.Lazy as TL
 
 $(deriveHttpStatusCode ''BackendErrorCode)
 
+data GargErrorScheme
+  = -- | The old error scheme.
+    GES_old
+    -- | The new error scheme, that returns a 'FrontendError'.
+  | GES_new
+    deriving (Show, Eq)
+
 -- | Transforms a backend internal error into something that the frontend
 -- can consume. This is the only representation we offer to the outside world,
 -- as we later encode this into a 'ServerError' in the main server handler.

src/Gargantext/API/Errors/Types.hs

@@ -640,10 +640,10 @@ genFrontendErr be = do
             pure $ mkFrontendErr' txt $ FE_job_generic_exception err
 
 instance ToJSON BackendErrorCode where
-  toJSON = JSON.String . T.pack . drop 3 . show
+  toJSON = JSON.String . T.pack . show
 
 instance FromJSON BackendErrorCode where
-  parseJSON (String s) = case readMaybe (T.unpack $ "EC_" <> s) of
+  parseJSON (String s) = case readMaybe (T.unpack s) of
     Just v     -> pure v
     Nothing    -> fail $ "FromJSON BackendErrorCode unexpected value: " <> T.unpack s
   parseJSON ty = typeMismatch "BackendErrorCode" ty

src/Gargantext/API/Routes.hs

@@ -15,6 +15,7 @@ Portability : POSIX
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Gargantext.API.Routes
       where
@@ -28,6 +29,7 @@ import Gargantext.API.Admin.FrontEnd (FrontEndAPI)
 import Gargantext.API.Auth.PolicyCheck
 import Gargantext.API.Context
 import Gargantext.API.Count  (CountAPI, count, Query)
+import Gargantext.API.Errors (GargErrorScheme (..))
 import Gargantext.API.Errors.Types
 import Gargantext.API.GraphQL qualified as GraphQL
 import Gargantext.API.Members (MembersAPI, members)
@@ -51,11 +53,38 @@ import Gargantext.Database.Prelude (HasConfig(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (gc_max_docs_scrapers)
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
+import Network.Wai (requestHeaders)
 import Servant
 import Servant.Auth as SA
 import Servant.Auth.Swagger ()
+import Servant.Ekg
+import Servant.Server.Internal.Delayed
+import Servant.Server.Internal.DelayedIO
+import Servant.Swagger
 import Servant.Swagger.UI
-
+import qualified Data.List as L
+
+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 HasSwagger (WithCustomErrorScheme GargAPI) where
+    toSwagger _ = toSwagger (Proxy :: Proxy GargAPI)
+
+instance HasEndpoint sub => HasEndpoint (WithCustomErrorScheme sub) where
+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
+  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
 
 type GargAPI = MkGargAPI (GargAPIVersion GargAPI')
 
@@ -207,10 +236,7 @@ type GargPrivateAPI' =
        -- :<|> "auth"     :> Capture "node_id" Int  :> NodeAPI
 ---------------------------------------------------------------------
 
-type API = SwaggerAPI
-       :<|> GargAPI
-       :<|> GraphQL.API
-       :<|> FrontEndAPI
+type API = WithCustomErrorScheme (SwaggerAPI :<|> GargAPI :<|> GraphQL.API :<|> FrontEndAPI)
 
 -- | API for serving @swagger.json@
 type SwaggerAPI = SwaggerSchemaUI "swagger-ui" "swagger.json"

src/Gargantext/API/Server.hs

@@ -53,18 +53,19 @@ serverGargAPI baseUrl -- orchestrator
 server :: Env -> IO (Server API)
 server env = do
   -- orchestrator <- scrapyOrchestrator env
-  pure $  swaggerSchemaUIServer swaggerDoc
+  pure $ \errScheme -> swaggerSchemaUIServer swaggerDoc
      :<|> hoistServerWithContext
             (Proxy :: Proxy GargAPI)
             (Proxy :: Proxy AuthContext)
-            transformJSON
+            (transformJSON errScheme)
             (serverGargAPI (env ^. hasConfig . gc_url_backend_api))
      :<|> hoistServerWithContext
             (Proxy :: Proxy GraphQL.API)
             (Proxy :: Proxy AuthContext)
-            transformJSON
+            (transformJSON errScheme)
             GraphQL.api
      :<|> frontEndServer
   where
-    transformJSON :: forall a. GargM Env BackendInternalError a -> Handler a
-    transformJSON = Handler . withExceptT showAsServantJSONErr . (`runReaderT` env)
+    transformJSON :: forall a. GargErrorScheme -> GargM Env BackendInternalError a -> Handler a
+    transformJSON GES_old = Handler . withExceptT showAsServantJSONErr . (`runReaderT` env)
+    transformJSON GES_new = Handler . withExceptT (frontendErrorToServerError . backendErrorToFrontendError) . (`runReaderT` env)

test/Test/API/Errors.hs

@@ -10,7 +10,7 @@ import Network.Wai.Test
 import Servant
 import Servant.Auth.Client ()
 import Servant.Client
-import Test.API.Private (protected, withValidLogin)
+import Test.API.Private (protected, withValidLogin, protectedNewError)
 import Test.API.Setup (withTestDBAndPort, setupEnvironment, mkUrl, createAliceAndBob)
 import Test.Hspec
 import Test.Hspec.Wai.Internal (withApplication)
@@ -48,3 +48,14 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
                 ->liftIO $ do
                     statusCode `shouldBe` 404
                     simpleBody `shouldBe` [r|{"error":"Node does not exist (nodeId-99)"}|]
+
+      it "returns the new error if header X-Garg-Error-Scheme: new is passed" $ \((_testEnv, port), app) -> do
+        withApplication app $ do
+          withValidLogin port "gargantua" (GargPassword "secret_key") $ \token -> do
+            res <- protectedNewError token "GET" (mkUrl port "/node/99") ""
+            case res of
+              SResponse{..}
+                | Status{..} <- simpleStatus
+                ->liftIO $ do
+                    statusCode `shouldBe` 404
+                    simpleBody `shouldBe` [r|{"data":{"node_id":99},"diagnostic":"FE_node_lookup_failed_not_found {nenf_node_id = nodeId-99}","type":"EC_404__node_lookup_failed_not_found"}|]

test/Test/API/Private.hs

@@ -10,9 +10,12 @@ module Test.API.Private (
   , withValidLogin
   , getJSON
   , protected
+  , protectedWith
+  , protectedNewError
   ) where
 
 import Data.ByteString.Lazy qualified as L
+import Data.CaseInsensitive qualified as CI
 import Data.Text.Encoding qualified as TE
 import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Routes
@@ -36,11 +39,21 @@ import Test.Utils (jsonFragment, shouldRespondWith')
 
 -- | Issue a request with a valid 'Authorization: Bearer' inside.
 protected :: Token -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
-protected tkn mth url payload =
-  request mth url [ (hAccept, "application/json;charset=utf-8")
+protected tkn mth url = protectedWith mempty tkn mth url
+
+protectedWith :: [Network.HTTP.Types.Header]
+              -> Token
+              -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
+protectedWith extraHeaders tkn mth url payload =
+  request mth url ([ (hAccept, "application/json;charset=utf-8")
                   , (hContentType, "application/json")
                   , (hAuthorization, "Bearer " <> TE.encodeUtf8 tkn)
-                  ] payload
+                  ] <> extraHeaders) payload
+
+protectedNewError :: Token -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
+protectedNewError tkn mth url = protectedWith newErrorFormat tkn mth url
+  where
+    newErrorFormat = [(CI.mk "X-Garg-Error-Scheme", "new")]
 
 getJSON :: ByteString -> WaiSession () SResponse
 getJSON url =