[tests] fix tests hanging

Also, changed exceptions to safe

README.md

@@ -178,6 +178,12 @@ Or, from "outside":
 ```shell
 $ nix-shell --run "cabal v2-test --test-show-details=streaming"
 ```
+
+If you want to run particular tests, use:
+```shell
+cabal v2-test garg-test-tasty --test-show-details=streaming --test-option=--pattern='/job status update and tracking/
+```
+
 ### Working on libraries
 
 When a devlopment is needed on libraries (for instance, the HAL crawler in https://gitlab.iscpif.fr/gargantext/crawlers):

gargantext.cabal

@@ -576,6 +576,7 @@ library
     , regex
     , replace-attoparsec ^>= 1.4.5.0
     , resource-pool ^>= 0.2.3.2
+    , safe-exceptions >= 0.1.7.4 && < 0.2
     , serialise ^>= 0.2.4.0
     , servant >= 0.18.3 && < 0.20
     , servant-auth ^>= 0.4.0.0
@@ -763,6 +764,7 @@ common testDependencies
     , raw-strings-qq
     , recover-rtti >= 0.4 && < 0.5
     , resource-pool >= 0.2.3.2 && < 0.2.4
+    , safe-exceptions >= 0.1.7.4 && < 0.2
     , servant-auth
     , servant-auth
     , servant-auth-client

src/Gargantext/API/Admin/EnvTypes.hs

@@ -176,8 +176,8 @@ instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where
 
 instance CET.HasCentralExchangeNotification Env where
   ce_notify m = do
-    nc <- asks (view env_config)
-    liftBase $ CE.notify (_gc_notifications_config nc) m
+    c <- asks (view env_config)
+    liftBase $ CE.notify (_gc_notifications_config c) m
     
 -- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its
 -- constructor it's not exported, to not leak internal details of its implementation.

src/Gargantext/API/Errors.hs

@@ -21,7 +21,7 @@ module Gargantext.API.Errors (
 
 import Prelude
 
-import Control.Exception
+import Control.Exception.Safe
 import Data.Aeson qualified as JSON
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL

src/Gargantext/Core.hs

@@ -15,6 +15,7 @@ Portability : POSIX
 module Gargantext.Core
   where
 
+import Control.Exception.Safe (impureThrow)
 import Data.Aeson
 import Data.LanguageCodes qualified as ISO639
 import Data.Bimap qualified as Bimap
@@ -25,7 +26,6 @@ import Data.Text (pack)
 import Gargantext.Prelude hiding (All)
 import Servant.API
 import Test.QuickCheck
-import Control.Exception (throw)
 import Prelude (userError)
 
 ------------------------------------------------------------------------
@@ -180,5 +180,5 @@ fromDBid :: forall a. (HasCallStack, HasDBid a, Typeable a) => Int -> a
 fromDBid i = case lookupDBid i of
   Nothing ->
     let err = userError $ "HasDBid " <> show (typeRep (Proxy :: Proxy a)) <> " not found or not implemented."
-    in throw $ WithStacktrace callStack err
+    in impureThrow $ WithStacktrace callStack err
   Just v  -> v

src/Gargantext/Core/AsyncUpdates/CentralExchange.hs

@@ -103,5 +103,5 @@ notify (NotificationsConfig { _nc_central_exchange_connect }) ceMessage = do
       _ <- connect s $ T.unpack _nc_central_exchange_connect
       let str = Aeson.encode ceMessage
       withLogger () $ \ioLogger ->
-        logMsg ioLogger INFO $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
+        logMsg ioLogger DEBUG $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
       void $ sendNonblocking s $ BSL.toStrict str

src/Gargantext/Core/Config.hs

@@ -46,18 +46,19 @@ import Toml.Schema
 -- stripRight :: Char -> T.Text -> T.Text
 -- stripRight c s = if T.last s == c then stripRight c (T.take (T.length s - 1) s) else s
 
-data GargConfig = GargConfig { _gc_datafilepath         :: !FilePath
-                             -- , _gc_repofilepath      :: !FilePath
+-- Non-strict data so that we can use it in tests
+data GargConfig = GargConfig { _gc_datafilepath         :: ~FilePath
+                             -- , _gc_repofilepath      :: ~FilePath
 
-                             , _gc_frontend_config      :: !FrontendConfig
-                             , _gc_mail_config          :: !MailConfig
-                             , _gc_database_config      :: !PSQL.ConnectInfo
-                             , _gc_nlp_config           :: !NLPConfig
-                             , _gc_notifications_config :: !NotificationsConfig
-                             , _gc_frames               :: !FramesConfig
-                             , _gc_jobs                 :: !JobsConfig
-                             , _gc_secrets              :: !SecretsConfig
-                             , _gc_apis                 :: !APIsConfig
+                             , _gc_frontend_config      :: ~FrontendConfig
+                             , _gc_mail_config          :: ~MailConfig
+                             , _gc_database_config      :: ~PSQL.ConnectInfo
+                             , _gc_nlp_config           :: ~NLPConfig
+                             , _gc_notifications_config :: ~NotificationsConfig
+                             , _gc_frames               :: ~FramesConfig
+                             , _gc_jobs                 :: ~JobsConfig
+                             , _gc_secrets              :: ~SecretsConfig
+                             , _gc_apis                 :: ~APIsConfig
                              }
   deriving (Generic, Show)
 

src/Gargantext/Core/Config/Types.hs

@@ -271,10 +271,10 @@ makeLenses ''APIsConfig
 
 
 data NotificationsConfig =
-  NotificationsConfig { _nc_central_exchange_bind    :: !T.Text
-                      , _nc_central_exchange_connect :: !T.Text
-                      , _nc_dispatcher_bind          :: !T.Text
-                      , _nc_dispatcher_connect       :: !T.Text }
+  NotificationsConfig { _nc_central_exchange_bind    :: ~T.Text
+                      , _nc_central_exchange_connect :: ~T.Text
+                      , _nc_dispatcher_bind          :: ~T.Text
+                      , _nc_dispatcher_connect       :: ~T.Text }
   deriving (Show, Eq)
 instance FromValue NotificationsConfig where
   fromValue = parseTableFromValue $ do

src/Gargantext/Database/Prelude.hs

@@ -14,7 +14,7 @@ Portability : POSIX
 
 module Gargantext.Database.Prelude where
 
-import Control.Exception (throw)
+import Control.Exception.Safe (throw)
 import Control.Lens (Getter, view)
 import Control.Monad.Random ( MonadRandom )
 import Control.Monad.Trans.Control (MonadBaseControl)

src/Gargantext/System/Logging.hs

@@ -14,7 +14,7 @@ module Gargantext.System.Logging (
   ) where
 
 import Language.Haskell.TH hiding (Type)
-import Control.Exception.Lifted (bracket)
+import Control.Exception.Safe (MonadMask, bracket)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Control
 import Data.Kind (Type)
@@ -104,7 +104,7 @@ liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
 
 -- | exception-safe combinator that creates and destroys a logger.
 -- Think about it like a 'bracket' function from 'Control.Exception'.
-withLogger :: (MonadBaseControl IO m, MonadIO m, HasLogger m)
+withLogger :: (MonadBaseControl IO m, MonadIO m, HasLogger m, MonadMask m)
            => LogInitParams m
            -> (Logger m -> m a)
            -> m a

src/Gargantext/Utils/Jobs/Internal.hs

@@ -10,7 +10,7 @@ module Gargantext.Utils.Jobs.Internal (
 
 import Control.Concurrent
 import Control.Concurrent.Async
-import Control.Exception
+import Control.Exception.Safe
 import Control.Lens
 import Control.Monad
 import Control.Monad.Except
@@ -20,7 +20,9 @@ import Data.Monoid
 import Data.Kind (Type)
 import Data.Sequence (Seq)
 import qualified Data.Sequence as Seq
+import Gargantext.Prelude (panicTrace)
 import Prelude
+import Protolude qualified
 import Servant.API.Alternative
 import Servant.API.ContentTypes
 
@@ -89,19 +91,25 @@ newJob
 newJob newJobHandle getenv jobkind f input = do
   je <- getJobEnv
   env <- getenv
-  let postCallback m = forM_ (input ^. SJ.job_callback) $ \url ->
+  let postCallback m = forM_ (input ^. SJ.job_callback) $ \url -> do
         C.runClientM (SJ.clientMCallback m)
                      (C.mkClientEnv (jeManager je) (url  ^. SJ.base_url))
 
-      pushLog logF = \w -> do
+      pushLog logF w = do
         postCallback (SJ.mkChanEvent w)
         logF w
 
       f' jId inp logF = do
-        r <- f env (newJobHandle jId (liftIO . pushLog logF . Seq.singleton)) inp
-        case r of
-          Left e  -> postCallback (SJ.mkChanError e) >> throwIO e
-          Right a -> postCallback (SJ.mkChanResult a) >> pure a
+        catch (do
+          r <- f env (newJobHandle jId (liftIO . pushLog logF . Seq.singleton)) inp
+          case r of
+            Left e  -> postCallback (SJ.mkChanError e) >> throwIO e
+            Right a -> postCallback (SJ.mkChanResult a) >> pure a)
+          (\e -> do
+              -- We don't want jobs to fail silently
+              Protolude.putText $ Protolude.show (e :: SomeException)
+              _ <- panicTrace $ Protolude.show (e :: SomeException)
+              throwIO e)
 
   jid <- queueJob jobkind (input ^. SJ.job_input) f'
   pure (SJ.JobStatus jid [] SJ.IsPending Nothing)

src/Gargantext/Utils/Jobs/Map.hs

@@ -25,7 +25,7 @@ module Gargantext.Utils.Jobs.Map (
 import Control.Concurrent
 import Control.Concurrent.Async qualified as Async
 import Control.Concurrent.STM
-import Control.Exception
+import Control.Exception.Safe
 import Control.Monad
 import Data.Map.Strict (Map)
 import Data.Time.Clock

src/Gargantext/Utils/Jobs/Monad.hs

@@ -32,7 +32,7 @@ module Gargantext.Utils.Jobs.Monad (
   ) where
 
 import Control.Concurrent.STM
-import Control.Exception
+import Control.Exception.Safe
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Kind (Type)

src/Gargantext/Utils/Jobs/Queue.hs

@@ -3,7 +3,7 @@ module Gargantext.Utils.Jobs.Queue where
 
 import Control.Concurrent
 import Control.Concurrent.STM
-import Control.Exception
+import Control.Exception.Safe
 import Control.Monad
 import Data.Function
 import Data.Maybe

test/Test/API/Setup.hs

@@ -4,7 +4,7 @@ module Test.API.Setup where
 
 import Control.Concurrent.Async qualified as Async
 import Control.Concurrent.MVar
-import Control.Exception
+import Control.Exception.Safe
 import Control.Lens
 import Control.Monad.Reader
 import Data.ByteString.Lazy.Char8 qualified as C8L

test/Test/Database/Types.hs

@@ -14,7 +14,7 @@ Portability : POSIX
 
 module Test.Database.Types where
 
-import Control.Exception
+import Control.Exception.Safe
 import Control.Lens
 import Control.Monad.Except
 import Control.Monad.Reader

test/Test/Offline/Errors.hs

@@ -2,7 +2,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Test.Offline.Errors (tests) where
 
-import Control.Exception
+import Control.Exception (evaluate)
+import Control.Exception.Safe (try)
 import Gargantext.Prelude.Error
 import Gargantext.Core (fromDBid)
 import Gargantext.Database.Admin.Config ()
@@ -11,6 +12,7 @@ import Prelude
 import Test.Tasty
 import Test.Tasty.HUnit
 
+
 tests :: TestTree
 tests = testGroup "Errors" [
     testCase "fromDBid comes with a CallStack" fromDBid_cs

test/Test/Utils.hs

@@ -5,7 +5,7 @@
 
 module Test.Utils where
 
-import Control.Exception ()
+import Control.Exception.Safe ()
 import Control.Monad ()
 import Data.Aeson qualified as JSON
 import Data.Aeson.KeyMap qualified as KM

test/Test/Utils/Jobs.hs

@@ -25,6 +25,8 @@ import Gargantext.API.Admin.EnvTypes as EnvTypes
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
+import Gargantext.Core.Config (GargConfig(..))
+import Gargantext.Core.Config.Types (NotificationsConfig(..))
 import Gargantext.Prelude
 import Gargantext.Utils.Jobs.Error
 import Gargantext.Utils.Jobs.Internal (newJob)
@@ -38,6 +40,7 @@ import Prelude qualified
 import Servant.Job.Core qualified as SJ
 import Servant.Job.Types qualified as SJ
 import System.IO.Unsafe
+import System.Timeout (timeout)
 import Test.Hspec
 import Test.Hspec.Expectations.Contrib (annotate)
 import Test.Utils (waitUntil)
@@ -269,6 +272,23 @@ newTestEnv = do
   k <- genSecret
   let settings = defaultJobSettings 1 k
   myEnv <- newJobEnv settings defaultPrios testTlsManager
+  let _gc_notifications_config =
+        NotificationsConfig { _nc_central_exchange_bind = Prelude.error "nc_central_exchange_bind not needed, but forced somewhere (check StrictData)"
+                            , _nc_central_exchange_connect = "tcp://localhost:15510"
+                            , _nc_dispatcher_bind = Prelude.error "nc_dispatcher_bind not needed, but forced somewhere (check StrictData)"
+                            , _nc_dispatcher_connect = Prelude.error "nc_dispatcher_connect not needed, but forced somewhere (check StrictData)" }
+  let _env_config =
+        GargConfig { _gc_datafilepath = Prelude.error "gc_datafilepath not needed, but forced somewhere (check StrictData)"
+                   , _gc_frontend_config = Prelude.error "gc_frontend_config not needed, but forced somewhere (check StrictData)"
+                   , _gc_mail_config = Prelude.error "gc_mail_config not needed, but forced somewhere (check StrictData)"
+                   , _gc_database_config = Prelude.error "gc_database_config not needed, but forced somewhere (check StrictData)"
+                   , _gc_nlp_config = Prelude.error "gc_nlp_config not needed, but forced somewhere (check StrictData)"
+                   , _gc_notifications_config
+                   , _gc_frames = Prelude.error "gc_frames not needed, but forced somewhere (check StrictData)"
+                   , _gc_jobs = Prelude.error "gc_jobs not needed, but forced somewhere (check StrictData)"
+                   , _gc_secrets = Prelude.error "gc_secrets not needed, but forced somewhere (check StrictData)"
+                   , _gc_apis = Prelude.error "gc_apis not needed, but forced somewhere (check StrictData)"
+                   }
   pure $ Env
        { _env_settings  = Prelude.error "env_settings not needed, but forced somewhere (check StrictData)"
        , _env_logger    = Prelude.error "env_logger not needed, but forced somewhere (check StrictData)"
@@ -278,7 +298,7 @@ newTestEnv = do
        , _env_self_url  = Prelude.error "self_url not needed, but forced somewhere (check StrictData)"
        , _env_scrapers  = Prelude.error "scrapers not needed, but forced somewhere (check StrictData)"
        , _env_jobs      = myEnv
-       , _env_config    = Prelude.error "config not needed, but forced somewhere (check StrictData)"
+       , _env_config
        , _env_mail      = Prelude.error "mail not needed, but forced somewhere (check StrictData)"
        , _env_nlp       = Prelude.error "nlp not needed, but forced somewhere (check StrictData)"
        , _env_central_exchange = Prelude.error "central exchange not needed, but forced somewhere (check StrictData)"
@@ -347,9 +367,15 @@ testMarkProgress = do
         liftIO $ threadDelay 100_000
         st <- getLatestJobStatus hdl
         liftIO $ atomically $ writeTBQueue evts st
-      readAllEvents = do
-        allEventsArrived <- isFullTBQueue evts
-        if allEventsArrived then flushTBQueue evts else retry
+      readAllEvents = do  
+        -- We will get thread blocking if there is ANY error in the job
+        -- Hence we assert the `readAllEvents` test doesn't take too long
+        mRet <- timeout 1_000_000 $ atomically $ do
+          allEventsArrived <- isFullTBQueue evts
+          -- STM retry if things failed
+          check allEventsArrived
+          flushTBQueue evts
+        return $ fromMaybe [] mRet
 
   withJob_ myEnv $ \hdl _input -> do
     markStarted 10 hdl
@@ -375,7 +401,7 @@ testMarkProgress = do
 
     getStatus hdl
 
-  [jl0, jl1, jl2, jl3, jl4, jl5, jl6] <- atomically readAllEvents
+  [jl0, jl1, jl2, jl3, jl4, jl5, jl6] <- readAllEvents
 
   -- Check the events are what we expect
   jl0 `shouldBe` JobLog { _scst_succeeded = Just 0