Drop-in panicTrace function

This commit adds a `panicTrace` function to be used as a drop-in
replacement of the `panic` function, with the difference that we
wrap the error in a `WithStacktrace` error, to be later caught
and logged.

src/Gargantext/API/Errors.hs

@@ -64,6 +64,11 @@ backendErrorToFrontendError = \case
     -> internalServerErrorToFrontendError internalServerError
   InternalJobError jobError
     -> jobErrorToFrontendError jobError
+  -- As this carries a 'SomeException' which might exposes sensible
+  -- information, we do not send to the frontend its content.
+  InternalUnexpectedError _
+    -> let msg = T.pack $ "An unexpected error occurred. Please check your server logs."
+       in mkFrontendErr' msg $ FE_internal_server_error msg
 
 internalServerErrorToFrontendError :: ServerError -> FrontendError
 internalServerErrorToFrontendError = \case

src/Gargantext/API/Errors/Types.hs

@@ -33,9 +33,6 @@ module Gargantext.API.Errors.Types (
 
   -- * Generating test cases
   , genFrontendErr
-
-  -- * Attaching callstacks to exceptions
-  , WithStacktrace(..)
   ) where
 
 import Control.Exception
@@ -93,6 +90,7 @@ data BackendInternalError
   | InternalAuthenticationError !AuthenticationError
   | InternalServerError         !ServerError
   | InternalJobError            !Jobs.JobError
+  | InternalUnexpectedError     !SomeException
   deriving (Show, Typeable)
 
 makePrisms ''BackendInternalError

src/Gargantext/API/Ngrams/Types.hs

@@ -32,7 +32,7 @@ import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), C
 import Data.Set qualified as Set
 import Data.String (IsString(..))
 import Data.Swagger hiding (version, patch)
-import Data.Text (pack, strip)
+import Data.Text (pack, strip, unpack)
 import Data.Validity
 import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
 import Database.PostgreSQL.Simple.ToField (ToField, toJSONField, toField)
@@ -49,6 +49,7 @@ import Servant hiding (Patch)
 import Servant.Job.Utils (jsonOptions)
 import Test.QuickCheck (elements, frequency)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import Gargantext.Core.Errors.Types (panicTrace)
 
 ------------------------------------------------------------------------
 
@@ -791,7 +792,7 @@ ngramsTypeFromTabType tabType =
       Authors    -> TableNgrams.Authors
       Institutes -> TableNgrams.Institutes
       Terms      -> TableNgrams.NgramsTerms
-      _          -> panic $ here <> "No Ngrams for this tab"
+      _          -> panicTrace $ unpack $ here <> "No Ngrams for this tab"
       -- TODO: This `panic` would disapear with custom NgramsType.
 
 ----

src/Gargantext/API/Server.hs

@@ -8,31 +8,35 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-{-# LANGUAGE MonoLocalBinds #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TemplateHaskell      #-}
 
 module Gargantext.API.Server where
 
 import Control.Lens ((^.))
+import Control.Monad.Catch (catch, throwM)
+import Data.Text qualified as T
 import Data.Version (showVersion)
 import Gargantext.API.Admin.Auth (auth, forgotPassword, forgotPasswordAsync)
 import Gargantext.API.Admin.Auth.Types (AuthContext)
 import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Admin.FrontEnd (frontEndServer)
 import Gargantext.API.Auth.PolicyCheck ()
+import Gargantext.API.Errors
 import Gargantext.API.GraphQL qualified as GraphQL
 import Gargantext.API.Prelude
 import Gargantext.API.Public qualified as Public
 import Gargantext.API.Routes
 import Gargantext.API.Swagger (swaggerDoc)
 import Gargantext.API.ThrowAll (serverPrivateGargAPI)
+import Gargantext.Core.Errors.Types
 import Gargantext.Database.Prelude (hasConfig)
-import Gargantext.Prelude hiding (Handler)
+import Gargantext.Prelude hiding (Handler, catch)
 import Gargantext.Prelude.Config (gc_url_backend_api)
+import Gargantext.System.Logging
 import Paths_gargantext qualified as PG -- cabal magic build module
 import Servant
 import Servant.Swagger.UI (swaggerSchemaUIServer)
-import Gargantext.API.Errors
 
 
 serverGargAPI :: Text -> ServerT GargAPI (GargM Env BackendInternalError)
@@ -68,4 +72,16 @@ server env = do
   where
     transformJSON :: forall a. GargErrorScheme -> GargM Env BackendInternalError a -> Handler a
     transformJSON GES_old = Handler . withExceptT showAsServantJSONErr . (`runReaderT` env)
-    transformJSON GES_new = Handler . withExceptT (frontendErrorToServerError . backendErrorToFrontendError) . (`runReaderT` env)
+    transformJSON GES_new = Handler . withExceptT (frontendErrorToServerError . backendErrorToFrontendError) . (`runReaderT` env) . handlePanicErrors
+
+handlePanicErrors :: GargM Env BackendInternalError a -> GargM Env BackendInternalError a
+handlePanicErrors h = h `catch` handleSomeException
+  where
+    handleSomeException :: SomeException -> GargM Env BackendInternalError a
+    handleSomeException se
+      | Just ex@(WithStacktrace _ (_ :: UnexpectedPanic)) <- fromException se
+      = do
+        $(logLocM) ERROR $ T.pack $ displayException ex
+        ReaderT $ \_ -> ExceptT $ pure $ Left $ InternalUnexpectedError se
+      | otherwise
+      = throwM se -- re-throw the uncaught exception.

src/Gargantext/Core/Errors/Types.hs

 module Gargantext.Core.Errors.Types (
   -- * Attaching callstacks to exceptions
     WithStacktrace(..)
+  , UnexpectedPanic(..)
   , withStacktrace
+
+  -- * Drop-in replacement for panic/error
+  , panicTrace
   ) where
 
 import Control.Exception
@@ -23,3 +27,11 @@ instance Exception e => Exception (WithStacktrace e) where
 
 withStacktrace :: HasCallStack => e -> WithStacktrace e
 withStacktrace = withFrozenCallStack . WithStacktrace callStack
+
+newtype UnexpectedPanic = UnexpectedPanic String
+  deriving Show
+
+instance Exception UnexpectedPanic
+
+panicTrace :: HasCallStack => String -> x
+panicTrace = throw . withFrozenCallStack . WithStacktrace callStack . UnexpectedPanic

src/Gargantext/Core/NodeStory.hs

@@ -113,6 +113,8 @@ import Database.PostgreSQL.Simple.ToField qualified as PGS
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 import GHC.Conc (TVar, newTVar, readTVar, writeTVar)
 import Gargantext.API.Ngrams.Types
+import Gargantext.Core (toDBid)
+import Gargantext.Core.Errors.Types (panicTrace)
 import Gargantext.Core.Types (ListId, NodeId(..), NodeType)
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Admin.Config ()
@@ -123,7 +125,6 @@ import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude hiding (to)
 import Gargantext.Prelude.Database
 import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
-import Gargantext.Core (toDBid)
 
 ------------------------------------------------------------------------
 data NodeStoryEnv = NodeStoryEnv
@@ -747,4 +748,4 @@ fixNodeStoryVersions = do
         [PGS.Only (Just maxVersion)] -> do
           _ <- runPGSExecute c updateVerQuery (maxVersion, nId, ngramsType)
           pure ()
-        _ -> panic "Should get only 1 result!"
+        _ -> panicTrace "Should get only 1 result!"

src/Gargantext/Core/Text/List/Social.hs

@@ -25,6 +25,7 @@ import Data.Vector qualified as V
 import GHC.Generics
 import Gargantext.API.Ngrams.Types (NgramsTerm, NgramsPatch)
 import Gargantext.Core.NodeStory (getNodesArchiveHistory)
+import Gargantext.Core.Errors.Types (panicTrace)
 import Gargantext.Core.Text.List.Social.Find (findListsId)
 import Gargantext.Core.Text.List.Social.Patch (addScorePatches)
 import Gargantext.Core.Text.List.Social.Prelude (FlowCont, FlowListScores)
@@ -86,13 +87,13 @@ instance FromHttpApiData FlowSocialListWith
     parseUrlPiece "My lists first"    = pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
     parseUrlPiece "Others lists first" = pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
     parseUrlPiece "NoList"          = pure $ NoList True
-    parseUrlPiece x                 = panic $ "[G.C.T.L.Social] TODO FromHttpApiData FlowSocialListWith error: " <> (show x)
+    parseUrlPiece x                 = panicTrace $ "[G.C.T.L.Social] TODO FromHttpApiData FlowSocialListWith error: " <> (show x)
 
 instance ToHttpApiData   FlowSocialListWith where
     toUrlPiece (FlowSocialListWithPriority  MySelfFirst) = "MySelfFirst"
     toUrlPiece (FlowSocialListWithPriority  OthersFirst) = "OtherListsFirst"
     toUrlPiece (NoList _) = "NoList"
-    toUrlPiece (FlowSocialListWithLists _)  = panic "[G.C.T.L.Social] TODO ToHttpApiData FlowSocialListWith"
+    toUrlPiece (FlowSocialListWithLists _)  = panicTrace "[G.C.T.L.Social] TODO ToHttpApiData FlowSocialListWith"
 
 data FlowSocialListPriority = MySelfFirst | OthersFirst
   deriving (Eq, Show, Generic, Enum, Bounded)
@@ -124,7 +125,7 @@ flowSocialList :: ( HasNodeError err
 flowSocialList Nothing u = flowSocialList' MySelfFirst u
 flowSocialList (Just (FlowSocialListWithPriority p))  u = flowSocialList' p u
 flowSocialList (Just (FlowSocialListWithLists    ls)) _ = getHistoryScores ls
-flowSocialList (Just (NoList _))                     _u = panic "[G.C.T.L.Social] Should not be executed"
+flowSocialList (Just (NoList _))                     _u = panicTrace "[G.C.T.L.Social] Should not be executed"
 
 flowSocialList' :: ( HasNodeError err
                    , HasTreeError err

src/Gargantext/Core/Text/Terms.hs

@@ -46,6 +46,7 @@ import Data.Text qualified as Text
 import Data.Traversable
 import GHC.Base (String)
 import Gargantext.Core
+import Gargantext.Core.Errors.Types (panicTrace)
 import Gargantext.Core.Text (sentences, HasText(..))
 import Gargantext.Core.Text.Terms.Eleve (mainEleveWith, Tries, Token, buildTries, toToken)
 import Gargantext.Core.Text.Terms.Mono  (monoTerms)
@@ -187,7 +188,7 @@ type MinNgramSize = Int
 -- language agnostic extraction
 -- TODO: newtype BlockText
 termsUnsupervised :: TermType Lang -> Text -> [TermsWithCount]
-termsUnsupervised (Unsupervised { _tt_model = Nothing }) = panic "[termsUnsupervised] no model"
+termsUnsupervised (Unsupervised { _tt_model = Nothing }) = panicTrace "[termsUnsupervised] no model"
 termsUnsupervised (Unsupervised { _tt_model = Just _tt_model, .. }) =
                map (\(t, cnt) -> (text2term _tt_lang t, cnt))
              . groupWithCounts

src/Gargantext/Core/Utils.hs

@@ -27,6 +27,7 @@ import Data.List qualified as List
 import Data.Maybe
 import Data.Monoid
 import Data.Text qualified as T
+import Gargantext.Core.Errors.Types
 import Gargantext.Core.Utils.Prefix
 import Gargantext.Prelude
 import Prelude ((!!))
@@ -66,7 +67,7 @@ groupWithCounts = map f
                 . List.group
                 . List.sort
   where
-    f [] = panic "[groupWithCounts] impossible"
+    f [] = panicTrace "[groupWithCounts] impossible"
     f ts@(t:_) = (t, length ts)
 
 addTuples :: (Num a, Num b) => (a, b) -> (a, b) -> (a, b)

src/Gargantext/Core/Viz/Graph.hs

@@ -19,6 +19,7 @@ import Data.ByteString.Lazy as DBL (readFile, writeFile)
 import Data.HashMap.Strict (HashMap, lookup)
 import Data.Text qualified as Text
 import Gargantext.API.Ngrams.Types (NgramsTerm(..), NgramsRepoElement(..), mSetToList)
+import Gargantext.Core.Errors.Types (panicTrace)
 import Gargantext.Core.Viz.Graph.Types
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
@@ -58,7 +59,7 @@ graphV3ToGraphWithFiles g1 g2 = do
   -- GraphV3 <- IO Fichier
   graph <- DBL.readFile g1
   let newGraph = case DA.decode graph :: Maybe GraphV3 of
-        Nothing -> panic (Text.pack "no graph")
+        Nothing -> panicTrace "no graph"
         Just new -> new
 
   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)

src/Gargantext/Database/Query/Table/User.hs

@@ -58,7 +58,7 @@ import Data.Time (UTCTime)
 import Data.UUID qualified as UUID
 import Gargantext.Core (HasDBid, toDBid)
 import Gargantext.Core.Types.Individu
-import Gargantext.Database.Admin.Config (nodeTypeId)
+import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..), hu_pubmed_api_key, hu_epo_api_user, hu_epo_api_token)
 import Gargantext.Database.Admin.Types.Node (NodeType(NodeUser), Node, NodeId(..), pgNodeId)
 import Gargantext.Database.Admin.Types.Node (UserId(..))

test/Test/Database/Types.hs

@@ -27,7 +27,6 @@ import Database.PostgreSQL.Simple qualified as PG
 import Database.Postgres.Temp qualified as Tmp
 import Gargantext hiding (to)
 import Gargantext.API.Admin.EnvTypes
-import Gargantext.API.Admin.EnvTypes qualified as EnvTypes
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
@@ -73,12 +72,15 @@ newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
            , MonadIO
            )
 
+data TestJobHandle = TestNoJobHandle
+
 instance MonadJobStatus TestMonad where
-  type JobHandle      TestMonad = EnvTypes.ConcreteJobHandle BackendInternalError
+  type JobHandle      TestMonad = TestJobHandle
   type JobType        TestMonad = GargJob
   type JobOutputType  TestMonad = JobLog
   type JobEventType   TestMonad = JobLog
 
+  noJobHandle _         = TestNoJobHandle
   getLatestJobStatus _  = TestMonad (pure noJobLog)
   withTracer _ jh n     = n jh
   markStarted _ _       = TestMonad $ pure ()