Commit 673d3d45 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

Modify constraints to allow for MonadLogger

parent f88ffb37
{-# LANGUAGE ConstraintKinds #-}
module CLI.Admin (
adminCLI
......@@ -17,11 +18,14 @@ import Gargantext.Database.Prelude
import Gargantext.Prelude
import Options.Applicative
import Prelude (String)
import Control.Monad.Random
type DBCmdWithRandom env err a = forall m. (IsDBEnvExtra env, MonadRandom m, IsDBCmd env err m) => m a
adminCLI :: AdminArgs -> IO ()
adminCLI (AdminArgs settingsPath mails) = do
withDevEnv settingsPath $ \env -> do
x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: CmdRandom DevEnv BackendInternalError (NonEmpty UserId))
x <- runCmdDev' env ((newUsers $ NE.map cs (NE.fromList mails)) :: DBCmdWithRandom DevEnv BackendInternalError (NonEmpty UserId))
putStrLn (show x :: Text)
adminCmd :: HasCallStack => Mod CommandFields CLI
......
......@@ -18,7 +18,7 @@ module CLI.Init where
import CLI.Parsers
import CLI.Types
import Data.List.NonEmpty qualified as NE
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Dev (withDevEnv, runCmdDev')
import Gargantext.API.Errors.Types
import Gargantext.API.Node () -- instances only
import Gargantext.Core.Config (GargConfig(..))
......@@ -70,7 +70,7 @@ initCLI (InitArgs settingsPath) = do
pure (masterUserId, masterRootId, masterCorpusId, masterListId)
withDevEnv settingsPath $ \env -> do
x <- runCmdDev env $ runDBTx $ do
x <- runCmdDev' env $ runDBTx $ do
_ <- initFirstTriggers secret
_ <- createUsers
x' <- initMaster
......
......@@ -17,7 +17,7 @@ module CLI.Invitations where
import CLI.Parsers
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.Node () -- instances only
import Gargantext.API.Node.Share qualified as Share
......@@ -26,6 +26,7 @@ import Gargantext.Core.Types
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Prelude (IsDBCmdExtra)
import Gargantext.Prelude
import Gargantext.System.Logging.Types
import Options.Applicative
import Prelude (String)
......@@ -33,12 +34,12 @@ invitationsCLI :: InvitationsArgs -> IO ()
invitationsCLI (InvitationsArgs settingsPath user node_id email) = do
-- _cfg <- readConfig settingsPath
let invite :: (IsDBCmdExtra env BackendInternalError m, MonadRandom m)
let invite :: (IsDBCmdExtra env BackendInternalError m, MonadRandom m, MonadLogger m)
=> m Int
invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email)
withDevEnv settingsPath $ \env -> do
void $ runCmdDev env invite
void $ runCmdDev' env invite
invitationsCmd :: HasCallStack => Mod CommandFields CLI
invitationsCmd = command "invitations" (info (helper <*> fmap CLISub invitations_p) (progDesc "Mailing invitations."))
......
......@@ -30,11 +30,13 @@ Pouillard (who mainly made it).
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
module Gargantext.API
where
import Control.Concurrent.Async qualified as Async
import Control.Exception.Safe qualified as Safe
import Data.Cache qualified as InMemory
import Data.List (lookup)
import Data.Set qualified as Set
......@@ -65,6 +67,7 @@ import Servant hiding (Header)
import Servant.Client.Core.BaseUrl (showBaseUrl, baseUrlPort)
import System.Clock qualified as Clock
import System.Cron.Schedule qualified as Cron
import Gargantext.API.Errors.Types (BackendInternalError (..))
-- | startGargantext takes as parameters port number and Toml file.
startGargantext :: Mode -> SettingsFile -> IO ()
......@@ -92,16 +95,18 @@ startGargantext mode sf@(SettingsFile settingsFile) = do
let runProxy = run proxyPort (mid (microServicesProxyApp proxyCache env))
Async.race_ runServer runProxy
where runDbCheck env = do
r <- runExceptT (runReaderT DB.dbCheck env) `catch`
(\(err :: SomeException) -> pure $ Left err)
case r of
Right True -> pure ()
Right False -> panicTrace $
"You must run 'gargantext init -c " <> pack settingsFile <>
"' before running gargantext-server (only the first time)."
Left err -> panicTrace $ "Unexpected exception:" <> show err
oneHour = Clock.fromNanoSecs 3600_000_000_000
where
runDbCheck :: Env -> IO ()
runDbCheck env = do
r <- (runExceptT @BackendInternalError (runReaderT DB.dbCheck env)) `Safe.catch`
(\(err :: SomeException) -> pure $ Left $ InternalUnexpectedError err)
case r of
Right True -> pure ()
Right False -> panicTrace $
"You must run 'gargantext init -c " <> pack settingsFile <>
"' before running gargantext-server (only the first time)."
Left err -> panicTrace $ "Unexpected exception:" <> show err
oneHour = Clock.fromNanoSecs 3600_000_000_000
startupInfo :: GargConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
startupInfo config mainPort proxyStatus = do
......
......@@ -239,8 +239,8 @@ forgotPasswordPost :: (IsDBEnvExtra env)
forgotPasswordPost (ForgotPasswordRequest _email) = do
pure $ ForgotPasswordResponse "ok"
forgotPasswordGet :: (IsDBEnvExtra env, HasServerError err)
=> Maybe Text -> Cmd env err ForgotPasswordGet
forgotPasswordGet :: (IsDBEnvExtra env, IsDBTxCmd env err m, HasServerError err)
=> Maybe Text -> m ForgotPasswordGet
forgotPasswordGet Nothing = pure $ ForgotPasswordGet ""
forgotPasswordGet (Just uuid) = do
let mUuid = fromText uuid
......@@ -256,8 +256,7 @@ forgotPasswordGet (Just uuid) = do
---------------------
forgotPasswordGetUser :: ( IsDBEnvExtra env)
=> UserLight -> Cmd env err ForgotPasswordGet
forgotPasswordGetUser :: (IsDBEnvExtra env, IsDBTxCmd env err m) => UserLight -> m ForgotPasswordGet
forgotPasswordGetUser (UserLight { .. }) = do
-- pick some random password
password <- liftBase gargPass
......@@ -273,8 +272,7 @@ forgotPasswordGetUser (UserLight { .. }) = do
pure $ ForgotPasswordGet password
forgotUserPassword :: (IsDBEnvExtra env)
=> UserLight -> Cmd env err ()
forgotUserPassword :: (IsDBEnvExtra env, IsDBTxCmd env err m) => UserLight -> m ()
forgotUserPassword (UserLight { .. }) = do
--printDebug "[forgotUserPassword] userLight_id" userLight_id
--logDebug $ "[forgotUserPassword]" :# ["userLight_id" .= userLight_id]
......@@ -298,8 +296,7 @@ forgotUserPassword (UserLight { .. }) = do
--------------------------
-- Generate a unique (in whole DB) UUID for passwords.
generateForgotPasswordUUID :: (IsDBEnvExtra env)
=> Cmd env err UUID
generateForgotPasswordUUID :: (IsDBEnvExtra env, IsDBTxCmd env err m) => m UUID
generateForgotPasswordUUID = do
uuid <- liftBase $ nextRandom
us <- runDBQuery $ getUsersWithForgotPasswordUUID uuid
......
{-# OPTIONS_GHC -Wno-deprecations #-}
{-|
Module : Gargantext.API.Dev
Description :
......@@ -24,7 +25,7 @@ import Gargantext.Core.Config (_gc_database_config, gc_logging)
import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.NodeStory (mkNodeStoryEnv)
import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd)
import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd, DBCmdWithEnv)
import Gargantext.Prelude
import Gargantext.System.Logging ( withLoggerIO )
import Network.HTTP.Client.TLS (newTlsManager)
......@@ -69,6 +70,10 @@ runCmdDev :: (Typeable err, Show err) => DevEnv -> CmdRandom DevEnv err a -> IO
runCmdDev env f =
either (fail . show) pure =<< runCmd env f
runCmdDev' :: (Typeable err, Show err) => env -> ReaderT env (ExceptT err IO) a -> IO a
runCmdDev' env m =
either (fail . show) pure =<< (runExceptT (runReaderT m env))
runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a
runCmdGargDev env cmd =
either (fail . show) pure =<< runExceptT (runReaderT cmd env)
......@@ -82,6 +87,12 @@ runCmdDevServantErr = runCmdDev
runCmdReplEasy :: CmdRandom DevEnv BackendInternalError a -> IO a
runCmdReplEasy f = withDevEnv defaultSettingsFile $ \env -> runCmdDev env f
runDBTxReplEasy :: DBCmdWithEnv DevEnv BackendInternalError a -> IO a
runDBTxReplEasy f =
withDevEnv defaultSettingsFile $ \env -> either (fail . show) pure =<< run_it env f
where
run_it env m = runExceptT $ runReaderT m env
-- | Execute a function that takes PSQL.Connection from the DB pool as
-- first parameter.
-- e.g.: runCmdReplEasyDB $ \c -> getNodeStory' c
......
......@@ -19,12 +19,12 @@ Portability : POSIX
module Gargantext.API.GraphQL where
-- import Data.Proxy
import Data.ByteString.Lazy.Char8 ( ByteString )
import Data.Morpheus ( App, deriveApp )
import Data.Morpheus.Server ( httpPlayground )
import Data.Morpheus.Subscriptions ( Event (..), httpPubApp )
import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..), Undefined, defaultRootResolver)
-- import Data.Proxy
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
import Gargantext.API.Auth.PolicyCheck
import Gargantext.API.Errors.Types
......@@ -35,6 +35,7 @@ import Gargantext.API.GraphQL.NLP qualified as GQLNLP
import Gargantext.API.GraphQL.Node qualified as GQLNode
import Gargantext.API.GraphQL.Team qualified as GQLTeam
import Gargantext.API.GraphQL.TreeFirstLevel qualified as GQLTree
import Gargantext.API.GraphQL.Types (GqlLogger)
import Gargantext.API.GraphQL.User qualified as GQLUser
import Gargantext.API.GraphQL.UserInfo qualified as GQLUserInfo
import Gargantext.API.Prelude (GargM)
......@@ -97,7 +98,7 @@ data Contet m
-- | The main GraphQL resolver: how queries, mutations and
-- subscriptions are handled.
rootResolver
:: (IsDBEnvExtra env, HasNLPServer env, HasJWTSettings env)
:: (IsDBEnvExtra env, HasNLPServer env, HasJWTSettings env, GqlLogger env)
=> AuthenticatedUser
-> AccessPolicyManager
-> RootResolver (GargM env BackendInternalError) e Query Mutation Undefined
......@@ -128,7 +129,7 @@ rootResolver authenticatedUser policyManager =
-- | Main GraphQL "app".
app
:: (Typeable env, IsDBEnvExtra env, HasNLPServer env, HasJWTSettings env)
:: (Typeable env, IsDBEnvExtra env, HasNLPServer env, HasJWTSettings env, GqlLogger env)
=> AuthenticatedUser
-> AccessPolicyManager
-> App (EVENT (GargM env BackendInternalError)) (GargM env BackendInternalError)
......@@ -166,7 +167,7 @@ data GraphQLAPIEndpoints mode = GraphQLAPIEndpoints
-- | Implementation of our API.
api
:: (Typeable env, IsDBEnvExtra env, HasJWTSettings env)
:: (Typeable env, IsDBEnvExtra env, HasJWTSettings env, GqlLogger env)
=> GraphQLAPI (AsServerT (GargM env BackendInternalError))
api = GraphQLAPI $ \case
(SAS.Authenticated auser)
......
......@@ -27,7 +27,7 @@ import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Context (getContextWith)
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude
import Gargantext.API.GraphQL.Types (GqlM)
import Gargantext.API.GraphQL.Types (GqlM, GqlLogger)
data AnnuaireContact = AnnuaireContact
{ ac_title :: !(Maybe Text)
......@@ -55,13 +55,13 @@ data AnnuaireContactArgs
-- | Function to resolve user from a query.
resolveAnnuaireContacts
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> AnnuaireContactArgs -> GqlM e env [AnnuaireContact]
resolveAnnuaireContacts AnnuaireContactArgs { contact_id } = dbAnnuaireContacts contact_id
-- | Inner function to fetch the user from DB.
dbAnnuaireContacts
:: IsDBEnvExtra env
:: (IsDBEnvExtra env, GqlLogger env)
=> Int -> GqlM e env [AnnuaireContact]
dbAnnuaireContacts contact_id = do
-- lift $ printDebug "[dbUsers]" user_id
......
......@@ -11,6 +11,7 @@ Portability : POSIX
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ConstraintKinds #-}
module Gargantext.API.GraphQL.Context where
......@@ -22,6 +23,7 @@ import Data.Morpheus.Types
, ResolverM
, QUERY
)
import Data.Text (pack)
import Data.Time.Format.ISO8601 (iso8601Show)
import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
......@@ -38,6 +40,7 @@ import Gargantext.Database.Query.Table.NodeContext qualified as DNC
import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..))
import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Hash (Hash)
import Gargantext.System.Logging (MonadLogger)
data ContextGQL = ContextGQL
{ c_id :: Int
......@@ -111,6 +114,7 @@ data ContextNgramsArgs
, list_id :: Int }
deriving (Generic, GQLType)
type GqlLogger env = MonadLogger (GargM env BackendInternalError)
type GqlM e env = Resolver QUERY e (GargM env BackendInternalError)
type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
......@@ -118,19 +122,19 @@ type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
-- | Function to resolve context from a query.
resolveNodeContext
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> NodeContextArgs -> GqlM e env [NodeContextGQL]
resolveNodeContext NodeContextArgs { context_id, node_id } =
dbNodeContext context_id node_id
resolveContextsForNgrams
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> ContextsForNgramsArgs -> GqlM e env [ContextGQL]
resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms, and_logic } =
dbContextForNgrams corpus_id ngrams_terms and_logic
resolveContextNgrams
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> ContextNgramsArgs -> GqlM e env [Text]
resolveContextNgrams ContextNgramsArgs { context_id, list_id } =
dbContextNgrams context_id list_id
......@@ -139,7 +143,7 @@ resolveContextNgrams ContextNgramsArgs { context_id, list_id } =
-- | Inner function to fetch the node context DB.
dbNodeContext
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> Int -> Int -> GqlM e env [NodeContextGQL]
dbNodeContext context_id node_id = do
-- lift $ printDebug "[dbUsers]" user_id
......@@ -151,7 +155,7 @@ dbNodeContext context_id node_id = do
-- | Returns list of `ContextGQL` for given ngrams in given corpus id.
dbContextForNgrams
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> Int -> [Text] -> Bool -> GqlM e env [ContextGQL]
dbContextForNgrams node_id ngrams_terms and_logic = do
contextsForNgramsTerms <- lift $ runDBQuery $
......@@ -161,7 +165,7 @@ dbContextForNgrams node_id ngrams_terms and_logic = do
-- | Fetch ngrams matching given context in a given list id.
dbContextNgrams
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> Int -> Int -> GqlM e env [Text]
dbContextNgrams context_id list_id = do
lift $ runDBQuery $ getContextNgramsMatchingFTS (UnsafeMkContextId context_id) (UnsafeMkNodeId list_id)
......@@ -221,7 +225,7 @@ toHyperdataRowDocumentGQL hyperdata =
}
HyperdataRowContact { } -> Nothing
updateNodeContextCategory :: (IsDBEnvExtra env)
updateNodeContextCategory :: (IsDBEnvExtra env, GqlLogger env)
=> AuthenticatedUser
-> AccessPolicyManager
-> NodeContextCategoryMArgs
......
......@@ -20,7 +20,7 @@ import Data.Morpheus.Types ( GQLType )
import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
import Gargantext.API.Auth.PolicyCheck ( nodeReadChecks, AccessPolicyManager )
import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
import Gargantext.API.GraphQL.Types ( GqlM )
import Gargantext.API.GraphQL.Types ( GqlM, GqlLogger )
import Gargantext.Core ( HasDBid(lookupDBid) )
import Gargantext.Database.Admin.Types.Node (NodeType)
import Gargantext.Database.Admin.Types.Node qualified as NN
......@@ -57,7 +57,7 @@ data NodeArgs
-- | Function to resolve user from a query.
resolveNodes
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> AuthenticatedUser
-> AccessPolicyManager
-> NodeArgs
......@@ -66,19 +66,19 @@ resolveNodes autUser mgr NodeArgs { node_id } =
withPolicy autUser mgr (nodeReadChecks $ NN.UnsafeMkNodeId node_id) $ dbNodes node_id
resolveNodesCorpus
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> CorpusArgs -> GqlM e env [Corpus]
resolveNodesCorpus CorpusArgs { corpus_id } = dbNodesCorpus corpus_id
dbNodes
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> Int -> GqlM e env [Node]
dbNodes node_id = do
node <- lift $ runDBQuery $ getNode $ NN.UnsafeMkNodeId node_id
pure [toNode node]
dbNodesCorpus
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> Int -> GqlM e env [Corpus]
dbNodesCorpus corpus_id = do
corpus <- lift $ runDBQuery $ getNode $ NN.UnsafeMkNodeId corpus_id
......@@ -97,17 +97,17 @@ data NodeChildrenArgs
} deriving (Generic, GQLType)
resolveNodeParent
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> NodeParentArgs -> GqlM e env [Node]
resolveNodeParent NodeParentArgs { node_id, parent_type } = dbParentNodes node_id parent_type
resolveNodeChildren
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> NodeChildrenArgs -> GqlM e env [Node]
resolveNodeChildren NodeChildrenArgs { node_id, child_type } = dbChildNodes node_id child_type
dbParentNodes
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> Int -> NodeType -> GqlM e env [Node]
dbParentNodes node_id parentType = do
-- let mParentType = readEither (T.unpack parent_type) :: Either Prelude.String NodeType
......@@ -124,7 +124,7 @@ dbParentNodes node_id parentType = do
node <- getNode id
pure [toNode node]
dbChildNodes :: (IsDBEnvExtra env)
dbChildNodes :: (IsDBEnvExtra env, GqlLogger env)
=> Int -> NodeType -> GqlM e env [Node]
dbChildNodes node_id childType = do
lift $ runDBQuery $ do
......
......@@ -16,16 +16,17 @@ import Prelude
import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.Class (lift)
import Data.Morpheus.App.Internal.Resolving (LiftOperation)
import Data.Morpheus.Types (ResolverO)
import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
import Gargantext.API.Auth.PolicyCheck ( BoolExpr, AccessCheck, AccessPolicyManager(..), AccessResult(..))
import Gargantext.API.Errors.Types ( BackendInternalError(..) )
import Gargantext.API.GraphQL.Types (GqlLogger)
import Gargantext.API.Prelude (GargM)
import Gargantext.Core.Config (HasConfig)
import Gargantext.Database.Prelude (HasConnectionPool)
import Data.Morpheus.Types (ResolverO)
import Data.Morpheus.App.Internal.Resolving (LiftOperation)
import Gargantext.API.Prelude (GargM)
withPolicy :: (HasConnectionPool env, HasConfig env, LiftOperation op)
withPolicy :: (HasConnectionPool env, HasConfig env, LiftOperation op, GqlLogger env)
=> AuthenticatedUser
-> AccessPolicyManager
-> BoolExpr AccessCheck
......
......@@ -18,7 +18,7 @@ import Data.Morpheus.Types (GQLType, ResolverM)
import Data.Text qualified as T
import Gargantext.API.Admin.Auth.Types (AuthenticationError(..))
import Gargantext.API.Errors.Types
import Gargantext.API.GraphQL.Types (GqlM)
import Gargantext.API.GraphQL.Types (GqlM, GqlLogger)
import Gargantext.API.GraphQL.Utils (authUser, AuthStatus (Invalid, Valid))
import Gargantext.API.Prelude (GargM)
import Gargantext.Core.Config (HasJWTSettings)
......@@ -53,10 +53,10 @@ data TeamDeleteMArgs = TeamDeleteMArgs
type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
resolveTeam :: (IsDBEnvExtra env) => TeamArgs -> GqlM e env Team
resolveTeam :: (IsDBEnvExtra env, GqlLogger env) => TeamArgs -> GqlM e env Team
resolveTeam TeamArgs { team_node_id } = dbTeam team_node_id
dbTeam :: (IsDBEnvExtra env) =>
dbTeam :: (IsDBEnvExtra env, GqlLogger env) =>
Int -> GqlM e env Team
dbTeam nodeId = do
let nId = UnsafeMkNodeId nodeId
......@@ -79,7 +79,7 @@ dbTeam nodeId = do
getUsername ((UserLight {userLight_username}, _):_) = userLight_username
-- TODO: list as argument
deleteTeamMembership :: (IsDBEnvExtra env, HasJWTSettings env) =>
deleteTeamMembership :: (IsDBEnvExtra env, HasJWTSettings env, GqlLogger env) =>
TeamDeleteMArgs -> GqlM' e env [Int]
deleteTeamMembership TeamDeleteMArgs { token, shared_folder_id, team_node_id } = do
userNodes <- lift $ runDBTx $ do
......
......@@ -18,7 +18,7 @@ import Data.Morpheus.Types (GQLType)
import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(..) )
import Gargantext.API.Auth.PolicyCheck (AccessPolicyManager, nodeReadChecks)
import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
import Gargantext.API.GraphQL.Types ( GqlM )
import Gargantext.API.GraphQL.Types ( GqlM, GqlLogger )
import Gargantext.Core (fromDBid)
-- import Gargantext.Core.Types (ContextId, CorpusId, ListId)
import Gargantext.Core.Types.Main ( Tree(..), _tn_node, _tn_children, NodeTree(..), _nt_name )
......@@ -65,7 +65,7 @@ data BreadcrumbInfo = BreadcrumbInfo
type ParentId = Maybe NodeId
resolveTree :: (IsDBEnvExtra env)
resolveTree :: (IsDBEnvExtra env, GqlLogger env)
=> AuthenticatedUser
-> AccessPolicyManager
-> TreeArgs
......@@ -73,7 +73,7 @@ resolveTree :: (IsDBEnvExtra env)
resolveTree autUser mgr TreeArgs { root_id } =
withPolicy autUser mgr (nodeReadChecks $ UnsafeMkNodeId root_id) $ dbTree (_auth_user_id autUser) root_id
dbTree :: (IsDBEnvExtra env) =>
dbTree :: (IsDBEnvExtra env, GqlLogger env) =>
NN.UserId -> Int -> GqlM e env (TreeFirstLevel (GqlM e env))
dbTree loggedInUserId root_id = do
let rId = UnsafeMkNodeId root_id
......@@ -86,7 +86,7 @@ dbTree loggedInUserId root_id = do
toParentId N.Node { _node_parent_id } = _node_parent_id
toTree :: (IsDBEnvExtra env) => NodeId -> ParentId -> Tree NodeTree -> TreeFirstLevel (GqlM e env)
toTree :: (IsDBEnvExtra env, GqlLogger env) => NodeId -> ParentId -> Tree NodeTree -> TreeFirstLevel (GqlM e env)
toTree rId pId TreeN { _tn_node, _tn_children } = TreeFirstLevel
{ parent = resolveParent pId
, root = toTreeNode pId _tn_node
......@@ -99,7 +99,7 @@ toTreeNode pId NodeTree { _nt_name, _nt_id, _nt_type } = TreeNode { name = _nt_n
childrenToTreeNodes :: (Tree NodeTree, NodeId) -> TreeNode
childrenToTreeNodes (TreeN {_tn_node}, rId) = toTreeNode (Just rId) _tn_node
resolveParent :: (IsDBEnvExtra env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
resolveParent :: (IsDBEnvExtra env, GqlLogger env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
resolveParent (Just pId) = do
node <- lift $ runDBQuery $ getNode pId
pure $ nodeToTreeNode node
......@@ -118,7 +118,7 @@ nodeToTreeNode N.Node {..} =
else
Nothing
resolveBreadcrumb :: (IsDBEnvExtra env) => BreadcrumbArgs -> GqlM e env BreadcrumbInfo
resolveBreadcrumb :: (IsDBEnvExtra env, GqlLogger env) => BreadcrumbArgs -> GqlM e env BreadcrumbInfo
resolveBreadcrumb BreadcrumbArgs { node_id } = dbRecursiveParents node_id
convertDbTreeToTreeNode :: HasCallStack => T.DbTreeNode -> TreeNode
......@@ -131,7 +131,7 @@ convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_par
}
dbRecursiveParents :: (IsDBEnvExtra env) => Int -> GqlM e env BreadcrumbInfo
dbRecursiveParents :: (IsDBEnvExtra env, GqlLogger env) => Int -> GqlM e env BreadcrumbInfo
dbRecursiveParents nodeId = do
let nId = UnsafeMkNodeId nodeId
dbParents <- lift $ runDBQuery $ T.recursiveParents nId allNodeTypes
......
{-# LANGUAGE ConstraintKinds #-}
module Gargantext.API.GraphQL.Types where
import Data.Morpheus.Types
import Gargantext.API.Prelude
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.System.Logging
type GqlLogger env = MonadLogger (GargM env BackendInternalError)
type GqlM e env = Resolver QUERY e (GargM env BackendInternalError)
type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
......@@ -18,7 +18,7 @@ import Data.Morpheus.Types ( GQLType )
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
import Gargantext.API.Auth.PolicyCheck (AccessPolicyManager, nodeReadChecks)
import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
import Gargantext.API.GraphQL.Types (GqlM, GqlM')
import Gargantext.API.GraphQL.Types (GqlM, GqlM', GqlLogger)
import Gargantext.Core.Types (NodeId(..), UserId)
import Gargantext.Core.Types.Individu qualified as Individu
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..))
......@@ -60,7 +60,7 @@ data UserEPOAPITokenMArgs
-- | Function to resolve user from a query.
resolveUsers
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> AuthenticatedUser
-> AccessPolicyManager
-> UserArgs
......@@ -70,12 +70,12 @@ resolveUsers autUser mgr UserArgs { user_id } = do
withPolicy autUser mgr (nodeReadChecks $ UnsafeMkNodeId user_id) $ dbUsers user_id
-- | Inner function to fetch the user from DB.
dbUsers :: (IsDBEnvExtra env)
dbUsers :: (IsDBEnvExtra env, GqlLogger env)
=> Int -> GqlM e env [User (GqlM e env)]
dbUsers user_id = lift (map toUser <$> runDBQuery (DBUser.getUsersWithId (Individu.RootId $ UnsafeMkNodeId user_id)))
toUser
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> UserLight -> User (GqlM e env)
toUser (UserLight { .. }) = User { u_email = userLight_email
, u_hyperdata = resolveHyperdata userLight_id
......@@ -83,25 +83,25 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
, u_username = userLight_username }
resolveHyperdata
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> UserId -> GqlM e env (Maybe HyperdataUser)
resolveHyperdata userid = lift (listToMaybe <$> runDBQuery (DBUser.getUserHyperdata (Individu.UserDBId userid)))
updateUserPubmedAPIKey :: ( IsDBEnvExtra env ) =>
updateUserPubmedAPIKey :: ( IsDBEnvExtra env, GqlLogger env ) =>
UserPubmedAPIKeyMArgs -> GqlM' e env Int
updateUserPubmedAPIKey UserPubmedAPIKeyMArgs { user_id, api_key } = do
_ <- lift $ runDBTx $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ UnsafeMkNodeId user_id) api_key
pure 1
updateUserEPOAPIUser :: ( IsDBEnvExtra env ) =>
updateUserEPOAPIUser :: ( IsDBEnvExtra env, GqlLogger env ) =>
UserEPOAPIUserMArgs -> GqlM' e env Int
updateUserEPOAPIUser UserEPOAPIUserMArgs { user_id, api_user } = do
_ <- lift $ runDBTx $ DBUser.updateUserEPOAPIUser (Individu.RootId $ UnsafeMkNodeId user_id) api_user
pure 1
updateUserEPOAPIToken :: ( IsDBEnvExtra env ) =>
updateUserEPOAPIToken :: ( IsDBEnvExtra env, GqlLogger env ) =>
UserEPOAPITokenMArgs -> GqlM' e env Int
updateUserEPOAPIToken UserEPOAPITokenMArgs { user_id, api_token } = do
_ <- lift $ runDBTx $ DBUser.updateUserEPOAPIToken (Individu.RootId $ UnsafeMkNodeId user_id) api_token
......
......@@ -44,7 +44,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
import Gargantext.API.Auth.PolicyCheck (AccessPolicyManager, userMe)
import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
import Gargantext.API.GraphQL.Types (GqlM, GqlM')
import Gargantext.API.GraphQL.Types (GqlM, GqlM', GqlLogger)
import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser)
import Gargantext.Core.Config (HasJWTSettings)
import Gargantext.Core.Types (UserId(..))
......@@ -109,7 +109,7 @@ data UserInfoMArgs
-- | Function to resolve user from a query.
resolveUserInfos
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> AuthenticatedUser
-> AccessPolicyManager
-> UserInfoArgs -> GqlM e env [UserInfo]
......@@ -119,7 +119,7 @@ resolveUserInfos autUser mgr UserInfoArgs { user_id } =
-- | Mutation for user info
updateUserInfo
:: (IsDBEnvExtra env, HasJWTSettings env)
:: (IsDBEnvExtra env, HasJWTSettings env, GqlLogger env)
-- => UserInfoMArgs -> ResolverM e (GargM env err) Int
=> UserInfoMArgs -> GqlM' e env Int
updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
......@@ -169,7 +169,7 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
-- | Inner function to fetch the user from DB.
dbUsers
:: (IsDBEnvExtra env)
:: (IsDBEnvExtra env, GqlLogger env)
=> UserId -> GqlM e env [UserInfo]
dbUsers user_id = do
-- lift $ printDebug "[dbUsers]" user_id
......
......@@ -81,7 +81,7 @@ getContextNgrams cId lId listType nt repo = do
mkCorpusSQLiteData :: ( CES.MonadMask m
, HasNodeStoryEnv env err
, HasNodeError err
, IsDBCmd env err m )
, IsDBTxCmd env err m )
=> CorpusId
-> Maybe ListId
-> m CorpusSQLiteData
......
......@@ -31,7 +31,7 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Tree (findNodesWithType)
import Gargantext.Prelude
import Servant.Server.Generic (AsServerT)
import qualified Gargantext.Core.Notifications.CentralExchange.Types as CE
import Gargantext.Core.Notifications.CentralExchange.Types qualified as CE
------------------------------------------------------------------------
-- TODO permission
......
......@@ -14,13 +14,13 @@ module Gargantext.Core.Config.Utils (
)
where
import Data.Text qualified as T
import Gargantext.Core.Config
import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Prelude
import Toml
import Gargantext.Core.Config
import System.Environment (lookupEnv)
import Gargantext.System.Logging.Types (parseLogLevel)
import qualified Data.Text as T
import System.Environment (lookupEnv)
import Toml
readConfig :: SettingsFile -> IO GargConfig
......
......@@ -3,7 +3,7 @@ module Gargantext.Core.Text.Corpus (makeSubcorpusFromQuery, subcorpusEasy) where
import Control.Lens (view)
import Data.Set.Internal qualified as Set (singleton)
import Data.Text qualified as T
import Gargantext.API.Dev (runCmdReplEasy)
import Gargantext.API.Dev (runDBTxReplEasy)
import Gargantext.API.Errors.Types (BackendInternalError(InternalNodeError))
import Gargantext.Core (Lang(EN))
import Gargantext.Core.NodeStory.Types (HasNodeStoryEnv, hasNodeStory)
......@@ -40,7 +40,7 @@ subcorpusEasy username cId rawQuery reuseParentList = do
let eitherQuery = Q.parseQuery $ Q.RawQuery rawQuery
case eitherQuery of
Left msg -> print $ "Error parsing query \"" <> rawQuery <> "\": " <> T.pack msg
Right query -> void $ runCmdReplEasy $ makeSubcorpusFromQuery (UserName username) (UnsafeMkNodeId cId) query reuseParentList
Right query -> void $ runDBTxReplEasy $ makeSubcorpusFromQuery (UserName username) (UnsafeMkNodeId cId) query reuseParentList
-- | Given a "parent" corpus and a query, search for all docs in the parent
......
......@@ -42,7 +42,7 @@ import Gargantext.Prelude hiding (to)
type MinSizeBranch = Int
flowPhylo :: (HasNodeStory env err m, HasDBid NodeType, IsDBCmd env err m)
flowPhylo :: (HasNodeStory env err m, HasDBid NodeType, IsDBTxCmd env err m)
=> CorpusId
-> m Phylo
flowPhylo cId = do
......
......@@ -27,8 +27,11 @@ module Gargantext.Database.Action.User.New
import Control.Lens (view)
import Control.Monad.Random
import Data.List.NonEmpty qualified as NE
import Data.Text (splitOn)
import Data.Text qualified as Text
import Gargantext.Core.Config (HasConfig(..))
import Gargantext.Core.Config.Mail (MailConfig)
import Gargantext.Core.Mail
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.Types.Individu
......@@ -39,9 +42,6 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError,
import Gargantext.Database.Query.Table.User
import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Pass.User (gargPass)
import Gargantext.Core.Config.Mail (MailConfig)
import qualified Data.List.NonEmpty as NE
import Gargantext.Core.Config (HasConfig(..))
------------------------------------------------------------------------
-- | Creates a new 'User' from the input 'EmailAddress', which needs to
......
......@@ -23,7 +23,7 @@ import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
-- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
import Database.PostgreSQL.Simple qualified as DPS
triggerCountInsert :: HasDBid NodeType => DBUpdate err Int64
triggerCountInsert = mkPGUpdate query (toDBid NodeDocument, toDBid NodeList)
......
......@@ -23,7 +23,7 @@ import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
import Database.PostgreSQL.Simple qualified as DPS
type MasterListId = ListId
......
......@@ -13,6 +13,7 @@ import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
import Gargantext.Prelude
import Gargantext.System.Logging.Types (MonadLogger)
-- $typesAndConstraints
--
......@@ -77,6 +78,9 @@ type IsCmd env err m =
type IsDBCmd env err m =
( IsCmd env err m
, IsDBEnv env
-- Due to the fact that a 'DBCmd' is essentially a DBTxCmd but with the ability to acquire
-- a configuration, it makes sense for it to be able to emit logging messages.
, MonadLogger m
)
-- | Full-fledged command class. Types in this class provide commands that can
......@@ -84,6 +88,7 @@ type IsDBCmd env err m =
type IsDBCmdExtra env err m =
( IsCmd env err m
, IsDBEnvExtra env
, MonadLogger m
)
-- | Basic command with access to randomness. It feels a little ad hoc to have
......
......@@ -75,7 +75,6 @@ import Shelly qualified as SH
import System.Directory (removeFile)
import System.IO.Temp (emptySystemTempFile)
type JSONB = DefaultFromField SqlJsonb
-- FIXME(adinapoli): Using this function is dangerous and it should
......@@ -91,7 +90,7 @@ withConn k = do
runCmd :: (Show err, Typeable err)
=> env
-> CmdRandom env err a
-> ReaderT env (ExceptT err IO) a
-> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env
......
......@@ -73,6 +73,7 @@ import Control.Arrow (returnA)
import Control.Lens (set, view)
import Data.Aeson ( encode, Value )
import Data.Bimap ((!>))
import Data.List.NonEmpty qualified as NE
import Database.PostgreSQL.Simple qualified as PGS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.API.Errors.Types (BackendInternalError (..))
......@@ -93,7 +94,6 @@ import Gargantext.Database.Schema.Node
import Gargantext.Prelude hiding (sum, head)
import Opaleye hiding (FromField)
import Prelude hiding (null, id, map, sum)
import qualified Data.List.NonEmpty as NE
queryNodeSearchTable :: Select NodeSearchRead
......
......@@ -53,24 +53,24 @@ module Gargantext.Database.Query.Table.NodeNode
import Control.Arrow (returnA)
import Control.Lens (view)
import Control.Lens qualified as L
import Data.Text (splitOn)
import Database.PostgreSQL.Simple qualified as PGS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..), Only (..))
import Data.Text (splitOn)
import Gargantext.Core ( HasDBid(toDBid) )
import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument, hd_publication_date )
import Gargantext.Database.Admin.Types.Hyperdata.Prelude ( Hyperdata )
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Schema.Ngrams ()
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.NodeNode
import Gargantext.Prelude
import Opaleye
import Opaleye qualified as O
import qualified Control.Lens as L
queryNodeNodeTable :: Select NodeNodeRead
queryNodeNodeTable = selectTable nodeNodeTable
......
......@@ -324,7 +324,7 @@ insertNewUsers newUsers = do
-- | Insert into the DB users with a clear-text password after conversion
-- via 'toUserHash'. This function is labeled \"unsafe\" because it doesn't
-- compose as far as DB transactional safety.
unsafeInsertHashNewUsers :: NonEmpty (NewUser GargPassword) -> DBCmd err Int64
unsafeInsertHashNewUsers :: NonEmpty (NewUser GargPassword) -> DBTxCmd err Int64
unsafeInsertHashNewUsers newUsers = do
hashed <- liftBase $ mapM toUserHash newUsers
runDBTx $ insertNewUsers hashed
......
......@@ -3,6 +3,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
{--| This module exposes a custom monad and functions to model database operations within Gargantext.
The peculiarity of the custom monad is that it describe a DSL for the operations we wish to perform,
......@@ -19,6 +20,7 @@ module Gargantext.Database.Transactional (
, DBUpdate
, DBQuery
, DBTxCmd
, IsDBTxCmd
-- * Executing queries and updates
, runDBQuery
, runDBTx
......@@ -163,13 +165,14 @@ type DBReadOnly err r a = DBTx err DBRead a
-- Strict constraints to perform transactional read and writes.
-- Isomorphic to a DBCmd, but it doesn't impose a 'HasConfig' constraint, as
-- values can always be passed as parameters of a query or update.
type DBTxCmd err a =
forall m env. (
IsCmd env err m
, HasConnectionPool env
, Safe.MonadCatch m
, MonadLogger m
) => m a
type DBTxCmd err a = forall m env. IsDBTxCmd env err m => m a
type IsDBTxCmd env err m =
( IsCmd env err m
, HasConnectionPool env
, Safe.MonadCatch m
, MonadLogger m
)
instance Functor (DBTransactionOp err r) where
fmap f = \case
......
......@@ -5,6 +5,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-| Tests for the transactional DB API -}
......@@ -30,11 +32,16 @@ import Database.PostgreSQL.Simple.Options qualified as Client
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.ToField
import Database.Postgres.Temp qualified as Tmp
import Gargantext.Core.Config (LogConfig(..))
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.User
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.User
import Gargantext.Database.Schema.Prelude (Table (..))
import Gargantext.Database.Transactional
import Gargantext.Prelude hiding (throwIO, catch)
import Gargantext.System.Logging.Loggers
import Gargantext.System.Logging.Types
import Opaleye (selectTable, requiredTableField, SqlInt4)
import Opaleye qualified as O
import Prelude qualified
......@@ -43,11 +50,9 @@ import System.Random.Stateful
import Test.API.Setup (setupEnvironment)
import Test.Database.Setup
import Test.Database.Types hiding (Counter)
import Test.Hspec
import Test.HUnit hiding (assert)
import Test.Hspec
import Text.RawString.QQ
import Gargantext.Database.Action.User
import Gargantext.Database.Query.Table.Node.Error
--
-- For these tests we do not want to test the normal GGTX database queries, but rather
......@@ -97,6 +102,23 @@ newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle
, MonadThrow
)
instance HasLogger (TestMonadM DBHandle err) where
data instance Logger (TestMonadM DBHandle err) = TestLogger1 { _IOLogger1 :: IOStdLogger }
type instance LogInitParams (TestMonadM DBHandle err) = LogConfig
type instance LogPayload (TestMonadM DBHandle err) = Prelude.String
initLogger cfg = fmap TestLogger1 $ (liftIO $ ioStdLogger cfg)
destroyLogger = liftIO . _iosl_destroy . _IOLogger1
logMsg (TestLogger1 ioLogger) lvl msg = liftIO $ _iosl_log_msg ioLogger lvl msg
logTxt (TestLogger1 ioLogger) lvl msg = liftIO $ _iosl_log_txt ioLogger lvl msg
instance MonadLogger (TestMonadM DBHandle IOException) where
getLogger = TestMonad $ do
initLogger @(TestMonadM DBHandle IOException) (LogConfig Nothing ERROR)
instance MonadLogger (TestMonadM TestEnv NodeError) where
getLogger = TestMonad $ do
initLogger @(TestMonadM TestEnv NodeError) (LogConfig Nothing ERROR)
runTestDBTxMonad :: DBHandle -> TestMonadM DBHandle IOException a -> IO a
runTestDBTxMonad env m = do
res <- flip runReaderT env . runExceptT . _TestMonad $ m
......
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