Merge branch 'testing' into stable

CHANGELOG.md

+## Version 0.0.7.3.6
+
+* [BACK][FIX][Store execution time of Phylomemy graph (#409)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/409)
+* [BACK][FIX][[Meta] Mistmatch between compound words representation in frontend and in database. (#386)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/386)
+* [FRONT][FIX][[Node Graph] Legend tab improvements (#689)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/689)
+* [FRONT][FIX][Display graph parameters in legend (#706)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/706)
+
 ## Version 0.0.7.3.5
 
 * [FRONT][FIX][[Topbar] Update the navigation bar links in the "Info" dropdown (#710)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/710)

README.md

@@ -346,4 +346,45 @@ Maybe you need to restore the gargantua password
 ```shell
 $ ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext-settings.toml'
 ```
+
 Maybe you need to change the port to 5433 for database connection in your gargantext.ini file.
+
+## `haskell-language-server`
+
+If you want to use `haskell-language-server` for GHC 9.4.7, install it
+with `ghcup`:
+```shell
+ghcup compile hls --version 2.7.0.0 --ghc 9.4.7
+```
+https://haskell-language-server.readthedocs.io/en/latest/installation.html
+
+## Running the tests
+
+Running the tests can be done via the following command:
+
+```hs
+cabal v2-test --test-show-details=streaming --flags 'test-crypto no-phylo-debug-logs'
+```
+
+The flags have the following meaning:
+
+* `test-crypto`: Switch to use very fast (but not production-secure) cryptography, so that tests runs
+  faster;
+* `no-phylo-debug-logs`: Suppresses the debugging logs which would normally be present in phylo pure (!) code.
+
+In order for some tests to run (like the phylo ones) is **required** to install the `gargantext-cli` via:
+
+```hs
+cabal v2-install gargantext:exe:gargantext-cli
+```
+
+### Modifying a golden test to accept a new (expected) output
+
+Some tests, like the Phylo one, use golden testing to ensure that the JSON Phylo we generate is
+the same as an expected one. This allows us to catch regressions in the serialisation or in the algorithm.
+Sometimes, however, we genuinely want to modify the output so that it's the new reference (i.e. the new
+golden reference). To do so, it's enough to run the testsuite passing the `--accept` flag, for example:
+
+```hs
+cabal v2-test garg-test-tasty --test-show-details=streaming --flags 'test-crypto no-phylo-debug-logs' --test-option=--pattern='/Phylo/' --test-option=--accept"
+```

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.7.3.5
+version: 0.0.7.3.6
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -839,7 +839,8 @@ test-suite garg-test-tasty
       Test.Server.ReverseProxy
       Test.Types
       Test.Utils
-      Test.Utils.Crypto
+      Test.Utils.Crypto 
+      Test.Ngrams.Lang.Occurrences
       Test.Utils.Jobs
   hs-source-dirs:
       test bin/gargantext-cli

src/Gargantext/API/Node/Update.hs

@@ -9,12 +9,13 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators    #-}
 
 module Gargantext.API.Node.Update
       where
 
-import Control.Lens (view)
+import Control.Lens (view, (^?), _Just)
 import Data.Set qualified as Set
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (AsyncJobs(..))
@@ -28,16 +29,16 @@ import Gargantext.Core.NodeStory.Types (HasNodeStory)
 import Gargantext.Core.Text.Ngrams (NgramsType(NgramsTerms))
 import Gargantext.Core.Types.Main (ListType(..))
 import Gargantext.Core.Viz.Graph.API (recomputeGraph)
-import Gargantext.Core.Viz.Phylo (subConfigAPI2config)
+import Gargantext.Core.Viz.Phylo (subConfigAPI2config, phylo_computeTime)
 import Gargantext.Core.Viz.Phylo.API.Tools (flowPhyloAPI)
 import Gargantext.Database.Action.Flow (reIndexWith)
 import Gargantext.Database.Action.Flow.Pairing (pairing)
 import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContextScore)
-import Gargantext.Database.Admin.Types.Hyperdata.Phylo ( HyperdataPhylo(HyperdataPhylo) )
+import Gargantext.Database.Admin.Types.Hyperdata.Phylo ( HyperdataPhylo(..), hp_data )
 import Gargantext.Database.Admin.Types.Node ( NodeId, NodeType(NodeCorpus, NodeAnnuaire, NodeTexts, NodeGraph, NodePhylo, NodeList) )
-import Gargantext.Database.Query.Table.Node (defaultList, getNode, getChildrenByType)
+import Gargantext.Database.Query.Table.Node (defaultList, getNode, getChildrenByType, getNodeWith)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
-import Gargantext.Database.Schema.Node (node_parent_id)
+import Gargantext.Database.Schema.Node (node_parent_id, node_hyperdata)
 import Gargantext.Prelude
 import Gargantext.System.Logging ( MonadLogger )
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
@@ -111,12 +112,14 @@ updateNode lId (UpdateNodeParamsList _mode) jobHandle = do
 
 updateNode phyloId (UpdateNodePhylo config) jobHandle = do
   markStarted 3 jobHandle
-  corpusId' <- view node_parent_id <$> getNode phyloId
+  oldPhylo      <- getNodeWith phyloId (Proxy @HyperdataPhylo)
+  let corpusId' = view node_parent_id oldPhylo
+  let mbComputeHistory = oldPhylo ^? node_hyperdata . hp_data . traverse . phylo_computeTime . _Just
   markProgress 1 jobHandle
 
   let corpusId = fromMaybe (panicTrace "no corpus id") corpusId'
 
-  phy <- timeMeasured "updateNode.flowPhyloAPI" $ flowPhyloAPI (subConfigAPI2config config) corpusId
+  phy <- timeMeasured "updateNode.flowPhyloAPI" $ flowPhyloAPI (subConfigAPI2config config) mbComputeHistory corpusId
   markProgress 2 jobHandle
 
 {-

src/Gargantext/Core/Notifications/Dispatcher.hs

@@ -14,12 +14,11 @@ https://dev.sub.gargantext.org/#/share/Notes/187918
     
 -}
 
-{-# LANGUAGE TypeOperators #-}
-    
 module Gargantext.Core.Notifications.Dispatcher (
     Dispatcher -- opaque
   , newDispatcher
   , terminateDispatcher
+  , withDispatcher
 
   -- * Querying a dispatcher
   , dispatcherSubscriptions
@@ -53,7 +52,6 @@ Dispatcher is a service, which provides couple of functionalities:
 
 data Dispatcher =
  Dispatcher { d_subscriptions :: SSet.Set Subscription
-            -- , d_ws_server     :: WSAPI AsServer
             , d_ce_listener   :: ThreadId
             }
 
@@ -72,9 +70,16 @@ newDispatcher nc = do
   d_ce_listener <- forkIO (dispatcherListener nc subscriptions)
 
   pure $ Dispatcher { d_subscriptions = subscriptions
-                    -- , d_ws_server     = server
                     , d_ce_listener   = d_ce_listener }
 
+withDispatcher :: NotificationsConfig -> (Dispatcher -> IO a) -> IO a
+withDispatcher nc cb = do
+  subscriptions <- SSet.newIO
+
+  Async.withAsync (dispatcherListener nc subscriptions) $ \a -> do
+    let dispatcher = Dispatcher { d_subscriptions = subscriptions
+                                , d_ce_listener   = Async.asyncThreadId a }
+    cb dispatcher
 
     
 -- | This is a nanomsg socket listener. We want to read the messages

src/Gargantext/Core/Notifications/Dispatcher/WebSocket.hs

@@ -142,6 +142,7 @@ getWSKey pc = do
   -- Sec-WebSocket-Key so we want to make that even more unique.
   uuid <- liftBase $ UUID.nextRandom
   let key = key' <> "-" <> show uuid
-  liftBase $ putText $ "[getWSKey] request headers: " <> (show $ WS.requestHeaders reqHead)
+  liftBase $ withLogger () $ \ioLogger -> do
+    logMsg ioLogger DEBUG $ "[wsLoop, getWSKey] request headers: " <> (show $ WS.requestHeaders reqHead)
 
   pure key

src/Gargantext/Core/Text/Terms/Mono.hs

@@ -33,7 +33,7 @@ words = monoTexts
 
 -- | Sentence split separators
 isSep :: Char -> Bool
-isSep = (`elem` (",.:;?!(){}[]\"\'" :: String))
+isSep = (`elem` (",.:;?!(){}[]" :: String))
 
 monoTerms :: Lang -> Text -> [TermsWithCount]
 monoTerms l txt = map (\t -> (monoText2term l t, 1)) $ monoTexts txt

src/Gargantext/Core/Viz/Graph/API.hs

@@ -75,8 +75,9 @@ getGraph nId = do
         let defaultBridgenessMethod = BridgenessMethod_Basic
         graph' <- computeGraph cId defaultPartitionMethod defaultBridgenessMethod (withMetric defaultMetric) defaultEdgesStrength (NgramsTerms, NgramsTerms) repo
         mt     <- defaultGraphMetadata cId listId "Title" repo defaultMetric defaultEdgesStrength
+        let mt' = set gm_legend (generateLegend graph') mt
         let
-          graph'' = set graph_metadata (Just mt) graph'
+          graph'' = set graph_metadata (Just mt') graph'
           hg = HyperdataGraphAPI graph'' camera
        -- _      <- updateHyperdata nId hg
         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
@@ -126,20 +127,27 @@ recomputeGraph nId partitionMethod bridgeMethod maybeSimilarity maybeStrength nt
 
   let computeG mt = do
         !g <- computeGraph cId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo
-        let g' = set graph_metadata mt g
+        let mt' = set gm_legend (generateLegend g) mt
+        let g' = set graph_metadata (Just mt') g
         _nentries <- updateHyperdata nId (HyperdataGraph (Just g') camera)
         pure g'
 
   case graph of
     Nothing     -> do
       mt     <- defaultGraphMetadata cId listId "Title" repo (fromMaybe Order1 maybeSimilarity) strength
-      g <- computeG $ Just mt
+      g <- computeG mt
       pure $ trace ("[G.V.G.API.recomputeGraph] Graph empty, computed" :: Text) g
     Just graph' -> if (listVersion == Just v) && (not force')
                      then pure graph'
                      else do
-                       g <- computeG graphMetadata
-                       pure $ trace ("[G.V.G.API] Graph exists, recomputing" :: Text) g
+                       case graphMetadata of
+                         Nothing -> do
+                           mt <- defaultGraphMetadata cId listId "Title" repo (fromMaybe Order1 maybeSimilarity) strength
+                           g <- computeG mt
+                           pure $ trace ("[G.V.G.API] Graph exists, no metadata, recomputing" :: Text) g
+                         Just mt -> do
+                           g <- computeG mt
+                           pure $ trace ("[G.V.G.API] Graph exists, recomputing" :: Text) g
 
 
 -- TODO remove repo

src/Gargantext/Core/Viz/Graph/Tools.hs

@@ -34,7 +34,7 @@ import Gargantext.Core.Viz.Graph.Bridgeness (bridgeness, Bridgeness(..), Partiti
 import Gargantext.Core.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map, Index, MatrixShape(..))
 import Gargantext.Core.Viz.Graph.Tools.IGraph (mkGraphUfromEdges, spinglass, spinglass')
 import Gargantext.Core.Viz.Graph.Tools.Infomap (infomap)
-import Gargantext.Core.Viz.Graph.Types (Attributes(..), Edge(..), Graph(..), MultiPartite(..), Node(..), Partite(..), Strength(..))
+import Gargantext.Core.Viz.Graph.Types (Attributes(..), Edge(..), Graph(..), MultiPartite(..), Node(..), Partite(..), Strength(..), LegendField(..))
 import Gargantext.Core.Viz.Graph.Utils (edgesFilter, nodesFilter)
 import Gargantext.Prelude
 import Graph.BAC.ProxemyOptim qualified as BAC
@@ -377,3 +377,11 @@ filterByNeighbours threshold distanceMap = filteredMap
                                        $ Map.filterWithKey (\(from', _) _ -> idx == from') distanceMap
                            in List.take (round threshold) selected
                       ) indexes
+
+generateLegend :: Graph -> [LegendField]
+generateLegend (Graph { _graph_nodes = nodes }) = List.sortBy (\(LegendField {_lf_id = a}) (LegendField {_lf_id = b}) -> compare a b) $ foldl' f [] nodes
+  where
+    f :: [LegendField] -> Node -> [LegendField]
+    f acc (Node {node_attributes = Attributes {clust_default = i}}) = case List.find (\(LegendField {_lf_id}) -> _lf_id == i) acc of
+      Just _  -> acc
+      Nothing -> acc ++ [LegendField {_lf_id = i, _lf_label = "Cluster" <> show i, _lf_color = "#FFF"}]

src/Gargantext/Core/Viz/Phylo.hs

@@ -23,16 +23,23 @@ one 8, e54847.
 
 {-# LANGUAGE DeriveAnyClass   #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Gargantext.Core.Viz.Phylo where
 
+import Control.Lens (over)
 import Data.Swagger
-import Data.Text (pack)
 import Data.Text.Lazy qualified as TextLazy
-import Data.TreeDiff (ToExpr)
+import Data.Text (pack)
+import Data.TreeDiff (ToExpr (..))
 import Data.Vector (Vector)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Prelude
+import Gargantext.Utils.UTCTime (ElapsedSeconds)
+import qualified Data.Aeson.Types as JS
+import qualified Data.List.NonEmpty as NE
 import Test.QuickCheck
 import Test.QuickCheck.Instances.Text()
 import Test.QuickCheck.Instances.Vector()
@@ -110,8 +117,6 @@ data Synchrony =
 instance ToSchema Synchrony where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
 
-
-
 data TimeUnit =
       Epoch
       { _epoch_period :: Int
@@ -425,7 +430,13 @@ type Period = (Date,Date)
 type PeriodStr = (DateStr,DateStr)
 
 
+newtype ComputeTimeHistory
+  = ComputeTimeHistory (NonEmpty ElapsedSeconds)
+  deriving stock (Show, Eq, Generic)
+  deriving newtype ToExpr
 
+instance ToSchema ComputeTimeHistory where
+  declareNamedSchema _ = declareNamedSchema (Proxy @[ElapsedSeconds])
 
 -- | Phylo datatype of a phylomemy
 --  foundations : the foundations of the phylo
@@ -442,6 +453,12 @@ data Phylo =
            , _phylo_periods      :: Map Period PhyloPeriod
            , _phylo_quality      :: Double
            , _phylo_level        :: Double
+           -- See #409, store historical data on
+           -- how many seconds it took to generate
+           -- a given phylomemy graph, to give a rough
+           -- estimate to end users. The field is optional
+           -- to make it backward compatible.
+           , _phylo_computeTime  :: !(Maybe ComputeTimeHistory)
            }
            deriving (Generic, Show, Eq, ToExpr)
 
@@ -685,6 +702,15 @@ instance ToJSON Software
 instance FromJSON PhyloGroup
 instance ToJSON PhyloGroup
 
+instance ToJSON ComputeTimeHistory where
+ toJSON = \case
+   ComputeTimeHistory runs
+     -> toJSON runs
+
+instance FromJSON ComputeTimeHistory where
+  parseJSON (JS.Array runs) = ComputeTimeHistory <$> parseJSON (JS.Array runs)
+  parseJSON ty              = JS.typeMismatch "ComputeTimeHistory" ty
+
 $(deriveJSON (unPrefix "_foundations_"  ) ''PhyloFoundations)
 
 instance FromJSON Phylo
@@ -708,6 +734,7 @@ instance NFData PhyloParam
 instance NFData PhyloFoundations
 instance NFData PhyloCounts
 instance NFData PhyloSources
+instance NFData ComputeTimeHistory
 instance NFData Phylo
 instance NFData PhyloPeriod
 instance NFData PhyloScale
@@ -798,3 +825,36 @@ instance Arbitrary Filter where
 
 instance Arbitrary PhyloParam where
   arbitrary = pure defaultPhyloParam
+
+instance Arbitrary ComputeTimeHistory where
+  arbitrary = oneof [ ComputeTimeHistory . NE.fromList . getNonEmpty <$> arbitrary ]
+
+-- The 'resize' ensure our tests won't take too long as
+-- we won't be generating very long lists.
+instance Arbitrary Phylo where
+  arbitrary = Phylo <$> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+
+--
+-- Functions that uses the lenses
+--
+
+-- | Adds the input 'ElapsedSeconds' to the 'Philo', in the 'ComputeTimeHistory'.
+trackComputeTime :: ElapsedSeconds -> Phylo -> Phylo
+trackComputeTime elapsedSecs = over phylo_computeTime update_time
+  where
+    -- In case we have more than one historical data available, we take only the last 5
+    -- runs, to not make the list unbounded.
+    update_time :: Maybe ComputeTimeHistory -> Maybe ComputeTimeHistory
+    update_time Nothing
+      = Just $ ComputeTimeHistory (NE.singleton elapsedSecs)
+    update_time (Just (ComputeTimeHistory (r NE.:| runs))) =
+      Just $ ComputeTimeHistory (elapsedSecs NE.:| (r : take 3 runs))
+

src/Gargantext/Core/Viz/Phylo/API.hs

@@ -101,7 +101,9 @@ postPhylo phyloId = Named.PostPhylo $ \_lId -> do
     -- _sft = Just (Software "Gargantext" "4")
     -- _prm = initPhyloParam vrs sft (Just q)
   corpusId <- getClosestParentIdByType phyloId NodeCorpus
-  phy <- flowPhyloAPI defaultConfig (fromMaybe (panicTrace "[G.C.V.P.API] no corpus ID found") corpusId) -- params
+  -- Being the first time we ask for the Phylo, there is no historical data
+  -- available about computing time, so we pass 'Nothing'.
+  phy <- flowPhyloAPI defaultConfig Nothing (fromMaybe (panicTrace "[G.C.V.P.API] no corpus ID found") corpusId) -- params
   -- phyloId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just corpusId) userId]
   _ <- updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
   pure phyloId

src/Gargantext/Core/Viz/Phylo/API/Tools.hs

@@ -33,7 +33,7 @@ import Gargantext.Core.NodeStory.Types (HasNodeStory)
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
 import Gargantext.Core.Text.Terms.WithList (Patterns, buildPatterns, termsInText)
 import Gargantext.Core.Types.Main (ListType(MapTerm))
-import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo)
+import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo (_phylo_computeTime), trackComputeTime, ComputeTimeHistory)
 import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
 import Gargantext.Core.Viz.Phylo.PhyloMaker  (toPhylo, toPhyloWithoutLink)
 import Gargantext.Core.Viz.Phylo.PhyloTools  ({-printIOMsg, printIOComment,-} setConfig)
@@ -49,7 +49,7 @@ import Gargantext.Database.Schema.Context ( ContextPoly(_context_hyperdata, _con
 import Gargantext.Database.Schema.Node ( NodePoly(_node_hyperdata), node_hyperdata )
 import Gargantext.Prelude hiding (to)
 import Gargantext.System.Logging ( MonadLogger, LogLevel(DEBUG), logLocM )
-import Gargantext.Utils.UTCTime (timeMeasured)
+import Gargantext.Utils.UTCTime (timeMeasured, timeMeasured'')
 import Prelude qualified
 import System.FilePath ((</>))
 import System.IO.Temp (withTempDirectory)
@@ -111,19 +111,23 @@ phylo2dot phylo = do
 
 
 flowPhyloAPI :: (HasNodeStory env err m, HasNodeError err, MonadLogger m)
-             => PhyloConfig -> CorpusId -> m Phylo
-flowPhyloAPI config cId = do
-  corpus <- corpusIdtoDocuments (timeUnit config) cId
-  let !phyloWithCliques = toPhyloWithoutLink corpus config
+             => PhyloConfig
+             -> Maybe ComputeTimeHistory
+             -- ^ Previous compute time historical data, if any.
+             -> CorpusId
+             -> m Phylo
+flowPhyloAPI config mbOldComputeHistory cId = do
+  corpus <- timeMeasured "flowPhyloAPI.corpusIdtoDocuments" $ corpusIdtoDocuments (timeUnit config) cId
   -- writePhylo phyloWithCliquesFile phyloWithCliques
   $(logLocM) DEBUG $ "PhyloConfig old: " <> show config
 
-  _ <- timeMeasured "flowPhyloAPI.phyloWithCliques" (pure $! phyloWithCliques)
+  (t1, phyloWithCliques) <- timeMeasured'' DEBUG "flowPhyloAPI.phyloWithCliques" (pure $! toPhyloWithoutLink corpus config)
+  (t2, phyloConfigured)  <- timeMeasured'' DEBUG "flowPhyloAPI.phyloConfigured" (pure $! setConfig config phyloWithCliques)
+  (t3, finalPhylo)       <- timeMeasured'' DEBUG "flowPhyloAPI.toPhylo" (pure $! toPhylo phyloConfigured)
 
-  let !phyloConfigured = setConfig config phyloWithCliques
-  _ <- timeMeasured "flowPhyloAPI.phyloConfigured" (pure $! phyloConfigured)
-
-  pure $! toPhylo phyloConfigured
+  -- As the phylo is computed fresh every time, without looking at the one stored (if any), we
+  -- have to manually propagate computing time across.
+  pure $! trackComputeTime (t1 + t2 + t3) (finalPhylo { _phylo_computeTime = mbOldComputeHistory })
 
 --------------------------------------------------------------------
 corpusIdtoDocuments :: (HasNodeStory env err m, HasNodeError err)

src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs

@@ -551,3 +551,4 @@ initPhylo docs conf =
                (fromList $ map (\prd -> (prd, PhyloPeriod prd ("","") (initPhyloScales 1 prd))) periods)
                0
                (_qua_granularity $ phyloQuality $ _phyloParam_config params)
+               Nothing

src/Gargantext/Utils/UTCTime.hs

@@ -12,20 +12,25 @@ Portability : POSIX
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Gargantext.Utils.UTCTime where
 
+import Data.Fixed (Fixed(..))
 import Data.Morpheus.Kind (SCALAR)
 import Data.Morpheus.Types (GQLType(..), DecodeScalar(..), EncodeScalar(..))
 import Data.Morpheus.Types qualified as DMT
 import Data.String (fromString)
-import Data.Swagger (ToSchema)
+import Data.Swagger (ToSchema (..))
 import Data.Text qualified as T
-import Data.Time (UTCTime)
-import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
+import Data.Time (UTCTime, nominalDiffTimeToSeconds)
+import Data.TreeDiff.Class
 import Gargantext.Prelude
 import Gargantext.System.Logging
 import Prelude (String)
+import Test.QuickCheck hiding (label)
 
 
 newtype NUTCTime = NUTCTime UTCTime
@@ -43,6 +48,23 @@ instance FromJSON NUTCTime
 instance ToJSON NUTCTime
 instance ToSchema NUTCTime
 
+newtype ElapsedSeconds = ElapsedSeconds { _Seconds :: POSIXTime }
+  deriving stock (Show, Eq, Generic)
+  deriving newtype (FromJSON, ToJSON, Num)
+
+instance NFData ElapsedSeconds
+
+instance ToExpr ElapsedSeconds where
+  toExpr (ElapsedSeconds x) =
+    let (MkFixed secs) = nominalDiffTimeToSeconds x
+    in toExpr secs
+
+instance ToSchema ElapsedSeconds where
+  declareNamedSchema _ = declareNamedSchema (Proxy @Int)
+
+instance Arbitrary ElapsedSeconds where
+  arbitrary = ElapsedSeconds . fromInteger . getPositive <$> arbitrary
+
 timeMeasured :: (MonadLogger m, MonadBase IO m, HasCallStack)
              => String
              -- ^ A label
@@ -51,18 +73,31 @@ timeMeasured :: (MonadLogger m, MonadBase IO m, HasCallStack)
              -> m a
 timeMeasured = withFrozenCallStack $ timeMeasured' DEBUG
 
-timeMeasured' :: (MonadLogger m, MonadBase IO m, HasCallStack)
+-- | A version of timeMeasured that also returns the elapsed time, in seconds.
+timeMeasured'' :: (MonadLogger m, MonadBase IO m, HasCallStack)
              => LogLevel
              -- ^ The severity of the log
              -> String
              -- ^ A label to identify the action.
              -> m a
              -- ^ The action to run
-             -> m a
-timeMeasured' severity label action = withFrozenCallStack $ do
+             -> m (ElapsedSeconds, a)
+timeMeasured'' severity label action = withFrozenCallStack $ do
   startTime <- liftBase getPOSIXTime
   res       <- action
   endTime   <- liftBase getPOSIXTime
-  let msg = label <> " took " <> (show $ endTime - startTime) <> " seconds to execute."
+  let finalTime = endTime - startTime
+  let msg = label <> " took " <> (show finalTime) <> " seconds to execute."
   $(logLocM) severity (fromString msg)
-  return res
+  pure (ElapsedSeconds finalTime, res)
+
+timeMeasured' :: (MonadLogger m, MonadBase IO m, HasCallStack)
+             => LogLevel
+             -- ^ The severity of the log
+             -> String
+             -- ^ A label to identify the action.
+             -> m a
+             -- ^ The action to run
+             -> m a
+timeMeasured' severity label action = withFrozenCallStack $
+  snd <$> timeMeasured'' severity label action

test/Test/API/Notifications.hs

@@ -11,25 +11,30 @@ Portability : POSIX
 
 {-# OPTIONS_GHC -Wno-orphans  #-}
 
+{-# LANGUAGE ScopedTypeVariables #-}
+
     
 module Test.API.Notifications (
     tests
   ) where
 
-import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (withAsync)
 import Control.Concurrent.STM.TChan
+import Control.Exception.Safe qualified as Exc
+import Control.Monad (void)
 import Control.Monad.STM (atomically)
 import Data.Aeson qualified as Aeson
+import Data.ByteString qualified as BS
 import Data.Maybe (isJust)
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
 import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
 import Gargantext.Core.Notifications.Dispatcher qualified as D
 import Gargantext.Core.Notifications.Dispatcher.Types qualified as DT
 import Gargantext.Core.Config.Types (NotificationsConfig(..))
-import Network.WebSockets.Client qualified as WS
-import Network.WebSockets.Connection qualified as WS
+import Network.WebSockets qualified as WS
 import Prelude
-import Test.API.Setup (withTestDBAndNotifications)  -- , setupEnvironment, createAliceAndBob)
+import Test.API.Setup (withTestDBAndNotifications)
 import Test.Hspec
 import Test.Instances ()
 
@@ -37,41 +42,55 @@ import Test.Instances ()
 tests :: NotificationsConfig -> D.Dispatcher -> Spec
 tests nc dispatcher = sequential $ aroundAll (withTestDBAndNotifications dispatcher) $ do
   describe "Dispatcher, Central Exchange, WebSockets" $ do
-    it "simple WS notification works" $ \((_testEnv, port), _) -> do
+    it "simple WS notification works" $ \((testEnv, port), _) -> do
       let topic = DT.UpdateTree 0
       tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
       -- setup a websocket connection
-      let wsConnect = do
-            WS.runClient "127.0.0.1" port "/ws" $ \conn -> do
+      let wsConnect =
+            withWSConnection ("127.0.0.1", port, "/ws") $ \conn -> do
               -- We wait a bit before the server settles
               threadDelay (100 * millisecond)
               WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe topic)
               d <- WS.receiveData conn
               let dec = Aeson.decode d :: Maybe DT.Notification
               atomically $ writeTChan tchan dec
-              -- atomically $ TVar.writeTVar tvar (Aeson.decode d)
-            putStrLn "[WSClient] after"
             
       -- wait a bit to settle
       threadDelay (100 * millisecond)
-    
-      wsConnection <- forkIO $ wsConnect
-      
-      -- wait a bit to connect
-      threadDelay (100 * millisecond)
-      threadDelay (500 * millisecond)
 
-      CE.notify nc $ CET.UpdateTreeFirstLevel 0
+      withAsync wsConnect $ \_a -> do
+        -- wait a bit to connect
+        threadDelay (500 * millisecond)
+  
+        CE.notify nc $ CET.UpdateTreeFirstLevel 0
+  
+        md <- atomically $ readTChan tchan
+  
+        md `shouldSatisfy` isJust
+        let (Just (DT.Notification topic' message')) = md
+        topic' `shouldBe` topic
+        message' `shouldBe` DT.MEmpty
+  
 
-      -- d <- TVar.readTVarIO tvar
-      md <- atomically $ readTChan tchan
-      killThread wsConnection
+millisecond :: Int
+millisecond = 1000
 
-      md `shouldSatisfy` isJust
-      let (Just (DT.Notification topic' message')) = md
-      topic' `shouldBe` topic
-      message' `shouldBe` DT.MEmpty
 
+-- | 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
 
-millisecond :: Int
-millisecond = 1000
+    -- 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 ]

test/Test/API/Setup.hs

 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.API.Setup (
     SpecContext(..)
@@ -18,7 +19,7 @@ import Data.ByteString.Lazy.Char8 qualified as C8L
 import Data.Cache qualified as InMemory
 import Data.Streaming.Network (bindPortTCP)
 import Gargantext.API (makeApp)
-import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..))
+import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env(..), env_dispatcher)
 import Gargantext.API.Admin.Settings
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
@@ -49,6 +50,7 @@ import Network.Wai qualified as Wai
 import Network.Wai.Handler.Warp (runSettingsSocket)
 import Network.Wai.Handler.Warp qualified as Warp
 import Network.Wai.Handler.Warp.Internal
+import Network.WebSockets qualified as WS
 import Prelude
 import Servant.Auth.Client ()
 import Servant.Client
@@ -150,11 +152,26 @@ withTestDBAndPort action =
 withTestDBAndNotifications :: D.Dispatcher -> (((TestEnv, Warp.Port), Application) -> IO ()) -> IO ()
 withTestDBAndNotifications dispatcher action = do
   withTestDB $ \testEnv -> do    
-    app <- withLoggerHoisted Mock $ \ioLogger -> do
-             env <- newTestEnv testEnv ioLogger 8080
-             makeApp $ env { _env_dispatcher = dispatcher }
-    let stgs = Warp.defaultSettings { settingsOnExceptionResponse = showDebugExceptions }
-    Warp.testWithApplicationSettings stgs (pure app) $ \port -> action ((testEnv, port), app)
+    withLoggerHoisted Mock $ \ioLogger -> do
+      env <- newTestEnv testEnv ioLogger 8080
+             <&> env_dispatcher .~ dispatcher
+      app <- makeApp env
+      let stgs = Warp.defaultSettings { settingsOnExceptionResponse = showDebugExceptions }
+
+      -- An exception can be thrown by the websocket server (when client closes connection)
+      -- TODO I don't quite understand why the exception has to be caught here
+      -- and not under 'WS.runClient'
+      catches (Warp.testWithApplicationSettings stgs (pure app) $ \port -> action ((testEnv, port), app))
+        [ Handler $ \(err :: WS.ConnectionException) ->
+            case err of
+              WS.CloseRequest _ _ ->
+                withLogger () $ \ioLogger' ->
+                  logTxt ioLogger' DEBUG "[withTestDBAndNotifications] closeRequest caught"
+              _ -> throw err
+        
+        -- re-throw any other exceptions
+        , Handler $ \(err :: SomeException) -> throw err ]
+      
 
 -- | Starts the backend server /and/ the microservices proxy, the former at
 -- a random port, the latter at a predictable port.

test/Test/Core/AsyncUpdates.hs

@@ -9,7 +9,7 @@ Portability : POSIX
 
 -}
 
-module Test.Core.Notifications
+module Test.Core.AsyncUpdates
   ( test
   , qcTests )
 where

test/Test/Ngrams/Lang/Occurrences.hs

@@ -14,7 +14,28 @@ commentary with @some markup@.
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.Ngrams.Lang.Occurrences where
+import Test.Hspec
+import Data.Either
+import Gargantext.Core.Text.Terms.WithList
+import Gargantext.Core (Lang(ZH, EN))
+import Gargantext.Prelude
 
+test :: Spec
+test = do 
+    describe "terms in text counting" $ do
+            it "words with quotes should match" $ do
+                let ngrams = ["j'aime"]
+                let doc = "j'aime"
+                let output = []
+                    
+                termsInText EN (buildPatternsWith EN ngrams) doc `shouldBe` [("j'aime", 1)] 
+                
+            -- it "words with quotes should match and be case sentive" $ do
+            --     let ngrams = ["j'aIme"]
+            --     let doc = "j'aime"
+            --     let output = []
+                    
+            --     termsInText EN (buildPatternsWith EN ngrams) doc `shouldNotBe` [("j'aime", 1)] 
 {-
 import Test.Hspec
 

test/Test/Offline/JSON.hs

@@ -6,14 +6,15 @@
 module Test.Offline.JSON (tests) where
 
 import Data.Aeson
-import Data.ByteString qualified as B
 import Data.ByteString.Lazy.Char8 qualified as C8
+import Data.ByteString qualified as B
 import Data.Either
 import Gargantext.API.Errors
 import Gargantext.API.Node.Corpus.Types
 import Gargantext.API.Node.Types
 import Gargantext.API.Viz.Types
 import Gargantext.Core.Types.Phylo
+import qualified Gargantext.Core.Viz.Phylo as VizPhylo
 import Gargantext.Database.Admin.Types.Node
 import Paths_gargantext
 import Prelude
@@ -62,6 +63,8 @@ tests = testGroup "JSON" [
   , testProperty "GraphDataData" (jsonRoundtrip @GraphDataData)
   , testProperty "ObjectData"    (jsonRoundtrip @ObjectData)
   , testProperty "PhyloData"     (jsonRoundtrip @PhyloData)
+  , testProperty "ComputeTimeHistory" (jsonRoundtrip @VizPhylo.ComputeTimeHistory)
+  , testProperty "Phylo"         (jsonRoundtrip @VizPhylo.Phylo)
   , testProperty "LayerData"     (jsonRoundtrip @LayerData)
   , testCase "can parse bpa_phylo_test.json" testParseBpaPhylo
   , testCase "can parse open_science.json" testOpenSciencePhylo

test/Test/Offline/Phylo.hs

 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TupleSections #-}
 
 module Test.Offline.Phylo (tests) where
 
 import CLI.Phylo.Common
 import Data.Aeson as JSON
 import Data.Aeson.Types qualified as JSON
+import Data.Aeson.Encode.Pretty qualified as JSON
+import Data.ByteString.Lazy qualified as BL
 import Data.GraphViz.Attributes.Complete qualified as Graphviz
 import Data.Text.Lazy as TL
 import Data.TreeDiff
 import Data.Vector qualified as V
 import Gargantext.Core.Text.List.Formats.TSV
 import Gargantext.Core.Types.Phylo hiding (Phylo(..))
-import Gargantext.Core.Viz.Phylo hiding (EdgeType(..))
 import Gargantext.Core.Viz.Phylo.API.Tools (readPhylo, phylo2dot2json)
 import Gargantext.Core.Viz.Phylo.Example qualified as Cleopatre
+import Gargantext.Core.Viz.Phylo hiding (EdgeType(..))
 import Gargantext.Core.Viz.Phylo.PhyloExport
 import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloWithoutLink)
 import Gargantext.Core.Viz.Phylo.PhyloTools
 import Paths_gargantext
 import Prelude
 import Test.Tasty
+import Test.Tasty.Golden (goldenVsStringDiff)
 import Test.Tasty.HUnit
+import qualified Test.Tasty.Golden.Advanced as Advanced
 
 phyloTestConfig :: PhyloConfig
 phyloTestConfig = PhyloConfig {
@@ -48,6 +53,32 @@ phyloTestConfig = PhyloConfig {
   , exportFilter = [ByBranchSize {_branch_size = 3.0}]
   }
 
+phyloGolden :: TestName -> (FilePath, IO BL.ByteString) -> TestTree
+phyloGolden testName (fp, action) =
+  goldenVsStringDiff testName differ fp action
+  where
+    differ ref new = [ "diff", "-u", "-w", "--color=always", ref, new]
+
+-- | Use this variant for those tests which requires a more sophisticated way of
+-- comparing outputs directly on the GraphData
+phyloGoldenGraphData :: TestName -> (FilePath, IO GraphData) -> TestTree
+phyloGoldenGraphData testName (goldenPath, getActual) =
+  Advanced.goldenTest testName getGolden getActual differ updateGolden
+  where
+    differ ref new = pure $ case compareGraphDataFuzzy ref new of
+      True  -> Nothing
+      False -> Just $ show (ansiWlEditExprCompact $ ediff ref new)
+
+    updateGolden :: GraphData -> IO ()
+    updateGolden gd = BL.writeFile goldenPath (JSON.encodePretty gd)
+
+    getGolden :: IO GraphData
+    getGolden = do
+      expected_e <- JSON.eitherDecodeFileStrict' =<< getDataFileName goldenPath
+      case expected_e of
+        Left err -> fail err
+        Right (expected :: GraphData) -> pure expected
+
 tests :: TestTree
 tests = testGroup "Phylo" [
   testGroup "Export" [
@@ -56,14 +87,14 @@ tests = testGroup "Phylo" [
   ]
   , testGroup "toPhyloWithoutLink" [
     testCase "returns expected data" testSmallPhyloWithoutLinkExpectedOutput
-  , testCase "phyloCleopatre returns expected data" testCleopatreWithoutLinkExpectedOutput
-  , testCase "Nadal canned corpus returns expected data" testNadalWithoutLinkExpectedOutput
+  , phyloGolden "phyloCleopatre returns expected data" testCleopatreWithoutLinkExpectedOutput
+  , phyloGolden "Nadal canned corpus returns expected data" testNadalWithoutLinkExpectedOutput
   ]
   , testGroup "phylo2dot2json" [
-    testCase "is deterministic" testPhylo2dot2json
+    phyloGoldenGraphData "is deterministic" testPhylo2dot2json
   ]
   , testGroup "toPhylo" [
-    testCase "is deterministic" testToPhyloDeterminism
+    phyloGolden "is deterministic" testToPhyloDeterminism
   ]
   , testGroup "relatedComponents" [
     testCase "finds simple connection" testRelComp_Connected
@@ -71,14 +102,13 @@ tests = testGroup "Phylo" [
   , testCase "parses csv phylo" testCsvPhylo
   ]
 
-testCleopatreWithoutLinkExpectedOutput :: Assertion
-testCleopatreWithoutLinkExpectedOutput = do
+testCleopatreWithoutLinkExpectedOutput :: (FilePath, IO BL.ByteString)
+testCleopatreWithoutLinkExpectedOutput =
   let actual = toPhyloWithoutLink Cleopatre.docs Cleopatre.config
-  expected <- readPhylo =<< getDataFileName "test-data/phylo/cleopatre.golden.json"
-  assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
+  in ("test-data/phylo/cleopatre.golden.json", pure $ JSON.encodePretty actual)
 
-testNadalWithoutLinkExpectedOutput :: Assertion
-testNadalWithoutLinkExpectedOutput = do
+testNadalWithoutLinkExpectedOutput :: (FilePath, IO BL.ByteString)
+testNadalWithoutLinkExpectedOutput = ("test-data/phylo/nadal.golden.json",) $ do
   corpusPath'    <- getDataFileName "test-data/phylo/nadal_docslist.golden.tsv"
   listPath'      <- getDataFileName "test-data/phylo/nadal_ngramslist.golden.tsv"
   let config  = phyloTestConfig { corpusPath = corpusPath'
@@ -90,9 +120,7 @@ testNadalWithoutLinkExpectedOutput = do
                         (corpusPath config)
                         [Year 3 1 5,Month 3 1 5,Week 4 2 5]
                         mapList
-  let actual = setConfig phyloTestConfig $ toPhyloWithoutLink corpus config
-  expected   <- setConfig phyloTestConfig <$> (readPhylo =<< getDataFileName "test-data/phylo/nadal.golden.json")
-  assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
+  pure $ JSON.encodePretty $ setConfig phyloTestConfig $ toPhyloWithoutLink corpus config
 
 testSmallPhyloWithoutLinkExpectedOutput :: Assertion
 testSmallPhyloWithoutLinkExpectedOutput = do
@@ -111,17 +139,12 @@ testSmallPhyloWithoutLinkExpectedOutput = do
   expected   <- setConfig phyloTestConfig <$> (readPhylo =<< getDataFileName "test-data/phylo/small-phylo.golden.json")
   assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
 
-testPhylo2dot2json :: Assertion
-testPhylo2dot2json = do
-  expected_e <- JSON.eitherDecodeFileStrict' =<< getDataFileName "test-data/phylo/phylo2dot2json.golden.json"
-  case expected_e of
+testPhylo2dot2json :: (FilePath, IO GraphData)
+testPhylo2dot2json = ("test-data/phylo/phylo2dot2json.golden.json",) $ do
+  actual_e <- JSON.parseEither JSON.parseJSON <$> phylo2dot2json Cleopatre.phyloCleopatre
+  case actual_e of
     Left err -> fail err
-    Right (expected :: GraphData) -> do
-      actual_e <- JSON.parseEither JSON.parseJSON <$> phylo2dot2json Cleopatre.phyloCleopatre
-      case actual_e of
-        Left err -> fail err
-        Right (actual :: GraphData) -> do
-          assertBool ("Phylo mismatch!" <> show (ansiWlEditExprCompact $ ediff expected actual)) (expected `compareGraphDataFuzzy` actual)
+    Right (actual :: GraphData) -> pure actual
 
 compareGraphDataFuzzy :: GraphData -> GraphData -> Bool
 compareGraphDataFuzzy gd1 gd2 =
@@ -232,8 +255,8 @@ testRelComp_Connected = do
   (relatedComponents @Int) [[1,2], [3,5], [2,4],[9,5],[5,4]] @?= [[1,2,4,3,5,9]]
   (relatedComponents @Int) [[1,2,5], [4,5,9]]                @?= [[1,2,5,4,9]]
 
-testToPhyloDeterminism :: Assertion
-testToPhyloDeterminism = do
+testToPhyloDeterminism :: (FilePath, IO BL.ByteString)
+testToPhyloDeterminism = ("test-data/phylo/187481.json",) $ do
   corpusPath' <- getDataFileName "test-data/phylo/GarganText_DocsList-nodeId-187481.tsv"
   listPath'   <- getDataFileName "test-data/phylo/GarganText_NgramsList-187482.tsv"
   let config  = phyloTestConfig { corpusPath = corpusPath'
@@ -246,8 +269,7 @@ testToPhyloDeterminism = do
                               [Year 3 1 5,Month 3 1 5,Week 4 2 5]
                               mapList
   let actual = setConfig phyloTestConfig $ toPhylo $ toPhyloWithoutLink corpus config
-  expected    <- setConfig phyloTestConfig <$> (readPhylo =<< getDataFileName "test-data/phylo/187481.json")
-  assertBool ("Phylo mismatch! " <> show (ansiWlEditExprCompact $ ediff expected actual)) (expected == actual)
+  pure $ JSON.encodePretty actual
 
 testCsvPhylo :: Assertion
 testCsvPhylo = do

test/drivers/hspec/Main.hs

@@ -4,6 +4,7 @@ module Main where
 
 import Gargantext.Prelude hiding (isInfixOf)
 
+import Control.Concurrent.Async (asyncThreadId, withAsync)
 import Control.Monad
 import Data.Text (isInfixOf)
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
@@ -45,20 +46,13 @@ stopCoreNLPServer ph = do
   interruptProcessGroupOf ph
   putText "calling stop core nlp - done"
 
+
 withNotifications :: ((NotificationsConfig, ThreadId, D.Dispatcher) -> IO a) -> IO a
-withNotifications = bracket startNotifications stopNotifications
-  where
-    startNotifications :: IO (NotificationsConfig, ThreadId, D.Dispatcher)
-    startNotifications = do
-      central_exchange <- forkIO $ CE.gServer nc
-      dispatcher <- D.newDispatcher nc
-      pure (nc, central_exchange, dispatcher)
-    stopNotifications :: (NotificationsConfig, ThreadId, D.Dispatcher) -> IO ()
-    stopNotifications (_nc, central_exchange, dispatcher) = do
-      putText "calling stop notifications"
-      killThread central_exchange
-      D.terminateDispatcher dispatcher
-      putText "calling stop notifications - done"
+withNotifications cb = do
+  withAsync (CE.gServer nc) $ \ceA -> do
+    D.withDispatcher nc $ \d -> do
+      cb (nc, asyncThreadId ceA, d)
+
 
 nc :: NotificationsConfig
 nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560"
@@ -82,9 +76,10 @@ main = do
   hSetBuffering stdout NoBuffering
   -- TODO Ideally remove start/stop notifications and use
   -- Test/API/Setup to initialize this in env
-  withNotifications $ \(nc, _ce, dispatcher) -> do
-    bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do
+  bracket startCoreNLPServer stopCoreNLPServer $ \_ -> do
+    withNotifications $ \(nc, _ce, dispatcher) ->  hspec $ do
       API.tests nc dispatcher
+    hspec $ do
       ReverseProxy.tests
       DB.tests
       DB.nodeStoryTests

test/drivers/tasty/Main.hs

@@ -27,6 +27,8 @@ import qualified Test.Utils.Crypto               as Crypto
 import qualified Test.Utils.Jobs                 as Jobs
 import qualified Test.Core.Similarity            as Similarity
 import qualified Test.Core.Notifications          as Notifications
+import qualified Test.Core.AsyncUpdates          as AsyncUpdates
+import qualified Test.Ngrams.Lang.Occurrences    as Occurrences
 
 import Test.Tasty
 import Test.Tasty.Hspec
@@ -40,7 +42,8 @@ main = do
   nlpSpec          <- testSpec "NLP" NLP.test
   jobsSpec         <- testSpec "Jobs" Jobs.test
   similaritySpec   <- testSpec "Similarity" Similarity.test
-  asyncUpdatesSpec <- testSpec "Notifications" Notifications.test
+  asyncUpdatesSpec <- testSpec "AsyncUpdates" AsyncUpdates.test
+  occurrencesSepc  <- testSpec "Occurrences" Occurrences.test
 
   defaultMain $ testGroup "Gargantext"
     [ utilSpec
@@ -49,6 +52,7 @@ main = do
     , cryptoSpec
     , nlpSpec
     , jobsSpec
+    , occurrencesSepc
     , NgramsQuery.tests
     , CorpusQuery.tests
     , TSVParser.tests