Skip to content

haskell-gargantext
haskell-gargantext
Commit 3763d0dc authored by Alfredo Di Napoli's avatar Alfredo Di Napoli
Browse files
Options

Complete NodeError -> FrontendError

parent 37c94f6c
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 504 additions and 273 deletions
bin/gargantext-admin/Main.hs
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
......@@ -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.hs
View file @ 3763d0dc
This diff is collapsed.
src/Gargantext/API/Errors/Types/Backend.hs
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
{-# 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
View file @ 3763d0dc
......@@ -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
View file @ 3763d0dc
......@@ -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"
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment