Commit 405a3082 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

GargError -> BackendInternalError

parent 8a474bbb
......@@ -16,7 +16,7 @@ Portability : POSIX
module Main where
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Prelude (GargError)
import Gargantext.API.Errors.Types
import Gargantext.Database.Action.User.New (newUsers)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd'')
......@@ -28,6 +28,6 @@ main = do
(iniPath:mails) <- getArgs
withDevEnv iniPath $ \env -> do
x <- runCmdDev env ((newUsers $ map cs mails) :: Cmd'' DevEnv GargError [UserId])
x <- runCmdDev env ((newUsers $ map cs mails) :: Cmd'' DevEnv BackendInternalError [UserId])
putStrLn (show x :: Text)
pure ()
......@@ -20,8 +20,8 @@ import qualified Data.Text as Text
import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..))
import Gargantext.API.Errors.Types
import Gargantext.API.Node () -- instances
import Gargantext.API.Prelude (GargError)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Query (Limit)
......@@ -45,17 +45,17 @@ main = do
limit' = case (readMaybe limit :: Maybe Limit) of
Nothing -> panic $ "Cannot read limit: " <> (Text.pack limit)
Just l -> l
corpus :: forall m. (FlowCmdM DevEnv GargError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
corpus :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt format Plain corpusPath Nothing DevJobHandle
corpusCsvHal :: forall m. (FlowCmdM DevEnv GargError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
corpusCsvHal :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt CsvHal Plain corpusPath Nothing DevJobHandle
annuaire :: forall m. (FlowCmdM DevEnv GargError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath DevJobHandle
{-
let debatCorpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
let debatCorpus :: forall m. FlowCmdM DevEnv BackendInternalError m => m CorpusId
debatCorpus = do
docs <- liftIO ( splitEvery 500
<$> take (read limit :: Int)
......
......@@ -16,8 +16,8 @@ Import a corpus binary.
module Main where
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Errors.Types
import Gargantext.API.Node () -- instances only
import Gargantext.API.Prelude (GargError)
import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..))
import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMk_RootWithCorpus)
import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
......@@ -48,18 +48,18 @@ main = do
cfg <- readConfig iniPath
let secret = _gc_secretkey cfg
let createUsers :: Cmd GargError Int64
let createUsers :: Cmd BackendInternalError Int64
createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)
: arbitraryNewUsers
)
let
mkRoots :: Cmd GargError [(UserId, RootId)]
mkRoots :: Cmd BackendInternalError [(UserId, RootId)]
mkRoots = mapM getOrMkRoot $ map UserName ("gargantua" : arbitraryUsername)
-- TODO create all users roots
let
initMaster :: Cmd GargError (UserId, RootId, CorpusId, ListId)
initMaster :: Cmd BackendInternalError (UserId, RootId, CorpusId, ListId)
initMaster = do
(masterUserId, masterRootId, masterCorpusId)
<- getOrMk_RootWithCorpus (UserName userMaster)
......@@ -70,7 +70,7 @@ main = do
pure (masterUserId, masterRootId, masterCorpusId, masterListId)
withDevEnv iniPath $ \env -> do
_ <- runCmdDev env (initFirstTriggers secret :: DBCmd GargError [Int64])
_ <- runCmdDev env (initFirstTriggers secret :: DBCmd BackendInternalError [Int64])
_ <- runCmdDev env createUsers
x <- runCmdDev env initMaster
_ <- runCmdDev env mkRoots
......
......@@ -16,7 +16,7 @@ module Main where
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Node () -- instances only
import Gargantext.API.Prelude (GargError)
import Gargantext.API.Errors.Types
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Admin.Types.Node
......@@ -36,7 +36,7 @@ main = do
_cfg <- readConfig iniPath
let invite :: (CmdRandom env GargError m, HasNLPServer env) => m Int
let invite :: (CmdRandom env BackendInternalError m, HasNLPServer env) => m Int
invite = Share.api (UserName $ cs user) (UnsafeMkNodeId $ (read node_id :: Int)) (Share.ShareTeamParams $ cs email)
withDevEnv iniPath $ \env -> do
......
......@@ -52,6 +52,7 @@ library
Gargantext.API.Auth.PolicyCheck
Gargantext.API.Dev
Gargantext.API.Errors
Gargantext.API.Errors.Class
Gargantext.API.Errors.Types
Gargantext.API.HashedResponse
Gargantext.API.Ngrams
......
......@@ -53,7 +53,7 @@ import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types
import Gargantext.API.Auth.PolicyCheck
import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer, _ServerError, GargM, GargError (..))
import Gargantext.API.Prelude (joseError, HasServerError, GargServerC, GargServer, _ServerError, GargM)
import Gargantext.Core.Mail (MailModel(..), mail)
import Gargantext.Core.Mail.Types (mailSettings)
import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
......@@ -72,6 +72,7 @@ import Gargantext.Prelude.Crypto.Pass.User (gargPass)
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Servant
import Servant.Auth.Server
import Gargantext.API.Errors
---------------------------------------------------
......@@ -163,7 +164,7 @@ withAccess p _ ur id = hoistServer p f
-- | Given the 'AuthenticatedUser', a policy check and a function that returns an @a@,
-- it runs the underlying policy check to ensure that the resource is returned only to
-- who is entitled to see it.
withPolicy :: GargServerC env GargError m
withPolicy :: GargServerC env BackendInternalError m
=> AuthenticatedUser
-> BoolExpr AccessCheck
-> m a
......@@ -174,10 +175,10 @@ withPolicy ur checks m mgr = case mgr of
res <- runAccessPolicy ur checks
case res of
Allow -> m
Deny err -> throwError $ GargServerError $ err
Deny err -> throwError $ InternalServerError $ err
withPolicyT :: forall env m api. (
GargServerC env GargError m
GargServerC env BackendInternalError m
, HasServer api '[]
)
=> Proxy api
......@@ -309,7 +310,7 @@ generateForgotPasswordUUID = do
type ForgotPasswordAsyncAPI = Summary "Forgot password asnc"
:> AsyncJobs JobLog '[JSON] ForgotPasswordAsyncParams JobLog
forgotPasswordAsync :: ServerT ForgotPasswordAsyncAPI (GargM Env GargError)
forgotPasswordAsync :: ServerT ForgotPasswordAsyncAPI (GargM Env BackendInternalError)
forgotPasswordAsync =
serveJobsAPI ForgotPasswordJob $ \jHandle p -> forgotPasswordAsync' p jHandle
......
......@@ -32,8 +32,9 @@ import Data.Text qualified as T
import Database.PostgreSQL.Simple (Connection)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Job
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.API.Prelude (GargM)
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
import Gargantext.Core.NodeStory
......@@ -64,17 +65,17 @@ modeToLoggingLevels = \case
-- For production, accepts everything but DEBUG.
Prod -> [minBound .. maxBound] \\ [DEBUG]
instance MonadLogger (GargM Env GargError) where
instance MonadLogger (GargM Env BackendInternalError) where
getLogger = asks _env_logger
instance HasLogger (GargM Env GargError) where
data instance Logger (GargM Env GargError) =
instance HasLogger (GargM Env BackendInternalError) where
data instance Logger (GargM Env BackendInternalError) =
GargLogger {
logger_mode :: Mode
, logger_set :: FL.LoggerSet
}
type instance LogInitParams (GargM Env GargError) = Mode
type instance LogPayload (GargM Env GargError) = FL.LogStr
type instance LogInitParams (GargM Env BackendInternalError) = Mode
type instance LogPayload (GargM Env BackendInternalError) = FL.LogStr
initLogger = \mode -> do
logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
pure $ GargLogger mode logger_set
......@@ -111,7 +112,7 @@ data GargJob
-- we need to remember to force the fields to WHNF at that point.
data Env = Env
{ _env_settings :: ~Settings
, _env_logger :: ~(Logger (GargM Env GargError))
, _env_logger :: ~(Logger (GargM Env BackendInternalError))
, _env_pool :: ~(Pool Connection)
, _env_nodeStory :: ~NodeStoryEnv
, _env_manager :: ~Manager
......@@ -234,17 +235,17 @@ data MockEnv = MockEnv
makeLenses ''MockEnv
instance MonadLogger (GargM DevEnv GargError) where
instance MonadLogger (GargM DevEnv BackendInternalError) where
getLogger = asks _dev_env_logger
instance HasLogger (GargM DevEnv GargError) where
data instance Logger (GargM DevEnv GargError) =
instance HasLogger (GargM DevEnv BackendInternalError) where
data instance Logger (GargM DevEnv BackendInternalError) =
GargDevLogger {
dev_logger_mode :: Mode
, dev_logger_set :: FL.LoggerSet
}
type instance LogInitParams (GargM DevEnv GargError) = Mode
type instance LogPayload (GargM DevEnv GargError) = FL.LogStr
type instance LogInitParams (GargM DevEnv BackendInternalError) = Mode
type instance LogPayload (GargM DevEnv BackendInternalError) = FL.LogStr
initLogger = \mode -> do
dev_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
pure $ GargDevLogger mode dev_logger_set
......@@ -258,7 +259,7 @@ instance HasLogger (GargM DevEnv GargError) where
data DevEnv = DevEnv
{ _dev_env_settings :: !Settings
, _dev_env_config :: !GargConfig
, _dev_env_logger :: !(Logger (GargM DevEnv GargError))
, _dev_env_logger :: !(Logger (GargM DevEnv BackendInternalError))
, _dev_env_pool :: !(Pool Connection)
, _dev_env_nodeStory :: !NodeStoryEnv
, _dev_env_mail :: !MailConfig
......
......@@ -28,6 +28,7 @@ import Data.Pool (Pool, createPool)
import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Core.NLP (nlpServerMap)
import Gargantext.Core.NodeStory
......@@ -171,7 +172,7 @@ readRepoEnv repoDir = do
devJwkFile :: FilePath
devJwkFile = "dev.jwk"
newEnv :: Logger (GargM Env GargError) -> PortNumber -> FilePath -> IO Env
newEnv :: Logger (GargM Env BackendInternalError) -> PortNumber -> FilePath -> IO Env
newEnv logger port file = do
!manager_env <- newTlsManager
!settings' <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
......
......@@ -21,24 +21,24 @@ module Gargantext.API.Auth.PolicyCheck (
) where
import Control.Lens
import Control.Monad
import Data.BoolExpr
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Errors.Types
import Gargantext.Core.Types
import Gargantext.Core.Types.Individu
import Gargantext.Database.Prelude (DBCmd, HasConfig (..))
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Tree
import Gargantext.Database.Query.Tree.Root
import Gargantext.Prelude.Config (GargConfig(..))
import Prelude
import Servant
import Servant.Auth.Server.Internal.AddSetCookie
import Servant.Ekg
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO
import qualified Servant.Swagger as Swagger
import Gargantext.Core.Types.Individu
import Gargantext.Database.Query.Table.Node.Error
import Data.BoolExpr
import Control.Monad
import Gargantext.API.Prelude
import Servant.Auth.Server.Internal.AddSetCookie
import Gargantext.Database.Query.Tree
import Gargantext.Database.Query.Tree.Root
-------------------------------------------------------------------------------
-- Types
......@@ -66,7 +66,7 @@ instance Monoid AccessResult where
-- | An access policy manager for gargantext that governs how resources are accessed
-- and who is entitled to see what.
data AccessPolicyManager = AccessPolicyManager
{ runAccessPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd GargError AccessResult }
{ runAccessPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd BackendInternalError AccessResult }
-- | A type representing all the possible access checks we might want to perform on a resource,
-- typically a 'Node'.
......@@ -97,7 +97,7 @@ data AccessCheck
accessPolicyManager :: AccessPolicyManager
accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
where
interpretPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd GargError AccessResult
interpretPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd BackendInternalError AccessResult
interpretPolicy ur chk = case chk of
BAnd b1 b2
-> liftM2 (<>) (interpretPolicy ur b1) (interpretPolicy ur b2)
......
......@@ -15,6 +15,7 @@ module Gargantext.API.Dev where
import Control.Monad (fail)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Settings
import Gargantext.API.Errors.Types
import Gargantext.API.Ngrams (saveNodeStoryImmediate)
import Gargantext.API.Prelude
import Gargantext.Core.NLP (nlpServerMap)
......@@ -69,7 +70,7 @@ runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
runCmdDev env f =
(either (fail . show) pure =<< runCmd env f)
runCmdGargDev :: DevEnv -> GargM DevEnv GargError a -> IO a
runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a
runCmdGargDev env cmd =
(either (fail . show) pure =<< runExceptT (runReaderT cmd env))
`finally`
......@@ -81,5 +82,5 @@ runCmdDevNoErr = runCmdDev
runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
runCmdDevServantErr = runCmdDev
runCmdReplEasy :: Cmd'' DevEnv GargError a -> IO a
runCmdReplEasy :: Cmd'' DevEnv BackendInternalError a -> IO a
runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
{-# LANGUAGE LambdaCase #-}
module Gargantext.API.Errors (
module Types
module Types
, module Class
-- * Conversion functions
, backendErrorTypeToErrStatus
, backendErrorToFrontendError
-- * Temporary shims
, showAsServantJSONErr
) where
import Prelude
import Gargantext.API.Errors.Class as Class
import Gargantext.API.Errors.Types as Types
import Gargantext.Database.Query.Table.Node.Error
import Servant.Server
import qualified Data.Aeson as JSON
import qualified Network.HTTP.Types.Status as HTTP
backendErrorTypeToErrStatus :: BackendErrorType -> HTTP.Status
backendErrorTypeToErrStatus = \case
_backendErrorTypeToErrStatus :: BackendErrorType -> HTTP.Status
_backendErrorTypeToErrStatus = \case
BE_phylo_corpus_not_ready -> HTTP.status500
BE_node_not_found -> HTTP.status500
BE_tree_error_root_not_found -> HTTP.status404
-- | Transforms a backend internal error into something that the frontend
-- can consume. This is the only representation we offer to the outside world,
-- as we later encode this into a 'ServerError' in the main server handler.
backendErrorToFrontendError :: BackendInternalError -> FrontendError
backendErrorToFrontendError = \case
InternalNodeError _nodeError
-> undefined
InternalTreeError _treeError
-> undefined
InternalValidationError _validationError
-> undefined
InternalJoseError _joseError
-> undefined
InternalServerError _internalServerError
-> undefined
InternalJobError _jobError
-> undefined
showAsServantJSONErr :: BackendInternalError -> ServerError
showAsServantJSONErr (InternalNodeError err@(NoListFound {})) = err404 { errBody = JSON.encode err }
showAsServantJSONErr (InternalNodeError err@NoRootFound) = err404 { errBody = JSON.encode err }
showAsServantJSONErr (InternalNodeError err@NoCorpusFound) = err404 { errBody = JSON.encode err }
showAsServantJSONErr (InternalNodeError err@NoUserFound{}) = err404 { errBody = JSON.encode err }
showAsServantJSONErr (InternalNodeError err@(DoesNotExist {})) = err404 { errBody = JSON.encode err }
showAsServantJSONErr (InternalServerError err) = err
showAsServantJSONErr a = err500 { errBody = JSON.encode a }
module Gargantext.API.Errors.Class where
import Control.Lens
import Crypto.JOSE.Error as Jose
class HasJoseError e where
_JoseError :: Prism' e Jose.Error
......@@ -16,8 +16,9 @@ module Gargantext.API.Errors.Types (
-- * The main frontend error type
FrontendError(..)
-- * The enumeration of all possible backend error types
-- * The internal backend type and an enumeration of all possible backend error types
, BackendErrorType(..)
, BackendInternalError(..)
-- * Constructing frontend errors
, mkFrontendErr
......@@ -32,18 +33,29 @@ module Gargantext.API.Errors.Types (
) where
import Control.Exception
import Control.Lens (makePrisms)
import Data.Aeson as JSON
import Data.Aeson.Types (typeMismatch)
import Data.Aeson.Types (typeMismatch, emptyArray)
import Data.Kind
import Data.Singletons.TH
import Data.Typeable
import Data.Validity (Validation)
import GHC.Generics
import GHC.Stack
import Gargantext.API.Errors.Class
import Gargantext.Core.Types (HasValidationError(..))
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Tree.Error
import Prelude
import Servant (ServerError)
import Servant.Job.Core
import Test.QuickCheck
import Test.QuickCheck.Instances.Text ()
import qualified Crypto.JWT as Jose
import qualified Data.Text as T
import qualified Gargantext.Utils.Jobs.Monad as Jobs
import qualified Servant.Job.Types as SJ
-- | A 'WithStacktrace' carries an error alongside its
-- 'CallStack', to be able to print the correct source location
......@@ -58,6 +70,49 @@ instance Exception e => Exception (WithStacktrace e) where
displayException WithStacktrace{..}
= displayException ct_error <> "\n" <> prettyCallStack ct_callStack
-------------------------------------------------------------------
-- | An internal error which can be emitted from the backend and later
-- converted into a 'FrontendError', for later consumption.
data BackendInternalError
= InternalNodeError !NodeError
| InternalTreeError !TreeError
| InternalValidationError !Validation
| InternalJoseError !Jose.Error
| InternalServerError !ServerError
| InternalJobError !Jobs.JobError
deriving (Show, Typeable)
makePrisms ''BackendInternalError
instance ToJSON BackendInternalError where
toJSON (InternalJobError s) =
object [ ("status", toJSON SJ.IsFailure)
, ("log", emptyArray)
, ("id", String mk_id)
, ("error", String $ T.pack $ show s) ]
where
mk_id = case s of
Jobs.InvalidMacID i -> i
_ -> ""
toJSON err = object [("error", String $ T.pack $ show err)]
instance Exception BackendInternalError
instance HasNodeError BackendInternalError where
_NodeError = _InternalNodeError
instance HasValidationError BackendInternalError where
_ValidationError = _InternalValidationError
instance HasTreeError BackendInternalError where
_TreeError = _InternalTreeError
instance HasServerError BackendInternalError where
_ServerError = _InternalServerError
instance HasJoseError BackendInternalError where
_JoseError = _InternalJoseError
-- | A (hopefully and eventually) exhaustive list of backend errors.
data BackendErrorType
= BE_phylo_corpus_not_ready
......
......@@ -28,6 +28,7 @@ import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
import Gargantext.API.Admin.Orchestrator.Types (JobLog)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Auth.PolicyCheck
import Gargantext.API.Errors.Types
import Gargantext.API.GraphQL.Annuaire qualified as GQLA
import Gargantext.API.GraphQL.AsyncTask qualified as GQLAT
import Gargantext.API.GraphQL.Context qualified as GQLCTX
......@@ -38,7 +39,7 @@ import Gargantext.API.GraphQL.Team qualified as GQLTeam
import Gargantext.API.GraphQL.TreeFirstLevel qualified as GQLTree
import Gargantext.API.GraphQL.User qualified as GQLUser
import Gargantext.API.GraphQL.UserInfo qualified as GQLUserInfo
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.API.Prelude (GargM)
import Gargantext.API.Prelude (HasJobEnv')
import Gargantext.API.Types
import Gargantext.Core.NLP (HasNLPServer)
......@@ -106,7 +107,7 @@ rootResolver
:: (CmdCommon env, HasNLPServer env, HasJobEnv' env, HasSettings env)
=> AuthenticatedUser
-> AccessPolicyManager
-> RootResolver (GargM env GargError) e Query Mutation Undefined
-> RootResolver (GargM env BackendInternalError) e Query Mutation Undefined
rootResolver authenticatedUser policyManager =
RootResolver
{ queryResolver = Query { annuaire_contacts = GQLA.resolveAnnuaireContacts
......@@ -135,7 +136,7 @@ app
:: (Typeable env, CmdCommon env, HasJobEnv' env, HasNLPServer env, HasSettings env)
=> AuthenticatedUser
-> AccessPolicyManager
-> App (EVENT (GargM env GargError)) (GargM env GargError)
-> App (EVENT (GargM env BackendInternalError)) (GargM env BackendInternalError)
app authenticatedUser policyManager = deriveApp (rootResolver authenticatedUser policyManager)
----------------------------------------------
......@@ -172,6 +173,6 @@ gqapi = Proxy
--api :: Server API
api
:: (Typeable env, CmdCommon env, HasJobEnv' env, HasSettings env)
=> ServerT API (GargM env GargError)
=> ServerT API (GargM env BackendInternalError)
api (SAS.Authenticated auser) = (httpPubApp [] . app auser) :<|> pure httpPlayground
api _ = panic "401 in graphql" -- SAS.throwAll (_ServerError # err401)
......@@ -18,7 +18,8 @@ import Data.IntMap.Strict qualified as IntMap
import Data.Map.Strict qualified as Map
import Data.Morpheus.Types ( GQLType, Resolver, QUERY )
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
import Gargantext.API.Prelude (GargM, GargError, HasJobEnv')
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude (GargM, HasJobEnv')
import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
import Gargantext.Prelude
import Servant.Job.Async (HasJobEnv(job_env), jenv_jobs, job_async)
......@@ -29,7 +30,7 @@ data JobLogArgs
{ job_log_id :: Int
} deriving (Generic, GQLType)
type GqlM e env = Resolver QUERY e (GargM env GargError)
type GqlM e env = Resolver QUERY e (GargM env BackendInternalError)
resolveJobLogs
:: (HasConnectionPool env, HasConfig env, HasJobEnv' env)
......
......@@ -25,7 +25,8 @@ import Data.Morpheus.Types
import Data.Text (pack)
import Data.Time.Format.ISO8601 (iso8601Show)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude (GargM)
import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument)
import Gargantext.Database.Admin.Types.Node (ContextTitle, NodeId(..), NodeTypeId, UserId, unNodeId, ContextId (..))
......@@ -109,8 +110,8 @@ data ContextNgramsArgs
, list_id :: Int }
deriving (Generic, GQLType)
type GqlM e env = Resolver QUERY e (GargM env GargError)
type GqlM' e env a = ResolverM e (GargM env GargError) a
type GqlM e env = Resolver QUERY e (GargM env BackendInternalError)
type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
-- GQL API
......
......@@ -6,8 +6,8 @@ import Prelude
import Control.Monad.Except
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Auth.PolicyCheck
import Gargantext.API.Errors.Types
import Gargantext.API.GraphQL.Types
import Gargantext.API.Prelude
import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
withPolicy :: (HasConnectionPool env, HasConfig env)
......@@ -21,5 +21,5 @@ withPolicy ur mgr checks m = case mgr of
res <- lift $ runAccessPolicy ur checks
case res of
Allow -> m
Deny err -> lift $ throwError $ GargServerError $ err
Deny err -> lift $ throwError $ InternalServerError $ err
......@@ -17,9 +17,10 @@ module Gargantext.API.GraphQL.Team where
import Data.Morpheus.Types (GQLType, ResolverM)
import Data.Text qualified as T
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Errors.Types
import Gargantext.API.GraphQL.Types (GqlM)
import Gargantext.API.GraphQL.Utils (authUser, AuthStatus (Invalid, Valid))
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.API.Prelude (GargM)
import Gargantext.Core.Types (NodeId(..), unNodeId)
import Gargantext.Core.Types.Individu qualified as Individu
import Gargantext.Database.Action.Share (membersOf, deleteMemberShip)
......@@ -49,7 +50,7 @@ data TeamDeleteMArgs = TeamDeleteMArgs
, team_node_id :: Int
} deriving (Generic, GQLType)
type GqlM' e env a = ResolverM e (GargM env GargError) a
type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
resolveTeam :: (CmdCommon env) => TeamArgs -> GqlM e env Team
resolveTeam TeamArgs { team_node_id } = dbTeam team_node_id
......
......@@ -3,6 +3,7 @@ module Gargantext.API.GraphQL.Types where
import Data.Morpheus.Types
import Gargantext.API.Prelude
import Gargantext.API.Errors.Types
type GqlM e env = Resolver QUERY e (GargM env GargError)
type GqlM' e env a = ResolverM e (GargM env GargError) a
type GqlM e env = Resolver QUERY e (GargM env BackendInternalError)
type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
......@@ -11,21 +11,22 @@ Portability : POSIX
module Gargantext.API.Members where
import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Database.Admin.Types.Node (NodeType(NodeTeam))
import Gargantext.Database.Query.Table.Node (getNodesIdWithType)
import Gargantext.Database.Action.Share (membersOf)
import Gargantext.Database.Admin.Types.Node (NodeType(NodeTeam))
import Gargantext.Database.Prelude (CmdCommon)
import Gargantext.Database.Query.Table.Node (getNodesIdWithType)
import Gargantext.Prelude
import Servant
type MembersAPI = Get '[JSON] [Text]
members :: ServerT MembersAPI (GargM Env GargError)
members :: ServerT MembersAPI (GargM Env BackendInternalError)
members = getMembers
getMembers :: (CmdCommon env) =>
GargM env GargError [Text]
GargM env BackendInternalError [Text]
getMembers = do
teamNodeIds <- getNodesIdWithType NodeTeam
m <- concatMapM membersOf teamNodeIds
......
......@@ -104,12 +104,13 @@ import Formatting (hprint, int, (%))
import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Errors.Types
import Gargantext.API.Metrics qualified as Metrics
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude
import Gargantext.Core.NodeStory
import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, TODO, assertValid, HasInvalidError, ContextId)
import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, TODO, assertValid, HasValidationError, ContextId)
import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast)
import Gargantext.Database.Admin.Config (userMaster)
......@@ -382,7 +383,7 @@ tableNgramsPull listId ngramsType p_version = do
tableNgramsPut :: ( HasNodeStory env err m
, HasNodeStoryImmediateSaver env
, HasNodeArchiveStoryImmediateSaver env
, HasInvalidError err
, HasValidationError err
)
=> TabType
-> ListId
......@@ -790,21 +791,21 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
getTableNgrams dId listId tabType searchQuery
apiNgramsTableCorpus :: NodeId -> ServerT TableNgramsApi (GargM Env GargError)
apiNgramsTableCorpus :: NodeId -> ServerT TableNgramsApi (GargM Env BackendInternalError)
apiNgramsTableCorpus cId = getTableNgramsCorpus cId
:<|> tableNgramsPut
:<|> scoresRecomputeTableNgrams cId
:<|> getTableNgramsVersion cId
:<|> apiNgramsAsync cId
apiNgramsTableDoc :: DocId -> ServerT TableNgramsApi (GargM Env GargError)
apiNgramsTableDoc :: DocId -> ServerT TableNgramsApi (GargM Env BackendInternalError)
apiNgramsTableDoc dId = getTableNgramsDoc dId
:<|> tableNgramsPut
:<|> scoresRecomputeTableNgrams dId
:<|> getTableNgramsVersion dId
:<|> apiNgramsAsync dId
apiNgramsAsync :: NodeId -> ServerT TableNgramsAsyncApi (GargM Env GargError)
apiNgramsAsync :: NodeId -> ServerT TableNgramsAsyncApi (GargM Env BackendInternalError)
apiNgramsAsync _dId =
serveJobsAPI TableNgramsJob $ \jHandle i -> withTracer (printDebug "tableNgramsPostChartsAsync") jHandle $
\jHandle' -> tableNgramsPostChartsAsync i jHandle'
......
......@@ -28,11 +28,12 @@ import Data.Vector (Vector)
import Data.Vector qualified as Vec
import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Ngrams (setListNgrams)
import Gargantext.API.Ngrams.List.Types
import Gargantext.API.Ngrams.Prelude (getNgramsList)
import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude (GargServer, GargM, GargError)
import Gargantext.API.Prelude (GargServer, GargM)
import Gargantext.API.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Types.Main (ListType(..))
......@@ -50,6 +51,7 @@ import Gargantext.Utils.Servant qualified as GUS
import Prelude qualified
import Protolude qualified as P
import Servant
------------------------------------------------------------------------
type GETAPI = Summary "Get List"
:> "lists"
......@@ -72,7 +74,7 @@ type JSONAPI = Summary "Update List"
:> "async"
:> AsyncJobs JobLog '[FormUrlEncoded] WithJsonFile JobLog
jsonApi :: ServerT JSONAPI (GargM Env GargError)
jsonApi :: ServerT JSONAPI (GargM Env BackendInternalError)
jsonApi = jsonPostAsync
----------------------
......@@ -85,7 +87,7 @@ type CSVAPI = Summary "Update List (legacy v3 CSV)"
:> "async"
:> AsyncJobs JobLog '[FormUrlEncoded] WithTextFile JobLog
csvApi :: ServerT CSVAPI (GargM Env GargError)
csvApi :: ServerT CSVAPI (GargM Env BackendInternalError)
csvApi = csvPostAsync
------------------------------------------------------------------------
......@@ -135,7 +137,7 @@ toIndexedNgrams m t = Indexed <$> i <*> n
n = Just (text2ngrams t)
------------------------------------------------------------------------
jsonPostAsync :: ServerT JSONAPI (GargM Env GargError)
jsonPostAsync :: ServerT JSONAPI (GargM Env BackendInternalError)
jsonPostAsync lId =
serveJobsAPI UpdateNgramsListJobJSON $ \jHandle f ->
postAsync' lId f jHandle
......@@ -216,7 +218,7 @@ csvPost l m = do
pure $ Right ()
------------------------------------------------------------------------
csvPostAsync :: ServerT CSVAPI (GargM Env GargError)
csvPostAsync :: ServerT CSVAPI (GargM Env BackendInternalError)
csvPostAsync lId =
serveJobsAPI UpdateNgramsListJobCSV $ \jHandle f -> do
markStarted 1 jHandle
......
......@@ -36,6 +36,7 @@ import Gargantext.API.Admin.Auth (withAccess, withPolicy)
import Gargantext.API.Admin.Auth.Types (PathId(..), AuthenticatedUser (..), auth_node_id)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Auth.PolicyCheck
import Gargantext.API.Errors.Types
import Gargantext.API.Metrics
import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableCorpus)
import Gargantext.API.Ngrams.Types (TabType(..))
......@@ -195,14 +196,14 @@ nodeAPI :: forall proxy a.
) => proxy a
-> AuthenticatedUser
-> NodeId
-> ServerT (NodeAPI a) (GargM Env GargError)
-> ServerT (NodeAPI a) (GargM Env BackendInternalError)
nodeAPI p authenticatedUser targetNode =
withAccess (Proxy :: Proxy (NodeAPI a)) Proxy authenticatedUser (PathNode targetNode) nodeAPI'
where
userRootId = RootId $ authenticatedUser ^. auth_node_id
nodeAPI' :: ServerT (NodeAPI a) (GargM Env GargError)
nodeAPI' :: ServerT (NodeAPI a) (GargM Env BackendInternalError)
nodeAPI' = withPolicy authenticatedUser (nodeChecks targetNode) (getNodeWith targetNode p)
:<|> rename targetNode
:<|> postNode authenticatedUser targetNode
......
......@@ -33,11 +33,13 @@ import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Errors.Types
import Gargantext.API.Node
import Gargantext.API.Prelude (GargError, GargM, simuLogs)
import Gargantext.API.Prelude (GargM, simuLogs)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Terms (TermType(..))
import Gargantext.Core.Types.Individu (User(..))
......@@ -47,9 +49,8 @@ import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAnnuaire(..), Hyperda
import Gargantext.Database.Admin.Types.Hyperdata.Contact (hyperdataContact)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Prelude (($), {-printDebug,-})
import qualified Gargantext.Utils.Aeson as GUA
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Gargantext.API.Admin.Auth.Types
import qualified Gargantext.Utils.Aeson as GUA
------------------------------------------------------------------------
type API = "contact" :> Summary "Contact endpoint"
......@@ -58,7 +59,7 @@ type API = "contact" :> Summary "Contact endpoint"
:> NodeNodeAPI HyperdataContact
api :: AuthenticatedUser -> CorpusId -> ServerT API (GargM Env GargError)
api :: AuthenticatedUser -> CorpusId -> ServerT API (GargM Env BackendInternalError)
api authUser@(AuthenticatedUser userNodeId _userUserId) cid =
(api_async (RootId userNodeId) cid)
:<|> (nodeNodeAPI (Proxy :: Proxy HyperdataContact) authUser cid)
......@@ -73,7 +74,7 @@ data AddContactParams = AddContactParams { firstname :: !Text, lastname
deriving (Generic)
----------------------------------------------------------------------
api_async :: User -> NodeId -> ServerT API_Async (GargM Env GargError)
api_async :: User -> NodeId -> ServerT API_Async (GargM Env BackendInternalError)
api_async u nId =
serveJobsAPI AddContactJob $ \jHandle p ->
addContact u nId p jHandle
......
......@@ -29,7 +29,7 @@ import Gargantext.Core.Text.Corpus.API qualified as API
import Gargantext.Core.Text.List (buildNgramsLists)
import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(..))
import Gargantext.Core.Text.Terms (TermType(..))
import Gargantext.Core.Types (HasInvalidError)
import Gargantext.Core.Types (HasValidationError)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Action.Flow (addDocumentsToHyperCorpus) --, DataText(..))
......@@ -124,7 +124,7 @@ insertSearxResponse :: ( MonadBase IO m
, HasNLPServer env
, HasNodeError err
, HasTreeError err
, HasInvalidError err )
, HasValidationError err )
=> User
-> CorpusId
-> ListId
......@@ -166,7 +166,7 @@ triggerSearxSearch :: ( MonadBase IO m
, HasNLPServer env
, HasNodeError err
, HasTreeError err
, HasInvalidError err
, HasValidationError err
, MonadJobStatus m )
=> User
-> CorpusId
......
......@@ -22,6 +22,7 @@ import Data.Swagger (ToSchema)
import Data.Text qualified as T
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Core (Lang(..))
import Gargantext.Core.NLP (nlpServerGet)
......@@ -75,7 +76,7 @@ type API = Summary " Document upload"
:> "async"
:> AsyncJobs JobLog '[JSON] DocumentUpload JobLog
api :: NodeId -> ServerT API (GargM Env GargError)
api :: NodeId -> ServerT API (GargM Env BackendInternalError)
api nId =
serveJobsAPI UploadDocumentJob $ \jHandle q -> do
documentUploadAsync nId q jHandle
......
......@@ -22,11 +22,13 @@ import Data.Aeson
import Data.List qualified as List
import Data.Swagger
import Data.Text qualified as T
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Errors.Types
import Gargantext.API.Ngrams (commitStatePatch, Versioned(..))
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.API.Prelude (GargM)
import Gargantext.Core (Lang(..))
import Gargantext.Core.NodeStory (HasNodeStoryImmediateSaver, HasNodeArchiveStoryImmediateSaver, currentVersion)
import Gargantext.Core.Text.Corpus.Parsers.Date (split')
......@@ -44,7 +46,6 @@ import Gargantext.Database.Schema.Node (node_hyperdata, node_name, node_date)
import Gargantext.Prelude
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Servant
import Gargantext.API.Admin.Auth.Types
-- import qualified Gargantext.Defaults as Defaults
------------------------------------------------------------------------
......@@ -67,7 +68,7 @@ instance ToSchema Params
api :: AuthenticatedUser
-- ^ The logged-in user
-> NodeId
-> ServerT API (GargM Env GargError)
-> ServerT API (GargM Env BackendInternalError)
api authenticatedUser nId =
serveJobsAPI DocumentFromWriteNodeJob $ \jHandle p ->
documentsFromWriteNodes authenticatedUser nId p jHandle
......
......@@ -33,6 +33,7 @@ import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Errors.Types
import Gargantext.API.Node.Types
import Gargantext.API.Prelude
import Gargantext.Core.Types (TODO)
......@@ -114,7 +115,7 @@ type FileAsyncApi = Summary "File Async Api"
fileAsyncApi :: AuthenticatedUser
-- ^ The logged-in user
-> NodeId
-> ServerT FileAsyncApi (GargM Env GargError)
-> ServerT FileAsyncApi (GargM Env BackendInternalError)
fileAsyncApi authenticatedUser nId =
serveJobsAPI AddFileJob $ \jHandle i ->
addWithFile authenticatedUser nId i jHandle
......
......@@ -29,6 +29,7 @@ import Web.FormUrlEncoded (FromForm)
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Errors.Types
import Gargantext.API.Node.Corpus.New (addToCorpusWithForm)
import Gargantext.API.Node.Corpus.New.Types (FileFormat(..), FileType(..))
import Gargantext.API.Node.Types (NewWithForm(..))
......@@ -62,7 +63,7 @@ type API = Summary " FrameCalc upload"
:> "async"
:> AsyncJobs JobLog '[JSON] FrameCalcUpload JobLog
api :: AuthenticatedUser -> NodeId -> ServerT API (GargM Env GargError)
api :: AuthenticatedUser -> NodeId -> ServerT API (GargM Env BackendInternalError)
api authenticatedUser nId =
serveJobsAPI UploadFrameCalcJob $ \jHandle p ->
frameCalcUploadAsync authenticatedUser nId p jHandle
......
......@@ -23,8 +23,10 @@ module Gargantext.API.Node.New
import Control.Lens hiding (elements, Empty)
import Data.Aeson
import Data.Swagger
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Node
......@@ -37,7 +39,6 @@ import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import Web.FormUrlEncoded (FromForm, ToForm)
import Gargantext.API.Admin.Auth.Types
------------------------------------------------------------------------
data PostNode = PostNode { pn_name :: Text
......@@ -75,7 +76,7 @@ postNodeAsyncAPI
-- ^ The logged-in user
-> NodeId
-- ^ The target node
-> ServerT PostNodeAsync (GargM Env GargError)
-> ServerT PostNodeAsync (GargM Env BackendInternalError)
postNodeAsyncAPI authenticatedUser nId =
serveJobsAPI NewNodeJob $ \jHandle p -> postNodeAsync authenticatedUser nId p jHandle
......
......@@ -23,9 +23,10 @@ import Data.Swagger
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Errors.Types
import Gargantext.API.Metrics qualified as Metrics
import Gargantext.API.Ngrams.Types qualified as NgramsTypes
import Gargantext.API.Prelude (GargM, GargError, simuLogs)
import Gargantext.API.Prelude (GargM, simuLogs)
import Gargantext.Core.Methods.Similarities (GraphMetric(..))
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.Types.Main (ListType(..))
......@@ -88,7 +89,7 @@ data Charts = Sources | Authors | Institutes | Ngrams | All
deriving (Generic, Eq, Ord, Enum, Bounded)
------------------------------------------------------------------------
api :: NodeId -> ServerT API (GargM Env GargError)
api :: NodeId -> ServerT API (GargM Env BackendInternalError)
api nId =
serveJobsAPI UpdateNodeJob $ \jHandle p ->
updateNode nId p jHandle
......
......@@ -20,33 +20,25 @@ module Gargantext.API.Prelude
)
where
import Control.Lens (Prism', (#))
import Control.Lens.TH (makePrisms)
import Control.Lens ((#))
import Crypto.JOSE.Error as Jose
import Data.Aeson.Types
import Data.Text qualified as Text
import Data.Typeable
import Data.Validity
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Class
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.NodeStory
import Gargantext.Core.Types
import Gargantext.Database.Prelude (CmdM, CmdRandom, HasConnectionPool, HasConfig)
import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Tree
import Gargantext.Prelude
import Gargantext.System.Logging
import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..), JobHandle)
import Gargantext.Utils.Jobs.Monad qualified as Jobs
import Servant
import Servant.Job.Async
import Servant.Job.Core (HasServerError(..), serverError)
import Servant.Job.Types qualified as SJ
class HasJoseError e where
_JoseError :: Prism' e Jose.Error
joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
joseError = throwError . (_JoseError #)
......@@ -64,13 +56,13 @@ type EnvC env =
)
type ErrC err =
( HasNodeError err
, HasInvalidError err
, HasTreeError err
, HasServerError err
, HasJoseError err
( HasNodeError err
, HasValidationError err
, HasTreeError err
, HasServerError err
, HasJoseError err
-- , ToJSON err -- TODO this is arguable
, Exception err
, Exception err
)
type GargServerC env err m =
......@@ -103,47 +95,6 @@ type GargNoServer' env err m =
, HasNodeError err
)
-------------------------------------------------------------------
data GargError
= GargNodeError NodeError
| GargTreeError TreeError
| GargInvalidError Validation
| GargJoseError Jose.Error
| GargServerError ServerError
| GargJobError Jobs.JobError
deriving (Show, Typeable)
makePrisms ''GargError
instance ToJSON GargError where
toJSON (GargJobError s) =
object [ ("status", toJSON SJ.IsFailure)
, ("log", emptyArray)
, ("id", String id)
, ("error", String $ Text.pack $ show s) ]
where
id = case s of
Jobs.InvalidMacID i -> i
_ -> ""
toJSON err = object [("error", String $ Text.pack $ show err)]
instance Exception GargError
instance HasNodeError GargError where
_NodeError = _GargNodeError
instance HasInvalidError GargError where
_InvalidError = _GargInvalidError
instance HasTreeError GargError where
_TreeError = _GargTreeError
instance HasServerError GargError where
_ServerError = _GargServerError
instance HasJoseError GargError where
_JoseError = _GargJoseError
------------------------------------------------------------------------
-- | Utils
-- | Simulate logs
......
......@@ -28,6 +28,7 @@ import Gargantext.API.Admin.FrontEnd (FrontEndAPI)
import Gargantext.API.Auth.PolicyCheck
import Gargantext.API.Context
import Gargantext.API.Count (CountAPI, count, Query)
import Gargantext.API.Errors.Types
import Gargantext.API.GraphQL qualified as GraphQL
import Gargantext.API.Members (MembersAPI, members)
import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableDoc)
......@@ -236,7 +237,7 @@ serverGargAdminAPI = roots
serverPrivateGargAPI'
:: AuthenticatedUser -> ServerT GargPrivateAPI' (GargM Env GargError)
:: AuthenticatedUser -> ServerT GargPrivateAPI' (GargM Env BackendInternalError)
serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
= serverGargAdminAPI
:<|> nodeAPI (Proxy :: Proxy HyperdataAny) authenticatedUser
......@@ -293,7 +294,7 @@ waitAPI n = do
pure $ "Waited: " <> show n
----------------------------------------
addCorpusWithQuery :: User -> ServerT New.AddWithQuery (GargM Env GargError)
addCorpusWithQuery :: User -> ServerT New.AddWithQuery (GargM Env BackendInternalError)
addCorpusWithQuery user cid =
serveJobsAPI AddCorpusQueryJob $ \jHandle q -> do
limit <- view $ hasConfig . gc_max_docs_scrapers
......@@ -303,7 +304,7 @@ addCorpusWithQuery user cid =
liftBase $ log x
-}
addCorpusWithForm :: User -> ServerT New.AddWithForm (GargM Env GargError)
addCorpusWithForm :: User -> ServerT New.AddWithForm (GargM Env BackendInternalError)
addCorpusWithForm user cid =
serveJobsAPI AddCorpusFormJob $ \jHandle i -> do
-- /NOTE(adinapoli)/ Track the initial steps outside 'addToCorpusWithForm', because it's
......@@ -311,12 +312,12 @@ addCorpusWithForm user cid =
markStarted 3 jHandle
New.addToCorpusWithForm user cid i jHandle
addCorpusWithFile :: User -> ServerT New.AddWithFile (GargM Env GargError)
addCorpusWithFile :: User -> ServerT New.AddWithFile (GargM Env BackendInternalError)
addCorpusWithFile user cid =
serveJobsAPI AddCorpusFileJob $ \jHandle i ->
New.addToCorpusWithFile user cid i jHandle
addAnnuaireWithForm :: ServerT Annuaire.AddWithForm (GargM Env GargError)
addAnnuaireWithForm :: ServerT Annuaire.AddWithForm (GargM Env BackendInternalError)
addAnnuaireWithForm cid =
serveJobsAPI AddAnnuaireFormJob $ \jHandle i ->
Annuaire.addToAnnuaireWithForm cid i jHandle
......@@ -14,8 +14,6 @@ Portability : POSIX
module Gargantext.API.Server where
import Control.Lens ((^.))
import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy.Char8 qualified as BL8
import Data.Version (showVersion)
import Gargantext.API.Admin.Auth (auth, forgotPassword, forgotPasswordAsync)
import Gargantext.API.Admin.Auth.Types (AuthContext)
......@@ -29,15 +27,15 @@ import Gargantext.API.Routes
import Gargantext.API.Swagger (swaggerDoc)
import Gargantext.API.ThrowAll (serverPrivateGargAPI)
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Database.Query.Table.Node.Error (NodeError(..))
import Gargantext.Prelude hiding (Handler)
import Gargantext.Prelude.Config (gc_url_backend_api)
import Paths_gargantext qualified as PG -- cabal magic build module
import Servant
import Servant.Swagger.UI (swaggerSchemaUIServer)
import Gargantext.API.Errors
serverGargAPI :: Text -> ServerT GargAPI (GargM Env GargError)
serverGargAPI :: Text -> ServerT GargAPI (GargM Env BackendInternalError)
serverGargAPI baseUrl -- orchestrator
= auth
:<|> forgotPassword
......@@ -68,26 +66,5 @@ server env = do
GraphQL.api
:<|> frontEndServer
where
-- transform :: forall a. GargM Env GargError a -> Handler a
-- transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
transformJSON :: forall a. GargM Env GargError a -> Handler a
transformJSON :: forall a. GargM Env BackendInternalError a -> Handler a
transformJSON = Handler . withExceptT showAsServantJSONErr . (`runReaderT` env)
showAsServantErr :: GargError -> ServerError
showAsServantErr (GargNodeError err@(NoListFound {})) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargNodeError err@NoRootFound) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargNodeError err@NoCorpusFound) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargNodeError err@NoUserFound{}) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargNodeError err@(DoesNotExist {})) = err404 { errBody = BL8.pack $ show err }
showAsServantErr (GargServerError err) = err
showAsServantErr a = err500 { errBody = BL8.pack $ show a }
showAsServantJSONErr :: GargError -> ServerError
showAsServantJSONErr (GargNodeError err@(NoListFound {})) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargNodeError err@NoRootFound) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargNodeError err@NoCorpusFound) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargNodeError err@NoUserFound{}) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargNodeError err@(DoesNotExist {})) = err404 { errBody = Aeson.encode err }
showAsServantJSONErr (GargServerError err) = err
showAsServantJSONErr a = err500 { errBody = Aeson.encode a }
......@@ -18,6 +18,7 @@ module Gargantext.API.ThrowAll where
import Control.Lens ((#))
import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.API.Routes (GargPrivateAPI, serverPrivateGargAPI')
import Gargantext.Prelude
......@@ -45,7 +46,7 @@ instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
throwAll' = throwError
serverPrivateGargAPI
:: ServerT GargPrivateAPI (GargM Env GargError)
:: ServerT GargPrivateAPI (GargM Env BackendInternalError)
serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
serverPrivateGargAPI _ = throwAll' (_ServerError # err401)
-- Here throwAll' requires a concrete type for the monad.
......@@ -23,7 +23,7 @@ module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
, Term(..), Terms(..), TermsCount, TermsWithCount
, TokenTag(..), POS(..), NER(..)
, Label, Stems
, HasInvalidError(..), assertValid
, HasValidationError(..), assertValid
, Name
, TableResult(..), NodeTableResult
, Ordering(..)
......@@ -171,11 +171,11 @@ instance Monoid TokenTag where
-- mappend t1 t2 = (<>) t1 t2
class HasInvalidError e where
_InvalidError :: Prism' e Validation
class HasValidationError e where
_ValidationError :: Prism' e Validation
assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
assertValid :: (MonadError e m, HasValidationError e) => Validation -> m ()
assertValid v = when (not $ validationIsValid v) $ throwError $ _ValidationError # v
-- assertValid :: MonadBase IO m => Validation -> m ()
-- assertValid v = when (not $ validationIsValid v) $ fail $ show v
......
......@@ -24,6 +24,7 @@ import Data.HashMap.Strict qualified as HashMap
import Data.Swagger
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Prelude
import Gargantext.Core.Methods.Similarities (Similarity(..), GraphMetric(..), withMetric)
......@@ -41,8 +42,8 @@ import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Node
import Gargantext.Prelude
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Servant
......@@ -70,7 +71,7 @@ instance FromJSON GraphVersions
instance ToJSON GraphVersions
instance ToSchema GraphVersions
graphAPI :: UserId -> NodeId -> ServerT GraphAPI (GargM Env GargError)
graphAPI :: UserId -> NodeId -> ServerT GraphAPI (GargM Env BackendInternalError)
graphAPI userId n = getGraph n
:<|> graphAsync n
:<|> graphClone userId n
......@@ -248,7 +249,7 @@ type GraphAsyncAPI = Summary "Recompute graph"
:> AsyncJobsAPI JobLog () JobLog
graphAsync :: NodeId -> ServerT GraphAsyncAPI (GargM Env GargError)
graphAsync :: NodeId -> ServerT GraphAsyncAPI (GargM Env BackendInternalError)
graphAsync n =
serveJobsAPI RecomputeGraphJob $ \jHandle _ -> graphRecompute n jHandle
......
......@@ -86,7 +86,7 @@ import Gargantext.Core.Text.List.Social (FlowSocialListWith(..))
import Gargantext.Core.Text.Terms
import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
import Gargantext.Core.Text.Terms.WithList (MatchedText, buildPatternsWith, termsInText)
import Gargantext.Core.Types (HasInvalidError, POS(NP), TermsCount)
import Gargantext.Core.Types (HasValidationError, POS(NP), TermsCount)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Main
import Gargantext.Core.Types.Query (Limit)
......@@ -193,7 +193,7 @@ flowDataText :: forall env err m.
, MonadLogger m
, HasNLPServer env
, HasTreeError err
, HasInvalidError err
, HasValidationError err
, MonadJobStatus m
)
=> User
......@@ -222,7 +222,7 @@ flowAnnuaire :: ( DbCmd' env err m
, MonadLogger m
, HasNLPServer env
, HasTreeError err
, HasInvalidError err
, HasValidationError err
, MonadJobStatus m )
=> User
-> Either CorpusName [CorpusId]
......@@ -241,7 +241,7 @@ flowCorpusFile :: ( DbCmd' env err m
, MonadLogger m
, HasNLPServer env
, HasTreeError err
, HasInvalidError err
, HasValidationError err
, MonadJobStatus m )
=> User
-> Either CorpusName [CorpusId]
......@@ -270,7 +270,7 @@ flowCorpus :: ( DbCmd' env err m
, MonadLogger m
, HasNLPServer env
, HasTreeError err
, HasInvalidError err
, HasValidationError err
, FlowCorpus a
, MonadJobStatus m )
=> User
......@@ -289,7 +289,7 @@ flow :: forall env err m a c.
, MonadLogger m
, HasNLPServer env
, HasTreeError err
, HasInvalidError err
, HasValidationError err
, FlowCorpus a
, MkCorpus c
, MonadJobStatus m
......@@ -366,7 +366,7 @@ createNodes user corpusName ctype = do
flowCorpusUser :: ( HasNodeError err
, HasInvalidError err
, HasValidationError err
, HasNLPServer env
, HasTreeError err
, HasNodeStory env err m
......
......@@ -28,7 +28,7 @@ import Gargantext.API.Ngrams (saveNodeStory)
import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Types (HasInvalidError(..), assertValid)
import Gargantext.Core.Types (HasValidationError(..), assertValid)
import Gargantext.Core.Types.Main (ListType(CandidateTerm))
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
......@@ -79,7 +79,7 @@ flowList_Tficf' u m nt f = do
------------------------------------------------------------------------
flowList_DbRepo :: (HasInvalidError err, HasNodeStory env err m)
flowList_DbRepo :: (HasValidationError err, HasNodeStory env err m)
=> ListId
-> Map NgramsType [NgramsElement]
-> m ListId
......@@ -154,7 +154,7 @@ toNodeNgramsW' l'' ngs = [ NodeNgrams { _nng_id = Nothing
]
listInsert :: (HasInvalidError err, HasNodeStory env err m)
listInsert :: (HasValidationError err, HasNodeStory env err m)
=> ListId
-> Map NgramsType [NgramsElement]
-> m ()
......@@ -168,7 +168,7 @@ listInsert lId ngs = mapM_ (\(typeList, ngElmts)
-- This function is maintained for its usage in Database.Action.Flow.List.
-- If the given list of ngrams elements contains ngrams already in
-- the repo, they will be ignored.
putListNgrams :: (HasInvalidError err, HasNodeStory env err m)
putListNgrams :: (HasValidationError err, HasNodeStory env err m)
=> NodeId
-> TableNgrams.NgramsType
-> [NgramsElement]
......@@ -178,7 +178,7 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
where
m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
putListNgrams' :: (HasInvalidError err, HasNodeStory env err m)
putListNgrams' :: (HasValidationError err, HasNodeStory env err m)
=> NodeId
-> TableNgrams.NgramsType
-> Map NgramsTerm NgramsRepoElement
......
......@@ -21,7 +21,7 @@ module Gargantext.Database.Action.Flow.Types
import Data.Aeson (ToJSON)
import Gargantext.Core.Types (HasInvalidError)
import Gargantext.Core.Types (HasValidationError)
import Gargantext.Core.Flow.Types
import Gargantext.Core.Text
import Gargantext.Core.NodeStory
......@@ -36,7 +36,7 @@ type FlowCmdM env err m =
( CmdM env err m
, HasNodeStory env err m
, HasNodeError err
, HasInvalidError err
, HasValidationError err
, HasTreeError err
, MonadLogger m
)
......
......@@ -22,7 +22,7 @@ import Gargantext.Prelude hiding (sum, head)
import Prelude qualified
------------------------------------------------------------------------
data NodeError = NoListFound { listId :: ListId }
data NodeError = NoListFound ListId
| NoRootFound
| NoCorpusFound
| NoUserFound User
......@@ -60,7 +60,7 @@ instance Prelude.Show NodeError
show (QueryNoParse err) = "QueryNoParse: " <> T.unpack err
instance ToJSON NodeError where
toJSON (NoListFound { listId }) =
toJSON (NoListFound listId) =
object [ ( "error", "No list found" )
, ( "listId", toJSON listId ) ]
toJSON err =
......
......@@ -28,6 +28,7 @@ import Text.Read (readMaybe)
import qualified Data.Text as T
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import qualified Gargantext.Utils.Jobs.Internal as Internal
import Gargantext.Utils.Jobs.Monad
......@@ -36,8 +37,8 @@ import Gargantext.System.Logging
import qualified Servant.Job.Async as SJ
jobErrorToGargError
:: JobError -> GargError
jobErrorToGargError = GargJobError
:: JobError -> BackendInternalError
jobErrorToGargError = InternalJobError
serveJobsAPI
:: (
......@@ -47,7 +48,7 @@ serveJobsAPI
, ToJSON (JobEventType m)
, ToJSON (JobOutputType m)
, MonadJobStatus m
, m ~ (GargM Env GargError)
, m ~ (GargM Env BackendInternalError)
, JobEventType m ~ JobOutputType m
)
=> JobType m
......
......@@ -10,6 +10,7 @@ import Gargantext.API (makeApp)
import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..))
import Gargantext.API.Admin.Settings
import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Core.NLP
import Gargantext.Core.NodeStory
......@@ -41,7 +42,7 @@ import qualified Network.Wai.Handler.Warp as Wai
import qualified Servant.Job.Async as ServantAsync
newTestEnv :: TestEnv -> Logger (GargM Env GargError) -> Warp.Port -> IO Env
newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env
newTestEnv testEnv logger port = do
file <- fakeIniPath
!manager_env <- newTlsManager
......
......@@ -29,6 +29,7 @@ import Gargantext hiding (to)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.EnvTypes qualified as EnvTypes
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Core.Mail.Types (HasMail(..))
import Gargantext.Core.NLP (HasNLPServer(..))
......@@ -58,7 +59,7 @@ data TestEnv = TestEnv {
test_db :: !DBHandle
, test_config :: !GargConfig
, test_usernameGen :: !Counter
, test_logger :: !(Logger (GargM TestEnv GargError))
, test_logger :: !(Logger (GargM TestEnv BackendInternalError))
}
newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
......@@ -71,7 +72,7 @@ newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
)
instance MonadJobStatus TestMonad where
type JobHandle TestMonad = EnvTypes.ConcreteJobHandle GargError
type JobHandle TestMonad = EnvTypes.ConcreteJobHandle BackendInternalError
type JobType TestMonad = GargJob
type JobOutputType TestMonad = JobLog
type JobEventType TestMonad = JobLog
......@@ -116,17 +117,17 @@ coreNLPConfig =
instance HasNLPServer TestEnv where
nlpServer = to $ const (Map.singleton EN coreNLPConfig)
instance MonadLogger (GargM TestEnv GargError) where
instance MonadLogger (GargM TestEnv BackendInternalError) where
getLogger = asks test_logger
instance HasLogger (GargM TestEnv GargError) where
data instance Logger (GargM TestEnv GargError) =
instance HasLogger (GargM TestEnv BackendInternalError) where
data instance Logger (GargM TestEnv BackendInternalError) =
GargTestLogger {
test_logger_mode :: Mode
, test_logger_set :: FL.LoggerSet
}
type instance LogInitParams (GargM TestEnv GargError) = Mode
type instance LogPayload (GargM TestEnv GargError) = FL.LogStr
type instance LogInitParams (GargM TestEnv BackendInternalError) = Mode
type instance LogPayload (GargM TestEnv BackendInternalError) = FL.LogStr
initLogger = \mode -> do
test_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
pure $ GargTestLogger mode test_logger_set
......
......@@ -26,6 +26,7 @@ import Data.Time
import Debug.RecoverRTTI (anythingToString)
import Gargantext.API.Admin.EnvTypes as EnvTypes
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Prelude
import Gargantext.Utils.Jobs.Internal (newJob)
......@@ -215,14 +216,14 @@ testFairness = do
newtype MyDummyMonad a =
MyDummyMonad { _MyDummyMonad :: GargM Env GargError a }
MyDummyMonad { _MyDummyMonad :: GargM Env BackendInternalError a }
deriving (Functor, Applicative, Monad, MonadIO, MonadReader Env)
instance MonadJob MyDummyMonad GargJob (Seq JobLog) JobLog where
getJobEnv = MyDummyMonad getJobEnv
instance MonadJobStatus MyDummyMonad where
type JobHandle MyDummyMonad = EnvTypes.ConcreteJobHandle GargError
type JobHandle MyDummyMonad = EnvTypes.ConcreteJobHandle BackendInternalError
type JobType MyDummyMonad = GargJob
type JobOutputType MyDummyMonad = JobLog
type JobEventType MyDummyMonad = JobLog
......@@ -252,7 +253,7 @@ withJob :: Env
-> IO (SJ.JobStatus 'SJ.Safe JobLog)
withJob env f = runMyDummyMonad env $ MyDummyMonad $
-- the job type doesn't matter in our tests, we use a random one, as long as it's of type 'GargJob'.
newJob @_ @GargError mkJobHandle (pure env) RecomputeGraphJob (\_ hdl input ->
newJob @_ @BackendInternalError mkJobHandle (pure env) RecomputeGraphJob (\_ hdl input ->
runMyDummyMonad env $ (Right <$> (f hdl input >> getLatestJobStatus hdl))) (SJ.JobInput () Nothing)
withJob_ :: Env
......
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