Complete NodeError -> FrontendError

bin/gargantext-admin/Main.hs

@@ -22,12 +22,13 @@ 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 BackendInternalError [UserId])
+    x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: Cmd'' DevEnv BackendInternalError (NonEmpty UserId))
     putStrLn (show x :: Text)
   pure ()

bin/gargantext-init/Main.hs

@@ -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 ()
@@ -50,7 +51,7 @@ main = do
 
   let createUsers :: Cmd BackendInternalError Int64
       createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)
-                                   : arbitraryNewUsers
+                                   NE.:| arbitraryNewUsers
                                    )
 
   let

src/Gargantext/API/Errors.hs

@@ -62,60 +62,68 @@ internalServerErrorToFrontendError = \case
 
 jobErrorToFrontendError :: JobError -> FrontendError
 jobErrorToFrontendError = \case
-  InvalidIDType idTy -> mkFrontendErrNoDiagnostic $ FE_job_error_invalid_id_type idTy
-  IDExpired jobId    -> mkFrontendErrNoDiagnostic $ FE_job_error_expired jobId
-  InvalidMacID macId -> mkFrontendErrNoDiagnostic $ FE_job_error_invalid_mac macId
-  UnknownJob jobId   -> mkFrontendErrNoDiagnostic $ FE_job_error_unknown_job jobId
-  JobException err   -> mkFrontendErrNoDiagnostic $ FE_job_error_generic_exception (T.pack $ displayException err)
+  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
-  -- externall).
+  -- 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_error_list_not_found lid
+    -> mkFrontendErrShow $ FE_node_list_not_found lid
   NoRootFound
-    -> mkFrontendErrShow FE_node_error_root_not_found
+    -> mkFrontendErrShow FE_node_root_not_found
   NoCorpusFound
-    -> mkFrontendErrShow FE_node_error_corpus_not_found
+    -> mkFrontendErrShow FE_node_corpus_not_found
   NoUserFound _ur
     -> undefined
-  MkNode
-    -> undefined
-  UserNoParent
-    -> undefined
-  HasParent
-    -> undefined
-  ManyParents
-    -> undefined
-  NegativeId
-    -> 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_error_not_implemented_yet
-  ManyNodeUsers
-    -> undefined
-  DoesNotExist nodeId
-    -> mkFrontendErrShow $ FE_node_error_not_found nodeId
-  NoContextFound _contextId
-    -> undefined
+    -> mkFrontendErrShow FE_node_not_implemented_yet
+  NoContextFound contextId
+    -> mkFrontendErrShow $ FE_node_context_not_found contextId
   NeedsConfiguration
-    -> undefined
-  NodeError _txt
-    -> undefined
-  QueryNoParse _txt
-    -> undefined
+    -> 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_error_root_not_found
-  EmptyRoot          -> mkFrontendErrShow FE_tree_error_empty_root
-  TooManyRoots roots -> mkFrontendErrShow $ FE_tree_error_too_many_roots roots
+  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.

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

@@ -16,27 +16,37 @@ import Prelude
 data BackendErrorCode
   =
   -- node errors
-    EC_404__node_error_list_not_found
-  | EC_404__node_error_root_not_found
-  | EC_404__node_error_not_found
-  | EC_404__node_error_corpus_not_found
-  | EC_500__node_error_not_implemented_yet
+    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_error_root_not_found
-  | EC_404__tree_error_empty_root
-  | EC_500__tree_error_too_many_roots
+  | 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_error_invalid_id_type
-  | EC_500__job_error_expired
-  | EC_500__job_error_invalid_mac
-  | EC_500__job_error_unknown_job
-  | EC_500__job_error_generic_exception
+  | 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])

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/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/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

@@ -275,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

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,27 +18,49 @@ 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
                | 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
@@ -46,18 +69,13 @@ instance Prelude.Show NodeError
     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) =
@@ -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/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"