Commit a3879ca5 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski

Merge branch '421-refactor-gargantext-database-prelude' into 'dev'

Resolve "Refactor `Gargantext.Database.Prelude`"

Closes #421

See merge request !372
parents 9a8cff4c ac72d900
Pipeline #7094 passed with stages
in 65 minutes and 5 seconds
...@@ -21,7 +21,7 @@ import Prelude (String) ...@@ -21,7 +21,7 @@ import Prelude (String)
adminCLI :: AdminArgs -> IO () adminCLI :: AdminArgs -> IO ()
adminCLI (AdminArgs settingsPath mails) = do adminCLI (AdminArgs settingsPath mails) = do
withDevEnv settingsPath $ \env -> do withDevEnv settingsPath $ \env -> do
x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: Cmd'' DevEnv BackendInternalError (NonEmpty UserId)) x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: CmdRandom DevEnv BackendInternalError (NonEmpty UserId))
putStrLn (show x :: Text) putStrLn (show x :: Text)
adminCmd :: HasCallStack => Mod CommandFields CLI adminCmd :: HasCallStack => Mod CommandFields CLI
......
...@@ -29,8 +29,7 @@ import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMkRootWithCorpus) ...@@ -29,8 +29,7 @@ import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMkRootWithCorpus)
import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers) import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (DBCmd') import Gargantext.Database.Prelude (DBCmd, DBCmdWithEnv)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.Node (getOrMkList) import Gargantext.Database.Query.Table.Node (getOrMkList)
import Gargantext.Database.Query.Table.User (insertNewUsers, ) import Gargantext.Database.Query.Table.User (insertNewUsers, )
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserMaster)) import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserMaster))
...@@ -49,18 +48,18 @@ initCLI (InitArgs settingsPath) = do ...@@ -49,18 +48,18 @@ initCLI (InitArgs settingsPath) = do
cfg <- readConfig settingsPath cfg <- readConfig settingsPath
let secret = _s_secret_key $ _gc_secrets cfg let secret = _s_secret_key $ _gc_secrets cfg
let createUsers :: forall env. DBCmd' env BackendInternalError Int64 let createUsers :: forall env. DBCmdWithEnv env BackendInternalError Int64
createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password) createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)
NE.:| arbitraryNewUsers NE.:| arbitraryNewUsers
) )
let let
mkRoots :: forall env. DBCmd' env BackendInternalError [(UserId, RootId)] mkRoots :: forall env. DBCmdWithEnv env BackendInternalError [(UserId, RootId)]
mkRoots = mapM getOrMkRoot $ map UserName ("gargantua" : arbitraryUsername) mkRoots = mapM getOrMkRoot $ map UserName ("gargantua" : arbitraryUsername)
-- TODO create all users roots -- TODO create all users roots
let let
initMaster :: forall env. DBCmd' env BackendInternalError (UserId, RootId, CorpusId, ListId) initMaster :: forall env. DBCmdWithEnv env BackendInternalError (UserId, RootId, CorpusId, ListId)
initMaster = do initMaster = do
(masterUserId, masterRootId, masterCorpusId) (masterUserId, masterRootId, masterCorpusId)
<- getOrMkRootWithCorpus MkCorpusUserMaster <- getOrMkRootWithCorpus MkCorpusUserMaster
......
...@@ -16,16 +16,15 @@ module CLI.Invitations where ...@@ -16,16 +16,15 @@ module CLI.Invitations where
import CLI.Parsers import CLI.Parsers
import CLI.Types import CLI.Types
import Control.Monad.Random (MonadRandom)
import Gargantext.API.Dev (withDevEnv, runCmdDev) import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
import Gargantext.API.Node () -- instances only import Gargantext.API.Node () -- instances only
import Gargantext.API.Node.Share qualified as Share import Gargantext.API.Node.Share qualified as Share
import Gargantext.API.Node.Share.Types qualified as Share import Gargantext.API.Node.Share.Types qualified as Share
import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Types import Gargantext.Core.Types
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Prelude (CmdRandom) import Gargantext.Database.Prelude (IsDBCmdExtra)
import Gargantext.Prelude import Gargantext.Prelude
import Options.Applicative import Options.Applicative
import Prelude (String) import Prelude (String)
...@@ -34,9 +33,8 @@ invitationsCLI :: InvitationsArgs -> IO () ...@@ -34,9 +33,8 @@ invitationsCLI :: InvitationsArgs -> IO ()
invitationsCLI (InvitationsArgs settingsPath user node_id email) = do invitationsCLI (InvitationsArgs settingsPath user node_id email) = do
-- _cfg <- readConfig settingsPath -- _cfg <- readConfig settingsPath
let invite :: ( CmdRandom env BackendInternalError m let invite :: (IsDBCmdExtra env BackendInternalError m, MonadRandom m)
, HasNLPServer env => m Int
, CET.HasCentralExchangeNotification env ) => m Int
invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email) invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email)
withDevEnv settingsPath $ \env -> do withDevEnv settingsPath $ \env -> do
......
...@@ -52,47 +52,9 @@ upgradeCLI (UpgradeArgs settingsFile) = do ...@@ -52,47 +52,9 @@ upgradeCLI (UpgradeArgs settingsFile) = do
let _secret = _s_secret_key $ _gc_secrets cfg let _secret = _s_secret_key $ _gc_secrets cfg
withDevEnv settingsFile $ \_env -> do withDevEnv settingsFile $ \_env -> do
-- _ <- runCmdDev env addIndex
-- _ <- runCmdDev env refreshIndex
___
putStrLn ("Uprade done with success !" :: Text) putStrLn ("Uprade done with success !" :: Text)
___
pure () pure ()
-- refreshIndex :: Cmd'' DevEnv IOException ()
-- refreshIndex = do
-- _ <- execPGSQuery [sql| REFRESH MATERIALIZED VIEW CONCURRENTLY context_node_ngrams_view; |] ()
-- pure ()
-- addIndex :: Cmd'' DevEnv IOException Int64
-- addIndex = do
-- execPGSQuery query ()
-- where
-- query = [sql|
-- CREATE MATERIALIZED VIEW IF NOT EXISTS context_node_ngrams_view AS
-- SELECT DISTINCT context_node_ngrams.context_id, ngrams_id, nodes_contexts.node_id
-- FROM nodes_contexts
-- JOIN context_node_ngrams
-- ON context_node_ngrams.context_id = nodes_contexts.context_id;
-- CREATE INDEX IF NOT EXISTS context_node_ngrams_context_id_ngrams_id_idx
-- ON context_node_ngrams(context_id, ngrams_id);
-- CREATE INDEX IF NOT EXISTS context_node_ngrams_view_context_id_idx
-- ON context_node_ngrams_view(context_id);
-- CREATE INDEX IF NOT EXISTS context_node_ngrams_view_ngrams_id_idx
-- ON context_node_ngrams_view(ngrams_id);
-- CREATE INDEX IF NOT EXISTS context_node_ngrams_view_node_id_idx
-- ON context_node_ngrams_view(node_id);
-- CREATE UNIQUE INDEX IF NOT EXISTS context_node_ngrams_view_context_ngrams_node_uniq_idx
-- ON context_node_ngrams_view (context_id, ngrams_id, node_id);
-- CREATE INDEX IF NOT EXISTS node_stories_ngrams_id_idx
-- ON node_stories(ngrams_id);
-- |]
upgradeCmd :: HasCallStack => Mod CommandFields CLI upgradeCmd :: HasCallStack => Mod CommandFields CLI
upgradeCmd = command "upgrade" (info (helper <*> fmap CLISub upgrade_p) (progDesc "Upgrade a Gargantext node.")) upgradeCmd = command "upgrade" (info (helper <*> fmap CLISub upgrade_p) (progDesc "Upgrade a Gargantext node."))
......
...@@ -675,6 +675,7 @@ executable gargantext ...@@ -675,6 +675,7 @@ executable gargantext
, haskell-bee , haskell-bee
, ini ^>= 0.4.1 , ini ^>= 0.4.1
, lens >= 5.2.2 && < 5.3 , lens >= 5.2.2 && < 5.3
, MonadRandom ^>= 0.6
, monad-logger ^>= 0.3.36 , monad-logger ^>= 0.3.36
, optparse-applicative , optparse-applicative
, optparse-generic ^>= 1.4.7 , optparse-generic ^>= 1.4.7
......
...@@ -62,7 +62,7 @@ import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..)) ...@@ -62,7 +62,7 @@ import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
import Gargantext.Core.Worker.Jobs.Types qualified as Jobs import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
import Gargantext.Database.Action.User.New (guessUserName) import Gargantext.Database.Action.User.New (guessUserName)
import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId) import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
import Gargantext.Database.Prelude (Cmd', CmdCommon, DbCmd') import Gargantext.Database.Prelude (Cmd, IsDBEnvExtra, IsDBCmd)
import Gargantext.Database.Query.Table.User import Gargantext.Database.Query.Table.User
import Gargantext.Database.Query.Tree (isDescendantOf, isIn) import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
import Gargantext.Database.Query.Tree.Root (getRoot) import Gargantext.Database.Query.Tree.Root (getRoot)
...@@ -81,7 +81,7 @@ import Servant.Server.Generic (AsServerT) ...@@ -81,7 +81,7 @@ import Servant.Server.Generic (AsServerT)
makeTokenForUser :: (HasJWTSettings env, HasAuthenticationError err) makeTokenForUser :: (HasJWTSettings env, HasAuthenticationError err)
=> NodeId => NodeId
-> UserId -> UserId
-> Cmd' env err Token -> Cmd env err Token
makeTokenForUser nodeId userId = do makeTokenForUser nodeId userId = do
jwtS <- view jwtSettings jwtS <- view jwtSettings
e <- liftBase $ makeJWT (AuthenticatedUser nodeId userId) jwtS Nothing e <- liftBase $ makeJWT (AuthenticatedUser nodeId userId) jwtS Nothing
...@@ -89,7 +89,7 @@ makeTokenForUser nodeId userId = do ...@@ -89,7 +89,7 @@ makeTokenForUser nodeId userId = do
either (authenticationError . LoginFailed nodeId userId) (pure . toStrict . LE.decodeUtf8) e either (authenticationError . LoginFailed nodeId userId) (pure . toStrict . LE.decodeUtf8) e
-- TODO not sure about the encoding... -- TODO not sure about the encoding...
checkAuthRequest :: ( HasJWTSettings env, HasAuthenticationError err, DbCmd' env err m ) checkAuthRequest :: ( HasJWTSettings env, HasAuthenticationError err, IsDBCmd env err m )
=> Username => Username
-> GargPassword -> GargPassword
-> m CheckAuth -> m CheckAuth
...@@ -114,7 +114,7 @@ checkAuthRequest couldBeEmail (GargPassword p) = do ...@@ -114,7 +114,7 @@ checkAuthRequest couldBeEmail (GargPassword p) = do
token <- makeTokenForUser nodeId userLight_id token <- makeTokenForUser nodeId userLight_id
pure $ Valid token nodeId userLight_id pure $ Valid token nodeId userLight_id
auth :: (HasJWTSettings env, HasAuthenticationError err, DbCmd' env err m) auth :: (HasJWTSettings env, HasAuthenticationError err, IsDBCmd env err m)
=> AuthRequest -> m AuthResponse => AuthRequest -> m AuthResponse
auth (AuthRequest u p) = do auth (AuthRequest u p) = do
checkAuthRequest' <- checkAuthRequest u p checkAuthRequest' <- checkAuthRequest u p
...@@ -138,7 +138,7 @@ authCheck _env (BasicAuthData login password) = pure $ ...@@ -138,7 +138,7 @@ authCheck _env (BasicAuthData login password) = pure $
maybe Indefinite Authenticated $ TODO maybe Indefinite Authenticated $ TODO
-} -}
withAccessM :: ( DbCmd' env err m ) withAccessM :: ( IsDBCmd env err m )
=> AuthenticatedUser => AuthenticatedUser
-> PathId -> PathId
-> m a -> m a
...@@ -229,19 +229,18 @@ All users can access to the Team folder as if they were owner. ...@@ -229,19 +229,18 @@ All users can access to the Team folder as if they were owner.
-} -}
forgotPassword :: IsGargServer env err m => Named.ForgotPasswordAPI (AsServerT m) forgotPassword :: IsGargServer env err m => Named.ForgotPasswordAPI (AsServerT m)
-- => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
forgotPassword = Named.ForgotPasswordAPI forgotPassword = Named.ForgotPasswordAPI
{ forgotPasswordPostEp = forgotPasswordPost { forgotPasswordPostEp = forgotPasswordPost
, forgotPasswordGetEp = forgotPasswordGet , forgotPasswordGetEp = forgotPasswordGet
} }
forgotPasswordPost :: (CmdCommon env) forgotPasswordPost :: (IsDBEnvExtra env)
=> ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse => ForgotPasswordRequest -> Cmd env err ForgotPasswordResponse
forgotPasswordPost (ForgotPasswordRequest _email) = do forgotPasswordPost (ForgotPasswordRequest _email) = do
pure $ ForgotPasswordResponse "ok" pure $ ForgotPasswordResponse "ok"
forgotPasswordGet :: (CmdCommon env, HasServerError err) forgotPasswordGet :: (IsDBEnvExtra env, HasServerError err)
=> Maybe Text -> Cmd' env err ForgotPasswordGet => Maybe Text -> Cmd env err ForgotPasswordGet
forgotPasswordGet Nothing = pure $ ForgotPasswordGet "" forgotPasswordGet Nothing = pure $ ForgotPasswordGet ""
forgotPasswordGet (Just uuid) = do forgotPasswordGet (Just uuid) = do
let mUuid = fromText uuid let mUuid = fromText uuid
...@@ -257,8 +256,8 @@ forgotPasswordGet (Just uuid) = do ...@@ -257,8 +256,8 @@ forgotPasswordGet (Just uuid) = do
--------------------- ---------------------
forgotPasswordGetUser :: ( CmdCommon env) forgotPasswordGetUser :: ( IsDBEnvExtra env)
=> UserLight -> Cmd' env err ForgotPasswordGet => UserLight -> Cmd env err ForgotPasswordGet
forgotPasswordGetUser (UserLight { .. }) = do forgotPasswordGetUser (UserLight { .. }) = do
-- pick some random password -- pick some random password
password <- liftBase gargPass password <- liftBase gargPass
...@@ -276,8 +275,8 @@ forgotPasswordGetUser (UserLight { .. }) = do ...@@ -276,8 +275,8 @@ forgotPasswordGetUser (UserLight { .. }) = do
pure $ ForgotPasswordGet password pure $ ForgotPasswordGet password
forgotUserPassword :: (CmdCommon env) forgotUserPassword :: (IsDBEnvExtra env)
=> UserLight -> Cmd' env err () => UserLight -> Cmd env err ()
forgotUserPassword (UserLight { .. }) = do forgotUserPassword (UserLight { .. }) = do
--printDebug "[forgotUserPassword] userLight_id" userLight_id --printDebug "[forgotUserPassword] userLight_id" userLight_id
--logDebug $ "[forgotUserPassword]" :# ["userLight_id" .= userLight_id] --logDebug $ "[forgotUserPassword]" :# ["userLight_id" .= userLight_id]
...@@ -301,8 +300,8 @@ forgotUserPassword (UserLight { .. }) = do ...@@ -301,8 +300,8 @@ forgotUserPassword (UserLight { .. }) = do
-------------------------- --------------------------
-- Generate a unique (in whole DB) UUID for passwords. -- Generate a unique (in whole DB) UUID for passwords.
generateForgotPasswordUUID :: (CmdCommon env) generateForgotPasswordUUID :: (IsDBEnvExtra env)
=> Cmd' env err UUID => Cmd env err UUID
generateForgotPasswordUUID = do generateForgotPasswordUUID = do
uuid <- liftBase $ nextRandom uuid <- liftBase $ nextRandom
us <- getUsersWithForgotPasswordUUID uuid us <- getUsersWithForgotPasswordUUID uuid
......
...@@ -23,7 +23,7 @@ import Gargantext.API.Prelude ( GargM ) ...@@ -23,7 +23,7 @@ import Gargantext.API.Prelude ( GargM )
import Gargantext.Core.Config (_gc_database_config) import Gargantext.Core.Config (_gc_database_config)
import Gargantext.Core.Config.Types (SettingsFile(..)) import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.NodeStory (fromDBNodeStoryEnv) import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
import Gargantext.Database.Prelude (Cmd', Cmd'', connPool, runCmd) import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Config.Utils (readConfig) import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.System.Logging ( withLoggerHoisted ) import Gargantext.System.Logging ( withLoggerHoisted )
...@@ -52,17 +52,17 @@ defaultSettingsFile :: SettingsFile ...@@ -52,17 +52,17 @@ defaultSettingsFile :: SettingsFile
defaultSettingsFile = SettingsFile "gargantext-settings.toml" defaultSettingsFile = SettingsFile "gargantext-settings.toml"
-- | Run Cmd Sugar for the Repl (GHCI) -- | Run Cmd Sugar for the Repl (GHCI)
runCmdRepl :: Show err => Cmd'' DevEnv err a -> IO a runCmdRepl :: Show err => CmdRandom DevEnv err a -> IO a
runCmdRepl f = withDevEnv defaultSettingsFile $ \env -> runCmdDev env f runCmdRepl f = withDevEnv defaultSettingsFile $ \env -> runCmdDev env f
runCmdReplServantErr :: Cmd'' DevEnv ServerError a -> IO a runCmdReplServantErr :: CmdRandom DevEnv ServerError a -> IO a
runCmdReplServantErr = runCmdRepl runCmdReplServantErr = runCmdRepl
-- In particular this writes the repo file after running -- In particular this writes the repo file after running
-- the command. -- the command.
-- This function is constrained to the DevEnv rather than -- This function is constrained to the DevEnv rather than
-- using HasConnectionPool and HasRepoVar. -- using HasConnectionPool and HasRepoVar.
runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a runCmdDev :: Show err => DevEnv -> CmdRandom DevEnv err a -> IO a
runCmdDev env f = runCmdDev env f =
either (fail . show) pure =<< runCmd env f either (fail . show) pure =<< runCmd env f
...@@ -70,13 +70,13 @@ runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a ...@@ -70,13 +70,13 @@ runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a
runCmdGargDev env cmd = runCmdGargDev env cmd =
either (fail . show) pure =<< runExceptT (runReaderT cmd env) either (fail . show) pure =<< runExceptT (runReaderT cmd env)
runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a runCmdDevNoErr :: DevEnv -> Cmd DevEnv () a -> IO a
runCmdDevNoErr = runCmdDev runCmdDevNoErr = runCmdDev
runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a runCmdDevServantErr :: DevEnv -> Cmd DevEnv ServerError a -> IO a
runCmdDevServantErr = runCmdDev runCmdDevServantErr = runCmdDev
runCmdReplEasy :: Cmd'' DevEnv BackendInternalError a -> IO a runCmdReplEasy :: CmdRandom DevEnv BackendInternalError a -> IO a
runCmdReplEasy f = withDevEnv defaultSettingsFile $ \env -> runCmdDev env f runCmdReplEasy f = withDevEnv defaultSettingsFile $ \env -> runCmdDev env f
-- | Execute a function that takes PSQL.Connection from the DB pool as -- | Execute a function that takes PSQL.Connection from the DB pool as
......
...@@ -42,7 +42,7 @@ import Gargantext.API.Prelude (GargM) ...@@ -42,7 +42,7 @@ import Gargantext.API.Prelude (GargM)
import Gargantext.API.Types (HTML) import Gargantext.API.Types (HTML)
import Gargantext.Core.Config (HasJWTSettings) import Gargantext.Core.Config (HasJWTSettings)
import Gargantext.Core.NLP (HasNLPServer) import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Database.Prelude (CmdCommon) import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Prelude hiding (ByteString) import Gargantext.Prelude hiding (ByteString)
import Servant import Servant
import Servant.Auth qualified as SA import Servant.Auth qualified as SA
...@@ -98,7 +98,7 @@ data Contet m ...@@ -98,7 +98,7 @@ data Contet m
-- | The main GraphQL resolver: how queries, mutations and -- | The main GraphQL resolver: how queries, mutations and
-- subscriptions are handled. -- subscriptions are handled.
rootResolver rootResolver
:: (CmdCommon env, HasNLPServer env, HasJWTSettings env) :: (IsDBEnvExtra env, HasNLPServer env, HasJWTSettings env)
=> AuthenticatedUser => AuthenticatedUser
-> AccessPolicyManager -> AccessPolicyManager
-> RootResolver (GargM env BackendInternalError) e Query Mutation Undefined -> RootResolver (GargM env BackendInternalError) e Query Mutation Undefined
...@@ -129,7 +129,7 @@ rootResolver authenticatedUser policyManager = ...@@ -129,7 +129,7 @@ rootResolver authenticatedUser policyManager =
-- | Main GraphQL "app". -- | Main GraphQL "app".
app app
:: (Typeable env, CmdCommon env, HasNLPServer env, HasJWTSettings env) :: (Typeable env, IsDBEnvExtra env, HasNLPServer env, HasJWTSettings env)
=> AuthenticatedUser => AuthenticatedUser
-> AccessPolicyManager -> AccessPolicyManager
-> App (EVENT (GargM env BackendInternalError)) (GargM env BackendInternalError) -> App (EVENT (GargM env BackendInternalError)) (GargM env BackendInternalError)
...@@ -167,7 +167,7 @@ data GraphQLAPIEndpoints mode = GraphQLAPIEndpoints ...@@ -167,7 +167,7 @@ data GraphQLAPIEndpoints mode = GraphQLAPIEndpoints
-- | Implementation of our API. -- | Implementation of our API.
api api
:: (Typeable env, CmdCommon env, HasJWTSettings env) :: (Typeable env, IsDBEnvExtra env, HasJWTSettings env)
=> GraphQLAPI (AsServerT (GargM env BackendInternalError)) => GraphQLAPI (AsServerT (GargM env BackendInternalError))
api = GraphQLAPI $ \case api = GraphQLAPI $ \case
(SAS.Authenticated auser) (SAS.Authenticated auser)
......
...@@ -23,7 +23,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact ...@@ -23,7 +23,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
, cw_lastName , cw_lastName
, hc_who, ContactWhere, hc_where, cw_organization, cw_labTeamDepts, cw_role, cw_office, cw_country, cw_city, cw_touch, ct_mail, ct_phone, ct_url, hc_title, hc_source) , hc_who, ContactWhere, hc_where, cw_organization, cw_labTeamDepts, cw_role, cw_office, cw_country, cw_city, cw_touch, ct_mail, ct_phone, ct_url, hc_title, hc_source)
import Gargantext.Database.Admin.Types.Node (ContextId (..)) import Gargantext.Database.Admin.Types.Node (ContextId (..))
import Gargantext.Database.Prelude (CmdCommon) import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Query.Table.Context (getContextWith) import Gargantext.Database.Query.Table.Context (getContextWith)
import Gargantext.Database.Schema.Node (node_hyperdata) import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude import Gargantext.Prelude
...@@ -55,13 +55,13 @@ data AnnuaireContactArgs ...@@ -55,13 +55,13 @@ data AnnuaireContactArgs
-- | Function to resolve user from a query. -- | Function to resolve user from a query.
resolveAnnuaireContacts resolveAnnuaireContacts
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> AnnuaireContactArgs -> GqlM e env [AnnuaireContact] => AnnuaireContactArgs -> GqlM e env [AnnuaireContact]
resolveAnnuaireContacts AnnuaireContactArgs { contact_id } = dbAnnuaireContacts contact_id resolveAnnuaireContacts AnnuaireContactArgs { contact_id } = dbAnnuaireContacts contact_id
-- | Inner function to fetch the user from DB. -- | Inner function to fetch the user from DB.
dbAnnuaireContacts dbAnnuaireContacts
:: CmdCommon env :: IsDBEnvExtra env
=> Int -> GqlM e env [AnnuaireContact] => Int -> GqlM e env [AnnuaireContact]
dbAnnuaireContacts contact_id = do dbAnnuaireContacts contact_id = do
-- lift $ printDebug "[dbUsers]" user_id -- lift $ printDebug "[dbUsers]" user_id
......
...@@ -33,7 +33,7 @@ import Gargantext.API.Prelude (GargM) ...@@ -33,7 +33,7 @@ import Gargantext.API.Prelude (GargM)
import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow) import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument ) import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument )
import Gargantext.Database.Admin.Types.Node (ContextTitle, NodeId(..), NodeTypeId, UserId, unNodeId, ContextId (..)) import Gargantext.Database.Admin.Types.Node (ContextTitle, NodeId(..), NodeTypeId, UserId, unNodeId, ContextId (..))
import Gargantext.Database.Prelude (CmdCommon) import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Query.Table.NodeContext (getNodeContext, getContextsForNgramsTerms, ContextForNgramsTerms(..), {- getContextNgrams, -} getContextNgramsMatchingFTS) import Gargantext.Database.Query.Table.NodeContext (getNodeContext, getContextsForNgramsTerms, ContextForNgramsTerms(..), {- getContextNgrams, -} getContextNgramsMatchingFTS)
import Gargantext.Database.Query.Table.NodeContext qualified as DNC import Gargantext.Database.Query.Table.NodeContext qualified as DNC
import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..)) import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..))
...@@ -119,19 +119,19 @@ type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a ...@@ -119,19 +119,19 @@ type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
-- | Function to resolve context from a query. -- | Function to resolve context from a query.
resolveNodeContext resolveNodeContext
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> NodeContextArgs -> GqlM e env [NodeContextGQL] => NodeContextArgs -> GqlM e env [NodeContextGQL]
resolveNodeContext NodeContextArgs { context_id, node_id } = resolveNodeContext NodeContextArgs { context_id, node_id } =
dbNodeContext context_id node_id dbNodeContext context_id node_id
resolveContextsForNgrams resolveContextsForNgrams
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> ContextsForNgramsArgs -> GqlM e env [ContextGQL] => ContextsForNgramsArgs -> GqlM e env [ContextGQL]
resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms, and_logic } = resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms, and_logic } =
dbContextForNgrams corpus_id ngrams_terms and_logic dbContextForNgrams corpus_id ngrams_terms and_logic
resolveContextNgrams resolveContextNgrams
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> ContextNgramsArgs -> GqlM e env [Text] => ContextNgramsArgs -> GqlM e env [Text]
resolveContextNgrams ContextNgramsArgs { context_id, list_id } = resolveContextNgrams ContextNgramsArgs { context_id, list_id } =
dbContextNgrams context_id list_id dbContextNgrams context_id list_id
...@@ -140,7 +140,7 @@ resolveContextNgrams ContextNgramsArgs { context_id, list_id } = ...@@ -140,7 +140,7 @@ resolveContextNgrams ContextNgramsArgs { context_id, list_id } =
-- | Inner function to fetch the node context DB. -- | Inner function to fetch the node context DB.
dbNodeContext dbNodeContext
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> Int -> Int -> GqlM e env [NodeContextGQL] => Int -> Int -> GqlM e env [NodeContextGQL]
dbNodeContext context_id node_id = do dbNodeContext context_id node_id = do
-- lift $ printDebug "[dbUsers]" user_id -- lift $ printDebug "[dbUsers]" user_id
...@@ -152,7 +152,7 @@ dbNodeContext context_id node_id = do ...@@ -152,7 +152,7 @@ dbNodeContext context_id node_id = do
-- | Returns list of `ContextGQL` for given ngrams in given corpus id. -- | Returns list of `ContextGQL` for given ngrams in given corpus id.
dbContextForNgrams dbContextForNgrams
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> Int -> [Text] -> Text -> GqlM e env [ContextGQL] => Int -> [Text] -> Text -> GqlM e env [ContextGQL]
dbContextForNgrams node_id ngrams_terms and_logic = do dbContextForNgrams node_id ngrams_terms and_logic = do
contextsForNgramsTerms <- lift $ getContextsForNgramsTerms (UnsafeMkNodeId node_id) ngrams_terms ( readMaybe $ unpack $ Text.toTitle and_logic ) contextsForNgramsTerms <- lift $ getContextsForNgramsTerms (UnsafeMkNodeId node_id) ngrams_terms ( readMaybe $ unpack $ Text.toTitle and_logic )
...@@ -161,7 +161,7 @@ dbContextForNgrams node_id ngrams_terms and_logic = do ...@@ -161,7 +161,7 @@ dbContextForNgrams node_id ngrams_terms and_logic = do
-- | Fetch ngrams matching given context in a given list id. -- | Fetch ngrams matching given context in a given list id.
dbContextNgrams dbContextNgrams
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> Int -> Int -> GqlM e env [Text] => Int -> Int -> GqlM e env [Text]
dbContextNgrams context_id list_id = do dbContextNgrams context_id list_id = do
lift $ getContextNgramsMatchingFTS (UnsafeMkContextId context_id) (UnsafeMkNodeId list_id) lift $ getContextNgramsMatchingFTS (UnsafeMkContextId context_id) (UnsafeMkNodeId list_id)
...@@ -221,7 +221,7 @@ toHyperdataRowDocumentGQL hyperdata = ...@@ -221,7 +221,7 @@ toHyperdataRowDocumentGQL hyperdata =
} }
HyperdataRowContact { } -> Nothing HyperdataRowContact { } -> Nothing
updateNodeContextCategory :: (CmdCommon env) updateNodeContextCategory :: (IsDBEnvExtra env)
=> AuthenticatedUser => AuthenticatedUser
-> AccessPolicyManager -> AccessPolicyManager
-> NodeContextCategoryMArgs -> NodeContextCategoryMArgs
......
...@@ -24,7 +24,7 @@ import Gargantext.API.GraphQL.Types ( GqlM ) ...@@ -24,7 +24,7 @@ import Gargantext.API.GraphQL.Types ( GqlM )
import Gargantext.Core ( HasDBid(lookupDBid) ) import Gargantext.Core ( HasDBid(lookupDBid) )
import Gargantext.Database.Admin.Types.Node (NodeType) import Gargantext.Database.Admin.Types.Node (NodeType)
import Gargantext.Database.Admin.Types.Node qualified as NN import Gargantext.Database.Admin.Types.Node qualified as NN
import Gargantext.Database.Prelude (CmdCommon) -- , JSONB) import Gargantext.Database.Prelude (IsDBEnvExtra) -- , JSONB)
import Gargantext.Database.Query.Table.Node (getClosestChildrenByType, getClosestParentIdByType, getNode) import Gargantext.Database.Query.Table.Node (getClosestChildrenByType, getClosestParentIdByType, getNode)
import Gargantext.Database.Schema.Node qualified as N import Gargantext.Database.Schema.Node qualified as N
import Gargantext.Prelude import Gargantext.Prelude
...@@ -57,7 +57,7 @@ data NodeArgs ...@@ -57,7 +57,7 @@ data NodeArgs
-- | Function to resolve user from a query. -- | Function to resolve user from a query.
resolveNodes resolveNodes
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> AuthenticatedUser => AuthenticatedUser
-> AccessPolicyManager -> AccessPolicyManager
-> NodeArgs -> NodeArgs
...@@ -66,19 +66,19 @@ resolveNodes autUser mgr NodeArgs { node_id } = ...@@ -66,19 +66,19 @@ resolveNodes autUser mgr NodeArgs { node_id } =
withPolicy autUser mgr (nodeReadChecks $ NN.UnsafeMkNodeId node_id) $ dbNodes node_id withPolicy autUser mgr (nodeReadChecks $ NN.UnsafeMkNodeId node_id) $ dbNodes node_id
resolveNodesCorpus resolveNodesCorpus
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> CorpusArgs -> GqlM e env [Corpus] => CorpusArgs -> GqlM e env [Corpus]
resolveNodesCorpus CorpusArgs { corpus_id } = dbNodesCorpus corpus_id resolveNodesCorpus CorpusArgs { corpus_id } = dbNodesCorpus corpus_id
dbNodes dbNodes
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> Int -> GqlM e env [Node] => Int -> GqlM e env [Node]
dbNodes node_id = do dbNodes node_id = do
node <- lift $ getNode $ NN.UnsafeMkNodeId node_id node <- lift $ getNode $ NN.UnsafeMkNodeId node_id
pure [toNode node] pure [toNode node]
dbNodesCorpus dbNodesCorpus
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> Int -> GqlM e env [Corpus] => Int -> GqlM e env [Corpus]
dbNodesCorpus corpus_id = do dbNodesCorpus corpus_id = do
corpus <- lift $ getNode $ NN.UnsafeMkNodeId corpus_id corpus <- lift $ getNode $ NN.UnsafeMkNodeId corpus_id
...@@ -97,17 +97,17 @@ data NodeChildrenArgs ...@@ -97,17 +97,17 @@ data NodeChildrenArgs
} deriving (Generic, GQLType) } deriving (Generic, GQLType)
resolveNodeParent resolveNodeParent
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> NodeParentArgs -> GqlM e env [Node] => NodeParentArgs -> GqlM e env [Node]
resolveNodeParent NodeParentArgs { node_id, parent_type } = dbParentNodes node_id parent_type resolveNodeParent NodeParentArgs { node_id, parent_type } = dbParentNodes node_id parent_type
resolveNodeChildren resolveNodeChildren
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> NodeChildrenArgs -> GqlM e env [Node] => NodeChildrenArgs -> GqlM e env [Node]
resolveNodeChildren NodeChildrenArgs { node_id, child_type } = dbChildNodes node_id child_type resolveNodeChildren NodeChildrenArgs { node_id, child_type } = dbChildNodes node_id child_type
dbParentNodes dbParentNodes
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> Int -> NodeType -> GqlM e env [Node] => Int -> NodeType -> GqlM e env [Node]
dbParentNodes node_id parentType = do dbParentNodes node_id parentType = do
-- let mParentType = readEither (T.unpack parent_type) :: Either Prelude.String NodeType -- let mParentType = readEither (T.unpack parent_type) :: Either Prelude.String NodeType
...@@ -123,7 +123,7 @@ dbParentNodes node_id parentType = do ...@@ -123,7 +123,7 @@ dbParentNodes node_id parentType = do
node <- lift $ getNode id node <- lift $ getNode id
pure [toNode node] pure [toNode node]
dbChildNodes :: (CmdCommon env) dbChildNodes :: (IsDBEnvExtra env)
=> Int -> NodeType -> GqlM e env [Node] => Int -> NodeType -> GqlM e env [Node]
dbChildNodes node_id childType = do dbChildNodes node_id childType = do
childIds <- lift $ getClosestChildrenByType (NN.UnsafeMkNodeId node_id) childType -- (fromNodeTypeId parent_type_id) childIds <- lift $ getClosestChildrenByType (NN.UnsafeMkNodeId node_id) childType -- (fromNodeTypeId parent_type_id)
......
...@@ -25,7 +25,7 @@ import Gargantext.Core.Config (HasJWTSettings) ...@@ -25,7 +25,7 @@ import Gargantext.Core.Config (HasJWTSettings)
import Gargantext.Core.Types (NodeId(..), unNodeId) import Gargantext.Core.Types (NodeId(..), unNodeId)
import Gargantext.Core.Types.Individu qualified as Individu import Gargantext.Core.Types.Individu qualified as Individu
import Gargantext.Database.Action.Share (membersOf, deleteMemberShip) import Gargantext.Database.Action.Share (membersOf, deleteMemberShip)
import Gargantext.Database.Prelude (CmdCommon) import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Query.Table.Node (getNode) import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Table.User (getUsersWithNodeHyperdata) import Gargantext.Database.Query.Table.User (getUsersWithNodeHyperdata)
import Gargantext.Database.Schema.Node (NodePoly(Node, _node_id), _node_user_id) import Gargantext.Database.Schema.Node (NodePoly(Node, _node_id), _node_user_id)
...@@ -53,10 +53,10 @@ data TeamDeleteMArgs = TeamDeleteMArgs ...@@ -53,10 +53,10 @@ data TeamDeleteMArgs = TeamDeleteMArgs
type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
resolveTeam :: (CmdCommon env) => TeamArgs -> GqlM e env Team resolveTeam :: (IsDBEnvExtra env) => TeamArgs -> GqlM e env Team
resolveTeam TeamArgs { team_node_id } = dbTeam team_node_id resolveTeam TeamArgs { team_node_id } = dbTeam team_node_id
dbTeam :: (CmdCommon env) => dbTeam :: (IsDBEnvExtra env) =>
Int -> GqlM e env Team Int -> GqlM e env Team
dbTeam nodeId = do dbTeam nodeId = do
let nId = UnsafeMkNodeId nodeId let nId = UnsafeMkNodeId nodeId
...@@ -78,7 +78,7 @@ dbTeam nodeId = do ...@@ -78,7 +78,7 @@ dbTeam nodeId = do
getUsername ((UserLight {userLight_username}, _):_) = userLight_username getUsername ((UserLight {userLight_username}, _):_) = userLight_username
-- TODO: list as argument -- TODO: list as argument
deleteTeamMembership :: (CmdCommon env, HasJWTSettings env) => deleteTeamMembership :: (IsDBEnvExtra env, HasJWTSettings env) =>
TeamDeleteMArgs -> GqlM' e env [Int] TeamDeleteMArgs -> GqlM' e env [Int]
deleteTeamMembership TeamDeleteMArgs { token, shared_folder_id, team_node_id } = do deleteTeamMembership TeamDeleteMArgs { token, shared_folder_id, team_node_id } = do
teamNode <- lift $ getNode $ UnsafeMkNodeId team_node_id teamNode <- lift $ getNode $ UnsafeMkNodeId team_node_id
......
...@@ -25,7 +25,7 @@ import Gargantext.Core.Types.Main ( Tree(..), _tn_node, _tn_children, NodeTree(. ...@@ -25,7 +25,7 @@ import Gargantext.Core.Types.Main ( Tree(..), _tn_node, _tn_children, NodeTree(.
import Gargantext.Database.Admin.Config () import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId(..), NodeType) import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId(..), NodeType)
import Gargantext.Database.Admin.Types.Node qualified as NN import Gargantext.Database.Admin.Types.Node qualified as NN
import Gargantext.Database.Prelude (CmdCommon) import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Query.Table.Node (getNode) import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Tree qualified as T import Gargantext.Database.Query.Tree qualified as T
import Gargantext.Database.Schema.Node (NodePoly(_node_parent_id)) import Gargantext.Database.Schema.Node (NodePoly(_node_parent_id))
...@@ -65,7 +65,7 @@ data BreadcrumbInfo = BreadcrumbInfo ...@@ -65,7 +65,7 @@ data BreadcrumbInfo = BreadcrumbInfo
type ParentId = Maybe NodeId type ParentId = Maybe NodeId
resolveTree :: (CmdCommon env) resolveTree :: (IsDBEnvExtra env)
=> AuthenticatedUser => AuthenticatedUser
-> AccessPolicyManager -> AccessPolicyManager
-> TreeArgs -> TreeArgs
...@@ -73,7 +73,7 @@ resolveTree :: (CmdCommon env) ...@@ -73,7 +73,7 @@ resolveTree :: (CmdCommon env)
resolveTree autUser mgr TreeArgs { root_id } = resolveTree autUser mgr TreeArgs { root_id } =
withPolicy autUser mgr (nodeReadChecks $ UnsafeMkNodeId root_id) $ dbTree (_auth_user_id autUser) root_id withPolicy autUser mgr (nodeReadChecks $ UnsafeMkNodeId root_id) $ dbTree (_auth_user_id autUser) root_id
dbTree :: (CmdCommon env) => dbTree :: (IsDBEnvExtra env) =>
NN.UserId -> Int -> GqlM e env (TreeFirstLevel (GqlM e env)) NN.UserId -> Int -> GqlM e env (TreeFirstLevel (GqlM e env))
dbTree loggedInUserId root_id = do dbTree loggedInUserId root_id = do
let rId = UnsafeMkNodeId root_id let rId = UnsafeMkNodeId root_id
...@@ -85,7 +85,7 @@ dbTree loggedInUserId root_id = do ...@@ -85,7 +85,7 @@ dbTree loggedInUserId root_id = do
toParentId N.Node { _node_parent_id } = _node_parent_id toParentId N.Node { _node_parent_id } = _node_parent_id
toTree :: (CmdCommon env) => NodeId -> ParentId -> Tree NodeTree -> TreeFirstLevel (GqlM e env) toTree :: (IsDBEnvExtra env) => NodeId -> ParentId -> Tree NodeTree -> TreeFirstLevel (GqlM e env)
toTree rId pId TreeN { _tn_node, _tn_children } = TreeFirstLevel toTree rId pId TreeN { _tn_node, _tn_children } = TreeFirstLevel
{ parent = resolveParent pId { parent = resolveParent pId
, root = toTreeNode pId _tn_node , root = toTreeNode pId _tn_node
...@@ -98,7 +98,7 @@ toTreeNode pId NodeTree { _nt_name, _nt_id, _nt_type } = TreeNode { name = _nt_n ...@@ -98,7 +98,7 @@ toTreeNode pId NodeTree { _nt_name, _nt_id, _nt_type } = TreeNode { name = _nt_n
childrenToTreeNodes :: (Tree NodeTree, NodeId) -> TreeNode childrenToTreeNodes :: (Tree NodeTree, NodeId) -> TreeNode
childrenToTreeNodes (TreeN {_tn_node}, rId) = toTreeNode (Just rId) _tn_node childrenToTreeNodes (TreeN {_tn_node}, rId) = toTreeNode (Just rId) _tn_node
resolveParent :: (CmdCommon env) => Maybe NodeId -> GqlM e env (Maybe TreeNode) resolveParent :: (IsDBEnvExtra env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
resolveParent (Just pId) = do resolveParent (Just pId) = do
node <- lift $ getNode pId node <- lift $ getNode pId
pure $ nodeToTreeNode node pure $ nodeToTreeNode node
...@@ -117,7 +117,7 @@ nodeToTreeNode N.Node {..} = ...@@ -117,7 +117,7 @@ nodeToTreeNode N.Node {..} =
else else
Nothing Nothing
resolveBreadcrumb :: (CmdCommon env) => BreadcrumbArgs -> GqlM e env BreadcrumbInfo resolveBreadcrumb :: (IsDBEnvExtra env) => BreadcrumbArgs -> GqlM e env BreadcrumbInfo
resolveBreadcrumb BreadcrumbArgs { node_id } = dbRecursiveParents node_id resolveBreadcrumb BreadcrumbArgs { node_id } = dbRecursiveParents node_id
convertDbTreeToTreeNode :: HasCallStack => T.DbTreeNode -> TreeNode convertDbTreeToTreeNode :: HasCallStack => T.DbTreeNode -> TreeNode
...@@ -130,7 +130,7 @@ convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_par ...@@ -130,7 +130,7 @@ convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_par
} }
dbRecursiveParents :: (CmdCommon env) => Int -> GqlM e env BreadcrumbInfo dbRecursiveParents :: (IsDBEnvExtra env) => Int -> GqlM e env BreadcrumbInfo
dbRecursiveParents nodeId = do dbRecursiveParents nodeId = do
let nId = UnsafeMkNodeId nodeId let nId = UnsafeMkNodeId nodeId
dbParents <- lift $ T.recursiveParents nId allNodeTypes dbParents <- lift $ T.recursiveParents nId allNodeTypes
......
...@@ -22,7 +22,7 @@ import Gargantext.API.GraphQL.Types (GqlM, GqlM') ...@@ -22,7 +22,7 @@ import Gargantext.API.GraphQL.Types (GqlM, GqlM')
import Gargantext.Core.Types (NodeId(..), UserId) import Gargantext.Core.Types (NodeId(..), UserId)
import Gargantext.Core.Types.Individu qualified as Individu import Gargantext.Core.Types.Individu qualified as Individu
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..)) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..))
import Gargantext.Database.Prelude (CmdCommon) import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Query.Table.User qualified as DBUser import Gargantext.Database.Query.Table.User qualified as DBUser
import Gargantext.Database.Schema.User (UserLight(..)) import Gargantext.Database.Schema.User (UserLight(..))
import Gargantext.Prelude import Gargantext.Prelude
...@@ -60,7 +60,7 @@ data UserEPOAPITokenMArgs ...@@ -60,7 +60,7 @@ data UserEPOAPITokenMArgs
-- | Function to resolve user from a query. -- | Function to resolve user from a query.
resolveUsers resolveUsers
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> AuthenticatedUser => AuthenticatedUser
-> AccessPolicyManager -> AccessPolicyManager
-> UserArgs -> UserArgs
...@@ -70,12 +70,12 @@ resolveUsers autUser mgr UserArgs { user_id } = do ...@@ -70,12 +70,12 @@ resolveUsers autUser mgr UserArgs { user_id } = do
withPolicy autUser mgr (nodeReadChecks $ UnsafeMkNodeId user_id) $ dbUsers user_id withPolicy autUser mgr (nodeReadChecks $ UnsafeMkNodeId user_id) $ dbUsers user_id
-- | Inner function to fetch the user from DB. -- | Inner function to fetch the user from DB.
dbUsers :: (CmdCommon env) dbUsers :: (IsDBEnvExtra env)
=> Int -> GqlM e env [User (GqlM e env)] => Int -> GqlM e env [User (GqlM e env)]
dbUsers user_id = lift (map toUser <$> DBUser.getUsersWithId (Individu.RootId $ UnsafeMkNodeId user_id)) dbUsers user_id = lift (map toUser <$> DBUser.getUsersWithId (Individu.RootId $ UnsafeMkNodeId user_id))
toUser toUser
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> UserLight -> User (GqlM e env) => UserLight -> User (GqlM e env)
toUser (UserLight { .. }) = User { u_email = userLight_email toUser (UserLight { .. }) = User { u_email = userLight_email
, u_hyperdata = resolveHyperdata userLight_id , u_hyperdata = resolveHyperdata userLight_id
...@@ -83,25 +83,25 @@ toUser (UserLight { .. }) = User { u_email = userLight_email ...@@ -83,25 +83,25 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
, u_username = userLight_username } , u_username = userLight_username }
resolveHyperdata resolveHyperdata
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> UserId -> GqlM e env (Maybe HyperdataUser) => UserId -> GqlM e env (Maybe HyperdataUser)
resolveHyperdata userid = lift (listToMaybe <$> DBUser.getUserHyperdata (Individu.UserDBId userid)) resolveHyperdata userid = lift (listToMaybe <$> DBUser.getUserHyperdata (Individu.UserDBId userid))
updateUserPubmedAPIKey :: ( CmdCommon env ) => updateUserPubmedAPIKey :: ( IsDBEnvExtra env ) =>
UserPubmedAPIKeyMArgs -> GqlM' e env Int UserPubmedAPIKeyMArgs -> GqlM' e env Int
updateUserPubmedAPIKey UserPubmedAPIKeyMArgs { user_id, api_key } = do updateUserPubmedAPIKey UserPubmedAPIKeyMArgs { user_id, api_key } = do
_ <- lift $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ UnsafeMkNodeId user_id) api_key _ <- lift $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ UnsafeMkNodeId user_id) api_key
pure 1 pure 1
updateUserEPOAPIUser :: ( CmdCommon env ) => updateUserEPOAPIUser :: ( IsDBEnvExtra env ) =>
UserEPOAPIUserMArgs -> GqlM' e env Int UserEPOAPIUserMArgs -> GqlM' e env Int
updateUserEPOAPIUser UserEPOAPIUserMArgs { user_id, api_user } = do updateUserEPOAPIUser UserEPOAPIUserMArgs { user_id, api_user } = do
_ <- lift $ DBUser.updateUserEPOAPIUser (Individu.RootId $ UnsafeMkNodeId user_id) api_user _ <- lift $ DBUser.updateUserEPOAPIUser (Individu.RootId $ UnsafeMkNodeId user_id) api_user
pure 1 pure 1
updateUserEPOAPIToken :: ( CmdCommon env ) => updateUserEPOAPIToken :: ( IsDBEnvExtra env ) =>
UserEPOAPITokenMArgs -> GqlM' e env Int UserEPOAPITokenMArgs -> GqlM' e env Int
updateUserEPOAPIToken UserEPOAPITokenMArgs { user_id, api_token } = do updateUserEPOAPIToken UserEPOAPITokenMArgs { user_id, api_token } = do
_ <- lift $ DBUser.updateUserEPOAPIToken (Individu.RootId $ UnsafeMkNodeId user_id) api_token _ <- lift $ DBUser.updateUserEPOAPIToken (Individu.RootId $ UnsafeMkNodeId user_id) api_token
......
...@@ -49,7 +49,7 @@ import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser) ...@@ -49,7 +49,7 @@ import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser)
import Gargantext.Core.Config (HasJWTSettings) import Gargantext.Core.Config (HasJWTSettings)
import Gargantext.Core.Types (UserId(..)) import Gargantext.Core.Types (UserId(..))
import Gargantext.Core.Types.Individu qualified as Individu import Gargantext.Core.Types.Individu qualified as Individu
import Gargantext.Database.Prelude (CmdCommon) import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Query.Table.User (getUsersWithHyperdata, getUsersWithNodeHyperdata, updateUserEmail) import Gargantext.Database.Query.Table.User (getUsersWithHyperdata, getUsersWithNodeHyperdata, updateUserEmail)
import Gargantext.Database.Schema.Node (node_id, node_hyperdata, NodePoly (Node, _node_id)) import Gargantext.Database.Schema.Node (node_id, node_hyperdata, NodePoly (Node, _node_id))
...@@ -108,7 +108,7 @@ data UserInfoMArgs ...@@ -108,7 +108,7 @@ data UserInfoMArgs
-- | Function to resolve user from a query. -- | Function to resolve user from a query.
resolveUserInfos resolveUserInfos
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> AuthenticatedUser => AuthenticatedUser
-> AccessPolicyManager -> AccessPolicyManager
-> UserInfoArgs -> GqlM e env [UserInfo] -> UserInfoArgs -> GqlM e env [UserInfo]
...@@ -118,7 +118,7 @@ resolveUserInfos autUser mgr UserInfoArgs { user_id } = ...@@ -118,7 +118,7 @@ resolveUserInfos autUser mgr UserInfoArgs { user_id } =
-- | Mutation for user info -- | Mutation for user info
updateUserInfo updateUserInfo
:: (CmdCommon env, HasJWTSettings env) :: (IsDBEnvExtra env, HasJWTSettings env)
-- => UserInfoMArgs -> ResolverM e (GargM env err) Int -- => UserInfoMArgs -> ResolverM e (GargM env err) Int
=> UserInfoMArgs -> GqlM' e env Int => UserInfoMArgs -> GqlM' e env Int
updateUserInfo (UserInfoMArgs { ui_id, .. }) = do updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
...@@ -167,7 +167,7 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do ...@@ -167,7 +167,7 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
-- | Inner function to fetch the user from DB. -- | Inner function to fetch the user from DB.
dbUsers dbUsers
:: (CmdCommon env) :: (IsDBEnvExtra env)
=> UserId -> GqlM e env [UserInfo] => UserId -> GqlM e env [UserInfo]
dbUsers user_id = do dbUsers user_id = do
-- lift $ printDebug "[dbUsers]" user_id -- lift $ printDebug "[dbUsers]" user_id
......
...@@ -16,13 +16,13 @@ import Control.Lens (view) ...@@ -16,13 +16,13 @@ import Control.Lens (view)
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser (..), auth_node_id) import Gargantext.API.Admin.Auth.Types (AuthenticatedUser (..), auth_node_id)
import Gargantext.Core.Config (HasJWTSettings(..)) import Gargantext.Core.Config (HasJWTSettings(..))
import Gargantext.Database.Admin.Types.Node (NodeId) import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Prelude (Cmd') import Gargantext.Database.Prelude (Cmd)
import Gargantext.Prelude import Gargantext.Prelude
import Servant.Auth.Server (verifyJWT, JWTSettings) import Servant.Auth.Server (verifyJWT, JWTSettings)
data AuthStatus = Valid | Invalid data AuthStatus = Valid | Invalid
authUser :: (HasJWTSettings env) => NodeId -> Text -> Cmd' env err AuthStatus authUser :: (HasJWTSettings env) => NodeId -> Text -> Cmd env err AuthStatus
authUser ui_id token = do authUser ui_id token = do
let token' = encodeUtf8 token let token' = encodeUtf8 token
jwtS <- view jwtSettings jwtS <- view jwtSettings
......
...@@ -47,7 +47,7 @@ import Gargantext.Core.Utils.Aeson (jsonOptions) ...@@ -47,7 +47,7 @@ import Gargantext.Core.Utils.Aeson (jsonOptions)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger)
import Gargantext.Core.Utils.Swagger (wellNamedSchema) import Gargantext.Core.Utils.Swagger (wellNamedSchema)
import Gargantext.Database.Admin.Types.Node (ContextId) import Gargantext.Database.Admin.Types.Node (ContextId)
import Gargantext.Database.Prelude (fromField', HasConnectionPool, CmdM') import Gargantext.Database.Prelude (fromField', HasConnectionPool, IsCmd)
import Gargantext.Prelude hiding (IsString, hash, from, replace, to) import Gargantext.Prelude hiding (IsString, hash, from, replace, to)
import Gargantext.Prelude.Crypto.Hash (IsHashable(..)) import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
import Gargantext.Utils.Servant (TSV, ZIP) import Gargantext.Utils.Servant (TSV, ZIP)
...@@ -730,7 +730,7 @@ initRepo = Repo 1 mempty [] ...@@ -730,7 +730,7 @@ initRepo = Repo 1 mempty []
-------------------- --------------------
type RepoCmdM env err m = type RepoCmdM env err m =
( CmdM' env err m ( IsCmd env err m
, HasConnectionPool env , HasConnectionPool env
, HasConfig env , HasConfig env
) )
......
...@@ -59,7 +59,7 @@ import Gargantext.Database.Action.Flow.Pairing (pairing) ...@@ -59,7 +59,7 @@ import Gargantext.Database.Action.Flow.Pairing (pairing)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny, HyperdataCorpus, HyperdataAnnuaire) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny, HyperdataCorpus, HyperdataAnnuaire)
import Gargantext.Database.Admin.Types.Hyperdata.Prelude ( HyperdataC ) import Gargantext.Database.Admin.Types.Hyperdata.Prelude ( HyperdataC )
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, JSONB) import Gargantext.Database.Prelude (DBCmdExtra, JSONB)
import Gargantext.Database.Query.Table.Node import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Children (getChildren) import Gargantext.Database.Query.Table.Node.Children (getChildren)
import Gargantext.Database.Query.Table.Node.Update (Update(..), update) import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
...@@ -143,7 +143,7 @@ type ScoreApi = Summary " To Score NodeNodes" ...@@ -143,7 +143,7 @@ type ScoreApi = Summary " To Score NodeNodes"
scoreApi :: CorpusId -> GargServer ScoreApi scoreApi :: CorpusId -> GargServer ScoreApi
scoreApi = putScore scoreApi = putScore
where where
putScore :: CorpusId -> NodesToScore -> Cmd err [Int] putScore :: CorpusId -> NodesToScore -> DBCmdExtra err [Int]
putScore cId cs' = nodeContextsScore $ map (\n -> (cId, n, nts_score cs')) (nts_nodesId cs') putScore cId cs' = nodeContextsScore $ map (\n -> (cId, n, nts_score cs')) (nts_nodesId cs')
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -182,20 +182,20 @@ treeFlatAPI authenticatedUser rootId = ...@@ -182,20 +182,20 @@ treeFlatAPI authenticatedUser rootId =
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | TODO Check if the name is less than 255 char -- | TODO Check if the name is less than 255 char
rename :: HasNodeError err => UserId -> NodeId -> RenameNode -> Cmd err [Int] rename :: HasNodeError err => UserId -> NodeId -> RenameNode -> DBCmdExtra err [Int]
rename loggedInUserId nId (RenameNode name') = U.update loggedInUserId (U.Rename nId name') rename loggedInUserId nId (RenameNode name') = U.update loggedInUserId (U.Rename nId name')
putNode :: forall err a. (HyperdataC a) putNode :: forall err a. (HyperdataC a)
=> NodeId => NodeId
-> a -> a
-> Cmd err Int -> DBCmdExtra err Int
putNode n h = fromIntegral <$> updateHyperdata n h putNode n h = fromIntegral <$> updateHyperdata n h
moveNode :: HasNodeError err moveNode :: HasNodeError err
=> UserId => UserId
-> NodeId -> NodeId
-> ParentId -> ParentId
-> Cmd err [Int] -> DBCmdExtra err [Int]
moveNode loggedInUserId n p = update loggedInUserId (Move n p) moveNode loggedInUserId n p = update loggedInUserId (Move n p)
------------------------------------------------------------- -------------------------------------------------------------
......
...@@ -34,7 +34,7 @@ import Gargantext.Database.Admin.Types.Node ...@@ -34,7 +34,7 @@ import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Action.Metrics.NgramsByContext (getNgramsByContextOnlyUser) import Gargantext.Database.Action.Metrics.NgramsByContext (getNgramsByContextOnlyUser)
import Gargantext.Database.Admin.Config (userMaster) import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..) ) import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..) )
import Gargantext.Database.Prelude (Cmd) import Gargantext.Database.Prelude (DBCmdExtra)
import Gargantext.Database.Query.Table.Node ( defaultList ) import Gargantext.Database.Query.Table.Node ( defaultList )
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername) import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
...@@ -95,7 +95,7 @@ getContextNgrams :: HasNodeError err ...@@ -95,7 +95,7 @@ getContextNgrams :: HasNodeError err
-> ListType -> ListType
-> NgramsType -> NgramsType
-> NodeListStory -> NodeListStory
-> Cmd err (Map ContextId (Set NgramsTerm)) -> DBCmdExtra err (Map ContextId (Set NgramsTerm))
getContextNgrams cId lId listType nt repo = do getContextNgrams cId lId listType nt repo = do
-- lId <- case lId' of -- lId <- case lId' of
-- Nothing -> defaultList cId -- Nothing -> defaultList cId
......
...@@ -10,13 +10,13 @@ import Gargantext.Core.Text.Corpus (makeSubcorpusFromQuery) ...@@ -10,13 +10,13 @@ import Gargantext.Core.Text.Corpus (makeSubcorpusFromQuery)
import Gargantext.Core.Text.Corpus.Query (RawQuery(..), parseQuery) import Gargantext.Core.Text.Corpus.Query (RawQuery(..), parseQuery)
import Gargantext.Core.Types (UserId) import Gargantext.Core.Types (UserId)
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Prelude (DbCmd') import Gargantext.Database.Prelude (IsDBCmd)
import Servant.Server.Generic (AsServerT) import Servant.Server.Generic (AsServerT)
makeSubcorpus :: ( HasNodeStoryEnv env makeSubcorpus :: ( HasNodeStoryEnv env
, HasNLPServer env , HasNLPServer env
, DbCmd' env BackendInternalError m , IsDBCmd env BackendInternalError m
) )
=> UserId => UserId
-> MakeSubcorpusAPI (AsServerT m) -> MakeSubcorpusAPI (AsServerT m)
......
...@@ -19,7 +19,7 @@ import Control.Lens (over) ...@@ -19,7 +19,7 @@ import Control.Lens (over)
import Gargantext.Core (Lang) import Gargantext.Core (Lang)
import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus, _hc_lang) import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus, _hc_lang)
import Gargantext.Database.Admin.Types.Node (CorpusId) import Gargantext.Database.Admin.Types.Node (CorpusId)
import Gargantext.Database.Prelude (DbCmd') import Gargantext.Database.Prelude (IsDBCmd)
import Gargantext.Database.Query.Table.Node (getNodeWith) import Gargantext.Database.Query.Table.Node (getNodeWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
...@@ -29,7 +29,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus) ...@@ -29,7 +29,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus)
-- | Updates the 'HyperdataCorpus' with the input 'Lang'. -- | Updates the 'HyperdataCorpus' with the input 'Lang'.
addLanguageToCorpus :: (HasNodeError err, DbCmd' env err m, MonadJobStatus m) addLanguageToCorpus :: (HasNodeError err, IsDBCmd env err m, MonadJobStatus m)
=> CorpusId => CorpusId
-> Lang -> Lang
-> m () -> m ()
......
...@@ -31,7 +31,7 @@ import Gargantext.Core.NLP (HasNLPServer) ...@@ -31,7 +31,7 @@ import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Worker.Jobs.Types qualified as Jobs import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
import Gargantext.Database.Action.Node (mkNodeWithParent) import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (CmdM, DBCmd') import Gargantext.Database.Prelude (IsDBCmdExtra, DBCmdWithEnv)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..)) import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Prelude import Gargantext.Prelude
import Servant.Server.Generic (AsServerT) import Servant.Server.Generic (AsServerT)
...@@ -47,7 +47,7 @@ postNode :: ( HasMail env ...@@ -47,7 +47,7 @@ postNode :: ( HasMail env
-> NodeId -> NodeId
-> PostNode -> PostNode
-- -> m [NodeId] -- -> m [NodeId]
-> DBCmd' env err [NodeId] -> DBCmdWithEnv env err [NodeId]
postNode authenticatedUser nId pn = do postNode authenticatedUser nId pn = do
postNode' authenticatedUser nId pn postNode' authenticatedUser nId pn
...@@ -73,7 +73,7 @@ postNodeAsyncAPI authenticatedUser nId = ...@@ -73,7 +73,7 @@ postNodeAsyncAPI authenticatedUser nId =
-- -> PostNode -- -> PostNode
-- -> m [NodeId] -- -> m [NodeId]
-- postNode' authenticatedUser pId (PostNode nodeName nt) = do -- postNode' authenticatedUser pId (PostNode nodeName nt) = do
postNode' :: ( CmdM env err m postNode' :: ( IsDBCmdExtra env err m
, HasNodeError err , HasNodeError err
, HasMail env , HasMail env
, CE.HasCentralExchangeNotification env) , CE.HasCentralExchangeNotification env)
......
...@@ -15,20 +15,19 @@ Portability : POSIX ...@@ -15,20 +15,19 @@ Portability : POSIX
module Gargantext.API.Node.Share module Gargantext.API.Node.Share
where where
import Control.Monad.Random (MonadRandom)
import Data.List qualified as List import Data.List qualified as List
import Data.Text qualified as Text import Data.Text qualified as Text
import Gargantext.API.Node.Share.Types (ShareNodeParams(..)) import Gargantext.API.Node.Share.Types (ShareNodeParams(..))
import Gargantext.API.Prelude (IsGargServer) import Gargantext.API.Prelude (IsGargServer)
import Gargantext.API.Routes.Named.Share qualified as Named import Gargantext.API.Routes.Named.Share qualified as Named
import Gargantext.Core.Notifications.CentralExchange.Types (HasCentralExchangeNotification)
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Types.Individu (User(..), arbitraryUsername) import Gargantext.Core.Types.Individu (User(..), arbitraryUsername)
import Gargantext.Database.Action.Share (ShareNodeWith(..)) import Gargantext.Database.Action.Share (ShareNodeWith(..))
import Gargantext.Database.Action.Share as DB (shareNodeWith, unshare) import Gargantext.Database.Action.Share as DB (shareNodeWith, unshare)
import Gargantext.Database.Action.User (getUserId', getUsername) import Gargantext.Database.Action.User (getUserId', getUsername)
import Gargantext.Database.Action.User.New (guessUserName, newUser) import Gargantext.Database.Action.User.New (guessUserName, newUser)
import Gargantext.Database.Admin.Types.Node (NodeId, NodeType(..), UserId(..)) import Gargantext.Database.Admin.Types.Node (NodeId, NodeType(..), UserId(..))
import Gargantext.Database.Prelude (CmdRandom) import Gargantext.Database.Prelude (IsDBCmdExtra)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..)) import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Tree (findNodesWithType) import Gargantext.Database.Query.Tree (findNodesWithType)
import Gargantext.Prelude import Gargantext.Prelude
...@@ -39,9 +38,9 @@ import Servant.Server.Generic (AsServerT) ...@@ -39,9 +38,9 @@ import Servant.Server.Generic (AsServerT)
-- TODO refactor userId which is used twice -- TODO refactor userId which is used twice
-- TODO change return type for better warning/info/success/error handling on the front -- TODO change return type for better warning/info/success/error handling on the front
api :: ( HasNodeError err api :: ( HasNodeError err
, HasNLPServer env , IsDBCmdExtra env err m
, CmdRandom env err m , MonadRandom m
, HasCentralExchangeNotification env ) )
=> User => User
-> NodeId -> NodeId
-> ShareNodeParams -> ShareNodeParams
......
...@@ -12,7 +12,7 @@ import Gargantext.API.Routes.Named.Share qualified as Named ...@@ -12,7 +12,7 @@ import Gargantext.API.Routes.Named.Share qualified as Named
import Gargantext.Core.Config (GargConfig, gc_frontend_config, HasConfig(hasConfig)) import Gargantext.Core.Config (GargConfig, gc_frontend_config, HasConfig(hasConfig))
import Gargantext.Core.Config.Types (fc_appPort, fc_url) import Gargantext.Core.Config.Types (fc_appPort, fc_url)
import Gargantext.Core.Types (NodeType, NodeId, unNodeId, _ValidationError) import Gargantext.Core.Types (NodeType, NodeId, unNodeId, _ValidationError)
import Gargantext.Database.Prelude (CmdCommon) import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Prelude import Gargantext.Prelude
import Network.URI (parseURI) import Network.URI (parseURI)
import Prelude (String) import Prelude (String)
...@@ -21,7 +21,7 @@ import Servant.Server.Generic (AsServerT) ...@@ -21,7 +21,7 @@ import Servant.Server.Generic (AsServerT)
shareURL :: IsGargServer env err m => Named.ShareURL (AsServerT m) shareURL :: IsGargServer env err m => Named.ShareURL (AsServerT m)
shareURL = Named.ShareURL getUrl shareURL = Named.ShareURL getUrl
getUrl :: (IsGargServer env err m, CmdCommon env) getUrl :: (IsGargServer env err m, IsDBEnvExtra env)
=> Maybe NodeType => Maybe NodeType
-> Maybe NodeId -> Maybe NodeId
-> m Named.ShareLink -> m Named.ShareLink
......
...@@ -18,6 +18,7 @@ module Gargantext.API.Prelude ...@@ -18,6 +18,7 @@ module Gargantext.API.Prelude
, serverError ) where , serverError ) where
import Control.Lens ((#)) import Control.Lens ((#))
import Control.Monad.Random (MonadRandom)
import Gargantext.API.Admin.Auth.Types (AuthenticationError) import Gargantext.API.Admin.Auth.Types (AuthenticationError)
import Gargantext.API.Errors.Class (HasAuthenticationError, _AuthenticationError) import Gargantext.API.Errors.Class (HasAuthenticationError, _AuthenticationError)
import Gargantext.API.Errors.Types (HasServerError(..), serverError) import Gargantext.API.Errors.Types (HasServerError(..), serverError)
...@@ -27,7 +28,7 @@ import Gargantext.Core.Mail.Types (HasMail) ...@@ -27,7 +28,7 @@ import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer) import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.NodeStory (HasNodeStory, HasNodeStoryEnv) import Gargantext.Core.NodeStory (HasNodeStory, HasNodeStoryEnv)
import Gargantext.Core.Types (HasValidationError) import Gargantext.Core.Types (HasValidationError)
import Gargantext.Database.Prelude (CmdM, CmdRandom, HasConnectionPool) import Gargantext.Database.Prelude (IsDBCmdExtra, HasConnectionPool)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..)) import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Tree (HasTreeError) import Gargantext.Database.Query.Tree (HasTreeError)
import Gargantext.Prelude import Gargantext.Prelude
...@@ -58,8 +59,9 @@ type ErrC err = ...@@ -58,8 +59,9 @@ type ErrC err =
) )
type GargServerC env err m = type GargServerC env err m =
( CmdRandom env err m ( HasNodeStory env err m
, HasNodeStory env err m , HasMail env
, MonadRandom m
, EnvC env , EnvC env
, ErrC err , ErrC err
, ToJSON err , ToJSON err
...@@ -84,7 +86,7 @@ type GargNoServer t = ...@@ -84,7 +86,7 @@ type GargNoServer t =
forall env err m. GargNoServer' env err m => m t forall env err m. GargNoServer' env err m => m t
type GargNoServer' env err m = type GargNoServer' env err m =
( CmdM env err m ( IsDBCmdExtra env err m
, HasNodeStory env err m , HasNodeStory env err m
, HasNodeError err , HasNodeError err
) )
......
...@@ -17,7 +17,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( hc_fields ) ...@@ -17,7 +17,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( hc_fields )
import Gargantext.Database.Admin.Types.Hyperdata.CorpusField import Gargantext.Database.Admin.Types.Hyperdata.CorpusField
import Gargantext.Database.Admin.Types.Hyperdata.Folder ( HyperdataFolder ) import Gargantext.Database.Admin.Types.Hyperdata.Folder ( HyperdataFolder )
import Gargantext.Database.Admin.Types.Node ( NodeId(..), Node, unNodeId ) import Gargantext.Database.Admin.Types.Node ( NodeId(..), Node, unNodeId )
import Gargantext.Database.Prelude (Cmd, DBCmd) import Gargantext.Database.Prelude (DBCmd, DBCmdExtra)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..)) import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Table.NodeNode (selectPublicNodes) import Gargantext.Database.Query.Table.NodeNode (selectPublicNodes)
import Gargantext.Database.Schema.Node ( NodePoly(..), node_date, node_hyperdata ) -- (NodePoly(..)) import Gargantext.Database.Schema.Node ( NodePoly(..), node_date, node_hyperdata ) -- (NodePoly(..))
...@@ -68,7 +68,7 @@ filterPublicDatas datas = ...@@ -68,7 +68,7 @@ filterPublicDatas datas =
& Map.elems & Map.elems
publicNodes :: HasNodeError err publicNodes :: HasNodeError err
=> Cmd err (Set NodeId) => DBCmdExtra err (Set NodeId)
publicNodes = do publicNodes = do
candidates <- filterPublicDatas <$> selectPublicNodes candidates <- filterPublicDatas <$> selectPublicNodes
pure $ Set.fromList pure $ Set.fromList
......
...@@ -41,7 +41,7 @@ import Gargantext.Core.Types.Query (Offset, Limit) ...@@ -41,7 +41,7 @@ import Gargantext.Core.Types.Query (Offset, Limit)
import Gargantext.Database.Action.Learn (FavOrTrash(..), moreLike) import Gargantext.Database.Action.Learn (FavOrTrash(..), moreLike)
import Gargantext.Database.Action.Search (searchCountInCorpus, searchInCorpus) import Gargantext.Database.Action.Search (searchCountInCorpus, searchInCorpus)
import Gargantext.Database.Admin.Types.Node (ContactId, CorpusId, NodeId) import Gargantext.Database.Admin.Types.Node (ContactId, CorpusId, NodeId)
import Gargantext.Database.Prelude (CmdM, DbCmd', DBCmd) import Gargantext.Database.Prelude (IsDBCmdExtra, IsDBCmd, DBCmd)
import Gargantext.Database.Query.Facet (FacetDoc , runViewDocuments, runCountDocuments, OrderBy(..), runViewAuthorsDoc) import Gargantext.Database.Query.Facet (FacetDoc , runViewDocuments, runCountDocuments, OrderBy(..), runViewAuthorsDoc)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Prelude import Gargantext.Prelude
...@@ -56,7 +56,7 @@ tableApi id' = Named.TableAPI ...@@ -56,7 +56,7 @@ tableApi id' = Named.TableAPI
} }
getTableApi :: (CmdM env err m, HasNodeError err, MonadLogger m) getTableApi :: (IsDBCmdExtra env err m, HasNodeError err, MonadLogger m)
=> NodeId => NodeId
-> Maybe TabType -> Maybe TabType
-> Maybe Limit -> Maybe Limit
...@@ -84,7 +84,7 @@ getTableApi cId tabType mLimit mOffset mOrderBy mQuery mYear = ...@@ -84,7 +84,7 @@ getTableApi cId tabType mLimit mOffset mOrderBy mQuery mYear =
t <- getTable cId tabType mOffset mLimit mOrderBy mQuery mYear t <- getTable cId tabType mOffset mLimit mOrderBy mQuery mYear
pure $ constructHashedResponse t pure $ constructHashedResponse t
postTableApi :: (CmdM env err m, MonadLogger m, HasNodeError err) postTableApi :: (IsDBCmdExtra env err m, MonadLogger m, HasNodeError err)
=> NodeId => NodeId
-> TableQuery -> TableQuery
-> m FacetTableResult -> m FacetTableResult
...@@ -99,7 +99,7 @@ postTableApi cId tq = case tq of ...@@ -99,7 +99,7 @@ postTableApi cId tq = case tq of
Trash -> searchInCorpus' cId True q (Just o) (Just l) (Just order) Trash -> searchInCorpus' cId True q (Just o) (Just l) (Just order)
x -> panicTrace $ "not implemented in tableApi " <> (show x) x -> panicTrace $ "not implemented in tableApi " <> (show x)
getTableHashApi :: (CmdM env err m, HasNodeError err, MonadLogger m) getTableHashApi :: (IsDBCmdExtra env err m, HasNodeError err, MonadLogger m)
=> NodeId => NodeId
-> Maybe TabType -> Maybe TabType
-> m Text -> m Text
...@@ -107,7 +107,7 @@ getTableHashApi cId tabType = do ...@@ -107,7 +107,7 @@ getTableHashApi cId tabType = do
HashedResponse { hash = h } <- getTableApi cId tabType Nothing Nothing Nothing Nothing Nothing HashedResponse { hash = h } <- getTableApi cId tabType Nothing Nothing Nothing Nothing Nothing
pure h pure h
searchInCorpus' :: (DbCmd' env err m, MonadLogger m) searchInCorpus' :: (IsDBCmd env err m, MonadLogger m)
=> CorpusId => CorpusId
-> Bool -> Bool
-> RawQuery -> RawQuery
......
...@@ -58,7 +58,7 @@ import Gargantext.Database.Admin.Types.Node ( NodeId(..) ) ...@@ -58,7 +58,7 @@ import Gargantext.Database.Admin.Types.Node ( NodeId(..) )
import Gargantext.Core.Text.Ngrams qualified as Ngrams import Gargantext.Core.Text.Ngrams qualified as Ngrams
import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Admin.Config () import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Prelude (DbCmd') import Gargantext.Database.Prelude (IsDBCmd)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError()) import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Prelude hiding (to) import Gargantext.Prelude hiding (to)
import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField) import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
...@@ -197,7 +197,7 @@ data NodeStoryEnv = NodeStoryEnv ...@@ -197,7 +197,7 @@ data NodeStoryEnv = NodeStoryEnv
} }
deriving (Generic) deriving (Generic)
type HasNodeStory env err m = ( DbCmd' env err m type HasNodeStory env err m = ( IsDBCmd env err m
, MonadReader env m , MonadReader env m
, MonadError err m , MonadError err m
, HasNodeStoryEnv env , HasNodeStoryEnv env
......
...@@ -19,7 +19,7 @@ import Gargantext.Database.Action.Search (searchInCorpus) ...@@ -19,7 +19,7 @@ import Gargantext.Database.Action.Search (searchInCorpus)
import Gargantext.Database.Action.User (getUserId) import Gargantext.Database.Action.User (getUserId)
import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus, hc_lang) import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus, hc_lang)
import Gargantext.Database.Admin.Types.Node (CorpusId, NodeId(UnsafeMkNodeId), NodeType(..), nodeId2ContextId) import Gargantext.Database.Admin.Types.Node (CorpusId, NodeId(UnsafeMkNodeId), NodeType(..), nodeId2ContextId)
import Gargantext.Database.Prelude (DBCmd') import Gargantext.Database.Prelude (DBCmdWithEnv)
import Gargantext.Database.Query.Facet.Types (facetDoc_id) import Gargantext.Database.Query.Facet.Types (facetDoc_id)
import Gargantext.Database.Query.Table.Node (insertDefaultNode, copyNodeStories, defaultList, getNodeWithType) import Gargantext.Database.Query.Table.Node (insertDefaultNode, copyNodeStories, defaultList, getNodeWithType)
import Gargantext.Database.Query.Table.Node.Document.Add qualified as Document (add) import Gargantext.Database.Query.Table.Node.Document.Add qualified as Document (add)
...@@ -55,7 +55,7 @@ makeSubcorpusFromQuery :: ( HasNodeStoryEnv env ...@@ -55,7 +55,7 @@ makeSubcorpusFromQuery :: ( HasNodeStoryEnv env
-> CorpusId -- ^ ID of the parent corpus -> CorpusId -- ^ ID of the parent corpus
-> Q.Query -- ^ The query to determine the subset of documents that will appear in the subcorpus -> Q.Query -- ^ The query to determine the subset of documents that will appear in the subcorpus
-> Bool -- ^ Whether to reuse parent term list (True) or compute a new one based only on the documents in the subcorpus (False) -> Bool -- ^ Whether to reuse parent term list (True) or compute a new one based only on the documents in the subcorpus (False)
-> DBCmd' env BackendInternalError CorpusId -- ^ The child corpus ID -> DBCmdWithEnv env BackendInternalError CorpusId -- ^ The child corpus ID
makeSubcorpusFromQuery user supercorpusId query reuseParentList = do makeSubcorpusFromQuery user supercorpusId query reuseParentList = do
userId <- getUserId user userId <- getUserId user
-- Insert the required nodes: -- Insert the required nodes:
......
...@@ -37,7 +37,7 @@ import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOn ...@@ -37,7 +37,7 @@ import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOn
import Gargantext.Database.Action.Node (mkNodeWithParent) import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Config ( userMaster ) import Gargantext.Database.Admin.Config ( userMaster )
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (DBCmd, DBCmd') import Gargantext.Database.Prelude (DBCmd, DBCmdWithEnv)
import Gargantext.Database.Query.Table.Node ( getOrMkList, getNodeWith, defaultList, getClosestParentIdByType ) import Gargantext.Database.Query.Table.Node ( getOrMkList, getNodeWith, defaultList, getClosestParentIdByType )
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername ) import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername )
...@@ -281,7 +281,7 @@ graphClone :: (HasNodeError err) ...@@ -281,7 +281,7 @@ graphClone :: (HasNodeError err)
=> UserId => UserId
-> NodeId -> NodeId
-> HyperdataGraphAPI -> HyperdataGraphAPI
-> DBCmd' env err NodeId -> DBCmdWithEnv env err NodeId
graphClone userId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph graphClone userId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
, _hyperdataAPICamera = camera }) = do , _hyperdataAPICamera = camera }) = do
let nodeType = NodeGraph let nodeType = NodeGraph
......
...@@ -20,14 +20,14 @@ import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..)) ...@@ -20,14 +20,14 @@ import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
import Gargantext.Core.Worker.Broker (initBrokerWithDBCreate) import Gargantext.Core.Worker.Broker (initBrokerWithDBCreate)
import Gargantext.Core.Worker.Jobs.Types (Job(..)) import Gargantext.Core.Worker.Jobs.Types (Job(..))
import Gargantext.Core.Worker.PGMQTypes (HasWorkerBroker, MessageId, SendJob) import Gargantext.Core.Worker.PGMQTypes (HasWorkerBroker, MessageId, SendJob)
import Gargantext.Database.Prelude (Cmd') import Gargantext.Database.Prelude (Cmd)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.System.Logging (logMsg, withLogger, LogLevel(..)) import Gargantext.System.Logging (logMsg, withLogger, LogLevel(..))
sendJob :: (HasWorkerBroker, HasConfig env) sendJob :: (HasWorkerBroker, HasConfig env)
=> Job => Job
-> Cmd' env err MessageId -> Cmd env err MessageId
sendJob job = do sendJob job = do
gcConfig <- view $ hasConfig gcConfig <- view $ hasConfig
liftBase $ sendJobWithCfg gcConfig job liftBase $ sendJobWithCfg gcConfig job
......
...@@ -27,7 +27,7 @@ import Gargantext.Database.Action.User (getUserId) ...@@ -27,7 +27,7 @@ import Gargantext.Database.Action.User (getUserId)
import Gargantext.Database.Admin.Types.Hyperdata.File ( HyperdataFile(..) ) import Gargantext.Database.Admin.Types.Hyperdata.File ( HyperdataFile(..) )
import Gargantext.Database.Admin.Types.Node ( NodeId, NodeType(..) ) -- (NodeType(..)) import Gargantext.Database.Admin.Types.Node ( NodeId, NodeType(..) ) -- (NodeType(..))
import Gargantext.Database.GargDB qualified as GargDB import Gargantext.Database.GargDB qualified as GargDB
import Gargantext.Database.Prelude (Cmd', CmdCommon) import Gargantext.Database.Prelude (Cmd, IsDBEnvExtra)
import Gargantext.Database.Query.Table.Node (getNodeWith) import Gargantext.Database.Query.Table.Node (getNodeWith)
import Gargantext.Database.Query.Table.Node qualified as N (getNode, deleteNode) import Gargantext.Database.Query.Table.Node qualified as N (getNode, deleteNode)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
...@@ -38,10 +38,10 @@ import Gargantext.Prelude ...@@ -38,10 +38,10 @@ import Gargantext.Prelude
-- TODO -- TODO
-- Delete Corpus children accoring its types -- Delete Corpus children accoring its types
-- Delete NodeList (NodeStory + cbor file) -- Delete NodeList (NodeStory + cbor file)
deleteNode :: (CmdCommon env, HasNodeError err) deleteNode :: (IsDBEnvExtra env, HasNodeError err)
=> User => User
-> NodeId -> NodeId
-> Cmd' env err Int -> Cmd env err Int
deleteNode u nodeId = do deleteNode u nodeId = do
node' <- N.getNode nodeId node' <- N.getNode nodeId
num <- case (view node_typename node') of num <- case (view node_typename node') of
......
...@@ -94,7 +94,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact ) ...@@ -94,7 +94,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact )
import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataAnnuaire, HyperdataCorpus(_hc_lang) ) import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataAnnuaire, HyperdataCorpus(_hc_lang) )
import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(toHyperdataDocument) ) import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(toHyperdataDocument) )
import Gargantext.Database.Admin.Types.Node hiding (DEBUG) -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId) import Gargantext.Database.Admin.Types.Node hiding (DEBUG) -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
import Gargantext.Database.Prelude (DbCmd', DBCmd') import Gargantext.Database.Prelude (IsDBCmd, DBCmdWithEnv)
import Gargantext.Database.Query.Table.ContextNodeNgrams2 ( ContextNodeNgrams2Poly(..), insertContextNodeNgrams2 ) import Gargantext.Database.Query.Table.ContextNodeNgrams2 ( ContextNodeNgrams2Poly(..), insertContextNodeNgrams2 )
import Gargantext.Database.Query.Table.Node ( MkCorpus, insertDefaultNodeIfNotExists, getOrMkList, getNodeWith ) import Gargantext.Database.Query.Table.Node ( MkCorpus, insertDefaultNodeIfNotExists, getOrMkList, getNodeWith )
import Gargantext.Database.Query.Table.Node.Document.Add qualified as Doc (add) import Gargantext.Database.Query.Table.Node.Document.Add qualified as Doc (add)
...@@ -136,7 +136,7 @@ getDataText :: (HasNodeError err) ...@@ -136,7 +136,7 @@ getDataText :: (HasNodeError err)
-> Maybe PUBMED.APIKey -> Maybe PUBMED.APIKey
-> Maybe EPO.AuthKey -> Maybe EPO.AuthKey
-> Maybe API.Limit -> Maybe API.Limit
-> DBCmd' env err (Either API.GetCorpusError DataText) -> DBCmdWithEnv env err (Either API.GetCorpusError DataText)
getDataText (ExternalOrigin api) la q mPubmedAPIKey mAuthKey li = do getDataText (ExternalOrigin api) la q mPubmedAPIKey mAuthKey li = do
cfg <- view hasConfig cfg <- view hasConfig
eRes <- liftBase $ API.get api (_tt_lang la) q mPubmedAPIKey mAuthKey (_ac_epo_api_url $ _gc_apis cfg) li eRes <- liftBase $ API.get api (_tt_lang la) q mPubmedAPIKey mAuthKey (_ac_epo_api_url $ _gc_apis cfg) li
...@@ -151,7 +151,7 @@ getDataText_Debug :: (HasNodeError err) ...@@ -151,7 +151,7 @@ getDataText_Debug :: (HasNodeError err)
-> TermType Lang -> TermType Lang
-> API.RawQuery -> API.RawQuery
-> Maybe API.Limit -> Maybe API.Limit
-> DBCmd' env err () -> DBCmdWithEnv env err ()
getDataText_Debug a l q li = do getDataText_Debug a l q li = do
result <- getDataText a l q Nothing Nothing li result <- getDataText a l q Nothing Nothing li
case result of case result of
...@@ -161,7 +161,7 @@ getDataText_Debug a l q li = do ...@@ -161,7 +161,7 @@ getDataText_Debug a l q li = do
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
flowDataText :: forall env err m. flowDataText :: forall env err m.
( DbCmd' env err m ( IsDBCmd env err m
, HasNodeStory env err m , HasNodeStory env err m
, MonadLogger m , MonadLogger m
, HasNLPServer env , HasNLPServer env
...@@ -191,7 +191,7 @@ flowDataText u (DataNew (mLen, txtC)) tt cid mfslw jobHandle = do ...@@ -191,7 +191,7 @@ flowDataText u (DataNew (mLen, txtC)) tt cid mfslw jobHandle = do
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- TODO use proxy -- TODO use proxy
flowAnnuaire :: ( DbCmd' env err m flowAnnuaire :: ( IsDBCmd env err m
, HasNodeStory env err m , HasNodeStory env err m
, MonadLogger m , MonadLogger m
, HasNLPServer env , HasNLPServer env
...@@ -210,7 +210,7 @@ flowAnnuaire mkCorpusUser l filePath jobHandle = do ...@@ -210,7 +210,7 @@ flowAnnuaire mkCorpusUser l filePath jobHandle = do
flow (Nothing :: Maybe HyperdataAnnuaire) mkCorpusUser l Nothing (fromIntegral $ length docs, yieldMany docs) jobHandle flow (Nothing :: Maybe HyperdataAnnuaire) mkCorpusUser l Nothing (fromIntegral $ length docs, yieldMany docs) jobHandle
------------------------------------------------------------------------ ------------------------------------------------------------------------
flowCorpusFile :: ( DbCmd' env err m flowCorpusFile :: ( IsDBCmd env err m
, HasNodeStory env err m , HasNodeStory env err m
, MonadLogger m , MonadLogger m
, HasNLPServer env , HasNLPServer env
...@@ -239,7 +239,7 @@ flowCorpusFile mkCorpusUser _l la ft ff fp mfslw jobHandle = do ...@@ -239,7 +239,7 @@ flowCorpusFile mkCorpusUser _l la ft ff fp mfslw jobHandle = do
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | TODO improve the needed type to create/update a corpus -- | TODO improve the needed type to create/update a corpus
-- (For now, Either is enough) -- (For now, Either is enough)
flowCorpus :: ( DbCmd' env err m flowCorpus :: ( IsDBCmd env err m
, HasNodeStory env err m , HasNodeStory env err m
, MonadLogger m , MonadLogger m
, HasNLPServer env , HasNLPServer env
...@@ -258,7 +258,7 @@ flowCorpus = flow (Nothing :: Maybe HyperdataCorpus) ...@@ -258,7 +258,7 @@ flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
flow :: forall env err m a c. flow :: forall env err m a c.
( DbCmd' env err m ( IsDBCmd env err m
, HasNodeStory env err m , HasNodeStory env err m
, MonadLogger m , MonadLogger m
, HasNLPServer env , HasNLPServer env
...@@ -300,7 +300,7 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do ...@@ -300,7 +300,7 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do
-- | Given a list of corpus documents and a 'NodeId' identifying the 'CorpusId', adds -- | Given a list of corpus documents and a 'NodeId' identifying the 'CorpusId', adds
-- the given documents to the corpus. Returns the Ids of the inserted documents. -- the given documents to the corpus. Returns the Ids of the inserted documents.
addDocumentsToHyperCorpus :: ( DbCmd' env err m addDocumentsToHyperCorpus :: ( IsDBCmd env err m
, HasNodeError err , HasNodeError err
, FlowCorpus document , FlowCorpus document
, MkCorpus corpus , MkCorpus corpus
...@@ -317,7 +317,7 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do ...@@ -317,7 +317,7 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do
pure ids pure ids
------------------------------------------------------------------------ ------------------------------------------------------------------------
createNodes :: ( DbCmd' env err m, HasNodeError err createNodes :: ( IsDBCmd env err m, HasNodeError err
, MkCorpus c , MkCorpus c
, HasCentralExchangeNotification env , HasCentralExchangeNotification env
) )
...@@ -410,7 +410,7 @@ buildSocialList l user userCorpusId listId ctype mfslw = do ...@@ -410,7 +410,7 @@ buildSocialList l user userCorpusId listId ctype mfslw = do
pure () pure ()
insertMasterDocs :: ( DbCmd' env err m insertMasterDocs :: ( IsDBCmd env err m
, HasNodeError err , HasNodeError err
, FlowCorpus a , FlowCorpus a
, MkCorpus c , MkCorpus c
...@@ -443,7 +443,7 @@ insertMasterDocs ncs c lang hs = do ...@@ -443,7 +443,7 @@ insertMasterDocs ncs c lang hs = do
-- _cooc <- insertDefaultNode NodeListCooc lId masterUserId -- _cooc <- insertDefaultNode NodeListCooc lId masterUserId
pure $ map contextId2NodeId ids' pure $ map contextId2NodeId ids'
saveDocNgramsWith :: (DbCmd' env err m) saveDocNgramsWith :: (IsDBCmd env err m)
=> ListId => ListId
-> HashMap.HashMap ExtractedNgrams (Map NgramsType (Map NodeId (Int, TermsCount))) -> HashMap.HashMap ExtractedNgrams (Map NgramsType (Map NodeId (Int, TermsCount)))
-> m () -> m ()
......
...@@ -36,7 +36,7 @@ import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOn ...@@ -36,7 +36,7 @@ import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOn
import Gargantext.Database.Admin.Config ( userMaster ) import Gargantext.Database.Admin.Config ( userMaster )
import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact, cw_firstName, cw_lastName, hc_who ) -- (HyperdataContact(..)) import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact, cw_firstName, cw_lastName, hc_who ) -- (HyperdataContact(..))
import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, DocId, ContactId, NodeId) import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, DocId, ContactId, NodeId)
import Gargantext.Database.Prelude (Cmd, DBCmd, runOpaQuery) import Gargantext.Database.Prelude (DBCmd, DBCmdExtra, runOpaQuery)
import Gargantext.Database.Query.Prelude (returnA) import Gargantext.Database.Query.Prelude (returnA)
import Gargantext.Database.Query.Table.Node (defaultList) import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Query.Table.Node.Children (getAllContacts) import Gargantext.Database.Query.Table.Node.Children (getAllContacts)
...@@ -51,7 +51,7 @@ import Opaleye ...@@ -51,7 +51,7 @@ import Opaleye
-- | isPairedWith -- | isPairedWith
-- All NodeAnnuaire paired with a Corpus of NodeId nId: -- All NodeAnnuaire paired with a Corpus of NodeId nId:
-- isPairedWith NodeAnnuaire corpusId -- isPairedWith NodeAnnuaire corpusId
isPairedWith :: NodeId -> NodeType -> Cmd err [NodeId] isPairedWith :: NodeId -> NodeType -> DBCmdExtra err [NodeId]
isPairedWith nId nt = runOpaQuery (selectQuery nt nId) isPairedWith nId nt = runOpaQuery (selectQuery nt nId)
where where
selectQuery :: NodeType -> NodeId -> Select (Column SqlInt4) selectQuery :: NodeType -> NodeId -> Select (Column SqlInt4)
......
...@@ -30,7 +30,7 @@ import Gargantext.Core.Types (HasValidationError, TermsCount) ...@@ -30,7 +30,7 @@ import Gargantext.Core.Types (HasValidationError, TermsCount)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument ) import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument )
import Gargantext.Database.Admin.Types.Node (NodeId) import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Prelude (CmdM) import Gargantext.Database.Prelude (IsDBCmdExtra)
import Gargantext.Database.Query.Table.Node.Document.Insert ( UniqParameters, InsertDb, ToNode, AddUniqId ) import Gargantext.Database.Query.Table.Node.Document.Insert ( UniqParameters, InsertDb, ToNode, AddUniqId )
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Tree.Error (HasTreeError) import Gargantext.Database.Query.Tree.Error (HasTreeError)
...@@ -40,7 +40,7 @@ import Gargantext.System.Logging ( MonadLogger ) ...@@ -40,7 +40,7 @@ import Gargantext.System.Logging ( MonadLogger )
type FlowCmdM env err m = type FlowCmdM env err m =
( CmdM env err m ( IsDBCmdExtra env err m
, HasNodeStory env err m , HasNodeStory env err m
, HasNodeError err , HasNodeError err
, HasValidationError err , HasValidationError err
......
...@@ -33,7 +33,7 @@ import Gargantext.Data.HashMap.Strict.Utils qualified as HashMap ...@@ -33,7 +33,7 @@ import Gargantext.Data.HashMap.Strict.Utils qualified as HashMap
import Gargantext.Database.Action.Flow.Types (DocumentIdWithNgrams(..), FlowInsertDB) import Gargantext.Database.Action.Flow.Types (DocumentIdWithNgrams(..), FlowInsertDB)
import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument, hd_abstract, hd_title ) import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument, hd_abstract, hd_title )
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (DBCmd, DbCmd') import Gargantext.Database.Prelude (DBCmd, IsDBCmd)
import Gargantext.Database.Query.Table.ContextNodeNgrams ( ContextNodeNgramsPoly(..), insertContextNodeNgrams ) import Gargantext.Database.Query.Table.ContextNodeNgrams ( ContextNodeNgramsPoly(..), insertContextNodeNgrams )
import Gargantext.Database.Query.Table.Node.Document.Add qualified as Doc (add) import Gargantext.Database.Query.Table.Node.Document.Add qualified as Doc (add)
import Gargantext.Database.Query.Table.Node.Document.Insert (ReturnId, addUniqId, insertDb, reId, reInserted, reUniqId) import Gargantext.Database.Query.Table.Node.Document.Insert (ReturnId, addUniqId, insertDb, reId, reInserted, reUniqId)
...@@ -119,7 +119,7 @@ mapNodeIdNgrams = HashMap.unionsWith (DM.unionWith (DM.unionWith addTuples)) . f ...@@ -119,7 +119,7 @@ mapNodeIdNgrams = HashMap.unionsWith (DM.unionWith (DM.unionWith addTuples)) . f
-- TODO Type NodeDocumentUnicised -- TODO Type NodeDocumentUnicised
insertDocs :: ( DbCmd' env err m insertDocs :: ( IsDBCmd env err m
-- , FlowCorpus a -- , FlowCorpus a
, FlowInsertDB a , FlowInsertDB a
, HasNodeError err , HasNodeError err
......
...@@ -20,7 +20,7 @@ import Gargantext.Core.Mail (mail, MailModel(..)) ...@@ -20,7 +20,7 @@ import Gargantext.Core.Mail (mail, MailModel(..))
import Gargantext.Core.Mail.Types (mailSettings) import Gargantext.Core.Mail.Types (mailSettings)
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.User import Gargantext.Database.Action.User
import Gargantext.Database.Prelude (CmdM) import Gargantext.Database.Prelude (IsDBCmdExtra)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..)) import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Schema.User import Gargantext.Database.Schema.User
import Gargantext.Prelude import Gargantext.Prelude
...@@ -28,7 +28,8 @@ import Gargantext.System.Logging (MonadLogger, LogLevel(..), logLocM) ...@@ -28,7 +28,8 @@ import Gargantext.System.Logging (MonadLogger, LogLevel(..), logLocM)
------------------------------------------------------------------------ ------------------------------------------------------------------------
sendMail :: (HasNodeError err, CmdM env err m, MonadLogger m) => User -> m () sendMail :: (HasNodeError err, IsDBCmdExtra env err m, MonadLogger m)
=> User -> m ()
sendMail u = do sendMail u = do
cfg <- view $ mailSettings cfg <- view $ mailSettings
userLight <- getUserLightDB u userLight <- getUserLightDB u
......
...@@ -26,7 +26,7 @@ import Gargantext.Core.Types (Name) ...@@ -26,7 +26,7 @@ import Gargantext.Core.Types (Name)
import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Hyperdata.Default import Gargantext.Database.Admin.Types.Hyperdata.Default
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (DBCmd') import Gargantext.Database.Prelude (DBCmdWithEnv)
import Gargantext.Database.Query.Table.Node import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
...@@ -41,7 +41,7 @@ mkNodeWithParent :: (HasNodeError err, HasDBid NodeType) ...@@ -41,7 +41,7 @@ mkNodeWithParent :: (HasNodeError err, HasDBid NodeType)
-> Maybe ParentId -> Maybe ParentId
-> UserId -> UserId
-> Name -> Name
-> DBCmd' env err [NodeId] -> DBCmdWithEnv env err [NodeId]
mkNodeWithParent NodeUser (Just pId) uid _ = nodeError $ NodeCreationFailed $ UserParentAlreadyExists uid pId mkNodeWithParent NodeUser (Just pId) uid _ = nodeError $ NodeCreationFailed $ UserParentAlreadyExists uid pId
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -75,7 +75,7 @@ mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err, HasDBid NodeType) ...@@ -75,7 +75,7 @@ mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err, HasDBid NodeType)
-> Maybe ParentId -> Maybe ParentId
-> UserId -> UserId
-> Name -> Name
-> DBCmd' env err [NodeId] -> DBCmdWithEnv env err [NodeId]
mkNodeWithParent_ConfigureHyperdata Notes (Just i) uId name = mkNodeWithParent_ConfigureHyperdata Notes (Just i) uId name =
mkNodeWithParent_ConfigureHyperdata' Notes (Just i) uId name mkNodeWithParent_ConfigureHyperdata' Notes (Just i) uId name
...@@ -107,7 +107,7 @@ mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType) ...@@ -107,7 +107,7 @@ mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType)
-> Maybe ParentId -> Maybe ParentId
-> UserId -> UserId
-> Name -> Name
-> DBCmd' env err [NodeId] -> DBCmdWithEnv env err [NodeId]
mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
nodeId <- case nt of nodeId <- case nt of
Notes -> insertNode Notes (Just name) Nothing i uId Notes -> insertNode Notes (Just name) Nothing i uId
......
...@@ -44,7 +44,7 @@ data ShareNodeWith = ShareNodeWith_User !NodeType !User ...@@ -44,7 +44,7 @@ data ShareNodeWith = ShareNodeWith_User !NodeType !User
| ShareNodeWith_Node !NodeType !NodeId | ShareNodeWith_Node !NodeType !NodeId
------------------------------------------------------------------------ ------------------------------------------------------------------------
deleteMemberShip :: HasNodeError err => [(SharedFolderId, TeamNodeId)] -> Cmd err [Int] deleteMemberShip :: HasNodeError err => [(SharedFolderId, TeamNodeId)] -> DBCmdExtra err [Int]
deleteMemberShip xs = mapM (\(s,t) -> deleteNodeNode s t) xs deleteMemberShip xs = mapM (\(s,t) -> deleteNodeNode s t) xs
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -56,7 +56,7 @@ type TeamNodeId = NodeId ...@@ -56,7 +56,7 @@ type TeamNodeId = NodeId
-- Result gives the username and its SharedFolderId that has to be eventually -- Result gives the username and its SharedFolderId that has to be eventually
-- used for the membership -- used for the membership
membersOf :: HasNodeError err membersOf :: HasNodeError err
=> TeamNodeId -> Cmd err [(Text, SharedFolderId)] => TeamNodeId -> DBCmdExtra err [(Text, SharedFolderId)]
membersOf nId = do membersOf nId = do
res <- runOpaQuery $ membersOfQuery nId res <- runOpaQuery $ membersOfQuery nId
pure $ catMaybes (uncurryMaybe <$> res) pure $ catMaybes (uncurryMaybe <$> res)
...@@ -91,7 +91,7 @@ shareNodeWith :: HasNodeError err ...@@ -91,7 +91,7 @@ shareNodeWith :: HasNodeError err
-> NodeId -> NodeId
-- ^ The target node we would like to share, it has -- ^ The target node we would like to share, it has
-- to be a 'NodeFolderShared'. -- to be a 'NodeFolderShared'.
-> Cmd err Int -> DBCmdExtra err Int
shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
nodeToCheck <- getNode n nodeToCheck <- getNode n
userIdCheck <- getUserId u userIdCheck <- getUserId u
...@@ -125,7 +125,7 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do ...@@ -125,7 +125,7 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType" shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType"
------------------------------------------------------------------------ ------------------------------------------------------------------------
getFolderId :: HasNodeError err => User -> NodeType -> Cmd err NodeId getFolderId :: HasNodeError err => User -> NodeType -> DBCmdExtra err NodeId
getFolderId u nt = do getFolderId u nt = do
rootId <- getRootId u rootId <- getRootId u
s <- getNodesWith rootId HyperdataAny (Just nt) Nothing Nothing s <- getNodesWith rootId HyperdataAny (Just nt) Nothing Nothing
...@@ -136,12 +136,12 @@ getFolderId u nt = do ...@@ -136,12 +136,12 @@ getFolderId u nt = do
------------------------------------------------------------------------ ------------------------------------------------------------------------
type TeamId = NodeId type TeamId = NodeId
delFolderTeam :: HasNodeError err => User -> TeamId -> Cmd err Int delFolderTeam :: HasNodeError err => User -> TeamId -> DBCmdExtra err Int
delFolderTeam u nId = do delFolderTeam u nId = do
folderSharedId <- getFolderId u NodeFolderShared folderSharedId <- getFolderId u NodeFolderShared
deleteNodeNode folderSharedId nId deleteNodeNode folderSharedId nId
unshare :: HasNodeError err unshare :: HasNodeError err
=> ParentId -> NodeId => ParentId -> NodeId
-> Cmd err Int -> DBCmdExtra err Int
unshare p n = deleteNodeNode p n unshare p n = deleteNodeNode p n
...@@ -34,7 +34,7 @@ import Gargantext.Core.Mail.Types (HasMail, mailSettings) ...@@ -34,7 +34,7 @@ import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow (getOrMkRoot) import Gargantext.Database.Action.Flow (getOrMkRoot)
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, DBCmd, CmdM, DBCmd') import Gargantext.Database.Prelude (DBCmd, DBCmdExtra, IsDBCmdExtra, DBCmdWithEnv)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..)) import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
import Gargantext.Database.Query.Table.User import Gargantext.Database.Query.Table.User
import Gargantext.Prelude import Gargantext.Prelude
...@@ -45,7 +45,7 @@ import qualified Data.List.NonEmpty as NE ...@@ -45,7 +45,7 @@ import qualified Data.List.NonEmpty as NE
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Creates a new 'User' from the input 'EmailAddress', which needs to -- | Creates a new 'User' from the input 'EmailAddress', which needs to
-- be valid (i.e. a valid username needs to be inferred via 'guessUsername'). -- be valid (i.e. a valid username needs to be inferred via 'guessUsername').
newUser :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env) newUser :: (IsDBCmdExtra env err m, MonadRandom m, HasNodeError err, HasMail env)
=> EmailAddress => EmailAddress
-> m UserId -> m UserId
newUser emailAddress = do newUser emailAddress = do
...@@ -62,7 +62,7 @@ newUser emailAddress = do ...@@ -62,7 +62,7 @@ newUser emailAddress = do
-- use 'newUser' instead for standard Gargantext code. -- use 'newUser' instead for standard Gargantext code.
new_user :: (HasNodeError err) new_user :: (HasNodeError err)
=> NewUser GargPassword => NewUser GargPassword
-> DBCmd' env err UserId -> DBCmdWithEnv env err UserId
new_user rq = do new_user rq = do
(uid NE.:| _) <- new_users (rq NE.:| []) (uid NE.:| _) <- new_users (rq NE.:| [])
pure uid pure uid
...@@ -75,14 +75,14 @@ new_user rq = do ...@@ -75,14 +75,14 @@ new_user rq = do
new_users :: (HasNodeError err) new_users :: (HasNodeError err)
=> NonEmpty (NewUser GargPassword) => NonEmpty (NewUser GargPassword)
-- ^ A list of users to create. -- ^ A list of users to create.
-> DBCmd' env err (NonEmpty UserId) -> DBCmdWithEnv env err (NonEmpty UserId)
new_users us = do new_users us = do
us' <- liftBase $ mapM toUserHash us us' <- liftBase $ mapM toUserHash us
void $ insertUsers $ NE.map toUserWrite us' void $ insertUsers $ NE.map toUserWrite us'
mapM (fmap fst . getOrMkRoot) $ NE.map (\u -> UserName (_nu_username u)) us mapM (fmap fst . getOrMkRoot) $ NE.map (\u -> UserName (_nu_username u)) us
------------------------------------------------------------------------ ------------------------------------------------------------------------
newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env) newUsers :: (IsDBCmdExtra env err m, MonadRandom m, HasNodeError err, HasMail env)
=> NonEmpty EmailAddress => NonEmpty EmailAddress
-> m (NonEmpty UserId) -> m (NonEmpty UserId)
newUsers us = do newUsers us = do
...@@ -109,7 +109,7 @@ guessUserName n = case splitOn "@" n of ...@@ -109,7 +109,7 @@ guessUserName n = case splitOn "@" n of
------------------------------------------------------------------------ ------------------------------------------------------------------------
newUsers' :: (HasNodeError err) newUsers' :: (HasNodeError err)
=> MailConfig -> NonEmpty (NewUser GargPassword) -> DBCmd' env err (NonEmpty UserId) => MailConfig -> NonEmpty (NewUser GargPassword) -> DBCmdWithEnv env err (NonEmpty UserId)
newUsers' cfg us = do newUsers' cfg us = do
us' <- liftBase $ mapM toUserHash us us' <- liftBase $ mapM toUserHash us
void $ insertUsers $ NE.map toUserWrite us' void $ insertUsers $ NE.map toUserWrite us'
...@@ -121,7 +121,7 @@ newUsers' cfg us = do ...@@ -121,7 +121,7 @@ newUsers' cfg us = do
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Updates a user's password, notifying the user via email, if necessary. -- | Updates a user's password, notifying the user via email, if necessary.
updateUser :: HasNodeError err updateUser :: HasNodeError err
=> SendEmail -> MailConfig -> NewUser GargPassword -> Cmd err Int64 => SendEmail -> MailConfig -> NewUser GargPassword -> DBCmdExtra err Int64
updateUser (SendEmail send) cfg u = do updateUser (SendEmail send) cfg u = do
u' <- liftBase $ toUserHash u u' <- liftBase $ toUserHash u
n <- updateUserDB $ toUserWrite u' n <- updateUserDB $ toUserWrite u'
...@@ -129,7 +129,7 @@ updateUser (SendEmail send) cfg u = do ...@@ -129,7 +129,7 @@ updateUser (SendEmail send) cfg u = do
pure n pure n
------------------------------------------------------------------------ ------------------------------------------------------------------------
_updateUsersPassword :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env) _updateUsersPassword :: (IsDBCmdExtra env err m, MonadRandom m, HasNodeError err, HasMail env)
=> [EmailAddress] -> m Int64 => [EmailAddress] -> m Int64
_updateUsersPassword us = do _updateUsersPassword us = do
us' <- mapM (\ea -> mkNewUser ea . GargPassword <$> gargPass) us us' <- mapM (\ea -> mkNewUser ea . GargPassword <$> gargPass) us
......
...@@ -14,7 +14,45 @@ Portability : POSIX ...@@ -14,7 +14,45 @@ Portability : POSIX
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Gargantext.Database.Prelude where module Gargantext.Database.Prelude
( -- * Types and Constraints
-- $typesAndConstraints
--
-- ** Environment Constraints
HasConnectionPool(..)
, IsDBEnv
, IsDBEnvExtra
-- ** Command Monad Constraints
, IsCmd
, IsDBCmd
, IsDBCmdExtra
-- ** Existential Versions of the Above Constraints, for Convenience
, Cmd
, CmdRandom
, DBCmd
, DBCmdWithEnv
, DBCmdExtra
-- ** Miscellaneous Type(s)
, JSONB
-- * Functions
-- ** Executing DB Queries
-- *** PostgreSQL.Simple
, execPGSQuery
, runPGSQuery
, runPGSQuery_
-- *** Opaleye
, runOpaQuery
, runCountOpaQuery
-- ** Other Functions
, runCmd
, createDBIfNotExists
, dbCheck
, formatPGSQuery
, fromField'
, mkCmd
, restrictMaybe
)
where
import Control.Exception.Safe (throw) import Control.Exception.Safe (throw)
import Control.Lens (Getter, view) import Control.Lens (Getter, view)
...@@ -35,79 +73,107 @@ import Gargantext.Core.Config (HasConfig(..)) ...@@ -35,79 +73,107 @@ import Gargantext.Core.Config (HasConfig(..))
import Gargantext.Core.Mail.Types (HasMail) import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer) import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Prelude import Gargantext.Prelude
import Opaleye (Unpackspec, showSql, FromFields, Select, runSelect, SqlJsonb, DefaultFromField, toFields, matchMaybe, MaybeFields) import Opaleye (FromFields, Select, runSelect, SqlJsonb, DefaultFromField, toFields, matchMaybe, MaybeFields)
import Opaleye.Aggregate (countRows) import Opaleye.Aggregate (countRows)
import Opaleye.Internal.Constant qualified import Opaleye.Internal.Constant qualified
import Opaleye.Internal.Operators qualified import Opaleye.Internal.Operators qualified
import Shelly qualified as SH import Shelly qualified as SH
-------------------------------------------------------
-- $typesAndConstraints
--
-- The names of the constraints and types in this module are chosen based on
-- the following guidelines:
-- * By default, constraints are relatively lenient. Stricter constraints are
-- obtained by appending the `Extra` suffix to the minimal constraint name.
-- * `IsDBEnv(Extra)` applies to the environment; the basic constraint allows
-- access to the database, and the `Extra` variant offers some more
-- capabilities such as access to mail.
-- * `IsCmd` is the basic constraint for command monads. Append `DB` to it to get
-- a monad of commands that can talk to the database. Append `Extra` to get
-- the ability to send mail, make use of the NLP server and deal with central
-- exchange notifications. Append `Random` to get access to randomness.
-- * Existential versions of the constraints bear the same name as the constraint
-- they are based on, but without the `Is` prefix.
class HasConnectionPool env where class HasConnectionPool env where
connPool :: Getter env (Pool Connection) connPool :: Getter env (Pool Connection)
instance HasConnectionPool (Pool Connection) where instance HasConnectionPool (Pool Connection) where
connPool = identity connPool = identity
------------------------------------------------------- -- | The most basic constraints for an environment with a database.
type JSONB = DefaultFromField SqlJsonb -- If possible, try to not add more constraints here. When performing
-------------------------------------------------------
type CmdM'' env err m =
( MonadReader env m
, MonadError err m
, MonadBaseControl IO m
, MonadRandom m
)
type CmdM' env err m =
( MonadReader env m
, MonadError err m
, MonadBaseControl IO m
)
-- | If possible, try to not add more constraints here. When performing
-- a query/update on the DB, one shouldn't need more than being able to -- a query/update on the DB, one shouldn't need more than being able to
-- fetch from the underlying 'env' the connection pool and access the -- fetch from the underlying 'env' the connection pool and access the
-- 'GargConfig' for some sensible defaults to store into the DB. -- 'GargConfig' for some sensible defaults to store into the DB.
type DbCommon env = type IsDBEnv env =
( HasConnectionPool env ( HasConnectionPool env
, HasConfig env , HasConfig env
) )
type CmdCommon env = -- | Constraints for a full-fledged environment, with a database, mail exchange,
( DbCommon env -- NLP processing, notifications.
, HasConfig env type IsDBEnvExtra env =
( IsDBEnv env
, HasMail env , HasMail env
, HasNLPServer env , HasNLPServer env
, CET.HasCentralExchangeNotification env ) , CET.HasCentralExchangeNotification env
type CmdM env err m =
( CmdM' env err m
, CmdCommon env
) )
type CmdRandom env err m = -- | The most general constraints for commands. To interact with the database,
( CmdM' env err m -- or access extra features (such as sending mail), you'll need to add some more
, DbCommon env -- constraints (see the rest of this module)
, MonadRandom m type IsCmd env err m =
, HasMail env ( MonadReader env m
, MonadError err m
, MonadBaseControl IO m
) )
type Cmd'' env err a = forall m. CmdM'' env err m => m a
type Cmd' env err a = forall m. CmdM' env err m => m a
type Cmd err a = forall m env. CmdM env err m => m a
type CmdR err a = forall m env. CmdRandom env err m => m a
type DBCmd' env err a = forall m. DbCmd' env err m => m a
type DBCmd err a = forall m env. DbCmd' env err m => m a
-- | Only the /minimum/ amount of class constraints required -- | Only the /minimum/ amount of class constraints required
-- to use the Gargantext Database. It's important, to ease testability, -- to use the Gargantext Database. It's important, to ease testability,
-- that these constraints stays as few as possible. -- that these constraints stays as few as possible.
type DbCmd' env err m = ( type IsDBCmd env err m =
CmdM' env err m ( IsCmd env err m
, DbCommon env , IsDBEnv env
) )
-- | Full-fledged command class. Types in this class provide commands that can
-- interact with the database, perform NLP processing, etc.
type IsDBCmdExtra env err m =
( IsCmd env err m
, IsDBEnvExtra env
)
-- | Basic command with access to randomness. It feels a little ad hoc to have
-- such a constraint instead of substituting it (and its counterpart existential
-- type `CmdRandom`) with its definition every time it appears in the codebase,
-- but I tried to doing that substitution and it wasn't so easy.
type IsCmdRandom env err m =
( IsCmd env err m
, MonadRandom m
)
-- | Barebones command type, without any built-in ability to interact with the
-- database or do stuff like email exchanges.
type Cmd env err a = forall m. IsCmd env err m => m a
-- | Basic command type with access to randomness
type CmdRandom env err a = forall m. IsCmdRandom env err m => m a
-- | Command type that allows for interaction with the database.
type DBCmd err a = forall m env. IsDBCmd env err m => m a
-- | Command type that allows for interaction with the database. Similar to
-- `DBCmd`, except you can constraint the environment type some more.
type DBCmdWithEnv env err a = forall m. IsDBCmd env err m => m a
-- | Full-fledged command types, with access to the database, mail, NLP
-- processing and central exchange notifications.
type DBCmdExtra err a = forall m env. IsDBCmdExtra env err m => m a
type JSONB = DefaultFromField SqlJsonb
fromInt64ToInt :: Int64 -> Int fromInt64ToInt :: Int64 -> Int
fromInt64ToInt = fromIntegral fromInt64ToInt = fromIntegral
...@@ -118,7 +184,7 @@ mkCmd k = do ...@@ -118,7 +184,7 @@ mkCmd k = do
liftBase $ withResource pool (liftBase . k) liftBase $ withResource pool (liftBase . k)
runCmd :: env runCmd :: env
-> Cmd'' env err a -> CmdRandom env err a
-> IO (Either err a) -> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env runCmd env m = runExceptT $ runReaderT m env
...@@ -136,10 +202,6 @@ runCountOpaQuery q = do ...@@ -136,10 +202,6 @@ runCountOpaQuery q = do
formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err DB.ByteString formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err DB.ByteString
formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
-- TODO use runPGSQueryDebug everywhere
runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> DBCmd err [b]
runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
runPGSQuery :: ( PGS.FromRow r, PGS.ToRow q ) runPGSQuery :: ( PGS.FromRow r, PGS.ToRow q )
=> PGS.Query -> q -> DBCmd err [r] => PGS.Query -> q -> DBCmd err [r]
runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn) runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
...@@ -149,22 +211,6 @@ runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn) ...@@ -149,22 +211,6 @@ runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
hPutStrLn stderr q' hPutStrLn stderr q'
throw (SomeException e) throw (SomeException e)
{-
-- TODO
runPGSQueryFold :: ( CmdM env err m
, PGS.FromRow r
)
=> PGS.Query -> a -> (a -> r -> IO a) -> m a
runPGSQueryFold q initialState consume = mkCmd $ \conn -> catch (PGS.fold_ conn initialState consume) (printError conn)
where
printError c (SomeException e) = do
q' <- PGS.formatQuery c q
hPutStrLn stderr q'
throw (SomeException e)
-}
-- | TODO catch error -- | TODO catch error
runPGSQuery_ :: ( PGS.FromRow r ) runPGSQuery_ :: ( PGS.FromRow r )
=> PGS.Query -> DBCmd err [r] => PGS.Query -> DBCmd err [r]
...@@ -177,10 +223,6 @@ runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError ...@@ -177,10 +223,6 @@ runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err Int64 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err Int64
execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
------------------------------------------------------------------------
-- connectGargandb :: SettingsFile -> IO Connection
-- connectGargandb sf = readConfig sf >>= \params -> connect (DBConfig.unTOMLConnectInfo params)
fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
fromField' field mb = do fromField' field mb = do
...@@ -194,9 +236,6 @@ fromField' field mb = do ...@@ -194,9 +236,6 @@ fromField' field mb = do
, show v , show v
] ]
printSqlOpa :: Default Unpackspec a a => Select a -> IO ()
printSqlOpa = putStrLn . maybe "Empty query" identity . showSql
dbCheck :: DBCmd err Bool dbCheck :: DBCmd err Bool
dbCheck = do dbCheck = do
r :: [PGS.Only Text] <- runPGSQuery_ "select username from public.auth_user" r :: [PGS.Only Text] <- runPGSQuery_ "select username from public.auth_user"
......
...@@ -24,7 +24,7 @@ import Gargantext.Core.Notifications.CentralExchange.Types qualified as CE ...@@ -24,7 +24,7 @@ import Gargantext.Core.Notifications.CentralExchange.Types qualified as CE
import Gargantext.Core.Types (Name) import Gargantext.Core.Types (Name)
import Gargantext.Database.Admin.Config () import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, DBCmd, runPGSQuery) import Gargantext.Database.Prelude (DBCmd, DBCmdExtra, runPGSQuery)
import Gargantext.Database.Query.Table.Node.Error import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.Node (getParentId, getNode, getUserRootPublicNode) import Gargantext.Database.Query.Table.Node (getParentId, getNode, getUserRootPublicNode)
import Gargantext.Database.Query.Table.NodeNode (isNodeReadOnly, SourceId (..), TargetId(..), publishNode, unpublishNode) import Gargantext.Database.Query.Table.NodeNode (isNodeReadOnly, SourceId (..), TargetId(..), publishNode, unpublishNode)
...@@ -48,7 +48,7 @@ unOnly :: Only a -> a ...@@ -48,7 +48,7 @@ unOnly :: Only a -> a
unOnly (Only a) = a unOnly (Only a) = a
-- | Prefer this, because it notifies parents of the node change -- | Prefer this, because it notifies parents of the node change
update :: HasNodeError err => UserId -> Update -> Cmd err [Int] update :: HasNodeError err => UserId -> Update -> DBCmdExtra err [Int]
update _loggedInUserId (Rename nId newName) = do update _loggedInUserId (Rename nId newName) = do
ret <- rename_db_update nId newName ret <- rename_db_update nId newName
mpId <- getParentId nId mpId <- getParentId nId
...@@ -94,12 +94,12 @@ update loggedInUserId (Move sourceId targetId) = do ...@@ -94,12 +94,12 @@ update loggedInUserId (Move sourceId targetId) = do
pure ids pure ids
publish :: HasNodeError err => UserId -> NodeId -> NodePublishPolicy -> Cmd err Int publish :: HasNodeError err => UserId -> NodeId -> NodePublishPolicy -> DBCmdExtra err Int
publish loggedInUserId sourceId policy = do publish loggedInUserId sourceId policy = do
targetId <- _node_id <$> getUserRootPublicNode loggedInUserId targetId <- _node_id <$> getUserRootPublicNode loggedInUserId
publish_node (SourceId sourceId) (TargetId targetId) policy publish_node (SourceId sourceId) (TargetId targetId) policy
publish_node :: HasNodeError err => SourceId -> TargetId -> NodePublishPolicy -> Cmd err Int publish_node :: HasNodeError err => SourceId -> TargetId -> NodePublishPolicy -> DBCmdExtra err Int
publish_node (SourceId sourceId) (TargetId targetId) policy = do publish_node (SourceId sourceId) (TargetId targetId) policy = do
sourceNode <- getNode sourceId sourceNode <- getNode sourceId
targetNode <- getNode targetId targetNode <- getNode targetId
...@@ -121,7 +121,7 @@ publish_node (SourceId sourceId) (TargetId targetId) policy = do ...@@ -121,7 +121,7 @@ publish_node (SourceId sourceId) (TargetId targetId) policy = do
-- Issue #400, for now we support only publishing corpus nodes -- Issue #400, for now we support only publishing corpus nodes
check_publish_source_type_allowed :: HasNodeError err => SourceId -> TargetId -> NodeType -> Cmd err () check_publish_source_type_allowed :: HasNodeError err => SourceId -> TargetId -> NodeType -> DBCmdExtra err ()
check_publish_source_type_allowed (SourceId nId) (TargetId tId) = \case check_publish_source_type_allowed (SourceId nId) (TargetId tId) = \case
NodeCorpus -> pure () NodeCorpus -> pure ()
NodeCorpusV3 -> pure () NodeCorpusV3 -> pure ()
......
...@@ -22,7 +22,7 @@ import Gargantext.Database.Action.User (getUserId, getUsername) ...@@ -22,7 +22,7 @@ import Gargantext.Database.Action.User (getUserId, getUsername)
import Gargantext.Database.Admin.Config ( corpusMasterName, userMaster ) import Gargantext.Database.Admin.Config ( corpusMasterName, userMaster )
import Gargantext.Database.Admin.Types.Hyperdata.User ( HyperdataUser ) import Gargantext.Database.Admin.Types.Hyperdata.User ( HyperdataUser )
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (runOpaQuery, DBCmd, DBCmd') import Gargantext.Database.Prelude (runOpaQuery, DBCmd, DBCmdWithEnv)
import Gargantext.Database.Query.Table.Node import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..)) import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
...@@ -44,7 +44,7 @@ getRoot = runOpaQuery . selectRoot ...@@ -44,7 +44,7 @@ getRoot = runOpaQuery . selectRoot
getOrMkRoot :: (HasNodeError err) getOrMkRoot :: (HasNodeError err)
=> User => User
-> DBCmd' env err (UserId, RootId) -> DBCmdWithEnv env err (UserId, RootId)
getOrMkRoot user = do getOrMkRoot user = do
userId <- getUserId user userId <- getUserId user
...@@ -80,7 +80,7 @@ userFromMkCorpusUser (MkCorpusUserNormalCorpusName u _cname) = u ...@@ -80,7 +80,7 @@ userFromMkCorpusUser (MkCorpusUserNormalCorpusName u _cname) = u
getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a) getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
=> MkCorpusUser => MkCorpusUser
-> Maybe a -> Maybe a
-> DBCmd' env err (UserId, RootId, CorpusId) -> DBCmdWithEnv env err (UserId, RootId, CorpusId)
getOrMkRootWithCorpus MkCorpusUserMaster c = do getOrMkRootWithCorpus MkCorpusUserMaster c = do
(userId, rootId) <- getOrMkRoot (UserName userMaster) (userId, rootId) <- getOrMkRoot (UserName userMaster)
corpusId'' <- do corpusId'' <- do
...@@ -121,7 +121,7 @@ mkCorpus cName c rootId userId = do ...@@ -121,7 +121,7 @@ mkCorpus cName c rootId userId = do
mkRoot :: (HasNodeError err) mkRoot :: (HasNodeError err)
=> User => User
-> DBCmd' env err [RootId] -> DBCmdWithEnv env err [RootId]
mkRoot user = do mkRoot user = do
-- TODO -- TODO
......
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