Merge branch 'dev' into 280-dev-xml-code-cleanup

CHANGELOG.md

+## Version 0.0.6.9.9.9.3.1
+
+* [FRONT][FIX][[NGram Table] Display of all terms return blank page (#208)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/208)
+* [FRONT][FIX][[Node Documents] Frontend enhancement - highlight terms side-by-side with other terms (#615)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/615)
+
+## Version 0.0.6.9.9.9.3
+
+* [BACK][FIX][A consistent error format for Gargantext (#267)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/267)
+* [BACK][FIX][Phylo Default (#284)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/284)
+
+## Version 0.0.6.9.9.9.2
+
+* [BACK][REFACT][A consistent error format for Gargantext (#267)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/267)
+* [FRONT][FIX][[Docs View] Highlight sometimes broken (#598)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/598)
+
+## Version 0.0.6.9.9.9.1
+
+* [FRONT][ERGO][[Top header & navbar] Reorganize to navbar (#569)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/569)
+* [BACK][TESTS][Adding new ngrams (#281)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/281)
+
 ## Version 0.0.6.9.9.9
 
 * [BACK][SECURITY][Post policy-manager fixups (#273)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/273)
 * [BACK][SECURITY][Investigate `isDescendantOf` (#279)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/279)
 * [BACK][FIX][`dateSplit` function is wrong (#275)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/275)
+* [FRONT][FIX][[Breadcrumb] Limit the elements that the user is allowed to see and add links (#609)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/609)
 
 ## Version 0.0.6.9.9.8.3.4
 

bin/gargantext-admin/Main.hs

@@ -16,18 +16,19 @@ Portability : POSIX
 module Main where
 
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
-import Gargantext.API.Prelude (GargError)
+import Gargantext.API.Errors.Types
 import Gargantext.Database.Action.User.New (newUsers)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (Cmd'')
 import Gargantext.Prelude
 import Gargantext.API.Admin.EnvTypes (DevEnv)
+import qualified Data.List.NonEmpty as NE
 
 main :: IO ()
 main = do
   (iniPath:mails) <- getArgs
 
   withDevEnv iniPath $ \env -> do
-    x <- runCmdDev env ((newUsers $ map cs mails) :: Cmd'' DevEnv GargError [UserId])
+    x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: Cmd'' DevEnv BackendInternalError (NonEmpty UserId))
     putStrLn (show x :: Text)
   pure ()

bin/gargantext-import/Main.hs

@@ -20,8 +20,8 @@ import qualified Data.Text as Text
 
 import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
 import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..))
+import Gargantext.API.Errors.Types
 import Gargantext.API.Node () -- instances
-import Gargantext.API.Prelude (GargError)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Types.Query (Limit)
@@ -45,17 +45,17 @@ main = do
     limit' = case (readMaybe limit :: Maybe Limit) of
       Nothing -> panic $ "Cannot read limit: " <> (Text.pack limit)
       Just l  -> l
-    corpus :: forall m. (FlowCmdM DevEnv GargError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    corpus :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
     corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt  format Plain corpusPath Nothing DevJobHandle
 
-    corpusCsvHal :: forall m. (FlowCmdM DevEnv GargError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    corpusCsvHal :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
     corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt CsvHal Plain corpusPath Nothing DevJobHandle
 
-    annuaire :: forall m. (FlowCmdM DevEnv GargError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
     annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath DevJobHandle
 
   {-
-  let debatCorpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
+  let debatCorpus :: forall m. FlowCmdM DevEnv BackendInternalError m => m CorpusId
       debatCorpus = do
         docs <- liftIO ( splitEvery 500
                        <$> take (read limit :: Int)

bin/gargantext-init/Main.hs

@@ -16,8 +16,8 @@ Import a corpus binary.
 module Main where
 
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
+import Gargantext.API.Errors.Types
 import Gargantext.API.Node () -- instances only
-import Gargantext.API.Prelude (GargError)
 import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..))
 import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMk_RootWithCorpus)
 import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
@@ -29,6 +29,7 @@ import Gargantext.Database.Query.Table.Node (getOrMkList)
 import Gargantext.Database.Query.Table.User (insertNewUsers, )
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..), readConfig)
+import qualified Data.List.NonEmpty as NE
 
 
 main :: IO ()
@@ -48,18 +49,18 @@ main = do
   cfg       <- readConfig         iniPath
   let secret = _gc_secretkey cfg
 
-  let createUsers :: Cmd GargError Int64
+  let createUsers :: Cmd BackendInternalError Int64
       createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)
-                                   : arbitraryNewUsers
+                                   NE.:| arbitraryNewUsers
                                    )
 
   let
-    mkRoots :: Cmd GargError [(UserId, RootId)]
+    mkRoots :: Cmd BackendInternalError [(UserId, RootId)]
     mkRoots = mapM getOrMkRoot $ map UserName ("gargantua" : arbitraryUsername)
     -- TODO create all users roots
 
   let
-    initMaster :: Cmd GargError (UserId, RootId, CorpusId, ListId)
+    initMaster :: Cmd BackendInternalError (UserId, RootId, CorpusId, ListId)
     initMaster = do
       (masterUserId, masterRootId, masterCorpusId)
                   <- getOrMk_RootWithCorpus (UserName userMaster)
@@ -70,7 +71,7 @@ main = do
       pure (masterUserId, masterRootId, masterCorpusId, masterListId)
 
   withDevEnv iniPath $ \env -> do
-    _ <- runCmdDev env (initFirstTriggers secret :: DBCmd GargError [Int64])
+    _ <- runCmdDev env (initFirstTriggers secret :: DBCmd BackendInternalError [Int64])
     _ <- runCmdDev env createUsers
     x <- runCmdDev env initMaster
     _ <- runCmdDev env mkRoots

bin/gargantext-invitations/Main.hs

@@ -16,7 +16,7 @@ module Main where
 
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Node () -- instances only
-import Gargantext.API.Prelude (GargError)
+import Gargantext.API.Errors.Types
 import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Admin.Types.Node
@@ -36,7 +36,7 @@ main = do
 
   _cfg       <- readConfig         iniPath
 
-  let invite :: (CmdRandom env GargError m, HasNLPServer env) => m Int
+  let invite :: (CmdRandom env BackendInternalError m, HasNLPServer env) => m Int
       invite = Share.api (UserName $ cs user) (UnsafeMkNodeId $ (read node_id :: Int)) (Share.ShareTeamParams $ cs email)
 
   withDevEnv iniPath $ \env -> do

bin/gargantext-phylo/Main.hs

@@ -26,6 +26,7 @@ import Data.Maybe (fromJust)
 import Data.Text  (unpack, replace, pack)
 import Data.Text qualified as T
 import Data.Vector qualified as Vector
+import GHC.IO.Encoding
 import Gargantext.API.Ngrams.Prelude (toTermList)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Text.Context (TermList)
@@ -253,6 +254,9 @@ fileToList parser path =
 main :: IO ()
 main = do
 
+    setLocaleEncoding utf8
+    currentLocale <- getLocaleEncoding
+    printIOMsg $ "Machine locale: " <> show currentLocale
     printIOMsg "Starting the reconstruction"
 
     printIOMsg "Read the configuration file"

bin/gargantext-server/Main.hs

@@ -28,6 +28,7 @@ import Gargantext.API (startGargantext) -- , startGargantextMock)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.Prelude
 import Gargantext.System.Logging
+import GHC.IO.Encoding
 import Options.Generic
 import System.Exit (exitSuccess)
 import qualified Paths_gargantext as PG -- cabal magic build module
@@ -54,6 +55,11 @@ deriving instance Show (MyOptions Unwrapped)
 
 main :: IO ()
 main = withLogger () $ \ioLogger -> do
+
+  -- Sets the locale to avoid encoding issues like in #284.
+  setLocaleEncoding utf8
+  currentLocale <- getLocaleEncoding
+
   MyOptions myMode myPort myIniFile myVersion  <- unwrapRecord
           "Gargantext server"
   ---------------------------------------------------------------
@@ -75,6 +81,7 @@ main = withLogger () $ \ioLogger -> do
   let start = case myMode of
         Mock -> panic "[ERROR] Mock mode unsupported"
         _ -> startGargantext myMode myPort' (unpack myIniFile')
-  logMsg ioLogger INFO $ "Starting with " <> show myMode <> " mode."
+  logMsg ioLogger INFO $ "Starting with "   <> show myMode <> " mode."
+  logMsg ioLogger INFO $ "Machine locale: " <> show currentLocale
   start
   ---------------------------------------------------------------

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 2.0
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.6.9.9.9
+version: 0.0.6.9.9.9.3.1
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -51,6 +51,11 @@ library
       Gargantext.API.Admin.Types
       Gargantext.API.Auth.PolicyCheck
       Gargantext.API.Dev
+      Gargantext.API.Errors
+      Gargantext.API.Errors.Class
+      Gargantext.API.Errors.TH
+      Gargantext.API.Errors.Types
+      Gargantext.API.Errors.Types.Backend
       Gargantext.API.HashedResponse
       Gargantext.API.Ngrams
       Gargantext.API.Ngrams.Prelude
@@ -130,6 +135,7 @@ library
       Gargantext.Database.Admin.Types.Node
       Gargantext.Database.Prelude
       Gargantext.Database.Query.Facet
+      Gargantext.Database.Query.Table.Ngrams
       Gargantext.Database.Query.Table.NgramsPostag
       Gargantext.Database.Query.Table.Node
       Gargantext.Database.Query.Table.Node.Error
@@ -141,6 +147,7 @@ library
       Gargantext.Database.Schema.User
       Gargantext.Defaults
       Gargantext.System.Logging
+      Gargantext.Utils.Dict
       Gargantext.Utils.Jobs
       Gargantext.Utils.Jobs.Internal
       Gargantext.Utils.Jobs.Map
@@ -216,7 +223,6 @@ library
       Gargantext.Core.Methods.Similarities.Accelerate.SpeGen
       Gargantext.Core.Methods.Similarities.Conditional
       Gargantext.Core.Methods.Similarities.Distributional
-      Gargantext.Core.NodeStoryFile
       Gargantext.Core.Statistics
       Gargantext.Core.Text.Convert
       Gargantext.Core.Text.Corpus.API.Hal
@@ -329,7 +335,6 @@ library
       Gargantext.Database.Query.Table.Context
       Gargantext.Database.Query.Table.ContextNodeNgrams
       Gargantext.Database.Query.Table.ContextNodeNgrams2
-      Gargantext.Database.Query.Table.Ngrams
       Gargantext.Database.Query.Table.Node.Children
       Gargantext.Database.Query.Table.Node.Contact
       Gargantext.Database.Query.Table.Node.Document.Add
@@ -892,6 +897,7 @@ test-suite garg-test-tasty
       Test.Core.Utils
       Test.Database.Operations
       Test.Database.Operations.DocumentSearch
+      Test.Database.Operations.NodeStory
       Test.Database.Setup
       Test.Database.Types
       Test.Graph.Clustering
@@ -997,11 +1003,13 @@ test-suite garg-test-hspec
   other-modules:
       Test.API
       Test.API.Authentication
+      Test.API.Errors
       Test.API.GraphQL
       Test.API.Private
       Test.API.Setup
       Test.Database.Operations
       Test.Database.Operations.DocumentSearch
+      Test.Database.Operations.NodeStory
       Test.Database.Setup
       Test.Database.Types
       Test.Utils
@@ -1041,6 +1049,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/Admin/Auth.hs

@@ -53,7 +53,7 @@ import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types
 import Gargantext.API.Auth.PolicyCheck
-import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer, _ServerError, GargM, GargError (..))
+import Gargantext.API.Prelude (authenticationError, HasServerError, GargServerC, GargServer, _ServerError, GargM)
 import Gargantext.Core.Mail (MailModel(..), mail)
 import Gargantext.Core.Mail.Types (mailSettings)
 import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
@@ -72,12 +72,13 @@ import Gargantext.Prelude.Crypto.Pass.User (gargPass)
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
 import Servant
 import Servant.Auth.Server
+import Gargantext.API.Errors
 
 ---------------------------------------------------
 
 -- | Main functions of authorization
 
-makeTokenForUser :: (HasSettings env, HasJoseError err)
+makeTokenForUser :: (HasSettings env, HasAuthenticationError err)
                  => NodeId
                  -> UserId
                  -> Cmd' env err Token
@@ -85,10 +86,10 @@ makeTokenForUser nodeId userId = do
   jwtS <- view $ settings . jwtSettings
   e <- liftBase $ makeJWT (AuthenticatedUser nodeId userId) jwtS Nothing
   -- TODO-SECURITY here we can implement token expiration ^^.
-  either joseError (pure . toStrict . LE.decodeUtf8) e
+  either (authenticationError . LoginFailed nodeId userId) (pure . toStrict . LE.decodeUtf8) e
   -- TODO not sure about the encoding...
 
-checkAuthRequest :: ( HasSettings env, HasJoseError err, DbCmd' env err m )
+checkAuthRequest :: ( HasSettings env, HasAuthenticationError err, DbCmd' env err m )
                  => Username
                  -> GargPassword
                  -> m CheckAuth
@@ -113,7 +114,7 @@ checkAuthRequest couldBeEmail (GargPassword p) = do
               token <- makeTokenForUser nodeId userLight_id
               pure $ Valid token nodeId userLight_id
 
-auth :: (HasSettings env, HasJoseError err, DbCmd' env err m)
+auth :: (HasSettings env, HasAuthenticationError err, DbCmd' env err m)
      => AuthRequest -> m AuthResponse
 auth (AuthRequest u p) = do
   checkAuthRequest' <- checkAuthRequest u p
@@ -163,7 +164,7 @@ withAccess p _ ur id = hoistServer p f
 -- | Given the 'AuthenticatedUser', a policy check and a function that returns an @a@,
 -- it runs the underlying policy check to ensure that the resource is returned only to
 -- who is entitled to see it.
-withPolicy :: GargServerC env GargError m
+withPolicy :: GargServerC env BackendInternalError m
            => AuthenticatedUser
            -> BoolExpr AccessCheck
            -> m a
@@ -174,10 +175,10 @@ withPolicy ur checks m mgr = case mgr of
     res <- runAccessPolicy ur checks
     case res of
       Allow     -> m
-      Deny err  -> throwError $ GargServerError $ err
+      Deny err  -> throwError $ InternalServerError $ err
 
 withPolicyT :: forall env m api. (
-                 GargServerC env GargError m
+                 GargServerC env BackendInternalError m
                , HasServer api '[]
                )
             => Proxy api
@@ -232,11 +233,12 @@ forgotPasswordPost (ForgotPasswordRequest email) = do
   -- users' emails
   pure $ ForgotPasswordResponse "ok"
 
-forgotPasswordGet :: (HasSettings env, CmdCommon env, HasJoseError err, HasServerError err)
+forgotPasswordGet :: (HasSettings env, CmdCommon env, HasAuthenticationError err, HasServerError err)
      => Maybe Text -> Cmd' env err ForgotPasswordGet
 forgotPasswordGet Nothing = pure $ ForgotPasswordGet ""
 forgotPasswordGet (Just uuid) = do
   let mUuid = fromText uuid
+  -- FIXME(adn) Sending out \"not found\" is leaking information here, we ought to fix it.
   case mUuid of
     Nothing -> throwError $ _ServerError # err404 { errBody = "Not found" }
     Just uuid' -> do
@@ -248,7 +250,7 @@ forgotPasswordGet (Just uuid) = do
 
 ---------------------
 
-forgotPasswordGetUser :: ( HasSettings env, CmdCommon env, HasJoseError err, HasServerError err)
+forgotPasswordGetUser :: ( HasSettings env, CmdCommon env, HasAuthenticationError err, HasServerError err)
      => UserLight -> Cmd' env err ForgotPasswordGet
 forgotPasswordGetUser (UserLight { .. }) = do
   -- pick some random password
@@ -309,7 +311,7 @@ generateForgotPasswordUUID = do
 type ForgotPasswordAsyncAPI = Summary "Forgot password asnc"
                               :> AsyncJobs JobLog '[JSON] ForgotPasswordAsyncParams JobLog
 
-forgotPasswordAsync :: ServerT ForgotPasswordAsyncAPI (GargM Env GargError)
+forgotPasswordAsync :: ServerT ForgotPasswordAsyncAPI (GargM Env BackendInternalError)
 forgotPasswordAsync =
   serveJobsAPI ForgotPasswordJob $ \jHandle p -> forgotPasswordAsync' p jHandle
 

src/Gargantext/API/Admin/Auth/Types.hs

@@ -25,6 +25,7 @@ import Gargantext.Prelude hiding (reverse)
 import Servant.Auth.Server
 import Test.QuickCheck (elements, oneof)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import qualified Crypto.JWT as Jose
 
 ---------------------------------------------------
 
@@ -70,6 +71,10 @@ instance ToSchema AuthenticatedUser where
 instance ToJWT AuthenticatedUser
 instance FromJWT AuthenticatedUser
 
+data AuthenticationError
+  = LoginFailed NodeId UserId Jose.Error
+  deriving (Show, Eq)
+
 -- TODO-SECURITY why is the CookieSettings necessary?
 type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
 

src/Gargantext/API/Admin/EnvTypes.hs

@@ -32,8 +32,9 @@ import Data.Text qualified as T
 import Database.PostgreSQL.Simple (Connection)
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Admin.Types
+import Gargantext.API.Errors.Types
 import Gargantext.API.Job
-import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
 import Gargantext.Core.NodeStory
@@ -64,17 +65,17 @@ modeToLoggingLevels = \case
    -- For production, accepts everything but DEBUG.
    Prod -> [minBound .. maxBound] \\ [DEBUG]
 
-instance MonadLogger (GargM Env GargError) where
+instance MonadLogger (GargM Env BackendInternalError) where
   getLogger = asks _env_logger
 
-instance HasLogger (GargM Env GargError) where
-  data instance Logger (GargM Env GargError)  =
+instance HasLogger (GargM Env BackendInternalError) where
+  data instance Logger (GargM Env BackendInternalError)  =
     GargLogger {
         logger_mode    :: Mode
       , logger_set     :: FL.LoggerSet
       }
-  type instance LogInitParams (GargM Env GargError) = Mode
-  type instance LogPayload (GargM Env GargError)    = FL.LogStr
+  type instance LogInitParams (GargM Env BackendInternalError) = Mode
+  type instance LogPayload (GargM Env BackendInternalError)    = FL.LogStr
   initLogger                = \mode -> do
     logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
     pure $ GargLogger mode logger_set
@@ -111,7 +112,7 @@ data GargJob
 -- we need to remember to force the fields to WHNF at that point.
 data Env = Env
   { _env_settings  :: ~Settings
-  , _env_logger    :: ~(Logger (GargM Env GargError))
+  , _env_logger    :: ~(Logger (GargM Env BackendInternalError))
   , _env_pool      :: ~(Pool Connection)
   , _env_nodeStory :: ~NodeStoryEnv
   , _env_manager   :: ~Manager
@@ -138,9 +139,6 @@ instance HasNodeStoryEnv Env where
 instance HasNodeStoryVar Env where
   hasNodeStoryVar = hasNodeStory . nse_getter
 
-instance HasNodeStorySaver Env where
-  hasNodeStorySaver = hasNodeStory . nse_saver
-
 instance HasNodeStoryImmediateSaver Env where
   hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
 
@@ -234,17 +232,17 @@ data MockEnv = MockEnv
 
 makeLenses ''MockEnv
 
-instance MonadLogger (GargM DevEnv GargError) where
+instance MonadLogger (GargM DevEnv BackendInternalError) where
   getLogger = asks _dev_env_logger
 
-instance HasLogger (GargM DevEnv GargError) where
-  data instance Logger (GargM DevEnv GargError)  =
+instance HasLogger (GargM DevEnv BackendInternalError) where
+  data instance Logger (GargM DevEnv BackendInternalError)  =
     GargDevLogger {
         dev_logger_mode    :: Mode
       , dev_logger_set     :: FL.LoggerSet
       }
-  type instance LogInitParams (GargM DevEnv GargError) = Mode
-  type instance LogPayload (GargM DevEnv GargError)    = FL.LogStr
+  type instance LogInitParams (GargM DevEnv BackendInternalError) = Mode
+  type instance LogPayload (GargM DevEnv BackendInternalError)    = FL.LogStr
   initLogger                = \mode -> do
     dev_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
     pure $ GargDevLogger mode dev_logger_set
@@ -258,7 +256,7 @@ instance HasLogger (GargM DevEnv GargError) where
 data DevEnv = DevEnv
   { _dev_env_settings  :: !Settings
   , _dev_env_config    :: !GargConfig
-  , _dev_env_logger    :: !(Logger (GargM DevEnv GargError))
+  , _dev_env_logger    :: !(Logger (GargM DevEnv BackendInternalError))
   , _dev_env_pool      :: !(Pool Connection)
   , _dev_env_nodeStory :: !NodeStoryEnv
   , _dev_env_mail      :: !MailConfig
@@ -310,9 +308,6 @@ instance HasNodeStoryEnv DevEnv where
 instance HasNodeStoryVar DevEnv where
   hasNodeStoryVar = hasNodeStory . nse_getter
 
-instance HasNodeStorySaver DevEnv where
-  hasNodeStorySaver = hasNodeStory . nse_saver
-
 instance HasNodeStoryImmediateSaver DevEnv where
   hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
 

src/Gargantext/API/Admin/Settings.hs

@@ -28,6 +28,7 @@ import Data.Pool (Pool, createPool)
 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Types
+import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.Core.NLP (nlpServerMap)
 import Gargantext.Core.NodeStory
@@ -171,7 +172,7 @@ readRepoEnv repoDir = do
 devJwkFile :: FilePath
 devJwkFile = "dev.jwk"
 
-newEnv :: Logger (GargM Env GargError) -> PortNumber -> FilePath -> IO Env
+newEnv :: Logger (GargM Env BackendInternalError) -> PortNumber -> FilePath -> IO Env
 newEnv logger port file = do
   !manager_env  <- newTlsManager
   !settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
@@ -186,8 +187,8 @@ newEnv logger port file = do
   !self_url_env  <- parseBaseUrl $ "http://0.0.0.0:" <> show port
   dbParam        <- databaseParameters file
   !pool          <- newPool dbParam
-  --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
-  !nodeStory_env <- readNodeStoryEnv pool
+  --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath config_env)
+  !nodeStory_env <- fromDBNodeStoryEnv pool
   !scrapers_env  <- newJobEnv defaultSettings manager_env
 
   secret        <- Jobs.genSecret

src/Gargantext/API/Auth/PolicyCheck.hs

@@ -21,24 +21,24 @@ module Gargantext.API.Auth.PolicyCheck (
   ) where
 
 import Control.Lens
+import Control.Monad
+import Data.BoolExpr
 import Gargantext.API.Admin.Auth.Types
+import Gargantext.API.Errors.Types
 import Gargantext.Core.Types
+import Gargantext.Core.Types.Individu
 import Gargantext.Database.Prelude (DBCmd, HasConfig (..))
+import Gargantext.Database.Query.Table.Node.Error
+import Gargantext.Database.Query.Tree
+import Gargantext.Database.Query.Tree.Root
 import Gargantext.Prelude.Config (GargConfig(..))
 import Prelude
 import Servant
+import Servant.Auth.Server.Internal.AddSetCookie
 import Servant.Ekg
 import Servant.Server.Internal.Delayed
 import Servant.Server.Internal.DelayedIO
 import qualified Servant.Swagger as Swagger
-import Gargantext.Core.Types.Individu
-import Gargantext.Database.Query.Table.Node.Error
-import Data.BoolExpr
-import Control.Monad
-import Gargantext.API.Prelude
-import Servant.Auth.Server.Internal.AddSetCookie
-import Gargantext.Database.Query.Tree
-import Gargantext.Database.Query.Tree.Root
 
 -------------------------------------------------------------------------------
 -- Types
@@ -66,7 +66,7 @@ instance Monoid AccessResult where
 -- | An access policy manager for gargantext that governs how resources are accessed
 -- and who is entitled to see what.
 data AccessPolicyManager = AccessPolicyManager
-  { runAccessPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd GargError AccessResult }
+  { runAccessPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd BackendInternalError AccessResult }
 
 -- | A type representing all the possible access checks we might want to perform on a resource,
 -- typically a 'Node'.
@@ -97,7 +97,7 @@ data AccessCheck
 accessPolicyManager :: AccessPolicyManager
 accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
   where
-    interpretPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd GargError AccessResult
+    interpretPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd BackendInternalError AccessResult
     interpretPolicy ur chk = case chk of
       BAnd b1 b2
         -> liftM2 (<>) (interpretPolicy ur b1) (interpretPolicy ur b2)

src/Gargantext/API/Dev.hs

@@ -15,6 +15,7 @@ module Gargantext.API.Dev where
 import Control.Monad (fail)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Settings
+import Gargantext.API.Errors.Types
 import Gargantext.API.Ngrams (saveNodeStoryImmediate)
 import Gargantext.API.Prelude
 import Gargantext.Core.NLP (nlpServerMap)
@@ -38,9 +39,9 @@ withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
     newDevEnv logger = do
       cfg     <- readConfig         iniPath
       dbParam <- databaseParameters iniPath
-      --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
+      --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
       pool    <- newPool            dbParam
-      nodeStory_env <- readNodeStoryEnv pool
+      nodeStory_env <- fromDBNodeStoryEnv pool
       setts   <- devSettings devJwkFile
       mail    <- Mail.readConfig iniPath
       nlp_config <- NLP.readConfig iniPath
@@ -69,7 +70,7 @@ runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
 runCmdDev env f =
   (either (fail . show) pure =<< runCmd env f)
 
-runCmdGargDev :: DevEnv -> GargM DevEnv GargError a -> IO a
+runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a
 runCmdGargDev env cmd =
   (either (fail . show) pure =<< runExceptT (runReaderT cmd env))
     `finally`
@@ -81,5 +82,5 @@ runCmdDevNoErr = runCmdDev
 runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
 runCmdDevServantErr = runCmdDev
 
-runCmdReplEasy :: Cmd'' DevEnv GargError a -> IO a
+runCmdReplEasy :: Cmd'' DevEnv BackendInternalError a -> IO a
 runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f

src/Gargantext/API/Errors.hs

+{-# LANGUAGE LambdaCase       #-}
+{-# LANGUAGE TemplateHaskell  #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Gargantext.API.Errors (
+    module Types
+  , module Class
+
+  -- * Types
+  , GargErrorScheme(..)
+
+  -- * Conversion functions
+  , backendErrorToFrontendError
+  , frontendErrorToServerError
+
+  -- * Temporary shims
+  , showAsServantJSONErr
+  ) where
+
+import Prelude
+
+import Control.Exception
+import Data.Validity ( prettyValidation )
+import Gargantext.API.Admin.Auth.Types
+import Gargantext.API.Errors.Class as Class
+import Gargantext.API.Errors.TH (deriveHttpStatusCode)
+import Gargantext.API.Errors.Types as Types
+import Gargantext.Database.Query.Table.Node.Error hiding (nodeError)
+import Gargantext.Database.Query.Tree hiding (treeError)
+import Gargantext.Utils.Jobs.Monad (JobError(..))
+import Servant.Server
+import qualified Data.Aeson as JSON
+import qualified Data.Text as T
+import qualified Network.HTTP.Types.Status as HTTP
+import qualified Data.Text.Lazy.Encoding as TE
+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.
+backendErrorToFrontendError :: BackendInternalError -> FrontendError
+backendErrorToFrontendError = \case
+  InternalNodeError nodeError
+    -> nodeErrorToFrontendError nodeError
+  InternalTreeError treeError
+    -> treeErrorToFrontendError treeError
+  InternalValidationError validationError
+    -> mkFrontendErr' "A validation error occurred"
+         $ FE_validation_error $ case prettyValidation validationError of
+             Nothing -> "unknown_validation_error"
+             Just v  -> T.pack v
+  InternalAuthenticationError authError
+    -> authErrorToFrontendError authError
+  InternalServerError internalServerError
+    -> internalServerErrorToFrontendError internalServerError
+  InternalJobError jobError
+    -> jobErrorToFrontendError jobError
+
+internalServerErrorToFrontendError :: ServerError -> FrontendError
+internalServerErrorToFrontendError = \case
+  ServerError{..} ->
+    mkFrontendErr' (T.pack errReasonPhrase) $ FE_internal_server_error (TL.toStrict $ TE.decodeUtf8 $ errBody)
+
+jobErrorToFrontendError :: JobError -> FrontendError
+jobErrorToFrontendError = \case
+  InvalidIDType idTy -> mkFrontendErrNoDiagnostic $ FE_job_invalid_id_type idTy
+  IDExpired jobId    -> mkFrontendErrNoDiagnostic $ FE_job_expired jobId
+  InvalidMacID macId -> mkFrontendErrNoDiagnostic $ FE_job_invalid_mac macId
+  UnknownJob jobId   -> mkFrontendErrNoDiagnostic $ FE_job_unknown_job jobId
+  JobException err   -> mkFrontendErrNoDiagnostic $ FE_job_generic_exception (T.pack $ displayException err)
+
+authErrorToFrontendError :: AuthenticationError -> FrontendError
+authErrorToFrontendError = \case
+  -- For now, we ignore the Jose error, as they are too specific
+  -- (i.e. they should be logged internally to Sentry rather than shared
+  -- externally).
+  LoginFailed nid uid _
+    -> mkFrontendErr' "Invalid username/password, or invalid session token." $ FE_login_failed_error nid uid
+
+nodeErrorToFrontendError :: NodeError -> FrontendError
+nodeErrorToFrontendError ne = case ne of
+  NoListFound lid
+    -> mkFrontendErrShow $ FE_node_list_not_found lid
+  NoRootFound
+    -> mkFrontendErrShow FE_node_root_not_found
+  NoCorpusFound
+    -> mkFrontendErrShow FE_node_corpus_not_found
+  NoUserFound _ur
+    -> undefined
+  NodeCreationFailed reason
+    -> case reason of
+         UserParentAlreadyExists pId uId
+           -> mkFrontendErrShow $ FE_node_creation_failed_parent_exists uId pId
+         UserParentDoesNotExist uId
+           -> mkFrontendErrShow $ FE_node_creation_failed_no_parent uId
+         InsertNodeFailed uId pId
+           -> mkFrontendErrShow $ FE_node_creation_failed_insert_node uId pId
+         UserHasNegativeId uid
+           -> mkFrontendErrShow $ FE_node_creation_failed_user_negative_id uid
+  NodeLookupFailed reason
+    -> case reason of
+         NodeDoesNotExist nid
+           -> mkFrontendErrShow $ FE_node_lookup_failed_not_found nid
+         UserDoesNotExist uid
+           -> mkFrontendErrShow $ FE_node_lookup_failed_user_not_found uid
+         UserNameDoesNotExist uname
+           -> mkFrontendErrShow $ FE_node_lookup_failed_username_not_found uname
+         UserHasTooManyRoots uid roots
+           -> mkFrontendErrShow $ FE_node_lookup_failed_user_too_many_roots uid roots
+  NotImplYet
+    -> mkFrontendErrShow FE_node_not_implemented_yet
+  NoContextFound contextId
+    -> mkFrontendErrShow $ FE_node_context_not_found contextId
+  NeedsConfiguration
+    -> mkFrontendErrShow $ FE_node_needs_configuration
+  NodeError err
+    -> mkFrontendErrShow $ FE_node_generic_exception (T.pack $ displayException err)
+
+  -- backward-compatibility shims, to remove eventually.
+  DoesNotExist nid
+    -> mkFrontendErrShow $ FE_node_lookup_failed_not_found nid
+
+treeErrorToFrontendError :: TreeError -> FrontendError
+treeErrorToFrontendError te = case te of
+  NoRoot             -> mkFrontendErrShow FE_tree_root_not_found
+  EmptyRoot          -> mkFrontendErrShow FE_tree_empty_root
+  TooManyRoots roots -> mkFrontendErrShow $ FE_tree_too_many_roots roots
+
+-- | Converts a 'FrontendError' into a 'ServerError' that the servant app can
+-- return to the frontend.
+frontendErrorToServerError :: FrontendError -> ServerError
+frontendErrorToServerError fe@(FrontendError diag ty _) =
+  ServerError { errHTTPCode     = HTTP.statusCode $ backendErrorTypeToErrStatus ty
+              , errReasonPhrase = T.unpack diag
+              , errBody         = JSON.encode fe
+              , errHeaders      = mempty
+              }
+
+showAsServantJSONErr :: BackendInternalError -> ServerError
+showAsServantJSONErr (InternalNodeError err@(NoListFound {}))  = err404 { errBody = JSON.encode err }
+showAsServantJSONErr (InternalNodeError err@NoRootFound{})     = err404 { errBody = JSON.encode err }
+showAsServantJSONErr (InternalNodeError err@NoCorpusFound)     = err404 { errBody = JSON.encode err }
+showAsServantJSONErr (InternalNodeError err@NoUserFound{})     = err404 { errBody = JSON.encode err }
+showAsServantJSONErr (InternalNodeError err@(DoesNotExist {})) = err404 { errBody = JSON.encode err }
+showAsServantJSONErr (InternalServerError err)                 = err
+showAsServantJSONErr a                                         = err500 { errBody = JSON.encode a }

src/Gargantext/API/Errors/Class.hs

+
+module Gargantext.API.Errors.Class where
+
+import Control.Lens
+import Gargantext.API.Admin.Auth.Types (AuthenticationError)
+
+class HasAuthenticationError e where
+  _AuthenticationError :: Prism' e AuthenticationError

src/Gargantext/API/Errors/TH.hs

+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Gargantext.API.Errors.TH (
+    deriveHttpStatusCode
+  , deriveIsFrontendErrorData
+  ) where
+
+import           Prelude
+
+import           Gargantext.API.Errors.Types.Backend
+import           Network.HTTP.Types
+import qualified Data.Map.Strict                as Map
+import qualified Data.Text                      as T
+import qualified Language.Haskell.TH            as TH
+import qualified Network.HTTP.Types as HTTP
+
+-- | A static map of the HTTP status code we support.
+supported_http_status_map :: Map.Map T.Text (TH.Q TH.Exp)
+supported_http_status_map = Map.fromList
+  [ ("200", TH.varE 'status200)
+  , ("400", TH.varE 'status400)
+  , ("403", TH.varE 'status403)
+  , ("404", TH.varE 'status404)
+  , ("500", TH.varE 'status500)
+  ]
+
+
+deriveHttpStatusCode :: TH.Name -> TH.Q [TH.Dec]
+deriveHttpStatusCode appliedType = do
+  info <- TH.reify appliedType
+  case info of
+    TH.TyConI (TH.DataD _ _ _ _ ctors _)
+      -> case extract_names ctors of
+           Left ctor   -> error $ "Only enum-like constructors supported: " ++ show ctor
+           Right names -> case parse_error_codes names of
+             Left n -> error $ "Couldn't extract error code from : " ++ TH.nameBase n
+                             ++ ". Make sure it's in the form XX_<validHttpStatusCode>__<textual_diagnostic>"
+             Right codes -> do
+               let static_matches = flip map codes $ \(n, stE, _txt) ->
+                     TH.match (TH.conP n [])
+                              (TH.normalB [| $(stE) |])
+                              []
+
+               [d| backendErrorTypeToErrStatus :: BackendErrorCode -> HTTP.Status
+                   backendErrorTypeToErrStatus = $(TH.lamCaseE static_matches) |]
+    err
+      -> error $ "Cannot call deriveHttpStatusCode on: " ++ show err
+
+extract_names :: [TH.Con] -> Either TH.Con [TH.Name]
+extract_names = mapM go
+  where
+    go :: TH.Con -> Either TH.Con TH.Name
+    go = \case
+      (TH.NormalC n []) -> Right n
+      e                 -> Left e
+
+parse_error_codes :: [TH.Name]
+                  -> Either TH.Name [(TH.Name, TH.Q TH.Exp, T.Text)]
+parse_error_codes = mapM go
+  where
+
+    do_parse = \n_txt ->
+      let sts_tl = T.drop 3 n_txt
+          code   = T.take 3 sts_tl
+          msg    = T.drop 5 sts_tl
+      in (code, msg)
+
+    go :: TH.Name -> Either TH.Name (TH.Name, TH.Q TH.Exp, T.Text)
+    go n = case Map.lookup code supported_http_status_map of
+             Nothing -> Left n
+             Just st -> Right (n, st, msg)
+      where
+        (code, msg) = do_parse $ (T.pack $ TH.nameBase n)
+
+deriveIsFrontendErrorData :: TH.Name -> TH.Q [TH.Dec]
+deriveIsFrontendErrorData appliedType = do
+  info <- TH.reify appliedType
+  case info of
+    TH.TyConI (TH.DataD _ _ _ _ ctors _)
+      -> case extract_names ctors of
+           Left ctor   -> error $ "Only enum-like constructors supported: " ++ show ctor
+           Right names -> fmap mconcat . sequence $ flip map names $ \n ->
+               [d| instance IsFrontendErrorData $(TH.promotedT n) where
+                     isFrontendErrorData _ = Dict |]
+    err
+      -> error $ "Cannot call deriveHttpStatusCode on: " ++ show err

src/Gargantext/API/Errors/Types/Backend.hs

+{-# LANGUAGE KindSignatures           #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TemplateHaskell          #-}
+{-# LANGUAGE TypeFamilies             #-}
+
+module Gargantext.API.Errors.Types.Backend where
+
+import Data.Aeson
+import Data.Kind
+import Data.Singletons.TH
+import Data.Typeable
+import Gargantext.Utils.Dict
+import Prelude
+
+-- | A (hopefully and eventually) exhaustive list of backend errors.
+data BackendErrorCode
+  =
+  -- node errors
+    EC_404__node_list_not_found
+  | EC_404__node_root_not_found
+  | EC_404__node_lookup_failed_not_found
+  | EC_400__node_lookup_failed_user_too_many_roots
+  | EC_404__node_lookup_failed_user_not_found
+  | EC_404__node_lookup_failed_username_not_found
+  | EC_404__node_corpus_not_found
+  | EC_500__node_not_implemented_yet
+  | EC_404__node_context_not_found
+  | EC_400__node_creation_failed_no_parent
+  | EC_400__node_creation_failed_parent_exists
+  | EC_400__node_creation_failed_insert_node
+  | EC_400__node_creation_failed_user_negative_id
+  | EC_500__node_generic_exception
+  | EC_400__node_needs_configuration
+  -- validation errors
+  | EC_400__validation_error
+  -- authentication errors
+  | EC_403__login_failed_error
+  -- tree errors
+  | EC_404__tree_root_not_found
+  | EC_404__tree_empty_root
+  | EC_500__tree_too_many_roots
+  -- internal server errors
+  | EC_500__internal_server_error
+  -- job errors
+  | EC_500__job_invalid_id_type
+  | EC_500__job_expired
+  | EC_500__job_invalid_mac
+  | EC_500__job_unknown_job
+  | EC_500__job_generic_exception
+  deriving (Show, Read, Eq, Enum, Bounded)
+
+$(genSingletons [''BackendErrorCode])
+
+----------------------------------------------------------------------------
+-- This data family maps a 'BackendErrorCode' into a concrete payload.
+----------------------------------------------------------------------------
+data family ToFrontendErrorData (payload :: BackendErrorCode) :: Type
+
+class ( SingI payload
+      , ToJSON (ToFrontendErrorData payload)
+      , FromJSON (ToFrontendErrorData payload)
+      , Show (ToFrontendErrorData payload)
+      , Eq (ToFrontendErrorData payload)
+      , Typeable payload
+      ) => IsFrontendErrorData payload where
+  isFrontendErrorData :: Proxy payload -> Dict IsFrontendErrorData payload

src/Gargantext/API/GraphQL.hs

@@ -28,6 +28,7 @@ import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog)
 import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.Auth.PolicyCheck
+import Gargantext.API.Errors.Types
 import Gargantext.API.GraphQL.Annuaire qualified as GQLA
 import Gargantext.API.GraphQL.AsyncTask qualified as GQLAT
 import Gargantext.API.GraphQL.Context qualified as GQLCTX
@@ -38,7 +39,7 @@ import Gargantext.API.GraphQL.Team qualified as GQLTeam
 import Gargantext.API.GraphQL.TreeFirstLevel qualified as GQLTree
 import Gargantext.API.GraphQL.User qualified as GQLUser
 import Gargantext.API.GraphQL.UserInfo qualified as GQLUserInfo
-import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.API.Prelude (GargM)
 import Gargantext.API.Prelude (HasJobEnv')
 import Gargantext.API.Types
 import Gargantext.Core.NLP (HasNLPServer)
@@ -106,7 +107,7 @@ rootResolver
   :: (CmdCommon env, HasNLPServer env, HasJobEnv' env, HasSettings env)
   => AuthenticatedUser
   -> AccessPolicyManager
-  -> RootResolver (GargM env GargError) e Query Mutation Undefined
+  -> RootResolver (GargM env BackendInternalError) e Query Mutation Undefined
 rootResolver authenticatedUser policyManager =
   RootResolver
     { queryResolver = Query { annuaire_contacts   = GQLA.resolveAnnuaireContacts
@@ -135,7 +136,7 @@ app
   :: (Typeable env, CmdCommon env, HasJobEnv' env, HasNLPServer env, HasSettings env)
   => AuthenticatedUser
   -> AccessPolicyManager
-  -> App (EVENT (GargM env GargError)) (GargM env GargError)
+  -> App (EVENT (GargM env BackendInternalError)) (GargM env BackendInternalError)
 app authenticatedUser policyManager = deriveApp (rootResolver authenticatedUser policyManager)
 
 ----------------------------------------------
@@ -172,6 +173,6 @@ gqapi = Proxy
 --api :: Server API
 api
   :: (Typeable env, CmdCommon env, HasJobEnv' env, HasSettings env)
-  => ServerT API (GargM env GargError)
+  => ServerT API (GargM env BackendInternalError)
 api (SAS.Authenticated auser) = (httpPubApp [] . app auser) :<|> pure httpPlayground
 api _                         = panic "401 in graphql" -- SAS.throwAll (_ServerError # err401)

src/Gargantext/API/GraphQL/AsyncTask.hs

@@ -18,7 +18,8 @@ import Data.IntMap.Strict qualified as IntMap
 import Data.Map.Strict qualified as Map
 import Data.Morpheus.Types ( GQLType, Resolver, QUERY )
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
-import Gargantext.API.Prelude (GargM, GargError, HasJobEnv')
+import Gargantext.API.Errors.Types
+import Gargantext.API.Prelude (GargM, HasJobEnv')
 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
 import Gargantext.Prelude
 import Servant.Job.Async (HasJobEnv(job_env), jenv_jobs, job_async)
@@ -29,7 +30,7 @@ data JobLogArgs
     { job_log_id :: Int
     } deriving (Generic, GQLType)
 
-type GqlM e env = Resolver QUERY e (GargM env GargError)
+type GqlM e env = Resolver QUERY e (GargM env BackendInternalError)
 
 resolveJobLogs
   :: (HasConnectionPool env, HasConfig env, HasJobEnv' env)

src/Gargantext/API/GraphQL/Context.hs

@@ -25,7 +25,8 @@ import Data.Morpheus.Types
 import Data.Text (pack)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Gargantext.API.Admin.Types (HasSettings)
-import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.API.Errors.Types
+import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument)
 import Gargantext.Database.Admin.Types.Node (ContextTitle, NodeId(..), NodeTypeId, UserId, unNodeId, ContextId (..))
@@ -109,8 +110,8 @@ data ContextNgramsArgs
     , list_id     :: Int }
     deriving (Generic, GQLType)
 
-type GqlM e env = Resolver QUERY e (GargM env GargError)
-type GqlM' e env a = ResolverM e (GargM env GargError) a
+type GqlM e env = Resolver QUERY e (GargM env BackendInternalError)
+type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
 
 -- GQL API
 

src/Gargantext/API/GraphQL/PolicyCheck.hs

@@ -6,8 +6,8 @@ import Prelude
 import Control.Monad.Except
 import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Auth.PolicyCheck
+import Gargantext.API.Errors.Types
 import Gargantext.API.GraphQL.Types
-import Gargantext.API.Prelude
 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
 
 withPolicy :: (HasConnectionPool env, HasConfig env)
@@ -21,5 +21,5 @@ withPolicy ur mgr checks m = case mgr of
     res <- lift $ runAccessPolicy ur checks
     case res of
       Allow     -> m
-      Deny err  -> lift $ throwError $ GargServerError $ err
+      Deny err  -> lift $ throwError $ InternalServerError $ err
 

src/Gargantext/API/GraphQL/Team.hs

@@ -17,9 +17,10 @@ module Gargantext.API.GraphQL.Team where
 import Data.Morpheus.Types (GQLType, ResolverM)
 import Data.Text qualified as T
 import Gargantext.API.Admin.Types (HasSettings)
+import Gargantext.API.Errors.Types
 import Gargantext.API.GraphQL.Types (GqlM)
 import Gargantext.API.GraphQL.Utils (authUser, AuthStatus (Invalid, Valid))
-import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Types (NodeId(..), unNodeId)
 import Gargantext.Core.Types.Individu qualified as Individu
 import Gargantext.Database.Action.Share (membersOf, deleteMemberShip)
@@ -49,7 +50,7 @@ data TeamDeleteMArgs = TeamDeleteMArgs
   , team_node_id     :: Int
   } deriving (Generic, GQLType)
 
-type GqlM' e env a = ResolverM e (GargM env GargError) a
+type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
 
 resolveTeam :: (CmdCommon env) => TeamArgs -> GqlM e env Team
 resolveTeam TeamArgs { team_node_id } = dbTeam team_node_id

src/Gargantext/API/GraphQL/Types.hs

@@ -3,6 +3,7 @@ module Gargantext.API.GraphQL.Types where
 
 import Data.Morpheus.Types
 import Gargantext.API.Prelude
+import Gargantext.API.Errors.Types
 
-type GqlM e env = Resolver QUERY e (GargM env GargError)
-type GqlM' e env a = ResolverM e (GargM env GargError) a
+type GqlM e env = Resolver QUERY e (GargM env BackendInternalError)
+type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a

src/Gargantext/API/Members.hs

@@ -11,21 +11,22 @@ Portability : POSIX
 module Gargantext.API.Members where
 
 import Gargantext.API.Admin.EnvTypes (Env)
+import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
-import Gargantext.Database.Admin.Types.Node (NodeType(NodeTeam))
-import Gargantext.Database.Query.Table.Node (getNodesIdWithType)
 import Gargantext.Database.Action.Share (membersOf)
+import Gargantext.Database.Admin.Types.Node (NodeType(NodeTeam))
 import Gargantext.Database.Prelude (CmdCommon)
+import Gargantext.Database.Query.Table.Node (getNodesIdWithType)
 import Gargantext.Prelude
 import Servant
 
 type MembersAPI = Get '[JSON] [Text]
 
-members :: ServerT MembersAPI (GargM Env GargError)
+members :: ServerT MembersAPI (GargM Env BackendInternalError)
 members = getMembers
 
 getMembers :: (CmdCommon env) =>
-              GargM env GargError [Text]
+              GargM env BackendInternalError [Text]
 getMembers = do
   teamNodeIds <- getNodesIdWithType NodeTeam
   m <- concatMapM membersOf teamNodeIds

src/Gargantext/API/Ngrams/List.hs

@@ -28,11 +28,12 @@ import Data.Vector (Vector)
 import Data.Vector qualified as Vec
 import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
 import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Errors.Types
 import Gargantext.API.Ngrams (setListNgrams)
 import Gargantext.API.Ngrams.List.Types
 import Gargantext.API.Ngrams.Prelude (getNgramsList)
 import Gargantext.API.Ngrams.Types
-import Gargantext.API.Prelude (GargServer, GargM, GargError)
+import Gargantext.API.Prelude (GargServer, GargM)
 import Gargantext.API.Types
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Types.Main (ListType(..))
@@ -50,6 +51,7 @@ import Gargantext.Utils.Servant qualified as GUS
 import Prelude qualified
 import Protolude qualified as P
 import Servant
+
 ------------------------------------------------------------------------
 type GETAPI = Summary "Get List"
             :> "lists"
@@ -72,7 +74,7 @@ type JSONAPI = Summary "Update List"
           :> "async"
             :> AsyncJobs JobLog '[FormUrlEncoded] WithJsonFile JobLog
 
-jsonApi :: ServerT JSONAPI (GargM Env GargError)
+jsonApi :: ServerT JSONAPI (GargM Env BackendInternalError)
 jsonApi = jsonPostAsync
 
 ----------------------
@@ -85,7 +87,7 @@ type CSVAPI = Summary "Update List (legacy v3 CSV)"
           :> "async"
             :> AsyncJobs JobLog '[FormUrlEncoded] WithTextFile JobLog
 
-csvApi :: ServerT CSVAPI (GargM Env GargError)
+csvApi :: ServerT CSVAPI (GargM Env BackendInternalError)
 csvApi = csvPostAsync
 
 ------------------------------------------------------------------------
@@ -122,7 +124,11 @@ setList :: HasNodeStory env err m
 setList l m  = do
   -- TODO check with Version for optim
   -- printDebug "New list as file" l
-  _ <- mapM (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList m
+  _ <- mapM (\(nt, Versioned _v ns) -> (setListNgrams l nt ns)) $ toList m
+  -- v <- getNodeStoryVar [l]
+  -- liftBase $ do
+  --   ns <- atomically $ readTVar v
+  --   printDebug "[setList] node story: " ns
   -- TODO reindex
   pure True
 
@@ -135,7 +141,7 @@ toIndexedNgrams m t = Indexed <$> i <*> n
     n = Just (text2ngrams t)
 
 ------------------------------------------------------------------------
-jsonPostAsync :: ServerT JSONAPI (GargM Env GargError)
+jsonPostAsync :: ServerT JSONAPI (GargM Env BackendInternalError)
 jsonPostAsync lId =
   serveJobsAPI UpdateNgramsListJobJSON $ \jHandle f ->
     postAsync' lId f jHandle
@@ -216,7 +222,7 @@ csvPost l m  = do
       pure $ Right ()
 
 ------------------------------------------------------------------------
-csvPostAsync :: ServerT CSVAPI (GargM Env GargError)
+csvPostAsync :: ServerT CSVAPI (GargM Env BackendInternalError)
 csvPostAsync lId =
   serveJobsAPI UpdateNgramsListJobCSV $ \jHandle f -> do
       markStarted 1 jHandle

src/Gargantext/API/Ngrams/Tools.hs

@@ -14,22 +14,20 @@ Portability : POSIX
 module Gargantext.API.Ngrams.Tools
   where
 
-import Control.Concurrent
 import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
 import Control.Monad.Reader
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.Map.Strict qualified as Map
-import Data.Pool (withResource)
 import Data.Set qualified as Set
 import Data.Validity
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory
-import Gargantext.Core.NodeStoryFile qualified as NSF
-import Gargantext.Core.Types (ListType(..), NodeId, NodeType(..), ListId)
-import Gargantext.Database.Prelude (HasConnectionPool(..))
+-- import Gargantext.Core.NodeStoryFile qualified as NSF
+import Gargantext.Core.Types (ListType(..), NodeId, ListId)
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
+import GHC.Conc (TVar, readTVar)
 
 
 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
@@ -43,7 +41,7 @@ getRepo :: HasNodeStory env err m
 getRepo listIds = do
   f <- getNodeListStory
   v  <- liftBase $ f listIds
-  v' <- liftBase $ readMVar v
+  v' <- liftBase $ atomically $ readTVar v
   pure $ v'
 
 
@@ -58,7 +56,7 @@ repoSize repo node_id = Map.map Map.size state'
 
 
 getNodeStoryVar :: HasNodeStory env err m
-           => [ListId] -> m (MVar NodeListStory)
+           => [ListId] -> m (TVar NodeListStory)
 getNodeStoryVar l = do
   f <- getNodeListStory
   v  <- liftBase $ f l
@@ -66,7 +64,7 @@ getNodeStoryVar l = do
 
 
 getNodeListStory :: HasNodeStory env err m
-                 => m ([NodeId] -> IO (MVar NodeListStory))
+                 => m ([NodeId] -> IO (TVar NodeListStory))
 getNodeListStory = do
   env <- view hasNodeStory
   pure $ view nse_getter env
@@ -228,20 +226,20 @@ getCoocByNgrams'' (Diagonal diag) (f1,f2) (m1,m2) =
 ------------------------------------------
 
 
-migrateFromDirToDb :: (HasNodeStory env err m) -- , HasNodeStory env err m)
-                   => m ()
-migrateFromDirToDb = do
-  pool <- view connPool
-  withResource pool $ \c -> do
-    listIds <- liftBase $ getNodesIdWithType c NodeList
-    -- printDebug "[migrateFromDirToDb] listIds" listIds
-    (NodeStory nls) <- NSF.getRepoReadConfig listIds
-    -- printDebug "[migrateFromDirToDb] nls" nls
-    _ <- mapM (\(nId, a) -> do
-                  n <- liftBase $ nodeExists c nId
-                  case n of
-                    False -> pure ()
-                    True  -> liftBase $ upsertNodeStories c nId a
-              ) $ Map.toList nls
-    --_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
-    pure ()
+-- migrateFromDirToDb :: (HasNodeStory env err m) -- , HasNodeStory env err m)
+--                    => m ()
+-- migrateFromDirToDb = do
+--   pool <- view connPool
+--   withResource pool $ \c -> do
+--     listIds <- liftBase $ getNodesIdWithType c NodeList
+--     -- printDebug "[migrateFromDirToDb] listIds" listIds
+--     (NodeStory nls) <- NSF.getRepoReadConfig listIds
+--     -- printDebug "[migrateFromDirToDb] nls" nls
+--     _ <- mapM (\(nId, a) -> do
+--                   n <- liftBase $ nodeExists c nId
+--                   case n of
+--                     False -> pure ()
+--                     True  -> liftBase $ upsertNodeStories c nId a
+--               ) $ Map.toList nls
+--     --_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
+--     pure ()

src/Gargantext/API/Ngrams/Types.hs

@@ -147,7 +147,9 @@ makeLenses ''RootParent
 data NgramsRepoElement = NgramsRepoElement
   { _nre_size        :: !Int
   , _nre_list        :: !ListType
+  -- root is the top-most parent of ngrams
   , _nre_root        :: !(Maybe NgramsTerm)
+  -- parent is the direct parent of this ngram
   , _nre_parent      :: !(Maybe NgramsTerm)
   , _nre_children    :: !(MSet NgramsTerm)
   }

src/Gargantext/API/Node.hs

@@ -36,6 +36,7 @@ import Gargantext.API.Admin.Auth (withAccess, withPolicy)
 import Gargantext.API.Admin.Auth.Types (PathId(..), AuthenticatedUser (..), auth_node_id)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Auth.PolicyCheck
+import Gargantext.API.Errors.Types
 import Gargantext.API.Metrics
 import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableCorpus)
 import Gargantext.API.Ngrams.Types (TabType(..))
@@ -195,14 +196,14 @@ nodeAPI :: forall proxy a.
        ) => proxy a
          -> AuthenticatedUser
          -> NodeId
-         -> ServerT (NodeAPI a) (GargM Env GargError)
+         -> ServerT (NodeAPI a) (GargM Env BackendInternalError)
 nodeAPI p authenticatedUser targetNode =
   withAccess (Proxy :: Proxy (NodeAPI a)) Proxy authenticatedUser (PathNode targetNode) nodeAPI'
   where
 
     userRootId = RootId $ authenticatedUser ^. auth_node_id
 
-    nodeAPI' :: ServerT (NodeAPI a) (GargM Env GargError)
+    nodeAPI' :: ServerT (NodeAPI a) (GargM Env BackendInternalError)
     nodeAPI' =  withPolicy authenticatedUser (nodeChecks targetNode) (getNodeWith targetNode p)
            :<|> rename                                targetNode
            :<|> postNode            authenticatedUser targetNode

src/Gargantext/API/Node/Contact.hs

@@ -33,11 +33,13 @@ import Servant
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
 
+import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
+import Gargantext.API.Errors.Types
 import Gargantext.API.Node
-import Gargantext.API.Prelude (GargError, GargM, simuLogs)
+import Gargantext.API.Prelude (GargM, simuLogs)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Text.Terms (TermType(..))
 import Gargantext.Core.Types.Individu (User(..))
@@ -47,9 +49,8 @@ import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAnnuaire(..), Hyperda
 import Gargantext.Database.Admin.Types.Hyperdata.Contact (hyperdataContact)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Prelude (($), {-printDebug,-})
-import qualified Gargantext.Utils.Aeson as GUA
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
-import Gargantext.API.Admin.Auth.Types
+import qualified Gargantext.Utils.Aeson as GUA
 
 ------------------------------------------------------------------------
 type API = "contact" :> Summary "Contact endpoint"
@@ -58,7 +59,7 @@ type API = "contact" :> Summary "Contact endpoint"
             :> NodeNodeAPI HyperdataContact
 
 
-api :: AuthenticatedUser -> CorpusId -> ServerT API (GargM Env GargError)
+api :: AuthenticatedUser -> CorpusId -> ServerT API (GargM Env BackendInternalError)
 api authUser@(AuthenticatedUser userNodeId _userUserId) cid =
        (api_async   (RootId userNodeId) cid)
   :<|> (nodeNodeAPI (Proxy :: Proxy HyperdataContact) authUser cid)
@@ -73,7 +74,7 @@ data AddContactParams = AddContactParams         { firstname :: !Text, lastname
     deriving (Generic)
 
 ----------------------------------------------------------------------
-api_async :: User -> NodeId -> ServerT API_Async (GargM Env GargError)
+api_async :: User -> NodeId -> ServerT API_Async (GargM Env BackendInternalError)
 api_async u nId =
   serveJobsAPI AddContactJob $ \jHandle p ->
     addContact u nId p jHandle

src/Gargantext/API/Node/Corpus/Searx.hs

@@ -29,7 +29,7 @@ import Gargantext.Core.Text.Corpus.API qualified as API
 import Gargantext.Core.Text.List (buildNgramsLists)
 import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(..))
 import Gargantext.Core.Text.Terms (TermType(..))
-import Gargantext.Core.Types (HasInvalidError)
+import Gargantext.Core.Types (HasValidationError)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Action.Flow (addDocumentsToHyperCorpus) --, DataText(..))
@@ -124,7 +124,7 @@ insertSearxResponse :: ( MonadBase IO m
                        , HasNLPServer env
                        , HasNodeError err
                        , HasTreeError err
-                       , HasInvalidError err )
+                       , HasValidationError err )
                     => User
                     -> CorpusId
                     -> ListId
@@ -166,7 +166,7 @@ triggerSearxSearch :: ( MonadBase IO m
                       , HasNLPServer env
                       , HasNodeError err
                       , HasTreeError err
-                      , HasInvalidError err 
+                      , HasValidationError err
                       , MonadJobStatus m )
                    => User
                    -> CorpusId

src/Gargantext/API/Node/DocumentUpload.hs

@@ -22,6 +22,7 @@ import Data.Swagger (ToSchema)
 import Data.Text qualified as T
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
+import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.NLP (nlpServerGet)
@@ -75,7 +76,7 @@ type API = Summary " Document upload"
            :> "async"
            :> AsyncJobs JobLog '[JSON] DocumentUpload JobLog
 
-api :: NodeId -> ServerT API (GargM Env GargError)
+api :: NodeId -> ServerT API (GargM Env BackendInternalError)
 api nId =
   serveJobsAPI UploadDocumentJob $ \jHandle q -> do
       documentUploadAsync nId q jHandle

src/Gargantext/API/Node/DocumentsFromWriteNodes.hs

@@ -22,11 +22,13 @@ import Data.Aeson
 import Data.List qualified as List
 import Data.Swagger
 import Data.Text qualified as T
+import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
+import Gargantext.API.Errors.Types
 import Gargantext.API.Ngrams (commitStatePatch, Versioned(..))
-import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.API.Prelude (GargM)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.NodeStory (HasNodeStoryImmediateSaver, HasNodeArchiveStoryImmediateSaver, currentVersion)
 import Gargantext.Core.Text.Corpus.Parsers.Date (split')
@@ -44,7 +46,6 @@ import Gargantext.Database.Schema.Node (node_hyperdata, node_name, node_date)
 import Gargantext.Prelude
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
 import Servant
-import Gargantext.API.Admin.Auth.Types
 -- import qualified Gargantext.Defaults as Defaults
 
 ------------------------------------------------------------------------
@@ -67,7 +68,7 @@ instance ToSchema Params
 api :: AuthenticatedUser
     -- ^ The logged-in user
     -> NodeId
-    -> ServerT API (GargM Env GargError)
+    -> ServerT API (GargM Env BackendInternalError)
 api authenticatedUser nId =
   serveJobsAPI DocumentFromWriteNodeJob $ \jHandle p ->
     documentsFromWriteNodes authenticatedUser nId p jHandle

src/Gargantext/API/Node/File.hs

@@ -33,6 +33,7 @@ import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
+import Gargantext.API.Errors.Types
 import Gargantext.API.Node.Types
 import Gargantext.API.Prelude
 import Gargantext.Core.Types (TODO)
@@ -114,7 +115,7 @@ type FileAsyncApi = Summary "File Async Api"
 fileAsyncApi :: AuthenticatedUser
              -- ^ The logged-in user
              -> NodeId
-             -> ServerT FileAsyncApi (GargM Env GargError)
+             -> ServerT FileAsyncApi (GargM Env BackendInternalError)
 fileAsyncApi authenticatedUser nId =
   serveJobsAPI AddFileJob $ \jHandle i ->
     addWithFile authenticatedUser nId i jHandle

src/Gargantext/API/Node/FrameCalcUpload.hs

@@ -29,6 +29,7 @@ import Web.FormUrlEncoded (FromForm)
 import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
+import Gargantext.API.Errors.Types
 import Gargantext.API.Node.Corpus.New (addToCorpusWithForm)
 import Gargantext.API.Node.Corpus.New.Types (FileFormat(..), FileType(..))
 import Gargantext.API.Node.Types (NewWithForm(..))
@@ -62,7 +63,7 @@ type API = Summary " FrameCalc upload"
            :> "async"
            :> AsyncJobs JobLog '[JSON] FrameCalcUpload JobLog
 
-api :: AuthenticatedUser -> NodeId -> ServerT API (GargM Env GargError)
+api :: AuthenticatedUser -> NodeId -> ServerT API (GargM Env BackendInternalError)
 api authenticatedUser nId =
   serveJobsAPI UploadFrameCalcJob $ \jHandle p ->
     frameCalcUploadAsync authenticatedUser nId p jHandle

src/Gargantext/API/Node/New.hs

@@ -23,8 +23,10 @@ module Gargantext.API.Node.New
 import Control.Lens hiding (elements, Empty)
 import Data.Aeson
 import Data.Swagger
+import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
+import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.Database.Action.Flow.Types
 import Gargantext.Database.Action.Node
@@ -37,7 +39,6 @@ import Servant
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
 import Web.FormUrlEncoded (FromForm, ToForm)
-import Gargantext.API.Admin.Auth.Types
 
 ------------------------------------------------------------------------
 data PostNode = PostNode { pn_name     :: Text
@@ -75,7 +76,7 @@ postNodeAsyncAPI
   -- ^ The logged-in user
   -> NodeId
   -- ^ The target node
-  -> ServerT PostNodeAsync (GargM Env GargError)
+  -> ServerT PostNodeAsync (GargM Env BackendInternalError)
 postNodeAsyncAPI authenticatedUser nId =
   serveJobsAPI NewNodeJob $ \jHandle p -> postNodeAsync authenticatedUser nId p jHandle
 

src/Gargantext/API/Node/Share.hs

@@ -67,10 +67,10 @@ api userInviting nId (ShareTeamParams user') = do
     Just (u,_) -> do
       isRegistered <- getUserId' (UserName u)
       case isRegistered of
-        Just _  -> do
+        Right _  -> do
           -- printDebug "[G.A.N.Share.api]" ("Team shared with " <> u)
           pure u
-        Nothing -> do
+        Left _err -> do
           username' <- getUsername userInviting
           _ <- case List.elem username' arbitraryUsername of
             True  -> do

src/Gargantext/API/Node/Update.hs

@@ -23,9 +23,10 @@ import Data.Swagger
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
+import Gargantext.API.Errors.Types
 import Gargantext.API.Metrics qualified as Metrics
 import Gargantext.API.Ngrams.Types qualified as NgramsTypes
-import Gargantext.API.Prelude (GargM, GargError, simuLogs)
+import Gargantext.API.Prelude (GargM, simuLogs)
 import Gargantext.Core.Methods.Similarities (GraphMetric(..))
 import Gargantext.Core.NodeStory (HasNodeStory)
 import Gargantext.Core.Types.Main (ListType(..))
@@ -88,7 +89,7 @@ data Charts = Sources | Authors | Institutes | Ngrams | All
     deriving (Generic, Eq, Ord, Enum, Bounded)
 
 ------------------------------------------------------------------------
-api :: NodeId -> ServerT API (GargM Env GargError)
+api :: NodeId -> ServerT API (GargM Env BackendInternalError)
 api nId =
   serveJobsAPI UpdateNodeJob $ \jHandle p ->
     updateNode nId p jHandle

src/Gargantext/API/Prelude.hs

@@ -20,36 +20,28 @@ module Gargantext.API.Prelude
   )
   where
 
-import Control.Lens (Prism', (#))
-import Control.Lens.TH (makePrisms)
-import Crypto.JOSE.Error as Jose
+import Control.Lens ((#))
 import Data.Aeson.Types
-import Data.Text qualified as Text
-import Data.Typeable
-import Data.Validity
+import Gargantext.API.Admin.Auth.Types (AuthenticationError)
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Admin.Types
+import Gargantext.API.Errors.Class
 import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Types
 import Gargantext.Database.Prelude (CmdM, CmdRandom, HasConnectionPool, HasConfig)
-import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Database.Query.Tree
 import Gargantext.Prelude
 import Gargantext.System.Logging
 import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..), JobHandle)
-import Gargantext.Utils.Jobs.Monad qualified as Jobs
 import Servant
 import Servant.Job.Async
 import Servant.Job.Core (HasServerError(..), serverError)
-import Servant.Job.Types qualified as SJ
 
-class HasJoseError e where
-  _JoseError :: Prism' e Jose.Error
-
-joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
-joseError = throwError . (_JoseError #)
+authenticationError :: (MonadError e m, HasAuthenticationError e) => AuthenticationError -> m a
+authenticationError = throwError . (_AuthenticationError #)
 
 type HasJobEnv' env = HasJobEnv env JobLog JobLog
 
@@ -64,13 +56,13 @@ type EnvC env =
   )
 
 type ErrC err =
-  ( HasNodeError     err
-  , HasInvalidError  err
-  , HasTreeError     err
-  , HasServerError   err
-  , HasJoseError     err
---  , ToJSON           err -- TODO this is arguable
-  , Exception        err
+  ( HasNodeError           err
+  , HasValidationError     err
+  , HasTreeError           err
+  , HasServerError         err
+  , HasAuthenticationError err
+--  , ToJSON               err -- TODO this is arguable
+  , Exception              err
   )
 
 type GargServerC env err m =
@@ -103,47 +95,6 @@ type GargNoServer' env err m =
   , HasNodeError       err
   )
 
--------------------------------------------------------------------
-data GargError
-  = GargNodeError    NodeError
-  | GargTreeError    TreeError
-  | GargInvalidError Validation
-  | GargJoseError    Jose.Error
-  | GargServerError  ServerError
-  | GargJobError     Jobs.JobError
-  deriving (Show, Typeable)
-
-makePrisms ''GargError
-
-instance ToJSON GargError where
-  toJSON (GargJobError s) =
-    object [ ("status", toJSON SJ.IsFailure)
-           , ("log", emptyArray)
-           , ("id", String id)
-           , ("error", String $ Text.pack $ show s) ]
-    where
-      id = case s of
-        Jobs.InvalidMacID i -> i
-        _ -> ""
-  toJSON err = object [("error", String $ Text.pack $ show err)]
-
-instance Exception GargError
-
-instance HasNodeError GargError where
-  _NodeError = _GargNodeError
-
-instance HasInvalidError GargError where
-  _InvalidError = _GargInvalidError
-
-instance HasTreeError GargError where
-  _TreeError = _GargTreeError
-
-instance HasServerError GargError where
-  _ServerError = _GargServerError
-
-instance HasJoseError GargError where
-  _JoseError = _GargJoseError
-
 ------------------------------------------------------------------------
 -- | Utils
 -- | Simulate logs

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,8 @@ 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)
 import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableDoc)
@@ -50,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')
 
@@ -206,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"
@@ -236,7 +263,7 @@ serverGargAdminAPI =  roots
 
 
 serverPrivateGargAPI'
-  :: AuthenticatedUser -> ServerT GargPrivateAPI' (GargM Env GargError)
+  :: AuthenticatedUser -> ServerT GargPrivateAPI' (GargM Env BackendInternalError)
 serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
        =  serverGargAdminAPI
      :<|> nodeAPI     (Proxy :: Proxy HyperdataAny)      authenticatedUser
@@ -293,7 +320,7 @@ waitAPI n = do
   pure $ "Waited: " <> show n
 ----------------------------------------
 
-addCorpusWithQuery :: User -> ServerT New.AddWithQuery (GargM Env GargError)
+addCorpusWithQuery :: User -> ServerT New.AddWithQuery (GargM Env BackendInternalError)
 addCorpusWithQuery user cid =
   serveJobsAPI AddCorpusQueryJob $ \jHandle q -> do
     limit <- view $ hasConfig . gc_max_docs_scrapers
@@ -303,7 +330,7 @@ addCorpusWithQuery user cid =
         liftBase $ log x
       -}
 
-addCorpusWithForm :: User -> ServerT New.AddWithForm (GargM Env GargError)
+addCorpusWithForm :: User -> ServerT New.AddWithForm (GargM Env BackendInternalError)
 addCorpusWithForm user cid =
   serveJobsAPI AddCorpusFormJob $ \jHandle i -> do
     -- /NOTE(adinapoli)/ Track the initial steps outside 'addToCorpusWithForm', because it's
@@ -311,12 +338,12 @@ addCorpusWithForm user cid =
     markStarted 3 jHandle
     New.addToCorpusWithForm user cid i jHandle
 
-addCorpusWithFile :: User -> ServerT New.AddWithFile (GargM Env GargError)
+addCorpusWithFile :: User -> ServerT New.AddWithFile (GargM Env BackendInternalError)
 addCorpusWithFile user cid =
   serveJobsAPI AddCorpusFileJob $ \jHandle i ->
     New.addToCorpusWithFile user cid i jHandle
 
-addAnnuaireWithForm :: ServerT Annuaire.AddWithForm (GargM Env GargError)
+addAnnuaireWithForm :: ServerT Annuaire.AddWithForm (GargM Env BackendInternalError)
 addAnnuaireWithForm cid =
   serveJobsAPI AddAnnuaireFormJob $ \jHandle i ->
     Annuaire.addToAnnuaireWithForm cid i jHandle

src/Gargantext/API/Server.hs

@@ -14,8 +14,6 @@ Portability : POSIX
 module Gargantext.API.Server where
 
 import Control.Lens ((^.))
-import Data.Aeson qualified as Aeson
-import Data.ByteString.Lazy.Char8 qualified as BL8
 import Data.Version (showVersion)
 import Gargantext.API.Admin.Auth (auth, forgotPassword, forgotPasswordAsync)
 import Gargantext.API.Admin.Auth.Types (AuthContext)
@@ -29,15 +27,15 @@ import Gargantext.API.Routes
 import Gargantext.API.Swagger (swaggerDoc)
 import Gargantext.API.ThrowAll (serverPrivateGargAPI)
 import Gargantext.Database.Prelude (hasConfig)
-import Gargantext.Database.Query.Table.Node.Error (NodeError(..))
 import Gargantext.Prelude hiding (Handler)
 import Gargantext.Prelude.Config (gc_url_backend_api)
 import Paths_gargantext qualified as PG -- cabal magic build module
 import Servant
 import Servant.Swagger.UI (swaggerSchemaUIServer)
+import Gargantext.API.Errors
 
 
-serverGargAPI :: Text -> ServerT GargAPI (GargM Env GargError)
+serverGargAPI :: Text -> ServerT GargAPI (GargM Env BackendInternalError)
 serverGargAPI baseUrl -- orchestrator
        =  auth
      :<|> forgotPassword
@@ -55,39 +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
-    -- transform :: forall a. GargM Env GargError a -> Handler a
-    -- transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
-    transformJSON :: forall a. GargM Env GargError a -> Handler a
-    transformJSON = Handler . withExceptT showAsServantJSONErr . (`runReaderT` env)
-
-
-showAsServantErr :: GargError -> ServerError
-showAsServantErr (GargNodeError err@(NoListFound {})) = err404 { errBody = BL8.pack $ show err }
-showAsServantErr (GargNodeError err@NoRootFound) = err404 { errBody = BL8.pack $ show err }
-showAsServantErr (GargNodeError err@NoCorpusFound) = err404 { errBody = BL8.pack $ show err }
-showAsServantErr (GargNodeError err@NoUserFound{}) = err404 { errBody = BL8.pack $ show err }
-showAsServantErr (GargNodeError err@(DoesNotExist {})) = err404 { errBody = BL8.pack $ show err }
-showAsServantErr (GargServerError err) = err
-showAsServantErr a = err500 { errBody = BL8.pack $ show a }
-
-showAsServantJSONErr :: GargError -> ServerError
-showAsServantJSONErr (GargNodeError err@(NoListFound {})) = err404 { errBody = Aeson.encode err }
-showAsServantJSONErr (GargNodeError err@NoRootFound) = err404 { errBody = Aeson.encode err }
-showAsServantJSONErr (GargNodeError err@NoCorpusFound) = err404 { errBody = Aeson.encode err }
-showAsServantJSONErr (GargNodeError err@NoUserFound{}) = err404 { errBody = Aeson.encode err }
-showAsServantJSONErr (GargNodeError err@(DoesNotExist {})) = err404 { errBody = Aeson.encode err }
-showAsServantJSONErr (GargServerError err) = err
-showAsServantJSONErr a = err500 { errBody = Aeson.encode a }
+    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)

src/Gargantext/API/ThrowAll.hs

@@ -18,6 +18,7 @@ module Gargantext.API.ThrowAll where
 
 import Control.Lens ((#))
 import Gargantext.API.Admin.EnvTypes (Env)
+import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.API.Routes (GargPrivateAPI, serverPrivateGargAPI')
 import Gargantext.Prelude
@@ -45,7 +46,7 @@ instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
   throwAll' = throwError
 
 serverPrivateGargAPI
-  :: ServerT GargPrivateAPI (GargM Env GargError)
+  :: ServerT GargPrivateAPI (GargM Env BackendInternalError)
 serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
 -- Here throwAll' requires a concrete type for the monad.

src/Gargantext/Core/NodeStoryFile.hs → src/Gargantext/Core/NodeStoryFile.hs.old

@@ -22,7 +22,7 @@ import Control.Lens (view)
 import Data.ByteString.Lazy qualified as DBL
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
-import Gargantext.Core.NodeStory hiding (readNodeStoryEnv)
+import Gargantext.Core.NodeStory hiding (fromDBNodeStoryEnv)
 import Gargantext.Core.Types (ListId, NodeId(..))
 import Gargantext.Database.Prelude (hasConfig)
 import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams

src/Gargantext/Core/Types.hs

@@ -23,7 +23,7 @@ module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
                              , Term(..), Terms(..), TermsCount, TermsWithCount
                              , TokenTag(..), POS(..), NER(..)
                              , Label, Stems
-                             , HasInvalidError(..), assertValid
+                             , HasValidationError(..), assertValid
                              , Name
                              , TableResult(..), NodeTableResult
                              , Ordering(..)
@@ -171,11 +171,11 @@ instance Monoid TokenTag where
   -- mappend t1 t2 = (<>) t1 t2
 
 
-class HasInvalidError e where
-  _InvalidError :: Prism' e Validation
+class HasValidationError e where
+  _ValidationError :: Prism' e Validation
 
-assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
-assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
+assertValid :: (MonadError e m, HasValidationError e) => Validation -> m ()
+assertValid v = when (not $ validationIsValid v) $ throwError $ _ValidationError # v
 -- assertValid :: MonadBase IO m => Validation -> m ()
 -- assertValid v = when (not $ validationIsValid v) $ fail $ show v
 

src/Gargantext/Core/Types/Individu.hs

@@ -28,7 +28,7 @@ import Gargantext.Prelude.Crypto.Auth qualified as Auth
 import Prelude qualified
 
 -- FIXME UserName used twice
-data User = UserDBId UserId | UserName Text | RootId NodeId | UserPublic
+data User = UserDBId UserId | UserName Text | RootId NodeId
   deriving (Eq)
 
 renderUser :: User -> T.Text
@@ -36,7 +36,6 @@ renderUser = \case
   UserDBId urId -> T.pack (show urId)
   UserName txt  -> txt
   RootId   nId  -> T.pack (show nId)
-  UserPublic    -> T.pack "public"
 
 type Username = Text
 

src/Gargantext/Core/Viz/Graph/API.hs

@@ -24,6 +24,7 @@ import Data.HashMap.Strict qualified as HashMap
 import Data.Swagger
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Errors.Types
 import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Prelude
 import Gargantext.Core.Methods.Similarities (Similarity(..), GraphMetric(..), withMetric)
@@ -41,8 +42,8 @@ import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.Select
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
-import Gargantext.Database.Schema.Node
 import Gargantext.Database.Schema.Ngrams
+import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
 import Servant
@@ -70,7 +71,7 @@ instance FromJSON GraphVersions
 instance ToJSON GraphVersions
 instance ToSchema GraphVersions
 
-graphAPI :: UserId -> NodeId -> ServerT GraphAPI (GargM Env GargError)
+graphAPI :: UserId -> NodeId -> ServerT GraphAPI (GargM Env BackendInternalError)
 graphAPI userId n = getGraph n
           :<|> graphAsync        n
           :<|> graphClone        userId n
@@ -248,7 +249,7 @@ type GraphAsyncAPI = Summary "Recompute graph"
                      :> AsyncJobsAPI JobLog () JobLog
 
 
-graphAsync :: NodeId -> ServerT GraphAsyncAPI (GargM Env GargError)
+graphAsync :: NodeId -> ServerT GraphAsyncAPI (GargM Env BackendInternalError)
 graphAsync n =
   serveJobsAPI RecomputeGraphJob $ \jHandle _ -> graphRecompute n jHandle
 

src/Gargantext/Database/Action/Flow.hs

@@ -86,7 +86,7 @@ import Gargantext.Core.Text.List.Social (FlowSocialListWith(..))
 import Gargantext.Core.Text.Terms
 import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
 import Gargantext.Core.Text.Terms.WithList (MatchedText, buildPatternsWith, termsInText)
-import Gargantext.Core.Types (HasInvalidError, POS(NP), TermsCount)
+import Gargantext.Core.Types (HasValidationError, POS(NP), TermsCount)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Types.Main
 import Gargantext.Core.Types.Query (Limit)
@@ -193,7 +193,7 @@ flowDataText :: forall env err m.
                 , MonadLogger m
                 , HasNLPServer env
                 , HasTreeError err
-                , HasInvalidError err
+                , HasValidationError err
                 , MonadJobStatus m
                 )
                 => User
@@ -222,7 +222,7 @@ flowAnnuaire :: ( DbCmd' env err m
                 , MonadLogger m
                 , HasNLPServer env
                 , HasTreeError err
-                , HasInvalidError err
+                , HasValidationError err
                 , MonadJobStatus m )
              => User
              -> Either CorpusName [CorpusId]
@@ -241,7 +241,7 @@ flowCorpusFile :: ( DbCmd' env err m
                   , MonadLogger m
                   , HasNLPServer env
                   , HasTreeError err
-                  , HasInvalidError err
+                  , HasValidationError err
                   , MonadJobStatus m )
            => User
            -> Either CorpusName [CorpusId]
@@ -270,7 +270,7 @@ flowCorpus :: ( DbCmd' env err m
               , MonadLogger m
               , HasNLPServer env
               , HasTreeError err
-              , HasInvalidError err
+              , HasValidationError err
               , FlowCorpus a
               , MonadJobStatus m )
            => User
@@ -289,7 +289,7 @@ flow :: forall env err m a c.
         , MonadLogger m
         , HasNLPServer env
         , HasTreeError err
-        , HasInvalidError err
+        , HasValidationError err
         , FlowCorpus a
         , MkCorpus c
         , MonadJobStatus m
@@ -366,7 +366,7 @@ createNodes user corpusName ctype = do
 
 
 flowCorpusUser :: ( HasNodeError err
-                  , HasInvalidError err
+                  , HasValidationError err
                   , HasNLPServer env
                   , HasTreeError err
                   , HasNodeStory env err m

src/Gargantext/Database/Action/Flow/List.hs

@@ -17,7 +17,6 @@ Portability : POSIX
 module Gargantext.Database.Action.Flow.List
     where
 
-import Control.Concurrent
 import Control.Lens ((^.), (+~), (%~), at, (.~), _Just)
 import Control.Monad.Reader
 import Data.List qualified as List
@@ -28,13 +27,14 @@ import Gargantext.API.Ngrams (saveNodeStory)
 import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory
-import Gargantext.Core.Types (HasInvalidError(..), assertValid)
+import Gargantext.Core.Types (HasValidationError(..), assertValid)
 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
 import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb,{- getCgramsId -})
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
 import Gargantext.Prelude hiding (toList)
+import GHC.Conc (readTVar, writeTVar)
 
 -- FLOW LIST
 -- 1. select specific terms of the corpus when compared with others langs
@@ -79,7 +79,7 @@ flowList_Tficf' u m nt f = do
 
 
 ------------------------------------------------------------------------
-flowList_DbRepo :: (HasInvalidError err, HasNodeStory env err m)
+flowList_DbRepo :: (HasValidationError err, HasNodeStory env err m)
                 => ListId
                 -> Map NgramsType [NgramsElement]
                 -> m ListId
@@ -154,7 +154,7 @@ toNodeNgramsW' l'' ngs = [ NodeNgrams { _nng_id            = Nothing
                          ]
 
 
-listInsert :: (HasInvalidError err, HasNodeStory env err m)
+listInsert :: (HasValidationError err, HasNodeStory env err m)
            => ListId
            -> Map NgramsType [NgramsElement]
            -> m ()
@@ -168,7 +168,7 @@ listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 -- This function is maintained for its usage in Database.Action.Flow.List.
 -- If the given list of ngrams elements contains ngrams already in
 -- the repo, they will be ignored.
-putListNgrams :: (HasInvalidError err, HasNodeStory env err m)
+putListNgrams :: (HasValidationError err, HasNodeStory env err m)
               => NodeId
               -> TableNgrams.NgramsType
               -> [NgramsElement]
@@ -178,7 +178,7 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
   where
     m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
 
-    putListNgrams' :: (HasInvalidError err, HasNodeStory env err m)
+    putListNgrams' :: (HasValidationError err, HasNodeStory env err m)
                    => NodeId
                    -> TableNgrams.NgramsType
                    -> Map NgramsTerm NgramsRepoElement
@@ -202,8 +202,10 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
       -- If valid the rest would be atomic and no merge is required.
       -}
       var <- getNodeStoryVar [listId]
-      liftBase $ modifyMVar_ var $ \r -> do
-        pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
-                 & unNodeStory . at listId . _Just . a_history %~ (p :)
-                 & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
+      liftBase $ atomically $ do
+        r <- readTVar var
+        writeTVar var $
+          r & unNodeStory . at listId . _Just . a_version +~ 1
+            & unNodeStory . at listId . _Just . a_history %~ (p :)
+            & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
       saveNodeStory

src/Gargantext/Database/Action/Flow/Types.hs

@@ -21,7 +21,7 @@ module Gargantext.Database.Action.Flow.Types
 
 import Data.Aeson (ToJSON)
 
-import Gargantext.Core.Types (HasInvalidError)
+import Gargantext.Core.Types (HasValidationError)
 import Gargantext.Core.Flow.Types
 import Gargantext.Core.Text
 import Gargantext.Core.NodeStory
@@ -36,7 +36,7 @@ type FlowCmdM env err m =
   ( CmdM     env err m
   , HasNodeStory env err m
   , HasNodeError err
-  , HasInvalidError err
+  , HasValidationError err
   , HasTreeError err
   , MonadLogger m
   )

src/Gargantext/Database/Action/Node.hs

@@ -42,14 +42,14 @@ mkNodeWithParent :: (HasNodeError err, HasDBid NodeType)
                  -> UserId
                  -> Name
                  -> DBCmd err [NodeId]
-mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
+mkNodeWithParent NodeUser (Just pId) uid  _ = nodeError $ NodeCreationFailed $ UserParentAlreadyExists uid pId
 
 ------------------------------------------------------------------------
 -- | MkNode, insert and eventually configure Hyperdata
 mkNodeWithParent NodeUser Nothing uId name =
   insertNodesWithParentR Nothing [node NodeUser name defaultHyperdataUser Nothing uId]
 
-mkNodeWithParent _ Nothing _ _ = nodeError HasParent
+mkNodeWithParent _ Nothing uId _ = nodeError $ NodeCreationFailed $ UserParentDoesNotExist uId
 ------------------------------------------------------------------------
 mkNodeWithParent Notes i u n =
   mkNodeWithParent_ConfigureHyperdata Notes i u n
@@ -65,7 +65,7 @@ mkNodeWithParent NodeFrameNotebook i u n =
 
 
 
-mkNodeWithParent nt (Just pId) uId name  = insertNode nt (Just name) Nothing pId uId
+mkNodeWithParent nt (Just pId) uId name  = (:[]) <$> insertNode nt (Just name) Nothing pId uId
 -- mkNodeWithParent _ _ _ _ = errorWith "[G.D.A.Node.mkNodeWithParent] nees parent"
 
 
@@ -85,7 +85,7 @@ mkNodeWithParent_ConfigureHyperdata Calc (Just i) uId name =
 mkNodeWithParent_ConfigureHyperdata NodeFrameVisio (Just i) uId name =
   mkNodeWithParent_ConfigureHyperdata' NodeFrameVisio (Just i) uId name
 
-mkNodeWithParent_ConfigureHyperdata NodeFrameNotebook (Just i) uId name =
+mkNodeWithParent_ConfigureHyperdata NodeFrameNotebook (Just i) uId name = (:[]) <$>
   insertNode NodeFrameNotebook  (Just "Notebook")
                                 (Just $ DefaultFrameCode $ HyperdataFrame { _hf_base = "Codebook"
                                                                           , _hf_frame_id = name }) i uId
@@ -101,26 +101,21 @@ mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType)
                                     -> Name
                                     -> DBCmd err [NodeId]
 mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
-  maybeNodeId <- case nt of
+  nodeId <- case nt of
      Notes -> insertNode Notes (Just name)   Nothing i uId
      Calc  -> insertNode Calc  (Just name)   Nothing i uId
      NodeFrameVisio -> insertNode NodeFrameVisio (Just name)   Nothing i uId
      _              -> nodeError NeedsConfiguration
 
-  case maybeNodeId of
-    []  -> nodeError (DoesNotExist i)
-    [n] -> do
-      cfg <- view hasConfig
-      u <- case nt of
-            Notes -> pure $ _gc_frame_write_url cfg
-            Calc  -> pure $ _gc_frame_calc_url  cfg
-            NodeFrameVisio -> pure $ _gc_frame_visio_url  cfg
-            _              -> nodeError NeedsConfiguration
-      let
-        s = _gc_secretkey cfg
-        hd = HyperdataFrame u (hash $ s <> (show n))
-      _ <- updateHyperdata n hd
-      pure [n]
-    (_:_:_)  -> nodeError MkNode
-mkNodeWithParent_ConfigureHyperdata' _ _ _ _ = nodeError HasParent
-
+  cfg <- view hasConfig
+  u <- case nt of
+        Notes -> pure $ _gc_frame_write_url cfg
+        Calc  -> pure $ _gc_frame_calc_url  cfg
+        NodeFrameVisio -> pure $ _gc_frame_visio_url  cfg
+        _              -> nodeError NeedsConfiguration
+  let
+    s = _gc_secretkey cfg
+    hd = HyperdataFrame u (hash $ s <> (show nodeId))
+  _ <- updateHyperdata nodeId hd
+  pure [nodeId]
+mkNodeWithParent_ConfigureHyperdata' _ Nothing uId _ = nodeError $ NodeCreationFailed $ UserParentDoesNotExist uId

src/Gargantext/Database/Action/User.hs

@@ -27,7 +27,7 @@ getUserLightWithId :: HasNodeError err => UserId -> DBCmd err UserLight
 getUserLightWithId i = do
   candidates <- head <$> getUsersWithId (UserDBId i)
   case candidates of
-    Nothing -> nodeError (NoUserFound (UserDBId i))
+    Nothing -> nodeError (NodeLookupFailed $ UserDoesNotExist i)
     Just u  -> pure u
 
 getUserLightDB :: HasNodeError err => User -> DBCmd err UserLight
@@ -43,22 +43,21 @@ getUserId :: HasNodeError err
 getUserId u = do
   maybeUser <- getUserId' u
   case maybeUser of
-    Nothing -> nodeError (NoUserFound u)
-    Just u'  -> pure u'
+    Left reason -> nodeError $ NodeLookupFailed reason
+    Right u'    -> pure u'
 
 getUserId' :: HasNodeError err
           => User
-          -> DBCmd err (Maybe UserId)
-getUserId' (UserDBId uid) = pure (Just uid)
+          -> DBCmd err (Either NodeLookupError UserId)
+getUserId' (UserDBId uid) = pure (Right uid)
 getUserId' (RootId   rid) = do
   n <- getNode rid
-  pure $ Just $ _node_user_id n
+  pure $ Right $ _node_user_id n
 getUserId' (UserName u  ) = do
   muser <- getUser u
   case muser of
-    Just user -> pure $ Just $ userLight_id user
-    Nothing   -> pure Nothing
-getUserId' UserPublic = pure Nothing
+    Just user -> pure $ Right $ userLight_id user
+    Nothing   -> pure $ Left $ UserNameDoesNotExist u
 
 ------------------------------------------------------------------------
 -- | Username = Text
@@ -73,11 +72,10 @@ getUsername user@(UserDBId _) = do
   users <- getUsersWithId user
   case head users of
     Just u  -> pure $ userLight_username u
-    Nothing -> nodeError $ NodeError "G.D.A.U.getUserName: User not found with that id"
+    Nothing -> errorWith "G.D.A.U.getUserName: User not found with that id"
 getUsername (RootId   rid) = do
   n <- getNode rid
   getUsername (UserDBId $ _node_user_id n)
-getUsername UserPublic = pure "UserPublic"
 
 --------------------------------------------------------------------------
 -- getRootId is in Gargantext.Database.Query.Tree.Root

src/Gargantext/Database/Action/User/New.hs

@@ -40,6 +40,7 @@ import Gargantext.Database.Query.Table.User
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Pass.User (gargPass)
 import Gargantext.Prelude.Mail.Types (MailConfig)
+import qualified Data.List.NonEmpty as NE
 
 ------------------------------------------------------------------------
 -- | Creates a new 'User' from the input 'EmailAddress', which needs to
@@ -63,10 +64,8 @@ new_user :: HasNodeError err
          => NewUser GargPassword
          -> DBCmd err UserId
 new_user rq = do
-  ur <- new_users [rq]
-  case head ur of
-    Nothing   -> nodeError MkNode
-    Just uid  -> pure uid
+  (uid NE.:| _) <- new_users (rq NE.:| [])
+  pure uid
 
 ------------------------------------------------------------------------
 -- | A DB-specific action to bulk-create users.
@@ -74,18 +73,18 @@ new_user rq = do
 -- notification, and thus lives in the 'DbCmd' effect stack. You may want to
 -- use 'newUsers' instead for standard Gargantext code.
 new_users :: HasNodeError err
-          => [NewUser GargPassword]
+          => NonEmpty (NewUser GargPassword)
           -- ^ A list of users to create.
-          -> DBCmd err [UserId]
+          -> DBCmd err (NonEmpty UserId)
 new_users us = do
   us'   <- liftBase        $ mapM toUserHash us
-  void  $ insertUsers      $ map  toUserWrite us'
-  mapM (fmap fst . getOrMkRoot) $ map  (\u -> UserName   (_nu_username u)) us
+  void  $ insertUsers      $ NE.map toUserWrite us'
+  mapM (fmap fst . getOrMkRoot) $ NE.map  (\u -> UserName   (_nu_username u)) us
 
 ------------------------------------------------------------------------
 newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
-         => [EmailAddress]
-         -> m [UserId]
+         => NonEmpty EmailAddress
+         -> m (NonEmpty UserId)
 newUsers us = do
   config <- view $ mailSettings
   us' <- mapM (\ea -> mkNewUser ea . GargPassword <$> gargPass) us
@@ -110,10 +109,10 @@ guessUserName n = case splitOn "@" n of
 
 ------------------------------------------------------------------------
 newUsers' :: HasNodeError err
-         => MailConfig -> [NewUser GargPassword] -> Cmd err [UserId]
+         => MailConfig -> NonEmpty (NewUser GargPassword) -> Cmd err (NonEmpty UserId)
 newUsers' cfg us = do
   us' <- liftBase         $ mapM toUserHash  us
-  void $ insertUsers      $ map  toUserWrite us'
+  void $ insertUsers      $ NE.map  toUserWrite us'
   urs <- mapM (fmap fst . getOrMkRoot) $ map  (\u -> UserName   (_nu_username u)) us
   _   <- mapM (\u -> mail cfg (Invitation u)) us
   -- printDebug "newUsers'" us

src/Gargantext/Database/Admin/Types/Node.hs

@@ -44,7 +44,7 @@ import Opaleye (DefaultFromField, defaultFromField, SqlInt4, SqlText, SqlTSVecto
 import Opaleye qualified as O
 import Prelude qualified
 import Servant hiding (Context)
-import Test.QuickCheck (elements)
+import Test.QuickCheck (elements, Positive (getPositive))
 import Test.QuickCheck.Arbitrary
 import Test.QuickCheck.Instances.Text ()
 import Test.QuickCheck.Instances.Time ()
@@ -74,6 +74,9 @@ instance DecodeScalar UserId where
 instance ResourceId UserId where
   isPositive = (> 0) . _UserId
 
+instance Arbitrary UserId where
+  arbitrary = UnsafeMkUserId . getPositive <$> arbitrary
+
 instance DefaultFromField SqlInt4 UserId
   where
     defaultFromField = fromPGSFromField
@@ -272,6 +275,9 @@ newtype ContextId = UnsafeMkContextId { _ContextId :: Int }
 
 instance ToParamSchema ContextId
 
+instance Arbitrary ContextId where
+  arbitrary = UnsafeMkContextId . getPositive <$> arbitrary
+
 instance FromHttpApiData ContextId where
   parseUrlPiece n = pure $ UnsafeMkContextId $ (read . cs) n
 instance ToHttpApiData ContextId where
@@ -304,8 +310,10 @@ instance FromHttpApiData NodeId where
 instance ToHttpApiData NodeId where
   toUrlPiece (UnsafeMkNodeId n) = toUrlPiece n
 instance ToParamSchema NodeId
+
+-- | It makes sense to generate only positive ids.
 instance Arbitrary NodeId where
-  arbitrary = UnsafeMkNodeId <$> arbitrary
+  arbitrary = UnsafeMkNodeId . getPositive <$> arbitrary
 
 type ParentId    = NodeId
 type CorpusId    = NodeId

src/Gargantext/Database/Query/Table/Node.hs

@@ -266,21 +266,25 @@ getNodeWith nId _ = do
 
 ------------------------------------------------------------------------
 -- | Sugar to insert Node with NodeType in Database
-insertDefaultNode :: HasDBid NodeType
-                  => NodeType -> ParentId -> UserId -> DBCmd err [NodeId]
+insertDefaultNode :: (HasDBid NodeType, HasNodeError err)
+                  => NodeType -> ParentId -> UserId -> DBCmd err NodeId
 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 
-insertDefaultNodeIfNotExists :: HasDBid NodeType
+insertDefaultNodeIfNotExists :: (HasDBid NodeType, HasNodeError err)
                              => NodeType -> ParentId -> UserId -> DBCmd err [NodeId]
 insertDefaultNodeIfNotExists nt p u = do
   children <- getChildrenByType p nt
   case children of
-    [] -> insertDefaultNode nt p u
+    [] -> (:[]) <$> insertDefaultNode nt p u
     xs -> pure xs
 
-insertNode :: HasDBid NodeType
-           => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> DBCmd err [NodeId]
-insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
+insertNode :: (HasDBid NodeType, HasNodeError err)
+           => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> DBCmd err NodeId
+insertNode nt n h p u = do
+  res <- insertNodesR [nodeW nt n h p u]
+  case res of
+    [x] -> pure x
+    _   -> nodeError $ NodeCreationFailed $ InsertNodeFailed u p
 
 nodeW ::  HasDBid NodeType
        => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
@@ -378,18 +382,18 @@ data CorpusType = CorpusDocument | CorpusContact
 
 class MkCorpus a
   where
-    mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> DBCmd err [NodeId]
+    mk :: (HasDBid NodeType, HasNodeError err) => Maybe Name -> Maybe a -> ParentId -> UserId -> DBCmd err [NodeId]
 
 instance MkCorpus HyperdataCorpus
   where
-    mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
-    mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
+    mk n Nothing  p u = (:[]) <$> insertNode NodeCorpus n Nothing p u
+    mk n (Just h) p u = (:[]) <$> insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 
 
 instance MkCorpus HyperdataAnnuaire
   where
-    mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
-    mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
+    mk n Nothing  p u = (:[]) <$> insertNode NodeCorpus   n Nothing p u
+    mk n (Just h) p u = (:[]) <$> insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 
 
 getOrMkList :: (HasNodeError err, HasDBid NodeType)
@@ -399,7 +403,7 @@ getOrMkList :: (HasNodeError err, HasDBid NodeType)
 getOrMkList pId uId =
   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
     where
-      mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
+      mkList' pId' uId' = insertDefaultNode NodeList pId' uId'
 
 -- | TODO remove defaultList
 defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> DBCmd err ListId

src/Gargantext/Database/Query/Table/Node/Error.hs

+{-# LANGUAGE LambdaCase #-}
 {-|
 Module      : Gargantext.Database.Types.Error
 Description :
@@ -17,50 +18,67 @@ import Gargantext.Core.Types.Individu
 
 import Prelude hiding (null, id, map, sum, show)
 
-import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..), ContextId)
+import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..), ContextId, UserId, ParentId)
 import Gargantext.Prelude hiding (sum, head)
 import Prelude qualified
 
+data NodeCreationError
+  = UserParentAlreadyExists UserId ParentId
+  | UserParentDoesNotExist  UserId
+  | UserHasNegativeId       UserId
+  | InsertNodeFailed        UserId ParentId
+
+renderNodeCreationFailed :: NodeCreationError -> T.Text
+renderNodeCreationFailed = \case
+  UserParentAlreadyExists uid pId -> "user id " <> T.pack (show uid) <> " has already a parent: " <> T.pack (show pId)
+  UserParentDoesNotExist uid -> "user id " <> T.pack (show uid) <> " has no parent"
+  UserHasNegativeId uid      -> "user id " <> T.pack (show uid) <> " is a negative id."
+  InsertNodeFailed uid pid -> "couldn't create the list for user id " <> T.pack (show uid) <> " and parent id " <> T.pack (show pid)
+
+data NodeLookupError
+  = NodeDoesNotExist     NodeId
+  | UserDoesNotExist     UserId
+  | UserNameDoesNotExist Username
+  | UserHasTooManyRoots UserId [NodeId]
+
+renderNodeLookupFailed :: NodeLookupError -> T.Text
+renderNodeLookupFailed = \case
+  NodeDoesNotExist nid -> "node with id " <> T.pack (show nid) <> " couldn't be found."
+  UserDoesNotExist uid -> "user with id " <> T.pack (show uid) <> " couldn't be found."
+  UserNameDoesNotExist uname -> "user with username '" <> uname <> " couldn't be found."
+  UserHasTooManyRoots uid roots -> "user with id " <> T.pack (show uid) <> " has too many roots: [" <> T.intercalate "," (map (T.pack . show) roots)
+
 ------------------------------------------------------------------------
-data NodeError = NoListFound { listId :: ListId }
+data NodeError = NoListFound ListId
                | NoRootFound
                | NoCorpusFound
                | NoUserFound User
-               | MkNode
-               | UserNoParent
-               | HasParent
-               | ManyParents
-               | NegativeId
+               | NodeCreationFailed NodeCreationError
+               | NodeLookupFailed   NodeLookupError
                | NotImplYet
-               | ManyNodeUsers
-               | DoesNotExist NodeId
                | NoContextFound ContextId
                | NeedsConfiguration
-               | NodeError Text
-               | QueryNoParse Text
+               | NodeError SomeException
+               -- Left for backward compatibility, but we should remove them.
+               | DoesNotExist NodeId
 
 instance Prelude.Show NodeError
   where
-    show (NoListFound {})   = "No list   found"
-    show NoRootFound   = "No Root   found"
-    show NoCorpusFound = "No Corpus found"
+    show (NoListFound {})   = "No list found"
+    show NoRootFound   = "No root found"
+    show NoCorpusFound = "No corpus found"
     show (NoUserFound ur) = "User(" <> T.unpack (renderUser ur) <> ") not found"
 
-    show MkNode        = "Cannot make node"
-    show NegativeId    = "Node with negative Id"
-    show UserNoParent  = "Should not have parent"
-    show HasParent     = "NodeType has parent"
+    show (NodeCreationFailed reason) = "Cannot make node due to: " <> T.unpack (renderNodeCreationFailed reason)
     show NotImplYet    = "Not implemented yet"
-    show ManyParents   = "Too many parents"
-    show ManyNodeUsers = "Many userNode/user"
-    show (DoesNotExist n)   = "Node does not exist (" <> show n <> ")"
+    show (NodeLookupFailed reason) = "Cannot lookup node due to: " <> T.unpack (renderNodeLookupFailed reason)
     show (NoContextFound n) = "Context node does not exist (" <> show n <> ")"
     show NeedsConfiguration = "Needs configuration"
-    show (NodeError e)      = "NodeError: " <> cs e
-    show (QueryNoParse err) = "QueryNoParse: " <> T.unpack err
+    show (NodeError e)      = "NodeError: " <> displayException e
+    show (DoesNotExist n)   = "Node does not exist (" <> show n <> ")"
 
 instance ToJSON NodeError where
-  toJSON (NoListFound { listId }) =
+  toJSON (NoListFound listId) =
     object [ ( "error", "No list found" )
            , ( "listId", toJSON listId ) ]
   toJSON err =
@@ -72,7 +90,7 @@ class HasNodeError e where
 errorWith :: ( MonadError e m
             , HasNodeError e)
           => Text -> m a
-errorWith x = nodeError (NodeError x)
+errorWith x = nodeError (NodeError $ toException $ userError $ T.unpack x)
 
 nodeError :: ( MonadError e m
              , HasNodeError e)

src/Gargantext/Database/Query/Table/User.hs

@@ -18,6 +18,7 @@ Functions to deal with users, database side.
 {-# LANGUAGE FunctionalDependencies      #-}
 {-# LANGUAGE QuasiQuotes            #-}
 {-# LANGUAGE TemplateHaskell             #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Gargantext.Database.Query.Table.User
   ( insertUsers
@@ -57,9 +58,9 @@ import Gargantext.Core.Types.Individu
 import Gargantext.Database.Admin.Config (nodeTypeId)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..), hu_pubmed_api_key)
 import Gargantext.Database.Admin.Types.Node (NodeType(NodeUser), Node, NodeId(..), pgNodeId)
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Admin.Types.Node (UserId(..))
 import Gargantext.Database.Prelude
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateNodeWithType)
 import Gargantext.Database.Schema.Node (NodeRead, node_hyperdata, queryNodeTable, node_id, node_user_id, node_typename)
 import Gargantext.Database.Schema.User
@@ -67,11 +68,12 @@ import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Auth qualified as Auth
 import Opaleye
 import PUBMED.Types qualified as PUBMED
+import qualified Data.List.NonEmpty as NE
 
 ------------------------------------------------------------------------
 -- TODO: on conflict, nice message
-insertUsers :: [UserWrite] -> DBCmd err Int64
-insertUsers us = mkCmd $ \c -> runInsert c insert
+insertUsers :: NonEmpty UserWrite -> DBCmd err Int64
+insertUsers (NE.toList -> us) = mkCmd $ \c -> runInsert c insert
   where
     insert = Insert userTable us rCount Nothing
 
@@ -302,7 +304,7 @@ getUser :: Username -> DBCmd err (Maybe UserLight)
 getUser u = userLightWithUsername u <$> usersLight
 
 ----------------------------------------------------------------------
-insertNewUsers :: [NewUser GargPassword] -> DBCmd err Int64
+insertNewUsers :: NonEmpty (NewUser GargPassword) -> DBCmd err Int64
 insertNewUsers newUsers = do
   users' <- liftBase $ mapM toUserHash newUsers
   insertUsers $ map toUserWrite users'

src/Gargantext/Database/Query/Tree.hs

@@ -64,6 +64,7 @@ import Gargantext.Database.Query.Tree.Error
 import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Database.Schema.NodeNode (NodeNodePoly(..))
 import Gargantext.Prelude hiding (to)
+import qualified Data.List.NonEmpty as NE
 
 ------------------------------------------------------------------------
 data DbTreeNode = DbTreeNode { _dt_nodeId   :: NodeId
@@ -254,6 +255,9 @@ findNodesWithType root target through =
       isInTarget n = List.elem (fromDBid $ view dt_typeId n)
                    $ List.nub $ target <> through
 
+treeNodeToNodeId :: DbTreeNode -> NodeId
+treeNodeToNodeId = _dt_nodeId
+
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 toTree :: ( MonadError e m
@@ -266,7 +270,7 @@ toTree m =
         Just [root] -> pure $ toTree' m root
         Nothing     -> treeError NoRoot
         Just []     -> treeError EmptyRoot
-        Just _r     -> treeError TooManyRoots
+        Just r      -> treeError $ TooManyRoots (NE.fromList $ map treeNodeToNodeId r)
 
       where
         toTree' :: Map (Maybe ParentId) [DbTreeNode]

src/Gargantext/Database/Query/Tree/Error.hs

@@ -15,19 +15,22 @@ module Gargantext.Database.Query.Tree.Error
   where
 
 import Control.Lens (Prism', (#))
+import Gargantext.Core.Types
 import Gargantext.Prelude
 import Prelude qualified
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Text as T
 
 ------------------------------------------------------------------------
 data TreeError = NoRoot
                | EmptyRoot
-               | TooManyRoots
+               | TooManyRoots (NonEmpty NodeId)
 
 instance Prelude.Show TreeError
   where
-    show NoRoot       = "Root node not found"
-    show EmptyRoot    = "Root node should not be empty"
-    show TooManyRoots = "Too many root nodes"
+    show NoRoot               = "Root node not found"
+    show EmptyRoot            = "Root node should not be empty"
+    show (TooManyRoots roots) = "Too many root nodes: [" <> T.unpack (T.intercalate "," . map show $ NE.toList roots) <> "]"
 
 class HasTreeError e where
   _TreeError :: Prism' e TreeError

src/Gargantext/Database/Query/Tree/Root.hs

@@ -37,7 +37,7 @@ getRootId :: (HasNodeError err) => User -> DBCmd err NodeId
 getRootId u = do
   maybeRoot <- head <$> getRoot u
   case maybeRoot of
-    Nothing -> nodeError $ NodeError "[G.D.Q.T.R.getRootId] No root id"
+    Nothing -> errorWith "[G.D.Q.T.R.getRootId] No root id"
     Just  r -> pure (_node_id r)
 
 getRoot :: User -> DBCmd err [Node HyperdataUser]
@@ -54,7 +54,7 @@ getOrMkRoot user = do
   rootId'' <- case rootId' of
         []  -> mkRoot user
         n   -> case length n >= 2 of
-            True  -> nodeError ManyNodeUsers
+            True  -> nodeError $ NodeLookupFailed $ UserHasTooManyRoots userId n
             False -> pure rootId'
 
   rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
@@ -80,7 +80,7 @@ getOrMk_RootWithCorpus user cName c = do
                   else do
                     c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
                     _tId <- case head c' of
-                              Nothing  -> nodeError $ NodeError "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
+                              Nothing  -> errorWith "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
                               Just c'' -> insertDefaultNode NodeTexts c'' userId
                     pure c'
 
@@ -102,7 +102,7 @@ mkRoot user = do
   una <- getUsername user
 
   case isPositive uid of
-     False -> nodeError NegativeId
+     False -> nodeError $ NodeCreationFailed (UserHasNegativeId uid)
      True  -> do
        rs <- mkNodeWithParent NodeUser Nothing uid una
        _ <- case rs of
@@ -135,4 +135,3 @@ selectRoot (RootId nid) =
     restrict -< _node_typename row   .== (sqlInt4 $ toDBid NodeUser)
     restrict -< _node_id   row   .== (pgNodeId nid)
     returnA  -< row
-selectRoot UserPublic = panic {-nodeError $ NodeError-}  "[G.D.Q.T.Root.selectRoot] No root for Public"

src/Gargantext/Utils/Dict.hs

+{-# LANGUAGE ConstraintKinds    #-}
+{-# LANGUAGE KindSignatures     #-}
+{-# LANGUAGE PolyKinds          #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Gargantext.Utils.Dict where
+
+import Prelude
+import Data.Kind
+
+-- A dictionary allowing us to treat constraints as first class values.
+data Dict (c :: k -> Constraint) (a :: k) where
+  Dict :: c a => Dict c a
+
+deriving instance Show (Dict c a)

src/Gargantext/Utils/Jobs.hs

@@ -28,6 +28,7 @@ import Text.Read (readMaybe)
 import qualified Data.Text as T
 
 import Gargantext.API.Admin.EnvTypes
+import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import qualified Gargantext.Utils.Jobs.Internal as Internal
 import Gargantext.Utils.Jobs.Monad
@@ -36,8 +37,8 @@ import Gargantext.System.Logging
 import qualified Servant.Job.Async as SJ
 
 jobErrorToGargError
-  :: JobError -> GargError
-jobErrorToGargError = GargJobError
+  :: JobError -> BackendInternalError
+jobErrorToGargError = InternalJobError
 
 serveJobsAPI
   :: (
@@ -47,7 +48,7 @@ serveJobsAPI
    , ToJSON (JobEventType m)
    , ToJSON (JobOutputType m)
    , MonadJobStatus m
-   , m ~ (GargM Env GargError)
+   , m ~ (GargM Env BackendInternalError)
    , JobEventType m ~ JobOutputType m
    )
   => JobType m

src/Gargantext/Utils/Jobs/Internal.hs

@@ -29,6 +29,7 @@ import qualified Data.Text as T
 import qualified Servant.Client as C
 import qualified Servant.Job.Async as SJ
 import qualified Servant.Job.Client as SJ
+import qualified Servant.Job.Core as SJ
 import qualified Servant.Job.Types as SJ
 
 serveJobsAPI
@@ -65,7 +66,7 @@ serveJobAPI t joberr jid' = wrap' (killJob t)
           -> m a
         wrap g = do
           jid <- handleIDError joberr (checkJID jid')
-          job <- maybe (throwError $ joberr UnknownJob) pure =<< findJob jid
+          job <- maybe (throwError $ joberr $ UnknownJob (SJ._id_number jid)) pure =<< findJob jid
           g jid job
 
         wrap' g limit offset = wrap (g limit offset)

src/Gargantext/Utils/Jobs/Monad.hs

@@ -112,10 +112,13 @@ findJob jid = do
   liftIO $ lookupJob jid jmap
 
 data JobError
-  = InvalidIDType
-  | IDExpired
+  =
+  -- | We expected to find a job tagged internall as \"job\", but we found the input @T.Text@ instead.
+    InvalidIDType T.Text
+  -- | The given ID expired.
+  | IDExpired Int
   | InvalidMacID T.Text
-  | UnknownJob
+  | UnknownJob Int
   | JobException SomeException
   deriving Show
 
@@ -126,8 +129,8 @@ checkJID
 checkJID (SJ.PrivateID tn n t d) = do
   now <- liftIO getCurrentTime
   js <- getJobsSettings
-  if | tn /= "job" -> pure (Left InvalidIDType)
-     | now > addUTCTime (fromIntegral $ jsIDTimeout js) t -> pure (Left IDExpired)
+  if | tn /= "job" -> pure (Left $ InvalidIDType $ T.pack tn)
+     | now > addUTCTime (fromIntegral $ jsIDTimeout js) t -> pure (Left $ IDExpired n)
      | d /= SJ.macID tn (jsSecretKey js) t n -> pure (Left $ InvalidMacID $ T.pack d)
      | otherwise -> pure $ Right (SJ.PrivateID tn n t d)
 

test/Test/API.hs

@@ -6,9 +6,11 @@ import Test.Hspec
 import qualified Test.API.Authentication as Auth
 import qualified Test.API.Private as Private
 import qualified Test.API.GraphQL as GraphQL
+import qualified Test.API.Errors as Errors
 
 tests :: Spec
 tests = describe "API" $ do
   Auth.tests
   Private.tests
   GraphQL.tests
+  Errors.tests

test/Test/API/Errors.hs

+{-# LANGUAGE QuasiQuotes #-}
+module Test.API.Errors (tests) where
+
+import Gargantext.API.Routes
+import Gargantext.Core.Types.Individu
+import Gargantext.Prelude hiding (get)
+import Network.HTTP.Client hiding (Proxy)
+import Network.HTTP.Types
+import Network.Wai.Test
+import Servant
+import Servant.Auth.Client ()
+import Servant.Client
+import Test.API.Private (protected, withValidLogin, protectedNewError)
+import Test.API.Setup (withTestDBAndPort, setupEnvironment, mkUrl, createAliceAndBob)
+import Test.Hspec
+import Test.Hspec.Wai.Internal (withApplication)
+import Text.RawString.QQ (r)
+import qualified Servant.Auth.Client as SA
+
+tests :: Spec
+tests = sequential $ aroundAll withTestDBAndPort $ do
+  describe "Errors API" $ do
+    describe "Prelude" $ do
+      it "setup DB triggers and users" $ \((testEnv, port), _) -> do
+        setupEnvironment testEnv
+        baseUrl <- parseBaseUrl "http://localhost"
+        manager <- newManager defaultManagerSettings
+        let clientEnv prt = mkClientEnv manager (baseUrl { baseUrlPort = prt })
+
+        createAliceAndBob testEnv
+
+        let ( roots_api :<|> _nodes_api
+              ) = client (Proxy :: Proxy (MkProtectedAPI GargAdminAPI)) (SA.Token "bogus")
+        let ( admin_user_api_get :<|> _) = roots_api
+
+        result <- runClientM admin_user_api_get (clientEnv port)
+        length result `shouldBe` 0
+
+    describe "GET /api/v1.0/node" $ do
+
+      it "returns the old error by default" $ \((_testEnv, port), app) -> do
+        withApplication app $ do
+          withValidLogin port "gargantua" (GargPassword "secret_key") $ \token -> do
+            res <- protected token "GET" (mkUrl port "/node/99") ""
+            case res of
+              SResponse{..}
+                | Status{..} <- simpleStatus
+                ->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 =

test/Test/API/Setup.hs

 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings    #-}
 
 module Test.API.Setup where
 
@@ -10,6 +11,7 @@ import Gargantext.API (makeApp)
 import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..))
 import Gargantext.API.Admin.Settings
 import Gargantext.API.Admin.Types
+import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.Core.NLP
 import Gargantext.Core.NodeStory
@@ -21,6 +23,7 @@ import Gargantext.Database.Admin.Trigger.Init
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getOrMkList)
+-- import Gargantext.Prelude (printDebug)
 import Gargantext.Prelude.Config
 import Gargantext.System.Logging
 import Network.HTTP.Client.TLS (newTlsManager)
@@ -41,7 +44,7 @@ import qualified Network.Wai.Handler.Warp as Wai
 import qualified Servant.Job.Async as ServantAsync
 
 
-newTestEnv :: TestEnv -> Logger (GargM Env GargError) -> Warp.Port -> IO Env
+newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env
 newTestEnv testEnv logger port = do
   file          <- fakeIniPath
   !manager_env  <- newTlsManager
@@ -54,7 +57,7 @@ newTestEnv testEnv logger port = do
   dbParam        <- pure $ testEnvToPgConnectionInfo testEnv
   !pool          <- newPool dbParam
 
-  !nodeStory_env <- readNodeStoryEnv pool
+  !nodeStory_env <- fromDBNodeStoryEnv pool
   !scrapers_env  <- ServantAsync.newJobEnv ServantAsync.defaultSettings manager_env
 
   secret        <- Jobs.genSecret
@@ -101,6 +104,7 @@ setupEnvironment env = flip runReaderT env $ runTestMonad $ do
                                         (Left corpusMasterName)
                                         (Nothing :: Maybe HyperdataCorpus)
   masterListId <- getOrMkList masterCorpusId masterUserId
+  -- printDebug "[setupEnvironment] masterListId: " masterListId
   void $ initLastTriggers masterListId
 
 -- | Creates two users, Alice & Bob. Alice shouldn't be able to see

test/Test/Database/Operations.hs

 {-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TupleSections        #-}
 {-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -6,13 +7,15 @@
 {-# OPTIONS_GHC -Wno-orphans      #-}
 
 module Test.Database.Operations (
-   tests
+     tests
+   , nodeStoryTests
   ) where
 
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Text qualified as T
 import Database.PostgreSQL.Simple
+import Database.PostgreSQL.Simple.SqlQQ
 import Gargantext.API.Node.Corpus.Update
 import Gargantext.Core
 import Gargantext.Core.Types.Individu
@@ -20,12 +23,14 @@ import Gargantext.Database.Action.User
 import Gargantext.Database.Action.User.New
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude (runPGSQuery)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Prelude
 import Test.API.Setup (setupEnvironment)
 import Test.Database.Operations.DocumentSearch
+import Test.Database.Operations.NodeStory
 import Test.Database.Setup (withTestDB)
 import Test.Database.Types
 import Test.Hspec
@@ -63,7 +68,26 @@ tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
       it "Can perform search by author in documents" corpusSearch02
       it "Can perform more complex searches using the boolean API" corpusSearch03
       it "Can correctly count doc score" corpusScore01
-
+        
+nodeStoryTests :: Spec
+nodeStoryTests = sequential $
+  -- run 'withTestDB' before _every_ test item
+  around setupDBAndCorpus $
+  describe "Database - node story" $ do
+    describe "Node story" $ do
+      it "[#281] Can create a list" createListTest
+      it "[#281] Can query node story" queryNodeStoryTest
+      it "[#218] Can add new terms to node story" insertNewTermsToNodeStoryTest
+      it "[#281] Can add new terms (with children) to node story" insertNewTermsWithChildrenToNodeStoryTest
+      it "[#281] Fixes child terms to match parents' terms" insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest
+      it "[#281] Can update node story when 'setListNgrams' is called" setListNgramsUpdatesNodeStoryTest
+      it "[#281] When 'setListNgrams' is called, childrens' parents are updated" setListNgramsUpdatesNodeStoryWithChildrenTest
+      it "[#281] Correctly commits patches to node story - simple" commitPatchSimpleTest
+  where
+    setupDBAndCorpus testsFunc = withTestDB $ \env -> do
+      setupEnvironment env
+      testsFunc env
+  
 data ExpectedActual a =
     Expected a
   | Actual a
@@ -126,8 +150,10 @@ corpusReadWrite01 env = do
   flip runReaderT env $ runTestMonad $ do
     uid      <- getUserId (UserName "alfredo")
     parentId <- getRootId (UserName "alfredo")
-    [corpusId] <- mk (Just "Test_Corpus") (Nothing :: Maybe HyperdataCorpus) parentId uid
-    liftIO $ corpusId `shouldBe` UnsafeMkNodeId 416
+    let corpusName = "Test_Corpus"
+    [corpusId] <- mk (Just corpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
+    [Only corpusId'] <- runPGSQuery [sql|SELECT id FROM nodes WHERE name = ?|] (Only corpusName)
+    liftIO $ corpusId `shouldBe` UnsafeMkNodeId corpusId'
     -- Retrieve the corpus by Id
     [corpus] <- getCorporaWithParentId parentId
     liftIO $ corpusId `shouldBe` (_node_id corpus)

test/Test/Database/Setup.hs

@@ -15,6 +15,7 @@ import Database.PostgreSQL.Simple.Options qualified as Client
 import Database.PostgreSQL.Simple.Options qualified as Opts
 import Database.Postgres.Temp qualified as Tmp
 import Gargantext.API.Admin.EnvTypes (Mode(Mock))
+import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config
 import Gargantext.System.Logging (withLoggerHoisted)
@@ -71,8 +72,13 @@ setup = do
                          (PG.close) 2 60 2
       bootstrapDB db pool gargConfig
       ugen <- emptyCounter
+      test_nodeStory <- fromDBNodeStoryEnv pool
       withLoggerHoisted Mock $ \logger -> do
-        pure $ TestEnv (DBHandle pool db) gargConfig ugen logger
+        pure $ TestEnv { test_db = DBHandle pool db
+                       , test_config = gargConfig
+                       , test_nodeStory
+                       , test_usernameGen = ugen
+                       , test_logger = logger }
 
 withTestDB :: (TestEnv -> IO ()) -> IO ()
 withTestDB = bracket setup teardown

test/Test/Database/Types.hs

@@ -29,9 +29,11 @@ import Gargantext hiding (to)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.EnvTypes qualified as EnvTypes
 import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.Core.Mail.Types (HasMail(..))
 import Gargantext.Core.NLP (HasNLPServer(..))
+import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude (HasConfig(..), HasConnectionPool(..))
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Prelude.Config
@@ -57,8 +59,9 @@ nextCounter (Counter ref) = atomicModifyIORef' ref (\old -> (succ old, old))
 data TestEnv = TestEnv {
     test_db                  :: !DBHandle
   , test_config              :: !GargConfig
+  , test_nodeStory           :: !NodeStoryEnv
   , test_usernameGen         :: !Counter
-  , test_logger              :: !(Logger (GargM TestEnv GargError))
+  , test_logger              :: !(Logger (GargM TestEnv BackendInternalError))
   }
 
 newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
@@ -71,7 +74,7 @@ newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
            )
 
 instance MonadJobStatus TestMonad where
-  type JobHandle      TestMonad = EnvTypes.ConcreteJobHandle GargError
+  type JobHandle      TestMonad = EnvTypes.ConcreteJobHandle BackendInternalError
   type JobType        TestMonad = GargJob
   type JobOutputType  TestMonad = JobLog
   type JobEventType   TestMonad = JobLog
@@ -107,6 +110,20 @@ instance HasMail TestEnv where
                                         , _mc_mail_password   = "test"
                                         , _mc_mail_login_type = NoAuth })
 
+instance HasNodeStoryEnv TestEnv where
+  hasNodeStory = to test_nodeStory
+
+
+instance HasNodeStoryVar TestEnv where
+  hasNodeStoryVar = hasNodeStory . nse_getter
+
+instance HasNodeStoryImmediateSaver TestEnv where
+  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
+
+instance HasNodeArchiveStoryImmediateSaver TestEnv where
+  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
+
+
 coreNLPConfig :: NLPServerConfig
 coreNLPConfig =
   let uri = parseURI "http://localhost:9000"
@@ -116,17 +133,17 @@ coreNLPConfig =
 instance HasNLPServer TestEnv where
   nlpServer = to $ const (Map.singleton EN coreNLPConfig)
 
-instance MonadLogger (GargM TestEnv GargError) where
+instance MonadLogger (GargM TestEnv BackendInternalError) where
   getLogger = asks test_logger
 
-instance HasLogger (GargM TestEnv GargError) where
-  data instance Logger (GargM TestEnv GargError) =
+instance HasLogger (GargM TestEnv BackendInternalError) where
+  data instance Logger (GargM TestEnv BackendInternalError) =
     GargTestLogger {
       test_logger_mode :: Mode
     , test_logger_set  :: FL.LoggerSet
     }
-  type instance LogInitParams (GargM TestEnv GargError) = Mode
-  type instance LogPayload (GargM TestEnv GargError)    = FL.LogStr
+  type instance LogInitParams (GargM TestEnv BackendInternalError) = Mode
+  type instance LogPayload (GargM TestEnv BackendInternalError)    = FL.LogStr
   initLogger                = \mode -> do
     test_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
     pure $ GargTestLogger mode test_logger_set

test/Test/Ngrams/Query.hs

@@ -2,19 +2,18 @@
 {-# LANGUAGE TypeApplications #-}
 module Test.Ngrams.Query (tests) where
 
-import           Control.Monad
-import           Data.Coerce
-import           Data.Monoid
-import           Gargantext.API.Ngrams
-import           Gargantext.API.Ngrams.Types
-import           Gargantext.Core.Types.Main
-import           Gargantext.Core.Types.Query
-import           Gargantext.Prelude
-import qualified Data.Map.Strict as Map
-import qualified Data.Patch.Class as Patch
-import qualified Data.Validity    as Validity
-import qualified Data.Text as T
-
+import Control.Monad
+import Data.Coerce
+import Data.Map.Strict qualified as Map
+import Data.Monoid
+import Data.Patch.Class qualified as Patch
+import Data.Text qualified as T
+import Data.Validity qualified as Validity
+import Gargantext.API.Ngrams
+import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Types.Main
+import Gargantext.Core.Types.Query
+import Gargantext.Prelude
 import Test.Ngrams.Query.PaginationCorpus
 import Test.Tasty
 import Test.Tasty.HUnit

test/Test/Offline/JSON.hs

 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Test.Offline.JSON (tests) where
 
 import Data.Aeson
 import Data.Either
+import Gargantext.API.Errors
 import Gargantext.API.Node.Corpus.New
 import Gargantext.API.Node.Corpus.Types
 import Gargantext.Core.Types.Phylo
@@ -20,15 +22,38 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy.Char8 as C8
 
 import Paths_gargantext
+import Gargantext.Database.Admin.Types.Node
 
 jsonRoundtrip :: (Show a, FromJSON a, ToJSON a, Eq a) => a -> Property
 jsonRoundtrip a =
   counterexample ("Parsed JSON: " <> C8.unpack (encode a)) $ eitherDecode (encode a) === Right a
 
+class (Show a, FromJSON a, ToJSON a, Eq a, Enum a, Bounded a) => EnumBoundedJSON a
+instance EnumBoundedJSON BackendErrorCode
+
+jsonEnumRoundtrip :: forall a. Dict EnumBoundedJSON a -> Property
+jsonEnumRoundtrip d = case d of
+  Dict -> conjoin $ map (prop Dict) [minBound .. maxBound]
+  where
+    prop :: Dict EnumBoundedJSON a -> a -> Property
+    prop Dict a = counterexample ("Parsed JSON: " <> C8.unpack (encode a)) $ eitherDecode (encode a) === Right a
+
+-- | Tests /all/ the 'BackendErrorCode' and their associated 'FrontendError' payloads.
+jsonFrontendErrorRoundtrip :: Property
+jsonFrontendErrorRoundtrip = conjoin $ map mk_prop [minBound .. maxBound]
+  where
+    mk_prop :: BackendErrorCode -> Property
+    mk_prop code = forAll (genFrontendErr code) $ \a ->
+      counterexample ("Parsed JSON: " <> C8.unpack (encode a)) $ eitherDecode (encode a) === Right a
+
 tests :: TestTree
 tests = testGroup "JSON" [
-    testProperty "Datafield roundtrips" (jsonRoundtrip @Datafield)
-  , testProperty "WithQuery roundtrips" (jsonRoundtrip @WithQuery)
+    testProperty "NodeId roundtrips"        (jsonRoundtrip @NodeId)
+  , testProperty "RootId roundtrips"        (jsonRoundtrip @RootId)
+  , testProperty "Datafield roundtrips"     (jsonRoundtrip @Datafield)
+  , testProperty "WithQuery roundtrips"     (jsonRoundtrip @WithQuery)
+  , testProperty "FrontendError roundtrips" jsonFrontendErrorRoundtrip
+  , testProperty "BackendErrorCode roundtrips" (jsonEnumRoundtrip (Dict @_ @BackendErrorCode))
   , testCase "WithQuery frontend compliance" testWithQueryFrontend
   , testGroup "Phylo" [
     testProperty "PeriodToNode"  (jsonRoundtrip @PeriodToNodeData)

test/Test/Utils/Jobs.hs

@@ -26,6 +26,7 @@ import Data.Time
 import Debug.RecoverRTTI (anythingToString)
 import Gargantext.API.Admin.EnvTypes as EnvTypes
 import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.Prelude
 import Gargantext.Utils.Jobs.Internal (newJob)
@@ -215,14 +216,14 @@ testFairness = do
 
 
 newtype MyDummyMonad a =
-  MyDummyMonad { _MyDummyMonad :: GargM Env GargError a }
+  MyDummyMonad { _MyDummyMonad :: GargM Env BackendInternalError a }
   deriving (Functor, Applicative, Monad, MonadIO, MonadReader Env)
 
 instance MonadJob MyDummyMonad GargJob (Seq JobLog) JobLog where
   getJobEnv = MyDummyMonad getJobEnv
 
 instance MonadJobStatus MyDummyMonad where
-  type JobHandle      MyDummyMonad = EnvTypes.ConcreteJobHandle GargError
+  type JobHandle      MyDummyMonad = EnvTypes.ConcreteJobHandle BackendInternalError
   type JobType        MyDummyMonad = GargJob
   type JobOutputType  MyDummyMonad = JobLog
   type JobEventType   MyDummyMonad = JobLog
@@ -252,7 +253,7 @@ withJob :: Env
         -> IO (SJ.JobStatus 'SJ.Safe JobLog)
 withJob env f = runMyDummyMonad env $ MyDummyMonad $
   -- the job type doesn't matter in our tests, we use a random one, as long as it's of type 'GargJob'.
-  newJob @_ @GargError mkJobHandle (pure env) RecomputeGraphJob (\_ hdl input ->
+  newJob @_ @BackendInternalError mkJobHandle (pure env) RecomputeGraphJob (\_ hdl input ->
     runMyDummyMonad env $ (Right <$> (f hdl input >> getLatestJobStatus hdl))) (SJ.JobInput () Nothing)
 
 withJob_ :: Env

test/drivers/hspec/Main.hs

@@ -43,3 +43,4 @@ main = do
   bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do
     API.tests
     DB.tests
+    DB.nodeStoryTests