[worker] tasty tests pass now

parent b3830a99
Pipeline #6935 canceled with stages
...@@ -127,12 +127,16 @@ library ...@@ -127,12 +127,16 @@ library
Gargantext.API.Ngrams.Tools Gargantext.API.Ngrams.Tools
Gargantext.API.Ngrams.Types Gargantext.API.Ngrams.Types
Gargantext.API.Node Gargantext.API.Node
Gargantext.API.Node.Corpus.Annuaire
Gargantext.API.Node.Corpus.New Gargantext.API.Node.Corpus.New
Gargantext.API.Node.Corpus.New.Types Gargantext.API.Node.Corpus.New.Types
Gargantext.API.Node.Corpus.Types Gargantext.API.Node.Corpus.Types
Gargantext.API.Node.Corpus.Update Gargantext.API.Node.Corpus.Update
Gargantext.API.Node.DocumentsFromWriteNodes.Types
Gargantext.API.Node.DocumentUpload.Types
Gargantext.API.Node.File Gargantext.API.Node.File
Gargantext.API.Node.File.Types Gargantext.API.Node.File.Types
Gargantext.API.Node.FrameCalcUpload.Types
Gargantext.API.Node.Share Gargantext.API.Node.Share
Gargantext.API.Node.Share.Types Gargantext.API.Node.Share.Types
Gargantext.API.Node.ShareURL Gargantext.API.Node.ShareURL
...@@ -247,6 +251,7 @@ library ...@@ -247,6 +251,7 @@ library
Gargantext.Core.Worker.Env Gargantext.Core.Worker.Env
Gargantext.Core.Worker.Jobs Gargantext.Core.Worker.Jobs
Gargantext.Core.Worker.Jobs.Types Gargantext.Core.Worker.Jobs.Types
Gargantext.Core.Worker.PGMQTypes
Gargantext.Core.Worker.Types Gargantext.Core.Worker.Types
Gargantext.Database.Action.Flow Gargantext.Database.Action.Flow
Gargantext.Database.Action.Flow.Types Gargantext.Database.Action.Flow.Types
...@@ -310,7 +315,6 @@ library ...@@ -310,7 +315,6 @@ library
Gargantext.API.Ngrams.NgramsTree Gargantext.API.Ngrams.NgramsTree
Gargantext.API.Node.Contact Gargantext.API.Node.Contact
Gargantext.API.Node.Contact.Types Gargantext.API.Node.Contact.Types
Gargantext.API.Node.Corpus.Annuaire
Gargantext.API.Node.Corpus.Export Gargantext.API.Node.Corpus.Export
Gargantext.API.Node.Corpus.Export.Types Gargantext.API.Node.Corpus.Export.Types
Gargantext.API.Node.Corpus.Searx Gargantext.API.Node.Corpus.Searx
...@@ -319,11 +323,8 @@ library ...@@ -319,11 +323,8 @@ library
Gargantext.API.Node.Phylo.Export Gargantext.API.Node.Phylo.Export
Gargantext.API.Node.Phylo.Export.Types Gargantext.API.Node.Phylo.Export.Types
Gargantext.API.Node.DocumentUpload Gargantext.API.Node.DocumentUpload
Gargantext.API.Node.DocumentUpload.Types
Gargantext.API.Node.DocumentsFromWriteNodes Gargantext.API.Node.DocumentsFromWriteNodes
Gargantext.API.Node.DocumentsFromWriteNodes.Types
Gargantext.API.Node.FrameCalcUpload Gargantext.API.Node.FrameCalcUpload
Gargantext.API.Node.FrameCalcUpload.Types
Gargantext.API.Node.Get Gargantext.API.Node.Get
Gargantext.API.Node.New Gargantext.API.Node.New
Gargantext.API.Node.New.Types Gargantext.API.Node.New.Types
...@@ -853,6 +854,8 @@ test-suite garg-test-tasty ...@@ -853,6 +854,8 @@ test-suite garg-test-tasty
Test.Utils.Crypto Test.Utils.Crypto
Test.Utils.Db Test.Utils.Db
Test.Utils.Jobs Test.Utils.Jobs
Test.Utils.Jobs.Types
Test.Utils.Notifications
hs-source-dirs: hs-source-dirs:
test bin/gargantext-cli test bin/gargantext-cli
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
...@@ -886,6 +889,7 @@ test-suite garg-test-hspec ...@@ -886,6 +889,7 @@ test-suite garg-test-hspec
Test.Types Test.Types
Test.Utils Test.Utils
Test.Utils.Db Test.Utils.Db
Test.Utils.Notifications
hs-source-dirs: hs-source-dirs:
test test
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
......
{-| {-|
Module : Gargantext.API.Node.FrameCalcUpload Module : Gargantext.API.Node.FrameCalcUpload.Types
Description : Frame calc upload types Description : Frame calc upload types
Copyright : (c) CNRS, 2024-Present Copyright : (c) CNRS, 2024-Present
License : AGPL + CECILL v3 License : AGPL + CECILL v3
......
...@@ -55,30 +55,22 @@ import StmContainers.Set as SSet ...@@ -55,30 +55,22 @@ import StmContainers.Set as SSet
-- | A topic is sent, when a client wants to subscribe to specific -- | A topic is sent, when a client wants to subscribe to specific
-- | types of notifications -- | types of notifications
data Topic = data Topic =
-- | Update given Servant Job (we currently send a request every
-- | second to get job status).
UpdateJobProgress (JobID 'Safe)
-- | New, worker version for updating job state -- | New, worker version for updating job state
| UpdateWorkerProgress JobInfo UpdateWorkerProgress JobInfo
-- | 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, Ord) deriving (Eq, Ord)
instance Prelude.Show Topic where instance Prelude.Show Topic where
show (UpdateJobProgress jId) = "UpdateJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode jId)
show (UpdateWorkerProgress ji) = "UpdateWorkerProgress " <> show ji show (UpdateWorkerProgress ji) = "UpdateWorkerProgress " <> show ji
show (UpdateTree nodeId) = "UpdateTree " <> show nodeId 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 (UpdateWorkerProgress ji) = hashWithSalt salt ("update-worker-progress" :: Text, Aeson.encode ji) hashWithSalt salt (UpdateWorkerProgress ji) = hashWithSalt salt ("update-worker-progress" :: Text, Aeson.encode ji)
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_worker_progress" -> do "update_worker_progress" -> do
ji <- o .: "ji" ji <- o .: "ji"
pure $ UpdateWorkerProgress ji pure $ UpdateWorkerProgress ji
...@@ -87,10 +79,6 @@ instance FromJSON Topic where ...@@ -87,10 +79,6 @@ instance FromJSON Topic where
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 (UpdateWorkerProgress ji) = Aeson.object [ toJSON (UpdateWorkerProgress ji) = Aeson.object [
"type" .= toJSON ("update_worker_progress" :: Text) "type" .= toJSON ("update_worker_progress" :: Text)
, "ji" .= toJSON ji , "ji" .= toJSON ji
......
...@@ -17,11 +17,9 @@ Portability : POSIX ...@@ -17,11 +17,9 @@ Portability : POSIX
module Gargantext.Core.Worker where module Gargantext.Core.Worker where
import Async.Worker.Broker.PGMQ (PGMQBroker) import Async.Worker.Broker.Types (toA, getMessage, messageId)
import Async.Worker.Broker.Types (BrokerMessage, toA, getMessage, messageId)
import Async.Worker qualified as W import Async.Worker qualified as W
import Async.Worker.Types qualified as W import Async.Worker.Types qualified as W
import Async.Worker.Types (HasWorkerBroker)
import Data.Text qualified as T import Data.Text qualified as T
import Gargantext.API.Admin.Auth (forgotUserPassword) import Gargantext.API.Admin.Auth (forgotUserPassword)
import Gargantext.API.Admin.Auth.Types (ForgotPasswordAsyncParams(..)) import Gargantext.API.Admin.Auth.Types (ForgotPasswordAsyncParams(..))
...@@ -42,6 +40,7 @@ import Gargantext.Core.Config.Worker (WorkerDefinition(..)) ...@@ -42,6 +40,7 @@ import Gargantext.Core.Config.Worker (WorkerDefinition(..))
import Gargantext.Core.Viz.Graph.API (graphRecompute) import Gargantext.Core.Viz.Graph.API (graphRecompute)
import Gargantext.Core.Worker.Broker (initBrokerWithDBCreate) import Gargantext.Core.Worker.Broker (initBrokerWithDBCreate)
import Gargantext.Core.Worker.Env import Gargantext.Core.Worker.Env
import Gargantext.Core.Worker.PGMQTypes (BrokerMessage, HasWorkerBroker, WState)
import Gargantext.Core.Worker.Jobs.Types (Job(..), getWorkerMNodeId) import Gargantext.Core.Worker.Jobs.Types (Job(..), getWorkerMNodeId)
import Gargantext.Core.Worker.Types (JobInfo(..)) import Gargantext.Core.Worker.Types (JobInfo(..))
import Gargantext.Database.Query.Table.User (getUsersWithEmail) import Gargantext.Database.Query.Table.User (getUsersWithEmail)
...@@ -52,10 +51,10 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(markStarted, markComplete, ma ...@@ -52,10 +51,10 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(markStarted, markComplete, ma
import System.Posix.Signals (Handler(Catch), installHandler, keyboardSignal) import System.Posix.Signals (Handler(Catch), installHandler, keyboardSignal)
initWorkerState :: (HasWorkerBroker PGMQBroker Job) initWorkerState :: HasWorkerBroker
=> WorkerEnv => WorkerEnv
-> WorkerDefinition -> WorkerDefinition
-> IO (W.State PGMQBroker Job) -> IO WState
initWorkerState env (WorkerDefinition { .. }) = do initWorkerState env (WorkerDefinition { .. }) = do
let gargConfig = env ^. hasConfig let gargConfig = env ^. hasConfig
broker <- initBrokerWithDBCreate gargConfig broker <- initBrokerWithDBCreate gargConfig
...@@ -70,10 +69,10 @@ initWorkerState env (WorkerDefinition { .. }) = do ...@@ -70,10 +69,10 @@ initWorkerState env (WorkerDefinition { .. }) = do
, onJobError = Just $ notifyJobFailed env , onJobError = Just $ notifyJobFailed env
, onWorkerKilledSafely = Just $ notifyJobKilled env } , onWorkerKilledSafely = Just $ notifyJobKilled env }
notifyJobStarted :: (HasWorkerBroker PGMQBroker Job) notifyJobStarted :: HasWorkerBroker
=> WorkerEnv => WorkerEnv
-> W.State PGMQBroker Job -> WState
-> BrokerMessage PGMQBroker (W.Job Job) -> BrokerMessage
-> IO () -> IO ()
notifyJobStarted env (W.State { name }) bm = do notifyJobStarted env (W.State { name }) bm = do
let j = toA $ getMessage bm let j = toA $ getMessage bm
...@@ -85,10 +84,10 @@ notifyJobStarted env (W.State { name }) bm = do ...@@ -85,10 +84,10 @@ notifyJobStarted env (W.State { name }) bm = do
let jh = WorkerJobHandle { _w_job_info = ji } let jh = WorkerJobHandle { _w_job_info = ji }
runWorkerMonad env $ markStarted 1 jh runWorkerMonad env $ markStarted 1 jh
notifyJobFinished :: (HasWorkerBroker PGMQBroker Job) notifyJobFinished :: HasWorkerBroker
=> WorkerEnv => WorkerEnv
-> W.State PGMQBroker Job -> WState
-> BrokerMessage PGMQBroker (W.Job Job) -> BrokerMessage
-> IO () -> IO ()
notifyJobFinished env (W.State { name }) bm = do notifyJobFinished env (W.State { name }) bm = do
let j = toA $ getMessage bm let j = toA $ getMessage bm
...@@ -100,10 +99,10 @@ notifyJobFinished env (W.State { name }) bm = do ...@@ -100,10 +99,10 @@ notifyJobFinished env (W.State { name }) bm = do
let jh = WorkerJobHandle { _w_job_info = ji } let jh = WorkerJobHandle { _w_job_info = ji }
runWorkerMonad env $ markComplete jh runWorkerMonad env $ markComplete jh
notifyJobTimeout :: (HasWorkerBroker PGMQBroker Job) notifyJobTimeout :: HasWorkerBroker
=> WorkerEnv => WorkerEnv
-> W.State PGMQBroker Job -> WState
-> BrokerMessage PGMQBroker (W.Job Job) -> BrokerMessage
-> IO () -> IO ()
notifyJobTimeout env (W.State { name }) bm = do notifyJobTimeout env (W.State { name }) bm = do
let j = toA $ getMessage bm let j = toA $ getMessage bm
...@@ -115,10 +114,10 @@ notifyJobTimeout env (W.State { name }) bm = do ...@@ -115,10 +114,10 @@ notifyJobTimeout env (W.State { name }) bm = do
let jh = WorkerJobHandle { _w_job_info = ji } let jh = WorkerJobHandle { _w_job_info = ji }
runWorkerMonad env $ markFailed (Just $ UnsafeMkHumanFriendlyErrorText "Worker job timed out!") jh runWorkerMonad env $ markFailed (Just $ UnsafeMkHumanFriendlyErrorText "Worker job timed out!") jh
notifyJobFailed :: (HasWorkerBroker PGMQBroker Job, HasCallStack) notifyJobFailed :: (HasWorkerBroker, HasCallStack)
=> WorkerEnv => WorkerEnv
-> W.State PGMQBroker Job -> WState
-> BrokerMessage PGMQBroker (W.Job Job) -> BrokerMessage
-> SomeException -> SomeException
-> IO () -> IO ()
notifyJobFailed env (W.State { name }) bm exc = do notifyJobFailed env (W.State { name }) bm exc = do
...@@ -131,10 +130,10 @@ notifyJobFailed env (W.State { name }) bm exc = do ...@@ -131,10 +130,10 @@ notifyJobFailed env (W.State { name }) bm exc = do
let jh = WorkerJobHandle { _w_job_info = ji } let jh = WorkerJobHandle { _w_job_info = ji }
runWorkerMonad env $ markFailed (Just $ UnsafeMkHumanFriendlyErrorText "Worker job failed") jh runWorkerMonad env $ markFailed (Just $ UnsafeMkHumanFriendlyErrorText "Worker job failed") jh
notifyJobKilled :: (HasWorkerBroker PGMQBroker Job, HasCallStack) notifyJobKilled :: (HasWorkerBroker, HasCallStack)
=> WorkerEnv => WorkerEnv
-> W.State PGMQBroker Job -> WState
-> Maybe (BrokerMessage PGMQBroker (W.Job Job)) -> Maybe BrokerMessage
-> IO () -> IO ()
notifyJobKilled _ _ Nothing = pure () notifyJobKilled _ _ Nothing = pure ()
notifyJobKilled env (W.State { name }) (Just bm) = do notifyJobKilled env (W.State { name }) (Just bm) = do
...@@ -154,20 +153,20 @@ notifyJobKilled env (W.State { name }) (Just bm) = do ...@@ -154,20 +153,20 @@ notifyJobKilled env (W.State { name }) (Just bm) = do
-- - progress report via notifications -- - progress report via notifications
-- - I think there is no point to save job result, as usually there is none (we have side-effects only) -- - I think there is no point to save job result, as usually there is none (we have side-effects only)
-- - replace Servant.Job to use workers instead of garg API threads -- - replace Servant.Job to use workers instead of garg API threads
withPGMQWorker :: (HasWorkerBroker PGMQBroker Job) withPGMQWorker :: HasWorkerBroker
=> WorkerEnv => WorkerEnv
-> WorkerDefinition -> WorkerDefinition
-> (Async () -> W.State PGMQBroker Job -> IO ()) -> (Async () -> WState -> IO ())
-> IO () -> IO ()
withPGMQWorker env wd cb = do withPGMQWorker env wd cb = do
state' <- initWorkerState env wd state' <- initWorkerState env wd
withAsync (W.run state') (\a -> cb a state') withAsync (W.run state') (\a -> cb a state')
withPGMQWorkerSingle :: (HasWorkerBroker PGMQBroker Job) withPGMQWorkerSingle :: HasWorkerBroker
=> WorkerEnv => WorkerEnv
-> WorkerDefinition -> WorkerDefinition
-> (Async () -> W.State PGMQBroker Job -> IO ()) -> (Async () -> WState -> IO ())
-> IO () -> IO ()
withPGMQWorkerSingle env wd cb = do withPGMQWorkerSingle env wd cb = do
state' <- initWorkerState env wd state' <- initWorkerState env wd
...@@ -175,10 +174,10 @@ withPGMQWorkerSingle env wd cb = do ...@@ -175,10 +174,10 @@ withPGMQWorkerSingle env wd cb = do
withAsync (W.runSingle state') (\a -> cb a state') withAsync (W.runSingle state') (\a -> cb a state')
withPGMQWorkerCtrlC :: (HasWorkerBroker PGMQBroker Job) withPGMQWorkerCtrlC :: HasWorkerBroker
=> WorkerEnv => WorkerEnv
-> WorkerDefinition -> WorkerDefinition
-> (Async () -> W.State PGMQBroker Job -> IO ()) -> (Async () -> WState -> IO ())
-> IO () -> IO ()
withPGMQWorkerCtrlC env wd cb = do withPGMQWorkerCtrlC env wd cb = do
withPGMQWorker env wd $ \a state' -> do withPGMQWorker env wd $ \a state' -> do
...@@ -186,10 +185,10 @@ withPGMQWorkerCtrlC env wd cb = do ...@@ -186,10 +185,10 @@ withPGMQWorkerCtrlC env wd cb = do
_ <- installHandler keyboardSignal (Catch (throwTo tid W.KillWorkerSafely)) Nothing _ <- installHandler keyboardSignal (Catch (throwTo tid W.KillWorkerSafely)) Nothing
cb a state' cb a state'
withPGMQWorkerSingleCtrlC :: (HasWorkerBroker PGMQBroker Job) withPGMQWorkerSingleCtrlC :: HasWorkerBroker
=> WorkerEnv => WorkerEnv
-> WorkerDefinition -> WorkerDefinition
-> (Async () -> W.State PGMQBroker Job -> IO ()) -> (Async () -> WState -> IO ())
-> IO () -> IO ()
withPGMQWorkerSingleCtrlC env wd cb = do withPGMQWorkerSingleCtrlC env wd cb = do
withPGMQWorkerSingle env wd $ \a state' -> do withPGMQWorkerSingle env wd $ \a state' -> do
...@@ -199,10 +198,10 @@ withPGMQWorkerSingleCtrlC env wd cb = do ...@@ -199,10 +198,10 @@ withPGMQWorkerSingleCtrlC env wd cb = do
-- | How the worker should process jobs -- | How the worker should process jobs
performAction :: (HasWorkerBroker PGMQBroker Job) performAction :: HasWorkerBroker
=> WorkerEnv => WorkerEnv
-> W.State PGMQBroker Job -> WState
-> BrokerMessage PGMQBroker (W.Job Job) -> BrokerMessage
-> IO () -> IO ()
performAction env _state bm = do performAction env _state bm = do
let job' = toA $ getMessage bm let job' = toA $ getMessage bm
......
...@@ -13,15 +13,14 @@ module Gargantext.Core.Worker.Broker ...@@ -13,15 +13,14 @@ module Gargantext.Core.Worker.Broker
( initBrokerWithDBCreate ) ( initBrokerWithDBCreate )
where where
import Async.Worker.Broker.PGMQ (PGMQBroker, BrokerInitParams(PGMQBrokerInitParams)) import Async.Worker.Broker.PGMQ (BrokerInitParams(PGMQBrokerInitParams))
import Async.Worker.Broker.Types (Broker, initBroker) import Async.Worker.Broker.Types (initBroker)
import Async.Worker.Types qualified as W
import Data.Text qualified as T import Data.Text qualified as T
import Data.Text.Encoding qualified as TE import Data.Text.Encoding qualified as TE
import Database.PostgreSQL.Simple qualified as PSQL import Database.PostgreSQL.Simple qualified as PSQL
import Gargantext.Core.Config (GargConfig(..), gc_worker) import Gargantext.Core.Config (GargConfig(..), gc_worker)
import Gargantext.Core.Config.Worker (WorkerSettings(..)) import Gargantext.Core.Config.Worker (WorkerSettings(..))
import Gargantext.Core.Worker.Jobs.Types (Job(..)) import Gargantext.Core.Worker.PGMQTypes (HasWorkerBroker, Broker)
import Gargantext.Database.Prelude (createDBIfNotExists) import Gargantext.Database.Prelude (createDBIfNotExists)
import Gargantext.Prelude import Gargantext.Prelude
...@@ -29,9 +28,9 @@ import Gargantext.Prelude ...@@ -29,9 +28,9 @@ import Gargantext.Prelude
-- | Create DB if not exists, then run 'initBroker' (which, in -- | Create DB if not exists, then run 'initBroker' (which, in
-- particular, creates the pgmq extension, if needed) -- particular, creates the pgmq extension, if needed)
initBrokerWithDBCreate :: (W.HasWorkerBroker PGMQBroker Job) initBrokerWithDBCreate :: HasWorkerBroker
=> GargConfig => GargConfig
-> IO (Broker PGMQBroker (W.Job Job)) -> IO Broker
initBrokerWithDBCreate gc@(GargConfig { _gc_database_config }) = do initBrokerWithDBCreate gc@(GargConfig { _gc_database_config }) = do
-- By using gargantext db credentials, we create pgmq db (if needed) -- By using gargantext db credentials, we create pgmq db (if needed)
let WorkerSettings { .. } = gc ^. gc_worker let WorkerSettings { .. } = gc ^. gc_worker
......
...@@ -221,7 +221,6 @@ data WorkerJobHandle = ...@@ -221,7 +221,6 @@ data WorkerJobHandle =
-- | Worker handles 1 job at a time, hence it's enough to provide -- | Worker handles 1 job at a time, hence it's enough to provide
-- simple progress tracking -- simple progress tracking
instance MonadJobStatus WorkerMonad where instance MonadJobStatus WorkerMonad where
-- type JobHandle WorkerMonad = WorkerJobHandle
type JobHandle WorkerMonad = WorkerJobHandle type JobHandle WorkerMonad = WorkerJobHandle
type JobOutputType WorkerMonad = JobLog type JobOutputType WorkerMonad = JobLog
type JobEventType WorkerMonad = JobLog type JobEventType WorkerMonad = JobLog
......
{-|
Module : Gargantext.Core.Worker.PGMQTypes
Description : Worker type aliases for PGMQ
Copyright : (c) CNRS, 2024-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE ConstraintKinds #-}
module Gargantext.Core.Worker.PGMQTypes where
import Async.Worker.Broker.PGMQ (PGMQBroker)
import Async.Worker.Broker.Types qualified as BT
import Async.Worker.Types qualified as W
import Gargantext.Core.Worker.Jobs.Types (Job)
type HasWorkerBroker = W.HasWorkerBroker PGMQBroker Job
type Broker = BT.Broker PGMQBroker (W.Job Job)
type BrokerMessage = BT.BrokerMessage PGMQBroker (W.Job Job)
type WState = W.State PGMQBroker Job
...@@ -19,7 +19,6 @@ import Gargantext.Core.Types (NodeId) ...@@ -19,7 +19,6 @@ import Gargantext.Core.Types (NodeId)
import Gargantext.Prelude import Gargantext.Prelude
data JobInfo = JobInfo { _ji_message_id :: BT.MessageId PGMQBroker data JobInfo = JobInfo { _ji_message_id :: BT.MessageId PGMQBroker
-- NOTE: Most jobs are associated with node id. -- NOTE: Most jobs are associated with node id.
-- The 'node_id' allows the frontend to assign progress bar to a node. -- The 'node_id' allows the frontend to assign progress bar to a node.
......
...@@ -37,12 +37,9 @@ import Prelude ...@@ -37,12 +37,9 @@ import Prelude
import Test.API.Setup (withTestDBAndNotifications) import Test.API.Setup (withTestDBAndNotifications)
import Test.Hspec import Test.Hspec
import Test.Instances () import Test.Instances ()
import Test.Utils.Notifications
instance Eq DT.Notification where
-- simple
(==) n1 n2 = show n1 == show n2
tests :: NotificationsConfig -> D.Dispatcher -> Spec tests :: NotificationsConfig -> D.Dispatcher -> Spec
tests nc dispatcher = sequential $ aroundAll (withTestDBAndNotifications dispatcher) $ do tests nc dispatcher = sequential $ aroundAll (withTestDBAndNotifications dispatcher) $ do
...@@ -52,7 +49,7 @@ tests nc dispatcher = sequential $ aroundAll (withTestDBAndNotifications dispatc ...@@ -52,7 +49,7 @@ tests nc dispatcher = sequential $ aroundAll (withTestDBAndNotifications dispatc
tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification)) tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
-- setup a websocket connection -- setup a websocket connection
let wsConnect = let wsConnect =
withWSConnection ("127.0.0.1", port, "/ws") $ \conn -> do withWSConnection ("127.0.0.1", port) $ \conn -> do
-- We wait a bit before the server settles -- We wait a bit before the server settles
threadDelay (100 * millisecond) threadDelay (100 * millisecond)
WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe topic) WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe topic)
...@@ -73,27 +70,3 @@ tests nc dispatcher = sequential $ aroundAll (withTestDBAndNotifications dispatc ...@@ -73,27 +70,3 @@ tests nc dispatcher = sequential $ aroundAll (withTestDBAndNotifications dispatc
md <- atomically $ readTChan tchan md <- atomically $ readTChan tchan
md `shouldBe` Just (DT.NUpdateTree nodeId) md `shouldBe` Just (DT.NUpdateTree nodeId)
millisecond :: Int
millisecond = 1000
-- | Wrap the logic of asynchronous connection closing
-- https://hackage.haskell.org/package/websockets-0.13.0.0/docs/Network-WebSockets-Connection.html#v:sendClose
withWSConnection :: (String, Int, String) -> WS.ClientApp () -> IO ()
withWSConnection (host, port, path) cb =
WS.runClient host port path $ \conn -> do
cb conn
-- shut down gracefully, otherwise a 'ConnectionException' is thrown
WS.sendClose conn ("" :: BS.ByteString)
-- wait for close response, should throw a 'CloseRequest' exception
Exc.catches (void $ WS.receiveDataMessage conn)
[ Exc.Handler $ \(err :: WS.ConnectionException) ->
case err of
WS.CloseRequest _ _ -> putStrLn "[withWSConnection] closeRequest caught"
_ -> Exc.throw err
-- re-throw any other exceptions
, Exc.Handler $ \(err :: Exc.SomeException) -> Exc.throw err ]
...@@ -17,10 +17,12 @@ import Gargantext.API.Routes.Named.Node ...@@ -17,10 +17,12 @@ import Gargantext.API.Routes.Named.Node
import Gargantext.API.Routes.Named.Private hiding (tableNgramsAPI) import Gargantext.API.Routes.Named.Private hiding (tableNgramsAPI)
import Gargantext.API.Routes.Named.Table import Gargantext.API.Routes.Named.Table
import Gargantext.API.Types () -- MimeUnrender instances import Gargantext.API.Types () -- MimeUnrender instances
import Gargantext.API.Worker (workerAPIPost)
import Gargantext.Core.Text.Corpus.Query (RawQuery) import Gargantext.Core.Text.Corpus.Query (RawQuery)
import Gargantext.Core.Types (ListId, NodeId, NodeType, NodeTableResult) import Gargantext.Core.Types (ListId, NodeId, NodeType, NodeTableResult)
import Gargantext.Core.Types.Main (ListType) import Gargantext.Core.Types.Main (ListType)
import Gargantext.Core.Types.Query (Limit, MaxSize, MinSize, Offset) import Gargantext.Core.Types.Query (Limit, MaxSize, MinSize, Offset)
import Gargantext.Core.Worker.Types (JobInfo)
import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Query.Facet qualified as Facet import Gargantext.Database.Query.Facet qualified as Facet
import Gargantext.Prelude import Gargantext.Prelude
...@@ -80,7 +82,7 @@ toServantToken = S.Token . TE.encodeUtf8 ...@@ -80,7 +82,7 @@ toServantToken = S.Token . TE.encodeUtf8
update_node :: Token update_node :: Token
-> NodeId -> NodeId
-> UpdateNodeParams -> UpdateNodeParams
-> ClientM (JobStatus 'Safe JobLog) -> ClientM JobInfo
update_node (toServantToken -> token) nodeId params = update_node (toServantToken -> token) nodeId params =
clientRoutes & apiWithCustomErrorScheme clientRoutes & apiWithCustomErrorScheme
& ($ GES_new) & ($ GES_new)
...@@ -96,8 +98,8 @@ update_node (toServantToken -> token) nodeId params = ...@@ -96,8 +98,8 @@ update_node (toServantToken -> token) nodeId params =
& ($ nodeId) & ($ nodeId)
& updateAPI & updateAPI
& updateNodeEp & updateNodeEp
& asyncJobsAPI' & workerAPIPost
& (\(_ :<|> submitForm :<|> _) -> submitForm (JobInput params Nothing)) & (\submitForm -> submitForm params)
get_table_ngrams :: Token get_table_ngrams :: Token
-> NodeId -> NodeId
......
...@@ -23,7 +23,7 @@ import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..), env_dispatcher) ...@@ -23,7 +23,7 @@ import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..), env_dispatcher)
import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
import Gargantext.API.Prelude import Gargantext.API.Prelude
import Gargantext.Core.Notifications.Dispatcher qualified as D import Gargantext.Core.Notifications.Dispatcher qualified as D
import Gargantext.Core.Config (_gc_secrets, gc_frontend_config, gc_jobs, hasConfig) import Gargantext.Core.Config (_gc_secrets, gc_frontend_config, hasConfig)
import Gargantext.Core.Config.Types (SettingsFile(..), jc_js_job_timeout, jc_js_id_timeout, fc_appPort, jwtSettings) import Gargantext.Core.Config.Types (SettingsFile(..), jc_js_job_timeout, jc_js_id_timeout, fc_appPort, jwtSettings)
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow import Gargantext.Database.Action.Flow
...@@ -36,10 +36,7 @@ import Gargantext.Database.Query.Table.Node (getOrMkList) ...@@ -36,10 +36,7 @@ import Gargantext.Database.Query.Table.Node (getOrMkList)
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..)) import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))
import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp) import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
import Gargantext.System.Logging import Gargantext.System.Logging
import Gargantext.Utils.Jobs qualified as Jobs
import Gargantext.Utils.Jobs.Monad qualified as Jobs import Gargantext.Utils.Jobs.Monad qualified as Jobs
import Gargantext.Utils.Jobs.Queue qualified as Jobs
import Gargantext.Utils.Jobs.Settings qualified as Jobs
import Network.HTTP.Client.TLS (newTlsManager) import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Types import Network.HTTP.Types
import Network.Wai (Application, responseLBS) import Network.Wai (Application, responseLBS)
...@@ -78,8 +75,6 @@ newTestEnv testEnv logger port = do ...@@ -78,8 +75,6 @@ newTestEnv testEnv logger port = do
!manager_env <- newTlsManager !manager_env <- newTlsManager
let config_env = test_config testEnv & (gc_frontend_config . fc_appPort) .~ port let config_env = test_config testEnv & (gc_frontend_config . fc_appPort) .~ port
prios <- withLogger () $ \ioLogger -> Jobs.readPrios ioLogger (sf <> ".jobs")
let prios' = Jobs.applyPrios prios Jobs.defaultPrios
!self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port !self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port
-- dbParam <- pure $ testEnvToPgConnectionInfo testEnv -- dbParam <- pure $ testEnvToPgConnectionInfo testEnv
-- !pool <- newPool dbParam -- !pool <- newPool dbParam
...@@ -87,11 +82,6 @@ newTestEnv testEnv logger port = do ...@@ -87,11 +82,6 @@ newTestEnv testEnv logger port = do
-- !nodeStory_env <- fromDBNodeStoryEnv pool -- !nodeStory_env <- fromDBNodeStoryEnv pool
!scrapers_env <- ServantAsync.newJobEnv ServantAsync.defaultSettings manager_env !scrapers_env <- ServantAsync.newJobEnv ServantAsync.defaultSettings manager_env
secret <- Jobs.genSecret
let jobs_settings = (Jobs.defaultJobSettings 1 secret)
& Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_jobs . jc_js_job_timeout)
& Jobs.l_jsIDTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_jobs . jc_js_id_timeout)
!jobs_env <- Jobs.newJobEnv jobs_settings prios' manager_env
!_env_jwt_settings <- jwtSettings (_gc_secrets config_env) !_env_jwt_settings <- jwtSettings (_gc_secrets config_env)
-- !central_exchange <- forkIO CE.gServer -- !central_exchange <- forkIO CE.gServer
...@@ -107,7 +97,6 @@ newTestEnv testEnv logger port = do ...@@ -107,7 +97,6 @@ newTestEnv testEnv logger port = do
, _env_nodeStory = test_nodeStory testEnv , _env_nodeStory = test_nodeStory testEnv
, _env_manager = manager_env , _env_manager = manager_env
, _env_scrapers = scrapers_env , _env_scrapers = scrapers_env
, _env_jobs = jobs_env
, _env_self_url = self_url_env , _env_self_url = self_url_env
, _env_config = config_env , _env_config = config_env
, _env_central_exchange = Prelude.error "[Test.API.Setup.Env] central exchange not needed, but forced somewhere (check StrictData)" , _env_central_exchange = Prelude.error "[Test.API.Setup.Env] central exchange not needed, but forced somewhere (check StrictData)"
......
...@@ -73,7 +73,7 @@ import Test.Hspec.Wai.Internal (withApplication, WaiSession) ...@@ -73,7 +73,7 @@ import Test.Hspec.Wai.Internal (withApplication, WaiSession)
import Test.Hspec.Wai.JSON (json) import Test.Hspec.Wai.JSON (json)
import Test.Hspec.Wai (shouldRespondWith) import Test.Hspec.Wai (shouldRespondWith)
import Test.Types (JobPollHandle(..)) import Test.Types (JobPollHandle(..))
import Test.Utils (getJSON, pollUntilFinished, postJSONUrlEncoded, protectedJSON, withValidLogin) import Test.Utils (getJSON, pollUntilFinished, pollUntilWorkFinished, postJSONUrlEncoded, protectedJSON, withValidLogin)
import Text.Printf (printf) import Text.Printf (printf)
import Web.FormUrlEncoded import Web.FormUrlEncoded
...@@ -358,8 +358,8 @@ createDocsList testDataPath testEnv port clientEnv token = do ...@@ -358,8 +358,8 @@ createDocsList testDataPath testEnv port clientEnv token = do
-- let mkPollUrl jh = "/corpus/" <> fromString (show $ _NodeId corpusId) <> "/add/form/async/" +|_jph_id jh|+ "/poll?limit=1" -- let mkPollUrl jh = "/corpus/" <> fromString (show $ _NodeId corpusId) <> "/add/form/async/" +|_jph_id jh|+ "/poll?limit=1"
-- j' <- pollUntilFinished token port mkPollUrl j -- j' <- pollUntilFinished token port mkPollUrl j
-- liftIO (_jph_status j' `shouldBe` "IsFinished") -- liftIO (_jph_status j' `shouldBe` "IsFinished")
j' <- pollUntilWorkFinished token port ji ji' <- pollUntilWorkFinished token port ji
liftIO $ j' `shouldSatisfy` isRight liftIO $ ji' `shouldBe` ji
pure corpusId pure corpusId
createFortranDocsList :: TestEnv -> Int -> ClientEnv -> Token -> WaiSession () CorpusId createFortranDocsList :: TestEnv -> Int -> ClientEnv -> Token -> WaiSession () CorpusId
...@@ -369,10 +369,13 @@ createFortranDocsList testEnv port = ...@@ -369,10 +369,13 @@ createFortranDocsList testEnv port =
updateNode :: Int -> ClientEnv -> Token -> NodeId -> WaiSession () () updateNode :: Int -> ClientEnv -> Token -> NodeId -> WaiSession () ()
updateNode port clientEnv token nodeId = do updateNode port clientEnv token nodeId = do
let params = UpdateNodeParamsTexts Both let params = UpdateNodeParamsTexts Both
(j :: JobPollHandle) <- checkEither $ fmap toJobPollHandle <$> liftIO (runClientM (update_node token nodeId params) clientEnv) -- (j :: JobPollHandle) <- checkEither $ fmap toJobPollHandle <$> liftIO (runClientM (update_node token nodeId params) clientEnv)
let mkPollUrl jh = "/node/" <> fromString (show $ _NodeId nodeId) <> "/update/" +|_jph_id jh|+ "/poll?limit=1" ji <- checkEither $ liftIO $ runClientM (update_node token nodeId params) clientEnv
j' <- pollUntilFinished token port mkPollUrl j -- let mkPollUrl jh = "/node/" <> fromString (show $ _NodeId nodeId) <> "/update/" +|_jph_id jh|+ "/poll?limit=1"
liftIO (_jph_status j' `shouldBe` "IsFinished") -- j' <- pollUntilFinished token port mkPollUrl j
-- liftIO (_jph_status j' `shouldBe` "IsFinished")
ji' <- pollUntilWorkFinished token port ji
liftIO $ ji' `shouldBe` ji
toJobPollHandle :: JobStatus 'Safe JobLog -> JobPollHandle toJobPollHandle :: JobStatus 'Safe JobLog -> JobPollHandle
toJobPollHandle = either (\x -> panicTrace $ "toJobPollHandle:" <> T.pack x) identity . JSON.eitherDecode . JSON.encode toJobPollHandle = either (\x -> panicTrace $ "toJobPollHandle:" <> T.pack x) identity . JSON.eitherDecode . JSON.encode
......
...@@ -37,7 +37,7 @@ import Gargantext.Core.NLP (HasNLPServer(..)) ...@@ -37,7 +37,7 @@ import Gargantext.Core.NLP (HasNLPServer(..))
import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude (HasConnectionPool(..)) import Gargantext.Database.Prelude (HasConnectionPool(..))
import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..)) import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..))
import Gargantext.Utils.Jobs import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
import Network.URI (parseURI) import Network.URI (parseURI)
import Prelude qualified import Prelude qualified
import System.Log.FastLogger qualified as FL import System.Log.FastLogger qualified as FL
...@@ -77,7 +77,6 @@ data TestJobHandle = TestNoJobHandle ...@@ -77,7 +77,6 @@ data TestJobHandle = TestNoJobHandle
instance MonadJobStatus TestMonad where instance MonadJobStatus TestMonad where
type JobHandle TestMonad = TestJobHandle type JobHandle TestMonad = TestJobHandle
type JobType TestMonad = GargJob
type JobOutputType TestMonad = JobLog type JobOutputType TestMonad = JobLog
type JobEventType TestMonad = JobLog type JobEventType TestMonad = JobLog
......
...@@ -16,36 +16,33 @@ module Test.Instances ...@@ -16,36 +16,33 @@ module Test.Instances
where where
import Data.List.NonEmpty qualified as NE import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Map.Strict.Patch qualified as PM import Data.Map.Strict.Patch qualified as PM
import Data.Patch.Class (Replace(Keep), replace) import Data.Patch.Class (Replace, replace)
import Data.Text qualified as T import Data.Text qualified as T
import Data.Validity (Validation(..), ValidationChain (..), prettyValidation) import Data.Validity (Validation(..), ValidationChain (..), prettyValidation)
import EPO.API.Client.Types qualified as EPO import EPO.API.Client.Types qualified as EPO
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..), ForgotPasswordAsyncParams(..)) import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..), ForgotPasswordAsyncParams(..))
import Gargantext.API.Admin.EnvTypes as EnvTypes
import Gargantext.API.Errors.Types qualified as Errors import Gargantext.API.Errors.Types qualified as Errors
import Gargantext.API.Ngrams.Types qualified as Ngrams import Gargantext.API.Ngrams.Types qualified as Ngrams
import Gargantext.API.Node.Corpus.Annuaire (AnnuaireWithForm(..))
import Gargantext.API.Node.Corpus.New (ApiInfo(..)) import Gargantext.API.Node.Corpus.New (ApiInfo(..))
import Gargantext.API.Node.DocumentsFromWriteNodes.Types qualified as DFWN
import Gargantext.API.Node.DocumentUpload.Types (DocumentUpload(..))
import Gargantext.API.Node.FrameCalcUpload.Types qualified as FCU
import Gargantext.API.Node.Types (NewWithForm(..), RenameNode(..), WithQuery(..)) import Gargantext.API.Node.Types (NewWithForm(..), RenameNode(..), WithQuery(..))
import Gargantext.API.Node.Types (RenameNode(..), WithQuery(..))
import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
import Gargantext.Core.Notifications.Dispatcher.Types qualified as DET import Gargantext.Core.Notifications.Dispatcher.Types qualified as DET
import Gargantext.Core.NodeStory.Types qualified as NS
import Gargantext.Core.Text.Ngrams (NgramsType(..))
import Gargantext.Core.Types.Individu qualified as Individu import Gargantext.Core.Types.Individu qualified as Individu
import Gargantext.Core.Types.Main (ListType(CandidateTerm, StopTerm, MapTerm)) import Gargantext.Core.Types.Main (ListType(CandidateTerm, StopTerm, MapTerm))
import Gargantext.Core.Worker.Jobs.Types (Job(..)) import Gargantext.Core.Worker.Jobs.Types (Job(..))
import Gargantext.Core.Worker.Types (JobInfo(..))
import Gargantext.Database.Admin.Types.Node (UserId(UnsafeMkUserId)) import Gargantext.Database.Admin.Types.Node (UserId(UnsafeMkUserId))
import Gargantext.Database.Admin.Types.Hyperdata qualified as Hyperdata import Gargantext.Database.Admin.Types.Hyperdata qualified as Hyperdata
import Gargantext.Prelude hiding (replace, Location) import Gargantext.Prelude hiding (replace, Location)
import Servant.Job.Core qualified as SJ import Servant.Job.Core qualified as SJ
import Servant.Job.Types qualified as SJ import Servant.Job.Types qualified as SJ
import Test.QuickCheck
import Test.Tasty.QuickCheck hiding (Positive, Negative)
import Text.Parsec.Error (ParseError, Message(..), newErrorMessage) import Text.Parsec.Error (ParseError, Message(..), newErrorMessage)
import Text.Parsec.Pos import Text.Parsec.Pos
import Test.QuickCheck
instance Arbitrary AuthenticatedUser where instance Arbitrary AuthenticatedUser where
...@@ -53,52 +50,6 @@ instance Arbitrary AuthenticatedUser where ...@@ -53,52 +50,6 @@ instance Arbitrary AuthenticatedUser where
<*> arbitrary -- _auth_user_id <*> arbitrary -- _auth_user_id
instance Arbitrary EnvTypes.GargJob where
arbitrary = do
oneof [ pure AddAnnuaireFormJob
, pure AddContactJob
, pure AddCorpusFileJob
, pure AddCorpusFormJob
, pure AddCorpusQueryJob
, pure AddFileJob
, pure DocumentFromWriteNodeJob
, pure ForgotPasswordJob
, pure NewNodeJob
, pure RecomputeGraphJob
, pure TableNgramsJob
, pure UpdateNgramsListJobJSON
, pure UpdateNgramsListJobTSV
, pure UpdateNodeJob
, pure UploadDocumentJob
, pure UploadFrameCalcJob
]
instance Arbitrary Job where
arbitrary = oneof [ pure Ping
, addCorpusFormAsyncGen
, forgotPasswordAsyncGen
, newNodeAsyncGen
, gargJobGen ]
where
forgotPasswordAsyncGen = do
email <- arbitrary
return $ ForgotPasswordAsync (ForgotPasswordAsyncParams { email })
addCorpusFormAsyncGen = do
_acf_args <- arbitrary
_acf_user <- arbitrary
_acf_cid <- arbitrary
return $ AddCorpusFormAsync { .. }
newNodeAsyncGen = do
_nna_node_id <- arbitrary
_nna_authenticatedUser <- arbitrary
_nna_postNode <- arbitrary
return $ NewNodeAsync { .. }
gargJobGen = do
_gj_garg_job <- arbitrary
return $ GargJob { _gj_garg_job }
instance Arbitrary Message where instance Arbitrary Message where
arbitrary = do arbitrary = do
msgContent <- arbitrary msgContent <- arbitrary
...@@ -177,6 +128,38 @@ instance Arbitrary WithQuery where ...@@ -177,6 +128,38 @@ instance Arbitrary WithQuery where
pure $ WithQuery { .. } pure $ WithQuery { .. }
-- The endpoint does nothing currently, but if it will, we need to provide some valid _wf_data
instance Arbitrary AnnuaireWithForm where
arbitrary = AnnuaireWithForm <$> arbitrary -- _wf_filetype
<*> arbitrary -- _wf_data
<*> arbitrary -- _wf_lang
instance Arbitrary DFWN.Params where
arbitrary = DFWN.Params <$> arbitrary -- id
<*> arbitrary -- paragraphs
<*> arbitrary -- lang
<*> arbitrary -- selection
instance Arbitrary ForgotPasswordAsyncParams where
arbitrary = ForgotPasswordAsyncParams <$> arbitrary -- TODO fix proper email
instance Arbitrary FCU.FrameCalcUpload where
arbitrary = FCU.FrameCalcUpload <$> arbitrary -- _wf_lang
<*> arbitrary -- _wf_selection
instance Arbitrary Ngrams.UpdateTableNgramsCharts where
arbitrary = Ngrams.UpdateTableNgramsCharts <$> arbitrary -- _utn_tab_type
<*> arbitrary -- _utn_list_id
instance Arbitrary DocumentUpload where
arbitrary = DocumentUpload <$> arbitrary -- _du_abstract
<*> arbitrary -- _du_authors
<*> arbitrary -- _du_sources
<*> arbitrary -- _du_title
<*> arbitrary -- _du_date -- TODO This isn't arbitrary
<*> arbitrary -- _du_language
-- Hyperdata -- Hyperdata
instance Arbitrary Hyperdata.HyperdataUser where instance Arbitrary Hyperdata.HyperdataUser where
arbitrary = Hyperdata.HyperdataUser <$> arbitrary arbitrary = Hyperdata.HyperdataUser <$> arbitrary
...@@ -197,6 +180,11 @@ instance Arbitrary Hyperdata.HyperdataPublic where ...@@ -197,6 +180,11 @@ instance Arbitrary Hyperdata.HyperdataPublic where
instance Arbitrary a => Arbitrary (SJ.JobOutput a) where instance Arbitrary a => Arbitrary (SJ.JobOutput a) where
arbitrary = SJ.JobOutput <$> arbitrary arbitrary = SJ.JobOutput <$> arbitrary
-- instance Arbitrary NewWithFile where
-- arbitrary = NewWithFile <$> arbitrary -- _wfi_b64_data
-- <*> arbitrary -- _wf_lang
-- <*> arbitrary -- _wf_name
instance Arbitrary NewWithForm where instance Arbitrary NewWithForm where
arbitrary = NewWithForm <$> arbitrary -- _wf_filetype arbitrary = NewWithForm <$> arbitrary -- _wf_filetype
<*> arbitrary -- _wf_fileformat <*> arbitrary -- _wf_fileformat
...@@ -263,16 +251,18 @@ instance Arbitrary DET.WSRequest where ...@@ -263,16 +251,18 @@ instance Arbitrary DET.WSRequest where
-- Ngrams -- Ngrams
instance Arbitrary a => Arbitrary (Ngrams.MSet a) instance Arbitrary a => Arbitrary (Ngrams.MSet a)
instance Arbitrary Ngrams.NgramsTerm instance Arbitrary Ngrams.NgramsTerm where
arbitrary = Ngrams.NgramsTerm <$>
-- we take into accoutn the fact, that tojsonkey strips the text
(arbitrary `suchThat` (\t -> t == T.strip t))
instance Arbitrary Ngrams.TabType where instance Arbitrary Ngrams.TabType where
arbitrary = elements [minBound .. maxBound] arbitrary = elements [minBound .. maxBound]
instance Arbitrary Ngrams.NgramsElement where instance Arbitrary Ngrams.NgramsElement where
arbitrary = elements [Ngrams.newNgramsElement Nothing "sport"] arbitrary = elements [Ngrams.newNgramsElement Nothing "sport"]
instance Arbitrary Ngrams.NgramsTable where instance Arbitrary Ngrams.NgramsTable where
arbitrary = pure ngramsMockTable arbitrary = pure ngramsMockTable
instance Arbitrary Ngrams.OrderBy instance Arbitrary Ngrams.OrderBy where
where arbitrary = elements [minBound..maxBound]
arbitrary = elements [minBound..maxBound]
instance (Ord a, Arbitrary a) => Arbitrary (Ngrams.PatchMSet a) where instance (Ord a, Arbitrary a) => Arbitrary (Ngrams.PatchMSet a) where
arbitrary = (Ngrams.PatchMSet . PM.fromMap) <$> arbitrary arbitrary = (Ngrams.PatchMSet . PM.fromMap) <$> arbitrary
instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
...@@ -440,3 +430,37 @@ genFrontendErr be = do ...@@ -440,3 +430,37 @@ genFrontendErr be = do
Errors.EC_500__job_generic_exception Errors.EC_500__job_generic_exception
-> do err <- arbitrary -> do err <- arbitrary
pure $ Errors.mkFrontendErr' txt $ Errors.FE_job_generic_exception err pure $ Errors.mkFrontendErr' txt $ Errors.FE_job_generic_exception err
instance Arbitrary Job where
arbitrary = oneof [ pure Ping
, addContactGen
, addCorpusFormAsyncGen
, addCorpusWithQueryGen
-- , addWithFileGen
, addToAnnuaireWithFormGen
, documentsFromWriteNodesGen
, forgotPasswordAsyncGen
, frameCalcUploadGen
, jsonPostGen
, ngramsPostChartsGen
, postNodeAsyncGen
, recomputeGraphGen
, updateNodeGen
, uploadDocumentGen ]
where
addContactGen = AddContact <$> arbitrary <*> arbitrary <*> arbitrary
addCorpusFormAsyncGen = AddCorpusFormAsync <$> arbitrary <*> arbitrary <*> arbitrary
addCorpusWithQueryGen = AddCorpusWithQuery <$> arbitrary <*> arbitrary <*> arbitrary
-- addWithFileGen = AddWithFile <$> arbitrary <*> arbitrary <*> arbitrary
addToAnnuaireWithFormGen = AddToAnnuaireWithForm <$> arbitrary <*> arbitrary
documentsFromWriteNodesGen = DocumentsFromWriteNodes <$> arbitrary <*> arbitrary <*> arbitrary
forgotPasswordAsyncGen = ForgotPasswordAsync <$> arbitrary
frameCalcUploadGen = FrameCalcUpload <$> arbitrary <*> arbitrary <*> arbitrary
jsonPostGen = JSONPost <$> arbitrary <*> arbitrary
ngramsPostChartsGen = NgramsPostCharts <$> arbitrary <*> arbitrary
postNodeAsyncGen = PostNodeAsync <$> arbitrary <*> arbitrary <*> arbitrary
recomputeGraphGen = RecomputeGraph <$> arbitrary
updateNodeGen = UpdateNode <$> arbitrary <*> arbitrary
uploadDocumentGen = UploadDocument <$> arbitrary <*> arbitrary
...@@ -3,6 +3,7 @@ ...@@ -3,6 +3,7 @@
module Test.Utils where module Test.Utils where
import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVarIO)
import Control.Exception.Safe () import Control.Exception.Safe ()
import Control.Monad () import Control.Monad ()
import Data.Aeson qualified as JSON import Data.Aeson qualified as JSON
...@@ -19,6 +20,7 @@ import Fmt (Builder) ...@@ -19,6 +20,7 @@ import Fmt (Builder)
import Gargantext.API.Admin.Auth.Types (AuthRequest(..), Token, authRes_token) import Gargantext.API.Admin.Auth.Types (AuthRequest(..), Token, authRes_token)
import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Routes.Types (xGargErrorScheme) import Gargantext.API.Routes.Types (xGargErrorScheme)
import Gargantext.Core.Notifications.Dispatcher.Types qualified as DT
import Gargantext.Core.Types.Individu (Username, GargPassword) import Gargantext.Core.Types.Individu (Username, GargPassword)
import Gargantext.Core.Worker.Types (JobInfo(..)) import Gargantext.Core.Worker.Types (JobInfo(..))
import Gargantext.Prelude import Gargantext.Prelude
...@@ -28,6 +30,7 @@ import Network.HTTP.Types (Header, Method, status200) ...@@ -28,6 +30,7 @@ import Network.HTTP.Types (Header, Method, status200)
import Network.HTTP.Types.Header (hAccept, hAuthorization, hContentType) import Network.HTTP.Types.Header (hAccept, hAuthorization, hContentType)
import Network.Wai.Handler.Warp (Port) import Network.Wai.Handler.Warp (Port)
import Network.Wai.Test (SResponse(..)) import Network.Wai.Test (SResponse(..))
import Network.WebSockets qualified as WS
import Prelude qualified import Prelude qualified
import Servant.Client (ClientEnv, baseUrlPort, mkClientEnv, parseBaseUrl, runClientM, makeClientRequest, defaultMakeClientRequest) import Servant.Client (ClientEnv, baseUrlPort, mkClientEnv, parseBaseUrl, runClientM, makeClientRequest, defaultMakeClientRequest)
import Servant.Client.Core (BaseUrl) import Servant.Client.Core (BaseUrl)
...@@ -41,6 +44,7 @@ import Test.Hspec.Wai.JSON (FromValue(..)) ...@@ -41,6 +44,7 @@ import Test.Hspec.Wai.JSON (FromValue(..))
import Test.Hspec.Wai.Matcher (MatchHeader(..), ResponseMatcher(..), bodyEquals, formatHeader, match) import Test.Hspec.Wai.Matcher (MatchHeader(..), ResponseMatcher(..), bodyEquals, formatHeader, match)
import Test.Tasty.HUnit (Assertion, assertBool) import Test.Tasty.HUnit (Assertion, assertBool)
import Test.Types import Test.Types
import Test.Utils.Notifications (withWSConnection, millisecond)
-- | Marks the input 'Assertion' as pending, by ignoring any exception -- | Marks the input 'Assertion' as pending, by ignoring any exception
...@@ -242,29 +246,45 @@ pollUntilWorkFinished :: HasCallStack ...@@ -242,29 +246,45 @@ pollUntilWorkFinished :: HasCallStack
-> Port -> Port
-> JobInfo -> JobInfo
-> WaiSession () JobInfo -> WaiSession () JobInfo
pollUntilWorkFinished tkn port = go 60 pollUntilWorkFinished tkn port ji = do
-- TODO Poll dispatcher for markJobFinished isFinishedTVar <- liftIO $ newTVarIO False
where let wsConnect =
go :: Int -> JobInfo -> WaiSession () JobInfo withWSConnection ("localhost", port) $ \conn -> do
go 0 ji = panicTrace $ "pollUntilWorkFinished exhausted attempts. Last found JobInfo: " <> TE.decodeUtf8 (L.toStrict $ JSON.encode ji) -- We wait a bit before the server settles
go n ji = case _jph_status h == "IsPending" || _jph_status h == "IsRunning" of threadDelay (100 * millisecond)
True -> do -- subscribe to notifications about this job
liftIO $ threadDelay 1_000_000 let topic = DT.UpdateWorkerProgress ji
h' <- protectedJSON tkn "GET" (mkUrl port $ mkUrlPiece h) "" WS.sendTextData conn $ JSON.encode (DT.WSSubscribe topic)
go (n-1) h' forever $ do
False d <- WS.receiveData conn
| _jph_status h == "IsFailure" let dec = JSON.decode d :: Maybe DT.Notification
-> panicTrace $ "JobPollHandle contains a failure: " <> TE.decodeUtf8 (L.toStrict $ JSON.encode h) case dec of
| otherwise Nothing -> pure ()
-> case any hasError (_jph_log h) of Just (DT.NUpdateWorkerProgress ji' jl) ->
True -> panicTrace $ "JobPollHandle contains a failure: " <> TE.decodeUtf8 (L.toStrict $ JSON.encode h) if ji' == ji && isFinished jl
False -> pure h then do
atomically $ writeTVar isFinishedTVar True
else
pure ()
_ -> pure ()
liftIO $ withAsync wsConnect $ \a -> do
mRet <- Timeout.timeout (60 * 1000 * millisecond) $ do
let go = do
isFinished <- readTVarIO isFinishedTVar
if isFinished
then return True
else do
threadDelay (1000 * millisecond)
go
go
case mRet of
Nothing -> panicTrace $ "[pollUntilWorkFinished] timed out while waiting to finish job " <> show ji
Just _ -> return ji
-- FIXME(adn) This is wrong, errs should be >= 1. where
hasError :: JobLog -> Bool isFinished (JobLog { .. }) = _scst_remaining == Just 0
hasError JobLog{..} = case _scst_failed of
Nothing -> False
Just errs -> errs > 1
-- | Like HUnit's '@?=', but With a nicer error message in case the two entities are not equal. -- | Like HUnit's '@?=', but With a nicer error message in case the two entities are not equal.
(@??=) :: (HasCallStack, ToExpr a, Eq a) => a -> a -> Assertion (@??=) :: (HasCallStack, ToExpr a, Eq a) => a -> a -> Assertion
......
This diff is collapsed.
{-|
Module : Test.Utils.Jobs.Types
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module Test.Utils.Jobs.Types
( TestJobEnv(..)
, initTestJobEnv
, initTestWorkerState
)
where
import Async.Worker.Broker.Types (toA, getMessage)
import Async.Worker.Types qualified as WT
import Control.Concurrent.STM
import Data.Text qualified as T
import Gargantext.Core.Config (hasConfig)
import Gargantext.Core.Config.Worker (WorkerDefinition(..))
import Gargantext.Core.Worker (performAction)
import Gargantext.Core.Worker.Broker (initBrokerWithDBCreate)
import Gargantext.Core.Worker.Env (WorkerEnv(..))
import Gargantext.Core.Worker.Jobs.Types (Job(..))
import Gargantext.Core.Worker.PGMQTypes (HasWorkerBroker, BrokerMessage, WState)
import Gargantext.Prelude
data TestJobEnv =
TestJobEnv { inProgress :: Maybe Job
, done :: [Job]
, failed :: [(Job, SomeException)]
, killed :: [Job]
, timedOut :: [Job]
}
initTestJobEnv :: TestJobEnv
initTestJobEnv =
TestJobEnv { inProgress = Nothing
, done = []
, failed = []
, killed = []
, timedOut = [] }
-- | Test worker state. Normally, the message notifications go through
-- the dispatcher system. Here we make a short-cut and just use a
-- TVar to store the processes worker jobs.
-- Job progress, however, is sent via the notifications mechanism,
-- because the worker itself doesn't implement it.
initTestWorkerState :: HasWorkerBroker
=> TVar TestJobEnv
-> WorkerEnv
-> WorkerDefinition
-> IO WState
initTestWorkerState jobTVar env (WorkerDefinition { .. }) = do
let gargConfig = env ^. hasConfig
broker <- initBrokerWithDBCreate gargConfig
pure $ WT.State { broker
, queueName = _wdQueue
, name = T.unpack _wdName
, performAction = performAction env
, onMessageReceived = Just $ onJobStarted jobTVar env
, onJobFinish = Just $ onJobFinished jobTVar env
, onJobTimeout = Just $ onJobTimeout jobTVar env
, onJobError = Just $ onJobError jobTVar env
, onWorkerKilledSafely = Just $ onWorkerKilled jobTVar env }
onJobStarted :: HasWorkerBroker
=> TVar TestJobEnv
-> WorkerEnv
-> WState
-> BrokerMessage
-> IO ()
onJobStarted jobTVar _env _state bm = do
let j = toA $ getMessage bm
let job = WT.job j
atomically $ modifyTVar jobTVar $ \testJobEnv -> do
testJobEnv { inProgress = Just job }
onJobFinished :: HasWorkerBroker
=> TVar TestJobEnv
-> WorkerEnv
-> WState
-> BrokerMessage
-> IO ()
onJobFinished jobTVar _env _state bm = do
let j = toA $ getMessage bm
let job = WT.job j
atomically $ modifyTVar jobTVar $ \testJobEnv -> do
testJobEnv { inProgress = Nothing
, done = done testJobEnv ++ [job] }
onJobTimeout :: HasWorkerBroker
=> TVar TestJobEnv
-> WorkerEnv
-> WState
-> BrokerMessage
-> IO ()
onJobTimeout jobTVar _env _state bm = do
let j = toA $ getMessage bm
let job = WT.job j
atomically $ modifyTVar jobTVar $ \testJobEnv -> do
testJobEnv { inProgress = Nothing
, timedOut = timedOut testJobEnv ++ [job] }
onJobError :: (HasWorkerBroker, HasCallStack)
=> TVar TestJobEnv
-> WorkerEnv
-> WState
-> BrokerMessage
-> SomeException
-> IO ()
onJobError jobTVar _env _state bm exc = do
let j = toA $ getMessage bm
let job = WT.job j
atomically $ modifyTVar jobTVar $ \testJobEnv -> do
testJobEnv { inProgress = Nothing
, failed = failed testJobEnv ++ [(job, exc)] }
onWorkerKilled :: (HasWorkerBroker, HasCallStack)
=> TVar TestJobEnv
-> WorkerEnv
-> WState
-> Maybe BrokerMessage
-> IO ()
onWorkerKilled _jobTVar _env _state Nothing = pure ()
onWorkerKilled jobTVar _env _state (Just bm) = do
let j = toA $ getMessage bm
let job = WT.job j
atomically $ modifyTVar jobTVar $ \testJobEnv -> do
testJobEnv { inProgress = Nothing
, killed = killed testJobEnv ++ [job] }
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Utils.Notifications where
import Control.Exception.Safe qualified as Exc
import Control.Monad (void)
import Data.ByteString qualified as BS
import Gargantext.Core.Notifications.Dispatcher.Types qualified as DT
import Network.WebSockets qualified as WS
import Prelude
import Test.Instances ()
instance Eq DT.Notification where
-- simple
(==) n1 n2 = show n1 == show n2
millisecond :: Int
millisecond = 1000
withWSConnection :: (String, Int) -> WS.ClientApp () -> IO ()
withWSConnection (host, port) = withWSConnection' (host, port, "/ws")
-- | Wrap the logic of asynchronous connection closing
-- https://hackage.haskell.org/package/websockets-0.13.0.0/docs/Network-WebSockets-Connection.html#v:sendClose
withWSConnection' :: (String, Int, String) -> WS.ClientApp () -> IO ()
withWSConnection' (host, port, path) cb =
WS.runClient host port path $ \conn -> do
cb conn
-- shut down gracefully, otherwise a 'ConnectionException' is thrown
WS.sendClose conn ("" :: BS.ByteString)
-- wait for close response, should throw a 'CloseRequest' exception
Exc.catches (void $ WS.receiveDataMessage conn)
[ Exc.Handler $ \(err :: WS.ConnectionException) ->
case err of
WS.CloseRequest _ _ -> putStrLn "[withWSConnection] closeRequest caught"
_ -> Exc.throw err
-- re-throw any other exceptions
, Exc.Handler $ \(err :: Exc.SomeException) -> Exc.throw err ]
...@@ -59,7 +59,6 @@ main = do ...@@ -59,7 +59,6 @@ main = do
, Phylo.tests , Phylo.tests
, testGroup "Stemming" [ Lancaster.tests ] , testGroup "Stemming" [ Lancaster.tests ]
, Worker.tests , Worker.tests
, Jobs.qcTests
, asyncUpdatesSpec , asyncUpdatesSpec
, Notifications.qcTests , Notifications.qcTests
] ]
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