Introduce the ToHumanFriendlyError typeclass

It forces programmers to think about errors we are logging and reporting
to the frontend, because they need to contain no sensitive data.

gargantext.cabal

@@ -230,6 +230,7 @@ library
       Gargantext.System.Logging
       Gargantext.Utils.Dict
       Gargantext.Utils.Jobs
+      Gargantext.Utils.Jobs.Error
       Gargantext.Utils.Jobs.Internal
       Gargantext.Utils.Jobs.Map
       Gargantext.Utils.Jobs.Monad

src/Gargantext/API/Job.hs

@@ -9,12 +9,24 @@ Portability : POSIX
 -}
 
 
-module Gargantext.API.Job where
+module Gargantext.API.Job (
+    jobLogStart
+  , jobLogProgress
+  , jobLogComplete
+  , jobLogAddMore
+  , jobLogFailures
+  , jobLogFailTotal
+  , jobLogEvt
+  , jobLogFailTotalWithMessage
+  , RemainingSteps(..)
+  , addErrorEvent
+  ) where
 
 import Control.Lens (over, _Just)
 import Data.Text qualified as T
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.Prelude
+import Gargantext.Utils.Jobs.Error
 
 newtype RemainingSteps = RemainingSteps { _RemainingSteps :: Int }
   deriving (Show, Eq, Num)
@@ -34,8 +46,8 @@ addEvent level message (JobLog { _scst_events = mEvts, .. }) = JobLog { _scst_ev
                           , _scev_level = Just level
                           , _scev_date = Nothing }
 
-addErrorEvent :: T.Text -> JobLog -> JobLog
-addErrorEvent message = addEvent "ERROR" message
+addErrorEvent :: ToHumanFriendlyError e => e -> JobLog -> JobLog
+addErrorEvent message = addEvent "ERROR" (mkHumanFriendly message)
 
 jobLogProgress :: Int -> JobLog -> JobLog
 jobLogProgress n jl = over (scst_succeeded . _Just) (+ n) $
@@ -70,7 +82,7 @@ jobLogFailTotal (JobLog { _scst_succeeded = mSucc
       Nothing -> (Nothing, mFail)
       Just rem' -> (Just 0, (+ rem') <$> mFail)
 
-jobLogFailTotalWithMessage :: T.Text -> JobLog -> JobLog
+jobLogFailTotalWithMessage :: ToHumanFriendlyError e => e -> JobLog -> JobLog
 jobLogFailTotalWithMessage message jl = addErrorEvent message $ jobLogFailTotal jl
 
 jobLogEvt :: JobLog -> ScraperEvent -> JobLog

src/Gargantext/API/Ngrams.hs

@@ -119,6 +119,7 @@ import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
 import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
 import Gargantext.Prelude.Clock (hasTime, getTime)
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
+import Gargantext.Utils.Jobs.Monad (markFailedNoErr)
 import Servant hiding (Patch)
 
 {-
@@ -429,7 +430,7 @@ tableNgramsPostChartsAsync utn jobHandle = do
         Nothing -> do
           -- printDebug "[tableNgramsPostChartsAsync] can't update charts, no parent, nId" nId
           markStarted 1 jobHandle
-          markFailed Nothing jobHandle
+          markFailedNoErr jobHandle
         Just cId -> do
           case tabType of
             Authors -> do
@@ -474,7 +475,7 @@ tableNgramsPostChartsAsync utn jobHandle = do
             _otherTabType -> do
               -- printDebug "[tableNgramsPostChartsAsync] no update for tabType = " tabType
               markStarted 1 jobHandle
-              markFailed Nothing jobHandle
+              markFailedNoErr jobHandle
 
   {-
   { _ne_list        :: ListType

src/Gargantext/API/Node/Corpus/New.hs

@@ -41,7 +41,7 @@ import Gargantext.API.Node.Types
 import Gargantext.Core (Lang(..), withDefaultLanguage, defaultLanguage)
 import Gargantext.Core.NodeStory (HasNodeStoryImmediateSaver, HasNodeArchiveStoryImmediateSaver, currentVersion, NgramsStatePatch')
 import Gargantext.Core.Text.Corpus.API qualified as API
-import Gargantext.Core.Text.Corpus.Parsers qualified as Parser (FileType(..), parseFormatC)
+import Gargantext.Core.Text.Corpus.Parsers qualified as Parser (FileType(..), parseFormatC, ParseFormatError(..))
 import Gargantext.Core.Text.List.Social (FlowSocialListWith(..))
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
@@ -254,7 +254,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
           $(logLocM) DEBUG $ T.pack $ "corpus id " <> show corpusId
 
           _ <- commitCorpus cid user
-          
+
           -- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
           sendMail user
           -- TODO ...
@@ -262,8 +262,8 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
 
         Left err -> do
           -- printDebug "Error: " err
-          $(logLocM) ERROR (T.pack $ show err)
-          markFailed (Just $ T.pack (show err)) jobHandle
+          $(logLocM) ERROR (T.pack $ show err) -- log the full error
+          markFailed (Just err) jobHandle
 
 type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint"
    :> "corpus"
@@ -352,9 +352,9 @@ addToCorpusWithForm user cid nwf jobHandle = do
       --sendMail user
 
       markComplete jobHandle
-    Left e -> do
-      printDebug "[addToCorpusWithForm] parse error" e
-      markFailed (Just e) jobHandle
+    Left parseErr -> do
+      $(logLocM) ERROR $ "parse error: " <> (Parser._ParseFormatError parseErr)
+      markFailed (Just parseErr) jobHandle
 
 {-
 addToCorpusWithFile :: FlowCmdM env err m

src/Gargantext/API/Node/DocumentsFromWriteNodes.hs

@@ -10,6 +10,7 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE MonoLocalBinds     #-}
+{-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeOperators      #-}
 
 module Gargantext.API.Node.DocumentsFromWriteNodes
@@ -43,7 +44,9 @@ import Gargantext.Database.Admin.Types.Node ( NodeId, Node, NodeType(..) )
 import Gargantext.Database.Query.Table.Node (getChildrenByType, getClosestParentIdByType', getNodeWith, getOrMkList)
 import Gargantext.Database.Schema.Node (node_hyperdata, node_name, node_date)
 import Gargantext.Prelude
+import Gargantext.System.Logging
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
+import Gargantext.Utils.Jobs.Error
 import Servant ( JSON, Summary, type (:>), HasServer(ServerT) )
 
 ------------------------------------------------------------------------
@@ -90,8 +93,9 @@ documentsFromWriteNodes authenticatedUser nId Params { selection, lang, paragrap
   cId <- case mcId of
     Just cId -> pure cId
     Nothing -> do
-      let msg = T.pack $ "[G.A.N.DFWN] Node has no corpus parent: " <> show nId
-      markFailed (Just msg) jobHandle
+      let msg = T.pack $ "Node has no corpus parent: " <> show nId
+      $(logLocM) ERROR msg
+      markFailed (Just $ UnsafeMkHumanFriendlyErrorText "The requested node has no corpus parent.") jobHandle
       panicTrace msg
 
   frameWriteIds <- getChildrenByType nId Notes

src/Gargantext/API/Node/FrameCalcUpload.hs

@@ -40,7 +40,7 @@ import Gargantext.Database.Prelude (HasConfig)
 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, getNodeWith)
 import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Prelude
-import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
+import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..), markFailureNoErr)
 import Network.HTTP.Client (newManager, httpLbs, parseRequest, responseBody)
 import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Servant ( type (:>), JSON, Summary, HasServer(ServerT) )
@@ -105,7 +105,7 @@ frameCalcUploadAsync authenticatedUser nId (FrameCalcUpload _wf_lang _wf_selecti
   -- printDebug "[frameCalcUploadAsync] mCId" mCId
 
   case mCId of
-    Nothing -> markFailure 1 Nothing jobHandle
+    Nothing -> markFailureNoErr 1 jobHandle
     Just cId ->
       -- FIXME(adn) Audit this conversion.
       addToCorpusWithForm (RootId userNodeId)

src/Gargantext/Core/Text/Corpus/API.hs

@@ -9,6 +9,8 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE LambdaCase #-}
+
 module Gargantext.Core.Text.Corpus.API
   ( ExternalAPIs(..)
   , Corpus.RawQuery(..)
@@ -33,6 +35,7 @@ import Gargantext.Core.Text.Corpus.API.Pubmed qualified as PUBMED
 import Gargantext.Core.Text.Corpus.Query qualified as Corpus
 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
 import Gargantext.Prelude hiding (get)
+import Gargantext.Utils.Jobs.Error
 import PUBMED.Types qualified as PUBMED
 import Servant.Client (ClientError)
 
@@ -40,9 +43,16 @@ data GetCorpusError
   = -- | We couldn't parse the user input query into something meaningful.
     InvalidInputQuery !Corpus.RawQuery !T.Text
     -- | The external service returned an error.
-  | ExternalAPIError !ClientError
+  | ExternalAPIError !ExternalAPIs !ClientError
   deriving (Show, Eq)
 
+instance ToHumanFriendlyError GetCorpusError where
+  mkHumanFriendly = \case
+    InvalidInputQuery rq txt ->
+      "Invalid input query (" <> Corpus.getRawQuery rq <> ") for corpus search: " <> txt
+    ExternalAPIError api _ ->
+      "There was a network problem while contacting the " <> T.pack (show api) <> " API provider. Please try again later or contact your network administrator."
+
 -- | Get External API metadata main function
 get :: ExternalAPIs
     -> Lang
@@ -61,14 +71,14 @@ get externalAPI lang q mPubmedAPIKey epoAuthKey epoAPIUrl limit = do
   -- For Arxiv we parse the query into a structured boolean query we submit over.
   case externalAPI of
       PubMed   ->
-        first ExternalAPIError <$> PUBMED.get (fromMaybe "" mPubmedAPIKey) q limit
+        first (ExternalAPIError externalAPI) <$> PUBMED.get (fromMaybe "" mPubmedAPIKey) q limit
       OpenAlex ->
-        first ExternalAPIError <$> OpenAlex.get (fromMaybe "" Nothing {- email -}) q (Just $ toISO639 lang) limit
+        first (ExternalAPIError externalAPI) <$> OpenAlex.get (fromMaybe "" Nothing {- email -}) q (Just $ toISO639 lang) limit
       Arxiv    -> runExceptT $ do
         corpusQuery <- ExceptT (pure parse_query)
         ExceptT $ fmap Right (Arxiv.get lang corpusQuery limit)
       HAL      ->
-        first ExternalAPIError <$> HAL.getC (Just $ toISO639 lang) (Corpus.getRawQuery q) (Corpus.getLimit <$> limit)
+        first (ExternalAPIError externalAPI) <$> HAL.getC (Just $ toISO639 lang) (Corpus.getRawQuery q) (Corpus.getLimit <$> limit)
       IsTex    -> do
         docs <- ISTEX.get lang (Corpus.getRawQuery q) (Corpus.getLimit <$> limit)
         pure $ Right (Just $ fromIntegral $ length docs, yieldMany docs)
@@ -76,7 +86,7 @@ get externalAPI lang q mPubmedAPIKey epoAuthKey epoAPIUrl limit = do
         docs <- ISIDORE.get lang (Corpus.getLimit <$> limit) (Just $ Corpus.getRawQuery q) Nothing
         pure $ Right (Just $ fromIntegral $ length docs, yieldMany docs)
       EPO -> do
-        first ExternalAPIError <$> EPO.get epoAuthKey epoAPIUrl q (toISO639 lang) limit
+        first (ExternalAPIError externalAPI) <$> EPO.get epoAuthKey epoAPIUrl q (toISO639 lang) limit
   where
     parse_query = first (InvalidInputQuery q . T.pack) $ Corpus.parseQuery q
 

src/Gargantext/Core/Text/Corpus/Parsers.hs

@@ -20,8 +20,17 @@ please follow the types.
 
 {-# LANGUAGE PackageImports    #-}
 
-module Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..), clean, parseFile, cleanText, parseFormatC, splitOn, etale)
-    where
+module Gargantext.Core.Text.Corpus.Parsers (
+    FileFormat(..)
+  , FileType(..)
+  , ParseFormatError(..)
+  , clean
+  , parseFile
+  , cleanText
+  , parseFormatC
+  , splitOn
+  , etale
+  ) where
 
 -- import Gargantext.Core.Text.Learn (detectLangDefault)
 import "zip" Codec.Archive.Zip (EntrySelector, withArchive, getEntry, getEntries, unEntrySelector)
@@ -49,6 +58,7 @@ import Gargantext.Core.Text.Corpus.Parsers.WOS qualified as WOS
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..) )
 import Gargantext.Prelude hiding (show, undefined)
+import Gargantext.Utils.Jobs.Error
 import Gargantext.Utils.Zip qualified as UZip
 import Protolude ( show )
 import System.FilePath (takeExtension)
@@ -81,73 +91,85 @@ data FileType = WOS
 --                | PDF        -- Not Implemented / pdftotext and import Pandoc ?
 --                | XML        -- Not Implemented / see :
 
-parseFormatC :: MonadBaseControl IO m
+newtype ParseFormatError = ParseFormatError { _ParseFormatError :: DT.Text }
+  deriving (Show, Eq, Ord, IsString)
+
+instance ToHumanFriendlyError ParseFormatError where
+  mkHumanFriendly = _ParseFormatError -- nothing sensitive that cannot be shown.
+
+parseFormatC :: forall m. MonadBaseControl IO m
+             => FileType
+             -> FileFormat
+             -> DB.ByteString
+             -> m (Either ParseFormatError (Integer, ConduitT () HyperdataDocument IO ()))
+parseFormatC ft ff bs0 = first ParseFormatError <$> do_parse ft ff bs0
+  where
+    do_parse :: MonadBaseControl IO m
              => FileType
              -> FileFormat
              -> DB.ByteString
-             -> m (Either Text (Integer, ConduitT () HyperdataDocument IO ()))
-parseFormatC CsvGargV3 Plain bs = do
-  let eParsedC = parseCsvC $ DBL.fromStrict bs
-  pure (second (transPipe (pure . runIdentity)) <$> eParsedC)
-parseFormatC CsvHal    Plain bs = do
-  let eParsedC = parseCsvC $ DBL.fromStrict bs
-  pure (second (transPipe (pure . runIdentity)) <$> eParsedC)
-parseFormatC Istex Plain bs = do
-  ep <- liftBase $ parseIstex EN $ DBL.fromStrict bs
-  pure $ (\p -> (1, yieldMany [p])) <$> ep
-parseFormatC RisPresse Plain bs = do
-  --docs <- enrichWith RisPresse
-  let eDocs = runParser' RisPresse bs
-  pure $ (\docs ->
-            ( fromIntegral $ length docs
-            , yieldMany docs
-              .| mapC presseEnrich
-              .| mapC (map $ both decodeUtf8)
-              .| mapMC (toDoc RIS)) ) <$> eDocs
-parseFormatC WOS Plain bs = do
-  let eDocs = runParser' WOS bs
-  pure $ (\docs ->
-            ( fromIntegral $ length docs
-            , yieldMany docs
-              .| mapC (map $ first WOS.keys)
-              .| mapC (map $ both decodeUtf8)
-              .| mapMC (toDoc WOS)) ) <$> eDocs
-
-parseFormatC Iramuteq Plain bs = do
-  let eDocs = runParser' Iramuteq bs
-  pure $ (\docs ->
-            ( fromIntegral $ length docs
-            , yieldMany docs
-              .| mapC (map $ first Iramuteq.keys)
-              .| mapC (map $ both decodeUtf8)
-              .| mapMC (toDoc Iramuteq . map (second (DT.replace "_" " ")))
-            )
-         )
-              <$> eDocs
-parseFormatC JSON    Plain bs = do
-  let eParsedC = parseJSONC $ DBL.fromStrict bs
-  pure (second (transPipe (pure . runIdentity)) <$> eParsedC)
-parseFormatC ft ZIP bs = liftBase $ UZip.withZipFileBS bs $ do
-  fileNames <- filter (filterZIPFileNameP ft) . DM.keys <$> getEntries
-  printDebug "[parseFormatC] fileNames" fileNames
-  fileContents <- mapM getEntry fileNames
-  --printDebug "[parseFormatC] fileContents" fileContents
-  eContents <- mapM (parseFormatC ft Plain) fileContents
-  --printDebug "[parseFormatC] contents" contents
-  --pure $ Left $ "Not implemented for ZIP"
-  let (errs, contents) = partitionEithers eContents
-  case errs of
-    [] ->
-      case contents of
-        [] -> pure $ Left "No files in zip"
-        _  -> do
-          let lenghts = fst <$> contents
-          let contents' = snd <$> contents
-          let totalLength = sum lenghts
-          pure $ Right ( totalLength
-                       , void (sequenceConduits contents') ) -- .| mapM_C (printDebug "[parseFormatC] doc")
-    _ -> pure $ Left $ DT.intercalate "\n" errs
-parseFormatC _ _ _ = pure $ Left "Not implemented"
+             -> m (Either DT.Text (Integer, ConduitT () HyperdataDocument IO ()))
+    do_parse CsvGargV3 Plain bs = do
+      let eParsedC = parseCsvC $ DBL.fromStrict bs
+      pure (second (transPipe (pure . runIdentity)) <$> eParsedC)
+    do_parse CsvHal    Plain bs = do
+      let eParsedC = parseCsvC $ DBL.fromStrict bs
+      pure (second (transPipe (pure . runIdentity)) <$> eParsedC)
+    do_parse Istex Plain bs = do
+      ep <- liftBase $ parseIstex EN $ DBL.fromStrict bs
+      pure $ (\p -> (1, yieldMany [p])) <$> ep
+    do_parse RisPresse Plain bs = do
+      --docs <- enrichWith RisPresse
+      let eDocs = runParser' RisPresse bs
+      pure $ (\docs ->
+                ( fromIntegral $ length docs
+                , yieldMany docs
+                  .| mapC presseEnrich
+                  .| mapC (map $ both decodeUtf8)
+                  .| mapMC (toDoc RIS)) ) <$> eDocs
+    do_parse WOS Plain bs = do
+      let eDocs = runParser' WOS bs
+      pure $ (\docs ->
+                ( fromIntegral $ length docs
+                , yieldMany docs
+                  .| mapC (map $ first WOS.keys)
+                  .| mapC (map $ both decodeUtf8)
+                  .| mapMC (toDoc WOS)) ) <$> eDocs
+    do_parse Iramuteq Plain bs = do
+      let eDocs = runParser' Iramuteq bs
+      pure $ (\docs ->
+                ( fromIntegral $ length docs
+                , yieldMany docs
+                  .| mapC (map $ first Iramuteq.keys)
+                  .| mapC (map $ both decodeUtf8)
+                  .| mapMC (toDoc Iramuteq . map (second (DT.replace "_" " ")))
+                )
+             )
+                  <$> eDocs
+    do_parse JSON    Plain bs = do
+      let eParsedC = parseJSONC $ DBL.fromStrict bs
+      pure (second (transPipe (pure . runIdentity)) <$> eParsedC)
+    do_parse fty ZIP bs = liftBase $ UZip.withZipFileBS bs $ do
+      fileNames <- filter (filterZIPFileNameP ft) . DM.keys <$> getEntries
+      printDebug "[do_parse] fileNames" fileNames
+      fileContents <- mapM getEntry fileNames
+      --printDebug "[do_parse] fileContents" fileContents
+      eContents <- mapM (do_parse fty Plain) fileContents
+      --printDebug "[do_parse] contents" contents
+      --pure $ Left $ "Not implemented for ZIP"
+      let (errs, contents) = partitionEithers eContents
+      case errs of
+        [] ->
+          case contents of
+            [] -> pure $ Left "No files in zip"
+            _  -> do
+              let lenghts = fst <$> contents
+              let contents' = snd <$> contents
+              let totalLength = sum lenghts
+              pure $ Right ( totalLength
+                           , void (sequenceConduits contents') ) -- .| mapM_C (printDebug "[do_parse] doc")
+        _ -> pure $ Left $ DT.intercalate "\n" errs
+    do_parse _ _ _ = pure $ Left "Not implemented"
 
 
 filterZIPFileNameP :: FileType -> EntrySelector -> Bool

src/Gargantext/Utils/Jobs.hs

@@ -18,6 +18,8 @@ module Gargantext.Utils.Jobs (
   , readPrios
   -- * Handy re-exports
   , MonadJobStatus(..)
+  , markFailureNoErr
+  , markFailedNoErr
   ) where
 
 import Control.Monad.Except ( runExceptT )
@@ -32,7 +34,7 @@ import Gargantext.API.Admin.EnvTypes ( mkJobHandle, Env, GargJob(..) )
 import Gargantext.API.Errors.Types ( BackendInternalError(InternalJobError) )
 import Gargantext.API.Prelude ( GargM )
 import qualified Gargantext.Utils.Jobs.Internal as Internal
-import Gargantext.Utils.Jobs.Monad ( JobError, MonadJobStatus(..) )
+import Gargantext.Utils.Jobs.Monad ( JobError, MonadJobStatus(..), markFailureNoErr, markFailedNoErr )
 import Gargantext.System.Logging
 
 import qualified Servant.Job.Async as SJ

src/Gargantext/Utils/Jobs/Error.hs

+{-# LANGUAGE LambdaCase #-}
+
+module Gargantext.Utils.Jobs.Error
+  ( ToHumanFriendlyError(..)
+  , HumanFriendlyErrorText(..)
+  ) where
+
+import Prelude
+import Data.Void
+import qualified Data.Text as T
+
+-- | This class represents the concept of \"human friendly strings\", by which we mean
+-- error messages and/or diagnostics which needs to be displayed to the end users, and, as such:
+--
+-- 1. They should be easy to understand for end users, not developers (developers would access
+--    the full debug logs on the server machine). As such, they don't have to include implementation
+--    details and/or technicalities;
+-- 2. They /MUST NOT/ include any sensitive data. Please be very careful when writing these instances
+--    because just calling \"T.pack . show\" on the input data is immediately wrong; things like Servant's
+--    'ClientError' or any HTTP exception might include api keys in the form of HTTP headers, so leaking
+--    that is /BAD/.
+class ToHumanFriendlyError e where
+  mkHumanFriendly :: e -> T.Text
+
+-- | A newtype to wrap a 'Text' to be displayed to the end user.
+-- /IMPORTANT/: You need to be very careful when using this newtype; please ensure that the text
+-- you are wrapping with this newtype doesn't contain sentitive information.
+newtype HumanFriendlyErrorText = UnsafeMkHumanFriendlyErrorText { _HumanFriendlyErrorText :: T.Text }
+  deriving (Show, Eq, Ord)
+
+instance ToHumanFriendlyError HumanFriendlyErrorText where
+  mkHumanFriendly = _HumanFriendlyErrorText
+
+-- /N.B/ Don't get fooled by this instance, it's just to help inference in case we use \"markFailed Nothing\".
+instance ToHumanFriendlyError Void where
+  mkHumanFriendly = absurd

src/Gargantext/Utils/Jobs/Monad.hs

-{-# LANGUAGE MultiWayIf, FunctionalDependencies, MultiParamTypeClasses, TypeFamilies #-}
+{-# LANGUAGE MultiWayIf, FunctionalDependencies, MultiParamTypeClasses, TypeFamilies, ScopedTypeVariables #-}
 module Gargantext.Utils.Jobs.Monad (
   -- * Types and classes
     JobEnv(..)
@@ -7,6 +7,9 @@ module Gargantext.Utils.Jobs.Monad (
 
   , MonadJob(..)
 
+  -- * Reporting errors to users in a friendly way
+  , ToHumanFriendlyError(..)
+
   -- * Tracking jobs status
   , MonadJobStatus(..)
 
@@ -24,11 +27,14 @@ module Gargantext.Utils.Jobs.Monad (
   , withJob
   , handleIDError
   , removeJob
+  , markFailedNoErr
+  , markFailureNoErr
   ) where
 
-import Gargantext.Utils.Jobs.Settings
+import Gargantext.Utils.Jobs.Error
 import Gargantext.Utils.Jobs.Map
 import Gargantext.Utils.Jobs.Queue
+import Gargantext.Utils.Jobs.Settings
 import Gargantext.Utils.Jobs.State
 
 import Control.Concurrent.STM
@@ -38,6 +44,7 @@ import Control.Monad.Reader
 import Data.Kind (Type)
 import Data.Map.Strict (Map)
 import Data.Time.Clock
+import Data.Void (Void)
 import qualified Data.Text as T
 import Network.HTTP.Client (Manager)
 import Prelude
@@ -213,14 +220,21 @@ class MonadJobStatus m where
 
   -- | Mark 'n' step of the job as failed, while simultaneously substracting this number
   -- from the remaining steps. Attach an optional error message to the failure.
-  markFailure :: Int -> Maybe T.Text -> JobHandle m -> m ()
+  markFailure :: forall e. ToHumanFriendlyError e => Int -> Maybe e -> JobHandle m -> m ()
 
   -- | Finish tracking a job by marking all the remaining steps as succeeded.
   markComplete :: JobHandle m -> m ()
 
   -- | Finish tracking a job by marking all the remaining steps as failed. Attach an optional
   -- message to the failure.
-  markFailed :: Maybe T.Text -> JobHandle m -> m ()
+  markFailed :: forall e. ToHumanFriendlyError e => Maybe e -> JobHandle m -> m ()
 
   -- | Add 'n' more steps to the running computation, they will be marked as remaining.
   addMoreSteps :: MonadJobStatus m => Int -> JobHandle m -> m ()
+
+-- | Helper on top of 'markFailed' for when we don't have a diagnostic to log.
+markFailedNoErr :: MonadJobStatus m => JobHandle m -> m ()
+markFailedNoErr = markFailed (Nothing :: Maybe Void)
+
+markFailureNoErr :: MonadJobStatus m => Int -> JobHandle m -> m ()
+markFailureNoErr steps = markFailure steps (Nothing :: Maybe Void)

test/Test/Utils/Jobs.hs

@@ -28,6 +28,7 @@ import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.Prelude
+import Gargantext.Utils.Jobs.Error
 import Gargantext.Utils.Jobs.Internal (newJob)
 import Gargantext.Utils.Jobs.Map
 import Gargantext.Utils.Jobs.Monad hiding (withJob)
@@ -345,10 +346,10 @@ testMarkProgress = do
     markProgress 1 hdl
     getStatus hdl
 
-    markFailure 1 Nothing hdl
+    markFailureNoErr 1 hdl
     getStatus hdl
 
-    markFailure 1 (Just "boom") hdl
+    markFailure 1 (Just $ UnsafeMkHumanFriendlyErrorText "boom") hdl
 
     getStatus hdl
     markComplete hdl
@@ -358,7 +359,7 @@ testMarkProgress = do
     markProgress 1 hdl
 
     getStatus hdl
-    markFailed (Just "kaboom") hdl
+    markFailed (Just $ UnsafeMkHumanFriendlyErrorText "kaboom") hdl
 
     getStatus hdl