[websockets] implement CE typeclass, fixes to haskell-nanomsg

parent ea87bb15
...@@ -25,14 +25,16 @@ import Options.Applicative ...@@ -25,14 +25,16 @@ import Options.Applicative
data Command = data Command =
Server CEServer
| SimpleServer
| WSServer | WSServer
| Client | Client
parser :: Parser (IO ()) parser :: Parser (IO ())
parser = subparser parser = subparser
( command "server" (info (pure gServer) idm) ( command "ce-server" (info (pure gServer) idm)
<> command "simple-server" (info (pure simpleServer) idm)
<> command "ws-server" (info (pure wsServer) idm) <> command "ws-server" (info (pure wsServer) idm)
<> command "client" (info (pure gClient) idm) ) <> command "client" (info (pure gClient) idm) )
...@@ -40,10 +42,23 @@ parser = subparser ...@@ -40,10 +42,23 @@ parser = subparser
main :: IO () main :: IO ()
main = join $ execParser (info parser idm) main = join $ execParser (info parser idm)
simpleServer :: IO ()
simpleServer = do
withSocket Pull $ \s -> do
_ <- bind s "tcp://*:5560"
putText "[simpleServer] receiving"
forever $ do
mr <- recvMalloc s 1024
C.putStrLn mr
-- case mr of
-- Nothing -> pure ()
-- Just r -> C.putStrLn r
-- threadDelay 10000
wsServer :: IO () wsServer :: IO ()
wsServer = do wsServer = do
withSocket Pull $ \ws -> do withSocket Pull $ \ws -> do
_ <- connect ws "ws://localhost:5566" _ <- bind ws "ws://*:5560"
forever $ do forever $ do
putText "[wsServer] receiving" putText "[wsServer] receiving"
r <- recv ws r <- recv ws
......
...@@ -169,7 +169,7 @@ source-repository-package ...@@ -169,7 +169,7 @@ source-repository-package
source-repository-package source-repository-package
type: git type: git
location: https://github.com/garganscript/nanomsg-haskell location: https://github.com/garganscript/nanomsg-haskell
tag: 5e4e119881d81b8a8f77a79b3caaebb1bb304790 tag: 23be4130804d86979eaee5caffe323a1c7f2b0d6
-- source-repository-package -- source-repository-package
-- type: git -- type: git
......
...@@ -172,6 +172,7 @@ library ...@@ -172,6 +172,7 @@ library
Gargantext.Core.AsyncUpdates.Constants Gargantext.Core.AsyncUpdates.Constants
Gargantext.Core.AsyncUpdates.Dispatcher Gargantext.Core.AsyncUpdates.Dispatcher
Gargantext.Core.AsyncUpdates.Dispatcher.Types Gargantext.Core.AsyncUpdates.Dispatcher.Types
Gargantext.Core.AsyncUpdates.Nanomsg
Gargantext.Core.Mail.Types Gargantext.Core.Mail.Types
Gargantext.Core.Methods.Similarities Gargantext.Core.Methods.Similarities
Gargantext.Core.Methods.Similarities.Conditional Gargantext.Core.Methods.Similarities.Conditional
...@@ -294,6 +295,7 @@ library ...@@ -294,6 +295,7 @@ library
Gargantext.API.GraphQL.Team Gargantext.API.GraphQL.Team
Gargantext.API.GraphQL.TreeFirstLevel Gargantext.API.GraphQL.TreeFirstLevel
Gargantext.API.GraphQL.Types Gargantext.API.GraphQL.Types
Gargantext.API.GraphQL.UnPrefix
Gargantext.API.GraphQL.User Gargantext.API.GraphQL.User
Gargantext.API.GraphQL.UserInfo Gargantext.API.GraphQL.UserInfo
Gargantext.API.GraphQL.Utils Gargantext.API.GraphQL.Utils
......
...@@ -37,6 +37,8 @@ import Gargantext.API.Admin.Types ...@@ -37,6 +37,8 @@ import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
import Gargantext.API.Job import Gargantext.API.Job
import Gargantext.API.Prelude (GargM, IsGargServer) import Gargantext.API.Prelude (GargM, IsGargServer)
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.AsyncUpdates.Dispatcher.Types (Dispatcher, HasDispatcher(..)) import Gargantext.Core.AsyncUpdates.Dispatcher.Types (Dispatcher, HasDispatcher(..))
import Gargantext.Core.Mail.Types (HasMail, mailSettings) import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..)) import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
...@@ -168,6 +170,9 @@ instance HasJobEnv Env JobLog JobLog where ...@@ -168,6 +170,9 @@ instance HasJobEnv Env JobLog JobLog where
instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where
getJobEnv = asks (view env_jobs) getJobEnv = asks (view env_jobs)
instance CET.HasCentralExchangeNotification Env where
ce_notify m = liftBase $ CE.notify m
-- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its -- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its
-- constructor it's not exported, to not leak internal details of its implementation. -- constructor it's not exported, to not leak internal details of its implementation.
data ConcreteJobHandle err = data ConcreteJobHandle err =
...@@ -187,8 +192,15 @@ mkJobHandle jId = JobHandle jId ...@@ -187,8 +192,15 @@ mkJobHandle jId = JobHandle jId
-- | Updates the status of a 'JobHandle' by using the input 'updateJobStatus' function. -- | Updates the status of a 'JobHandle' by using the input 'updateJobStatus' function.
updateJobProgress :: ConcreteJobHandle err -> (JobLog -> JobLog) -> GargM Env err () updateJobProgress :: ConcreteJobHandle err -> (JobLog -> JobLog) -> GargM Env err ()
updateJobProgress ConcreteNullHandle _ = pure () updateJobProgress ConcreteNullHandle _ = pure ()
updateJobProgress hdl@(JobHandle _ logStatus) updateJobStatus = updateJobProgress hdl@(JobHandle jId logStatus) updateJobStatus = do
Jobs.getLatestJobStatus hdl >>= logStatus . updateJobStatus jobLog <- Jobs.getLatestJobStatus hdl
let jobLogNew = updateJobStatus jobLog
logStatus jobLogNew
CET.ce_notify $ CET.UpdateJobProgress jId jobLogNew
-- mJob <- Jobs.findJob jId
-- case mJob of
-- Nothing -> pure ()
-- Just job -> liftBase $ CE.ce_notify $ CET.UpdateJobProgress jId job
instance Jobs.MonadJobStatus (GargM Env err) where instance Jobs.MonadJobStatus (GargM Env err) where
......
...@@ -11,7 +11,7 @@ import Data.Morpheus.Types ( GQLType, typeOptions ) ...@@ -11,7 +11,7 @@ import Data.Morpheus.Types ( GQLType, typeOptions )
import Data.Proxy import Data.Proxy
import Data.Swagger hiding (URL, url, port) import Data.Swagger hiding (URL, url, port)
import GHC.Generics hiding (to) import GHC.Generics hiding (to)
import Gargantext.API.GraphQL.Utils qualified as GQLU import Gargantext.API.GraphQL.UnPrefix qualified as GQLU
import Gargantext.Core.Types (TODO(..)) import Gargantext.Core.Types (TODO(..))
import Gargantext.Prelude import Gargantext.Prelude
import Servant import Servant
......
{-|
Module : Gargantext.API.GraphQL.UnPrefix
Description : Un-prefix for GraphQL API
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -Wno-deprecations #-} -- FIXME(adn) GraphQL will need updating.
module Gargantext.API.GraphQL.UnPrefix where
import Data.Morpheus.Types (GQLTypeOptions, fieldLabelModifier)
import Data.Text qualified as T
import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
import Gargantext.Prelude
unPrefix :: T.Text -> GQLTypeOptions -> GQLTypeOptions
unPrefix prefix options = options { fieldLabelModifier = nflm }
where
nflm label = unCapitalize $ dropPrefix (T.unpack prefix) $ ( fieldLabelModifier options ) label
...@@ -13,21 +13,13 @@ Portability : POSIX ...@@ -13,21 +13,13 @@ Portability : POSIX
module Gargantext.API.GraphQL.Utils where module Gargantext.API.GraphQL.Utils where
import Control.Lens (view) import Control.Lens (view)
import Data.Morpheus.Types (GQLTypeOptions, fieldLabelModifier)
import Data.Text qualified as T
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser (..), auth_node_id) import Gargantext.API.Admin.Auth.Types (AuthenticatedUser (..), auth_node_id)
import Gargantext.API.Admin.Types (jwtSettings, HasSettings (settings)) import Gargantext.API.Admin.Types (jwtSettings, HasSettings (settings))
import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
import Gargantext.Database.Admin.Types.Node (NodeId) import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Prelude (Cmd') import Gargantext.Database.Prelude (Cmd')
import Gargantext.Prelude import Gargantext.Prelude
import Servant.Auth.Server (verifyJWT, JWTSettings) import Servant.Auth.Server (verifyJWT, JWTSettings)
unPrefix :: T.Text -> GQLTypeOptions -> GQLTypeOptions
unPrefix prefix options = options { fieldLabelModifier = nflm }
where
nflm label = unCapitalize $ dropPrefix (T.unpack prefix) $ ( fieldLabelModifier options ) label
data AuthStatus = Valid | Invalid data AuthStatus = Valid | Invalid
authUser :: (HasSettings env) => NodeId -> Text -> Cmd' env err AuthStatus authUser :: (HasSettings env) => NodeId -> Text -> Cmd' env err AuthStatus
......
...@@ -28,7 +28,6 @@ import Gargantext.API.Errors.Types ...@@ -28,7 +28,6 @@ import Gargantext.API.Errors.Types
import Gargantext.API.Node.New.Types import Gargantext.API.Node.New.Types
import Gargantext.API.Prelude import Gargantext.API.Prelude
import Gargantext.API.Routes.Named.Node qualified as Named import Gargantext.API.Routes.Named.Node qualified as Named
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CE import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CE
import Gargantext.Database.Action.Flow.Types import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Node import Gargantext.Database.Action.Node
...@@ -50,9 +49,8 @@ postNode authenticatedUser pId (PostNode nodeName nt) = do ...@@ -50,9 +49,8 @@ postNode authenticatedUser pId (PostNode nodeName nt) = do
let userId = authenticatedUser ^. auth_user_id let userId = authenticatedUser ^. auth_user_id
nodeIds <- mkNodeWithParent nt (Just pId) userId nodeName nodeIds <- mkNodeWithParent nt (Just pId) userId nodeName
liftBase $ do -- mapM_ (CE.ce_notify . CE.UpdateTreeFirstLevel) nodeIds
-- mapM_ (CE.notify . CE.UpdateTreeFirstLevel) nodeIds CE.ce_notify $ CE.UpdateTreeFirstLevel pId
CE.notify $ CE.UpdateTreeFirstLevel pId
return nodeIds return nodeIds
...@@ -66,7 +64,7 @@ postNodeAsyncAPI authenticatedUser nId = Named.PostNodeAsyncAPI $ AsyncJobs $ ...@@ -66,7 +64,7 @@ postNodeAsyncAPI authenticatedUser nId = Named.PostNodeAsyncAPI $ AsyncJobs $
serveJobsAPI NewNodeJob $ \jHandle p -> postNodeAsync authenticatedUser nId p jHandle serveJobsAPI NewNodeJob $ \jHandle p -> postNodeAsync authenticatedUser nId p jHandle
------------------------------------------------------------------------ ------------------------------------------------------------------------
postNodeAsync :: (FlowCmdM env err m, MonadJobStatus m) postNodeAsync :: (FlowCmdM env err m, MonadJobStatus m, CE.HasCentralExchangeNotification env)
=> AuthenticatedUser => AuthenticatedUser
-- ^ The logged in user -- ^ The logged in user
-> NodeId -> NodeId
...@@ -85,8 +83,7 @@ postNodeAsync authenticatedUser nId (PostNode nodeName tn) jobHandle = do ...@@ -85,8 +83,7 @@ postNodeAsync authenticatedUser nId (PostNode nodeName tn) jobHandle = do
let userId = authenticatedUser ^. auth_user_id let userId = authenticatedUser ^. auth_user_id
_nodeIds <- mkNodeWithParent tn (Just nId) userId nodeName _nodeIds <- mkNodeWithParent tn (Just nId) userId nodeName
liftBase $ do -- mapM_ (CE.ce_notify . CE.UpdateTreeFirstLevel) nodeIds
-- mapM_ (CE.notify . CE.UpdateTreeFirstLevel) nodeIds CE.ce_notify $ CE.UpdateTreeFirstLevel nId
CE.notify $ CE.UpdateTreeFirstLevel nId
markComplete jobHandle markComplete jobHandle
...@@ -20,6 +20,7 @@ import Data.Text qualified as Text ...@@ -20,6 +20,7 @@ import Data.Text qualified as Text
import Gargantext.API.Node.Share.Types import Gargantext.API.Node.Share.Types
import Gargantext.API.Prelude import Gargantext.API.Prelude
import Gargantext.API.Routes.Named.Share qualified as Named import Gargantext.API.Routes.Named.Share qualified as Named
import Gargantext.Core.AsyncUpdates.CentralExchange.Types (HasCentralExchangeNotification)
import Gargantext.Core.NLP (HasNLPServer) import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Types.Individu (User(..), arbitraryUsername) import Gargantext.Core.Types.Individu (User(..), arbitraryUsername)
import Gargantext.Database.Action.Share (ShareNodeWith(..)) import Gargantext.Database.Action.Share (ShareNodeWith(..))
...@@ -37,7 +38,10 @@ import Servant.Server.Generic (AsServerT) ...@@ -37,7 +38,10 @@ import Servant.Server.Generic (AsServerT)
-- TODO permission -- TODO permission
-- TODO refactor userId which is used twice -- TODO refactor userId which is used twice
-- TODO change return type for better warning/info/success/error handling on the front -- TODO change return type for better warning/info/success/error handling on the front
api :: (HasNodeError err, HasNLPServer env, CmdRandom env err m) api :: ( HasNodeError err
, HasNLPServer env
, CmdRandom env err m
, HasCentralExchangeNotification env )
=> User => User
-> NodeId -> NodeId
-> ShareNodeParams -> ShareNodeParams
......
...@@ -26,6 +26,7 @@ import Gargantext.API.Admin.Auth.Types (AuthenticationError) ...@@ -26,6 +26,7 @@ import Gargantext.API.Admin.Auth.Types (AuthenticationError)
import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Types import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Class import Gargantext.API.Errors.Class
import Gargantext.Core.AsyncUpdates.CentralExchange.Types (HasCentralExchangeNotification)
import Gargantext.Core.Mail.Types (HasMail) import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer) import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
...@@ -53,6 +54,7 @@ type EnvC env = ...@@ -53,6 +54,7 @@ type EnvC env =
, HasNodeStoryEnv env , HasNodeStoryEnv env
, HasMail env , HasMail env
, HasNLPServer env , HasNLPServer env
, HasCentralExchangeNotification env
) )
type ErrC err = type ErrC err =
......
...@@ -18,13 +18,15 @@ module Gargantext.Core.AsyncUpdates.CentralExchange where ...@@ -18,13 +18,15 @@ module Gargantext.Core.AsyncUpdates.CentralExchange where
-- import Control.Concurrent (threadDelay) -- import Control.Concurrent (threadDelay)
import Control.Concurrent.Async qualified as Async import Control.Concurrent.Async qualified as Async
import Control.Concurrent.STM.TChan qualified as TChan
import Data.Aeson qualified as Aeson import Data.Aeson qualified as Aeson
import Data.ByteString.Char8 qualified as C import Data.ByteString.Char8 qualified as C
import Data.ByteString.Lazy qualified as BSL import Data.ByteString.Lazy qualified as BSL
import Gargantext.Core.AsyncUpdates.CentralExchange.Types import Gargantext.Core.AsyncUpdates.CentralExchange.Types
import Gargantext.Core.AsyncUpdates.Constants (cePort, dispatcherInternalPort) import Gargantext.Core.AsyncUpdates.Constants (cePort, dispatcherInternalPort)
-- import Gargantext.Core.AsyncUpdates.Nanomsg (withSafeSocket)
import Gargantext.Prelude import Gargantext.Prelude
import Nanomsg import Nanomsg (Pull(..), Push(..), bind, connect, recvMalloc, send, withSocket)
{- {-
...@@ -32,6 +34,11 @@ Central exchange is a service, which gathers messages from various ...@@ -32,6 +34,11 @@ Central exchange is a service, which gathers messages from various
places and informs the Dispatcher (which will then inform users about places and informs the Dispatcher (which will then inform users about
various events). various events).
The primary goal is to be able to read as many messages as possible
and then send them to the Dispatcher. Although nanomsg does some
message buffering, we don't want these messages to pile up, especially
with many users having updates.
-} -}
gServer :: IO () gServer :: IO ()
...@@ -40,14 +47,31 @@ gServer = do ...@@ -40,14 +47,31 @@ gServer = do
withSocket Push $ \s_dispatcher -> do withSocket Push $ \s_dispatcher -> do
_ <- bind s ("tcp://*:" <> show cePort) _ <- bind s ("tcp://*:" <> show cePort)
_ <- connect s_dispatcher ("tcp://localhost:" <> show dispatcherInternalPort) _ <- connect s_dispatcher ("tcp://localhost:" <> show dispatcherInternalPort)
tChan <- TChan.newTChanIO
-- | We have 2 threads: one that listens for nanomsg messages
-- | and puts them on the 'tChan' and the second one that reads
-- | the 'tChan' and calls Dispatcher accordingly. This is to
-- | make reading nanomsg as fast as possible.
void $ Async.concurrently (worker s_dispatcher tChan) $ do
forever $ do
-- putText "[central_exchange] receiving"
r <- recvMalloc s 1024
C.putStrLn $ "[central_exchange] " <> r
atomically $ TChan.writeTChan tChan r
where
worker s_dispatcher tChan = do
forever $ do forever $ do
putText "[central_exchange] receiving" r <- atomically $ TChan.readTChan tChan
r <- recv s
C.putStrLn r
case Aeson.decode (BSL.fromStrict r) of case Aeson.decode (BSL.fromStrict r) of
Just ujp@(UpdateJobProgress _jId _jobLog) -> do
putText $ "[central_exchange] " <> show ujp
-- send the same message that we received
send s_dispatcher r
Just (UpdateTreeFirstLevel node_id) -> do Just (UpdateTreeFirstLevel node_id) -> do
putText $ "[central_exchange] update tree: " <> show node_id putText $ "[central_exchange] update tree: " <> show node_id
putText $ "[central_exchange] sending that to the dispatcher: " <> show node_id -- putText $ "[central_exchange] sending that to the dispatcher: " <> show node_id
-- To make this more robust, use withAsync so we don't -- To make this more robust, use withAsync so we don't
-- block the main thread (send is blocking) -- block the main thread (send is blocking)
...@@ -61,13 +85,14 @@ gServer = do ...@@ -61,13 +85,14 @@ gServer = do
-- component. Currently I built this inside -- component. Currently I built this inside
-- gargantext-server but maybe it can be a separate -- gargantext-server but maybe it can be a separate
-- process, independent of the server. -- process, independent of the server.
Async.withAsync (pure ()) $ \_ -> do -- send the same message that we received
send s_dispatcher r send s_dispatcher r
_ -> putText "[central_exchange] unknown" _ -> putText $ "[central_exchange] unknown message"
notify :: CEMessage -> IO () notify :: CEMessage -> IO ()
notify ceMessage = do notify ceMessage = do
Async.withAsync (pure ()) $ \_ -> do
withSocket Push $ \s -> do withSocket Push $ \s -> do
_ <- connect s ("tcp://localhost:" <> show cePort) _ <- connect s ("tcp://localhost:" <> show cePort)
let str = Aeson.encode ceMessage let str = Aeson.encode ceMessage
......
...@@ -15,10 +15,18 @@ https://dev.sub.gargantext.org/#/share/Notes/187918 ...@@ -15,10 +15,18 @@ https://dev.sub.gargantext.org/#/share/Notes/187918
module Gargantext.Core.AsyncUpdates.CentralExchange.Types where module Gargantext.Core.AsyncUpdates.CentralExchange.Types where
import Codec.Binary.UTF8.String qualified as CBUTF8
import Data.Aeson ((.:), (.=), object, withObject) import Data.Aeson ((.:), (.=), object, withObject)
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (prependFailure, typeMismatch) import Data.Aeson.Types (prependFailure, typeMismatch)
import Data.ByteString.Lazy qualified as BSL
import Gargantext.API.Admin.Orchestrator.Types (JobLog)
import Gargantext.Core.Types (NodeId) import Gargantext.Core.Types (NodeId)
import Gargantext.Prelude import Gargantext.Prelude
-- import Gargantext.Utils.Jobs.Map qualified as JM
import Prelude qualified
import Servant.Job.Core (Safety(Safe))
import Servant.Job.Types (JobID)
{- {-
...@@ -30,21 +38,37 @@ various events). ...@@ -30,21 +38,37 @@ various events).
-- INTERNAL MESSAGES -- INTERNAL MESSAGES
data CEMessage = data CEMessage =
UpdateTreeFirstLevel NodeId -- UpdateJobProgress (JobID 'Safe) (JM.JobEntry (JobID 'Safe) (Seq JobLog) JobLog)
deriving (Show, Eq) UpdateJobProgress (JobID 'Safe) JobLog
| UpdateTreeFirstLevel NodeId
-- deriving (Eq)
instance Prelude.Show CEMessage where
show (UpdateJobProgress jId jobLog) = "UpdateJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode jId) <> " " <> show jobLog
show (UpdateTreeFirstLevel nodeId) = "UpdateTreeFirstLevel " <> show nodeId
instance FromJSON CEMessage where instance FromJSON CEMessage where
parseJSON = withObject "CEMessage" $ \o -> do parseJSON = withObject "CEMessage" $ \o -> do
type_ <- o .: "type" type_ <- o .: "type"
case type_ of case type_ of
"update_job_progress" -> do
jId <- o .: "j_id"
jobLog <- o .: "job_log"
pure $ UpdateJobProgress jId jobLog
"update_tree_first_level" -> do "update_tree_first_level" -> do
node_id <- o .: "node_id" node_id <- o .: "node_id"
pure $ UpdateTreeFirstLevel node_id pure $ UpdateTreeFirstLevel node_id
s -> prependFailure "parsing type failed, " (typeMismatch "type" s) s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
instance ToJSON CEMessage where instance ToJSON CEMessage where
toJSON (UpdateJobProgress jId jobLog) = object [
"type" .= toJSON ("update_job_progress" :: Text)
, "j_id" .= toJSON jId
, "job_log" .= toJSON jobLog
]
toJSON (UpdateTreeFirstLevel node_id) = object [ toJSON (UpdateTreeFirstLevel node_id) = object [
"type" .= toJSON ("update_tree_first_level" :: Text) "type" .= toJSON ("update_tree_first_level" :: Text)
, "node_id" .= toJSON node_id , "node_id" .= toJSON node_id
] ]
class HasCentralExchangeNotification env where
ce_notify :: (MonadReader env m, MonadBase IO m) => CEMessage -> m ()
...@@ -20,6 +20,7 @@ https://dev.sub.gargantext.org/#/share/Notes/187918 ...@@ -20,6 +20,7 @@ https://dev.sub.gargantext.org/#/share/Notes/187918
module Gargantext.Core.AsyncUpdates.Dispatcher where module Gargantext.Core.AsyncUpdates.Dispatcher where
import Control.Concurrent.Async qualified as Async import Control.Concurrent.Async qualified as Async
import Control.Concurrent.STM.TChan qualified as TChan
import Control.Lens (view) import Control.Lens (view)
import Data.Aeson ((.:), (.=)) import Data.Aeson ((.:), (.=))
import Data.Aeson qualified as Aeson import Data.Aeson qualified as Aeson
...@@ -38,8 +39,9 @@ import Gargantext.Core.AsyncUpdates.Constants as AUConstants ...@@ -38,8 +39,9 @@ import Gargantext.Core.AsyncUpdates.Constants as AUConstants
import Gargantext.Core.AsyncUpdates.Dispatcher.Types import Gargantext.Core.AsyncUpdates.Dispatcher.Types
import Gargantext.Core.Types (NodeId, UserId) import Gargantext.Core.Types (NodeId, UserId)
import Gargantext.Prelude import Gargantext.Prelude
-- import Gargantext.Utils.Jobs.Monad (MonadJobStatus(getLatestJobStatus))
import GHC.Conc (TVar, newTVarIO, readTVar, writeTVar) import GHC.Conc (TVar, newTVarIO, readTVar, writeTVar)
import Nanomsg import Nanomsg (Pull(..), bind, recvMalloc, withSocket)
import Network.WebSockets qualified as WS import Network.WebSockets qualified as WS
import Protolude.Base (Show(showsPrec)) import Protolude.Base (Show(showsPrec))
import Servant import Servant
...@@ -158,7 +160,7 @@ wsServer = WSAPI { wsAPIServer = streamData } ...@@ -158,7 +160,7 @@ wsServer = WSAPI { wsAPIServer = streamData }
WS.Text dm' _ -> do WS.Text dm' _ -> do
case Aeson.decode dm' of case Aeson.decode dm' of
Nothing -> do Nothing -> do
putText "[wsLoop] unknown message" putText $ "[wsLoop] unknown message: " <> show dm'
return user return user
Just (WSSubscribe topic) -> do Just (WSSubscribe topic) -> do
-- TODO Fix s_connected_user based on header -- TODO Fix s_connected_user based on header
...@@ -200,17 +202,37 @@ wsServer = WSAPI { wsAPIServer = streamData } ...@@ -200,17 +202,37 @@ wsServer = WSAPI { wsAPIServer = streamData }
return () return ()
-- | This is a nanomsg socket listener. We want to read the messages
-- | as fast as possible and then process them gradually in a separate
-- | thread.
dispatcher_listener :: SSet.Set Subscription -> IO () dispatcher_listener :: SSet.Set Subscription -> IO ()
dispatcher_listener subscriptions = do dispatcher_listener subscriptions = do
withSocket Pull $ \s -> do withSocket Pull $ \s -> do
_ <- bind s ("tcp://*:" <> show AUConstants.dispatcherInternalPort) _ <- bind s ("tcp://*:" <> show AUConstants.dispatcherInternalPort)
tChan <- TChan.newTChanIO
-- NOTE I'm not sure that we need more than 1 worker here, but in
-- theory, the worker can perform things like user authentication,
-- DB queries etc so it can be slow sometimes.
void $ Async.concurrently (Async.replicateConcurrently 5 $ worker s tChan) $ do
forever $ do
-- putText "[dispatcher_listener] receiving"
r <- recvMalloc s 1024
-- C.putStrLn $ "[dispatcher_listener] " <> r
atomically $ TChan.writeTChan tChan r
where
worker s tChan = do
-- tId <- myThreadId
forever $ do forever $ do
putText "[ce_listener] receiving" r <- atomically $ TChan.readTChan tChan
r <- recv s -- putText $ "[" <> show tId <> "] received a message: " <> decodeUtf8 r
C.putStrLn r
case Aeson.decode (BSL.fromStrict r) of case Aeson.decode (BSL.fromStrict r) of
Nothing -> putText "[ce_listener] unknown message from central exchange" Nothing -> putText "[dispatcher_listener] unknown message from central exchange"
Just ceMessage -> do Just ceMessage -> do
-- putText $ "[dispatcher_listener] received message: " <> show ceMessage
-- subs <- atomically $ readTVar subscriptions -- subs <- atomically $ readTVar subscriptions
filteredSubs <- atomically $ do filteredSubs <- atomically $ do
let subs' = UnfoldlM.filter (pure . ceMessageSubPred ceMessage) $ SSet.unfoldlM subscriptions let subs' = UnfoldlM.filter (pure . ceMessageSubPred ceMessage) $ SSet.unfoldlM subscriptions
...@@ -224,12 +246,21 @@ dispatcher_listener subscriptions = do ...@@ -224,12 +246,21 @@ dispatcher_listener subscriptions = do
-- send...) -- send...)
-- let filteredSubs = filterCEMessageSubs ceMessage subs -- let filteredSubs = filterCEMessageSubs ceMessage subs
mapM_ (sendNotification ceMessage) filteredSubs mapM_ (sendNotification ceMessage) filteredSubs
where
sendNotification :: CETypes.CEMessage -> Subscription -> IO () sendNotification :: CETypes.CEMessage -> Subscription -> IO ()
sendNotification ceMessage sub = do sendNotification ceMessage sub = do
let ws = s_ws_key_connection sub let ws = s_ws_key_connection sub
-- send the same thing to everyone for now let topic = s_topic sub
WS.sendDataMessage (wsConn ws) (WS.Text (Aeson.encode $ Notification $ s_topic sub) Nothing) notification <-
case ceMessage of
CETypes.UpdateJobProgress jId jobLog -> do
-- js <- getLatestJobStatus jId
-- putText $ "[sendNotification] latestJobStatus" js
pure $ Notification topic (MJobProgress jobLog)
CETypes.UpdateTreeFirstLevel nodeId -> pure $ Notification topic MEmpty
-- TODO send the same thing to everyone for now, this should be
-- converted to notifications
WS.sendDataMessage (wsConn ws) (WS.Text (Aeson.encode notification) Nothing)
-- Custom filtering of list of Subscriptions based on -- Custom filtering of list of Subscriptions based on
...@@ -240,5 +271,7 @@ filterCEMessageSubs :: CETypes.CEMessage -> [Subscription] -> [Subscription] ...@@ -240,5 +271,7 @@ filterCEMessageSubs :: CETypes.CEMessage -> [Subscription] -> [Subscription]
filterCEMessageSubs ceMessage subscriptions = filter (ceMessageSubPred ceMessage) subscriptions filterCEMessageSubs ceMessage subscriptions = filter (ceMessageSubPred ceMessage) subscriptions
ceMessageSubPred :: CETypes.CEMessage -> Subscription -> Bool ceMessageSubPred :: CETypes.CEMessage -> Subscription -> Bool
ceMessageSubPred (CETypes.UpdateJobProgress jId _jobLog) (Subscription { s_topic }) =
s_topic == UpdateJobProgress jId
ceMessageSubPred (CETypes.UpdateTreeFirstLevel node_id) (Subscription { s_topic }) = ceMessageSubPred (CETypes.UpdateTreeFirstLevel node_id) (Subscription { s_topic }) =
s_topic == UpdateTree node_id s_topic == UpdateTree node_id
...@@ -19,6 +19,7 @@ https://dev.sub.gargantext.org/#/share/Notes/187918 ...@@ -19,6 +19,7 @@ https://dev.sub.gargantext.org/#/share/Notes/187918
module Gargantext.Core.AsyncUpdates.Dispatcher.Types where module Gargantext.Core.AsyncUpdates.Dispatcher.Types where
import Codec.Binary.UTF8.String qualified as CBUTF8
import Control.Concurrent.Async qualified as Async import Control.Concurrent.Async qualified as Async
import Control.Lens (Getter, view) import Control.Lens (Getter, view)
import Data.Aeson ((.:), (.=)) import Data.Aeson ((.:), (.=))
...@@ -30,6 +31,7 @@ import Data.List (nubBy) ...@@ -30,6 +31,7 @@ import Data.List (nubBy)
import DeferredFolds.UnfoldlM qualified as UnfoldlM import DeferredFolds.UnfoldlM qualified as UnfoldlM
import Data.UUID.V4 as UUID import Data.UUID.V4 as UUID
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(_auth_user_id)) import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(_auth_user_id))
import Gargantext.API.Admin.Orchestrator.Types (JobLog)
import Gargantext.API.Admin.Types (jwtSettings, Settings, jwtSettings) import Gargantext.API.Admin.Types (jwtSettings, Settings, jwtSettings)
import Gargantext.API.Prelude (IsGargServer) import Gargantext.API.Prelude (IsGargServer)
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CETypes import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CETypes
...@@ -39,40 +41,74 @@ import Gargantext.Prelude ...@@ -39,40 +41,74 @@ import Gargantext.Prelude
import GHC.Conc (TVar, newTVarIO, readTVar, writeTVar) import GHC.Conc (TVar, newTVarIO, readTVar, writeTVar)
import Nanomsg import Nanomsg
import Network.WebSockets qualified as WS import Network.WebSockets qualified as WS
import Prelude qualified
import Protolude.Base (Show(showsPrec)) import Protolude.Base (Show(showsPrec))
import Servant import Servant
-- import Servant.API.NamedRoutes ((:-)) -- import Servant.API.NamedRoutes ((:-))
import Servant.API.WebSocket qualified as WS import Servant.API.WebSocket qualified as WS
import Servant.Auth.Server (verifyJWT) import Servant.Auth.Server (verifyJWT)
import Servant.Job.Core (Safety(Safe))
import Servant.Job.Types (JobID)
import Servant.Server.Generic (AsServer, AsServerT) import Servant.Server.Generic (AsServer, AsServerT)
import StmContainers.Set as SSet import StmContainers.Set as SSet
-- | A topic is sent, when a client wants to subscribe to specific
-- | types of notifications
data Topic = data Topic =
-- | Update given Servant Job (we currently send a request every -- | Update given Servant Job (we currently send a request every
-- | second to get job status). -- | second to get job status).
-- UpdateJob JobID UpdateJobProgress (JobID 'Safe)
-- | Given parent node id, trigger update of the node and its -- | Given parent node id, trigger update of the node and its
-- children (e.g. list is automatically created in a corpus) -- children (e.g. list is automatically created in a corpus)
UpdateTree NodeId | UpdateTree NodeId
deriving (Eq, Show) deriving (Eq)
instance Prelude.Show Topic where
show (UpdateJobProgress jId) = "UpdateJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode jId)
show (UpdateTree nodeId) = "UpdateTree " <> show nodeId
instance Hashable Topic where instance Hashable Topic where
hashWithSalt salt (UpdateJobProgress jId) = hashWithSalt salt ("update-job-progress" :: Text, Aeson.encode jId)
hashWithSalt salt (UpdateTree nodeId) = hashWithSalt salt ("update-tree" :: Text, nodeId) hashWithSalt salt (UpdateTree nodeId) = hashWithSalt salt ("update-tree" :: Text, nodeId)
instance FromJSON Topic where instance FromJSON Topic where
parseJSON = Aeson.withObject "Topic" $ \o -> do parseJSON = Aeson.withObject "Topic" $ \o -> do
type_ <- o .: "type" type_ <- o .: "type"
case type_ of case type_ of
"update_job_progress" -> do
jId <- o .: "j_id"
pure $ UpdateJobProgress jId
"update_tree" -> do "update_tree" -> do
node_id <- o .: "node_id" node_id <- o .: "node_id"
pure $ UpdateTree node_id pure $ UpdateTree node_id
s -> prependFailure "parsing type failed, " (typeMismatch "type" s) s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
instance ToJSON Topic where instance ToJSON Topic where
toJSON (UpdateJobProgress jId) = Aeson.object [
"type" .= toJSON ("update_job_progress" :: Text)
, "j_id" .= toJSON jId
]
toJSON (UpdateTree node_id) = Aeson.object [ toJSON (UpdateTree node_id) = Aeson.object [
"type" .= toJSON ("update_tree" :: Text) "type" .= toJSON ("update_tree" :: Text)
, "node_id" .= toJSON node_id , "node_id" .= toJSON node_id
] ]
-- | A message to be sent inside a Notification
data Message =
MJobProgress JobLog
| MEmpty
deriving (Eq)
instance Prelude.Show Message where
show (MJobProgress jobProgress) = "MJobProgress " <> show jobProgress
show MEmpty = "MEmpty"
instance ToJSON Message where
toJSON (MJobProgress jobProgress) = Aeson.object [
"type" .= toJSON ("MJobProgress" :: Text)
, "job_progress" .= toJSON jobProgress
]
toJSON MEmpty = Aeson.object [
"type" .= toJSON ("MEmpty" :: Text)
]
data ConnectedUser = data ConnectedUser =
CUUser UserId CUUser UserId
| CUPublic | CUPublic
...@@ -155,13 +191,16 @@ class HasDispatcher env where ...@@ -155,13 +191,16 @@ class HasDispatcher env where
hasDispatcher :: Getter env Dispatcher hasDispatcher :: Getter env Dispatcher
-- | A notification is sent to clients who subscribed to specific topics
data Notification = data Notification =
Notification Topic Notification Topic Message
deriving (Eq, Show) deriving (Eq, Show)
instance ToJSON Notification where instance ToJSON Notification where
toJSON (Notification topic) = Aeson.object [ toJSON (Notification topic message) = Aeson.object [
"notification" .= toJSON topic "notification" .= toJSON (Aeson.object [
"topic" .= toJSON topic
, "message" .= toJSON message
])
] ]
{-|
Module : Gargantext.Core.AsyncUpdates.Nanomsg
Description : Nanomsg utils
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
Docs:
https://dev.sub.gargantext.org/#/share/Notes/187918
-}
module Gargantext.Core.AsyncUpdates.Nanomsg where
import Gargantext.Prelude
import Nanomsg
withSafeSocket :: SocketType a => Text -> a -> (Socket a -> IO c) -> IO c
withSafeSocket socketName t =
bracket onOpen onClose
where
onOpen = do
s <- socket t
setRcvBuf s 1
setSndBuf s 1
rcvBufInt <- rcvBuf s
sndBufInt <- sndBuf s
putText $ "[" <> socketName <> "] rcvBuf: " <> show rcvBufInt <> ", sndBuf: " <> show sndBufInt
pure s
onClose s = do
close s
panicTrace $ "[withSafeSocket] " <> socketName <> " closed"
...@@ -20,8 +20,7 @@ module Gargantext.Database.Action.Delete ...@@ -20,8 +20,7 @@ module Gargantext.Database.Action.Delete
import Control.Lens (view) import Control.Lens (view)
import Data.Text (unpack) import Data.Text (unpack)
import Gargantext.Core (HasDBid(..)) import Gargantext.Core (HasDBid(..))
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE import Gargantext.Core.AsyncUpdates.CentralExchange.Types (ce_notify, CEMessage(..))
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CE
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Share (delFolderTeam) import Gargantext.Database.Action.Share (delFolderTeam)
import Gargantext.Database.Action.User (getUserId) import Gargantext.Database.Action.User (getUserId)
...@@ -60,11 +59,10 @@ deleteNode u nodeId = do ...@@ -60,11 +59,10 @@ deleteNode u nodeId = do
_ -> N.deleteNode nodeId _ -> N.deleteNode nodeId
-- | Node was deleted, refresh its parent (if exists) -- | Node was deleted, refresh its parent (if exists)
liftBase $ do -- mapM_ (CE.ce_notify . CE.UpdateTreeFirstLevel) nodeIds
-- mapM_ (CE.notify . CE.UpdateTreeFirstLevel) nodeIds
case view node_parent_id node' of case view node_parent_id node' of
Nothing -> return () Nothing -> return ()
Just pId -> CE.notify $ CE.UpdateTreeFirstLevel pId Just pId -> ce_notify $ UpdateTreeFirstLevel pId
return num return num
......
...@@ -65,8 +65,7 @@ import Data.Text qualified as T ...@@ -65,8 +65,7 @@ import Data.Text qualified as T
import EPO.API.Client.Types qualified as EPO import EPO.API.Client.Types qualified as EPO
import Gargantext.API.Ngrams.Tools (getTermsWith) import Gargantext.API.Ngrams.Tools (getTermsWith)
import Gargantext.Core (Lang(..), NLPServerConfig, withDefaultLanguage) import Gargantext.Core (Lang(..), NLPServerConfig, withDefaultLanguage)
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE import Gargantext.Core.AsyncUpdates.CentralExchange.Types (HasCentralExchangeNotification(ce_notify), CEMessage(..))
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CE
import Gargantext.Core.Ext.IMTUser (readFile_Annuaire) import Gargantext.Core.Ext.IMTUser (readFile_Annuaire)
import Gargantext.Core.NLP (HasNLPServer, nlpServerGet) import Gargantext.Core.NLP (HasNLPServer, nlpServerGet)
import Gargantext.Core.NodeStory.Types (HasNodeStory) import Gargantext.Core.NodeStory.Types (HasNodeStory)
...@@ -167,6 +166,7 @@ flowDataText :: forall env err m. ...@@ -167,6 +166,7 @@ flowDataText :: forall env err m.
, HasTreeError err , HasTreeError err
, HasValidationError err , HasValidationError err
, MonadJobStatus m , MonadJobStatus m
, HasCentralExchangeNotification env
) )
=> User => User
-> DataText -> DataText
...@@ -195,7 +195,8 @@ flowAnnuaire :: ( DbCmd' env err m ...@@ -195,7 +195,8 @@ flowAnnuaire :: ( DbCmd' env err m
, HasNLPServer env , HasNLPServer env
, HasTreeError err , HasTreeError err
, HasValidationError err , HasValidationError err
, MonadJobStatus m ) , MonadJobStatus m
, HasCentralExchangeNotification env )
=> MkCorpusUser => MkCorpusUser
-> TermType Lang -> TermType Lang
-> FilePath -> FilePath
...@@ -213,7 +214,8 @@ flowCorpusFile :: ( DbCmd' env err m ...@@ -213,7 +214,8 @@ flowCorpusFile :: ( DbCmd' env err m
, HasNLPServer env , HasNLPServer env
, HasTreeError err , HasTreeError err
, HasValidationError err , HasValidationError err
, MonadJobStatus m ) , MonadJobStatus m
, HasCentralExchangeNotification env )
=> MkCorpusUser => MkCorpusUser
-> Limit -- Limit the number of docs (for dev purpose) -> Limit -- Limit the number of docs (for dev purpose)
-> TermType Lang -> TermType Lang
...@@ -242,7 +244,8 @@ flowCorpus :: ( DbCmd' env err m ...@@ -242,7 +244,8 @@ flowCorpus :: ( DbCmd' env err m
, HasTreeError err , HasTreeError err
, HasValidationError err , HasValidationError err
, FlowCorpus a , FlowCorpus a
, MonadJobStatus m ) , MonadJobStatus m
, HasCentralExchangeNotification env )
=> MkCorpusUser => MkCorpusUser
-> TermType Lang -> TermType Lang
-> Maybe FlowSocialListWith -> Maybe FlowSocialListWith
...@@ -262,6 +265,7 @@ flow :: forall env err m a c. ...@@ -262,6 +265,7 @@ flow :: forall env err m a c.
, FlowCorpus a , FlowCorpus a
, MkCorpus c , MkCorpus c
, MonadJobStatus m , MonadJobStatus m
, HasCentralExchangeNotification env
) )
=> Maybe c => Maybe c
-> MkCorpusUser -> MkCorpusUser
...@@ -275,7 +279,7 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do ...@@ -275,7 +279,7 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do
-- TODO if public insertMasterDocs else insertUserDocs -- TODO if public insertMasterDocs else insertUserDocs
nlpServer <- view $ nlpServerGet (_tt_lang la) nlpServer <- view $ nlpServerGet (_tt_lang la)
runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC
.| CList.chunksOf 100 .| CList.chunksOf 2
.| mapM_C (addDocumentsWithProgress nlpServer userCorpusId) .| mapM_C (addDocumentsWithProgress nlpServer userCorpusId)
.| sinkNull .| sinkNull
...@@ -313,6 +317,7 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do ...@@ -313,6 +317,7 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do
------------------------------------------------------------------------ ------------------------------------------------------------------------
createNodes :: ( DbCmd' env err m, HasNodeError err createNodes :: ( DbCmd' env err m, HasNodeError err
, MkCorpus c , MkCorpus c
, HasCentralExchangeNotification env
) )
=> MkCorpusUser => MkCorpusUser
-> Maybe c -> Maybe c
...@@ -331,9 +336,8 @@ createNodes mkCorpusUser ctype = do ...@@ -331,9 +336,8 @@ createNodes mkCorpusUser ctype = do
_ <- insertDefaultNodeIfNotExists NodeGraph userCorpusId userId _ <- insertDefaultNodeIfNotExists NodeGraph userCorpusId userId
-- _ <- insertDefaultNodeIfNotExists NodeDashboard userCorpusId userId -- _ <- insertDefaultNodeIfNotExists NodeDashboard userCorpusId userId
liftBase $ do ce_notify $ UpdateTreeFirstLevel listId
CE.notify $ CE.UpdateTreeFirstLevel listId ce_notify $ UpdateTreeFirstLevel userCorpusId
CE.notify $ CE.UpdateTreeFirstLevel userCorpusId
pure (userId, userCorpusId, listId) pure (userId, userCorpusId, listId)
......
...@@ -27,7 +27,7 @@ module Gargantext.Database.Admin.Types.Hyperdata.Contact ...@@ -27,7 +27,7 @@ module Gargantext.Database.Admin.Types.Hyperdata.Contact
import Data.Morpheus.Types (GQLType(..)) import Data.Morpheus.Types (GQLType(..))
import Data.Time.Segment (jour) import Data.Time.Segment (jour)
import Gargantext.API.GraphQL.Utils qualified as GAGU import Gargantext.API.GraphQL.UnPrefix qualified as GAGU
import Gargantext.Core.Text (HasText(..)) import Gargantext.Core.Text (HasText(..))
import Gargantext.Database.Admin.Types.Hyperdata.Prelude import Gargantext.Database.Admin.Types.Hyperdata.Prelude
import Gargantext.Prelude import Gargantext.Prelude
......
...@@ -25,7 +25,7 @@ module Gargantext.Database.Admin.Types.Hyperdata.User ...@@ -25,7 +25,7 @@ module Gargantext.Database.Admin.Types.Hyperdata.User
where where
import Data.Morpheus.Types (GQLType(typeOptions)) import Data.Morpheus.Types (GQLType(typeOptions))
import qualified Gargantext.API.GraphQL.Utils as GAGU import qualified Gargantext.API.GraphQL.UnPrefix as GAGU
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.Database.Admin.Types.Hyperdata.Prelude import Gargantext.Database.Admin.Types.Hyperdata.Prelude
import Gargantext.Database.Admin.Types.Hyperdata.Contact import Gargantext.Database.Admin.Types.Hyperdata.Contact
......
...@@ -29,6 +29,7 @@ import Database.PostgreSQL.Simple qualified as PGS ...@@ -29,6 +29,7 @@ import Database.PostgreSQL.Simple qualified as PGS
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError) import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal (Field) import Database.PostgreSQL.Simple.Internal (Field)
import Database.PostgreSQL.Simple.Types (Query(..)) import Database.PostgreSQL.Simple.Types (Query(..))
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.Mail.Types (HasMail) import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer) import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Prelude import Gargantext.Prelude
...@@ -81,7 +82,8 @@ type CmdCommon env = ...@@ -81,7 +82,8 @@ type CmdCommon env =
( DbCommon env ( DbCommon env
, HasConfig env , HasConfig env
, HasMail env , HasMail env
, HasNLPServer env ) , HasNLPServer env
, CET.HasCentralExchangeNotification env )
type CmdM env err m = type CmdM env err m =
( CmdM' env err m ( CmdM' env err m
......
...@@ -24,7 +24,7 @@ module Gargantext.Database.Schema.User where ...@@ -24,7 +24,7 @@ module Gargantext.Database.Schema.User where
import Data.Morpheus.Types (GQLType(typeOptions)) import Data.Morpheus.Types (GQLType(typeOptions))
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Database.PostgreSQL.Simple.FromField (FromField, fromField) import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import Gargantext.API.GraphQL.Utils qualified as GAGU import Gargantext.API.GraphQL.UnPrefix qualified as GAGU
import Gargantext.Core.Types.Individu (GargPassword, toGargPassword) import Gargantext.Core.Types.Individu (GargPassword, toGargPassword)
import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Prelude (fromField') import Gargantext.Database.Prelude (fromField')
......
...@@ -31,27 +31,26 @@ module Gargantext.Utils.Jobs.Monad ( ...@@ -31,27 +31,26 @@ module Gargantext.Utils.Jobs.Monad (
, markFailureNoErr , markFailureNoErr
) where ) where
import Gargantext.Utils.Jobs.Error
import Gargantext.Utils.Jobs.Map
import Gargantext.Utils.Jobs.Queue
import Gargantext.Utils.Jobs.Settings
import Gargantext.Utils.Jobs.State
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Exception import Control.Exception
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader
import Data.Kind (Type) import Data.Kind (Type)
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Data.Proxy
import Data.Text qualified as T
import Data.Time.Clock import Data.Time.Clock
import Data.Void (Void) import Data.Void (Void)
import qualified Data.Text as T import Gargantext.Utils.Jobs.Error
import Gargantext.Utils.Jobs.Map
import Gargantext.Utils.Jobs.Queue
import Gargantext.Utils.Jobs.Settings
import Gargantext.Utils.Jobs.State
import Network.HTTP.Client (Manager) import Network.HTTP.Client (Manager)
import Prelude import Prelude
import Servant.Job.Core qualified as SJ
import Servant.Job.Types qualified as SJ
import qualified Servant.Job.Core as SJ
import qualified Servant.Job.Types as SJ
import Data.Proxy
data JobEnv t w a = JobEnv data JobEnv t w a = JobEnv
{ jeSettings :: JobSettings { jeSettings :: JobSettings
......
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