Commit 8e43cc9e authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

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.
parent 11e23878
......@@ -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
......
......@@ -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
......
......@@ -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.
----
......
......@@ -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.
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
......@@ -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!"
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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)
......
......@@ -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(..))
......
......@@ -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 ()
......
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