Merge branch 'adinapoli/issue-481' into 'dev'

Have `extractNgramsFromDocument` catch the right exception in case extraction fails

Closes #481

See merge request !419

src/Gargantext/Core/Text/Terms.hs

@@ -116,11 +116,11 @@ data ExtractedNgrams = SimpleNgrams   { unSimpleNgrams   :: Ngrams       }
 instance Hashable ExtractedNgrams
 
 -- | A typeclass that represents extracting ngrams from an entity.
-class ExtractNgrams h where
+class Monad m => ExtractNgrams m h where
   extractNgrams :: NLPServerConfig
                 -> TermType Lang
                 -> h
-                -> DBCmd err (HashMap ExtractedNgrams (Map NgramsType TermsWeight, TermsCount))
+                -> m (HashMap ExtractedNgrams (Map NgramsType TermsWeight, TermsCount))
 
 ------------------------------------------------------------------------
 enrichedTerms :: Lang -> PosTagAlgo -> POS -> Terms -> NgramsPostag

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

@@ -11,9 +11,19 @@ Multi-terms are ngrams where n > 1.
 
 -}
 
-module Gargantext.Core.Text.Terms.Multi (multiterms, Terms(..), tokenTag2terms, multiterms_rake, tokenTagsWith, tokenTags, cleanTextForNLP)
+module Gargantext.Core.Text.Terms.Multi (
+    multiterms
+  , Terms(..)
+  , MultitermsExtractionException(..)
+  , tokenTag2terms
+  , multiterms_rake
+  , tokenTagsWith
+  , tokenTags
+  , cleanTextForNLP
+  )
   where
 
+import Control.Exception.Safe qualified as Safe
 import Data.Attoparsec.Text as DAT (space, notChar, string )
 import Gargantext.Core (Lang(..), NLPServerConfig(..), PosTagAlgo(..))
 import Gargantext.Core.Text.Terms.Multi.Lang.En qualified as En
@@ -25,14 +35,23 @@ import Gargantext.Core.Types ( POS(NP), Terms(Terms), TermsWithCount, TokenTag(T
 import Gargantext.Core.Utils (groupWithCounts)
 import Gargantext.Prelude
 import Gargantext.Utils.SpacyNLP qualified as SpacyNLP
+import Network.HTTP.Client
 import Replace.Attoparsec.Text as RAT ( streamEdit )
 
 -------------------------------------------------------------------
 type NLP_API = Lang -> Text -> IO PosSentences
 
+data MultitermsExtractionException
+  = MEE_nlp_server_http_exception !NLPServerConfig !HttpException
+  deriving Show
+
+instance Exception MultitermsExtractionException
+
 -------------------------------------------------------------------
+-- | Extracts the terms from the input 'txt'. Throws a
+-- 'MultitermExtractionException' in case we fail.
 multiterms :: NLPServerConfig -> Lang -> Text -> IO [TermsWithCount]
-multiterms nsc l txt = do
+multiterms nsc l txt = handle (\ex -> Safe.throwIO $ MEE_nlp_server_http_exception nsc ex) $ do
   let txt' = cleanTextForNLP txt
   if txt' == ""
      then do

src/Gargantext/Database/Action/Flow.hs

@@ -56,7 +56,7 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
 
 import Conduit
 import Control.Lens ( to, view )
-import Control.Monad.Catch
+import Control.Exception.Safe (catch, MonadCatch)
 import Data.Conduit qualified as C
 import Data.Conduit.Internal (zipSources)
 import Data.Conduit.List qualified as CL
@@ -116,6 +116,7 @@ import Gargantext.Utils.Jobs.Monad ( JobHandle, MonadJobStatus(..) )
 ------------------------------------------------------------------------
 -- Imports for upgrade function
 import Gargantext.Database.Query.Tree.Error ( HasTreeError )
+import Gargantext.Core.Text.Terms.Multi (MultitermsExtractionException)
 
 ------------------------------------------------------------------------
 
@@ -256,9 +257,11 @@ flowCorpus :: ( IsDBCmd env err m
               , HasTreeError err
               , HasValidationError err
               , FlowCorpus a
+              , ExtractNgrams m a
               , MonadJobStatus m
               , MonadCatch m
-              , HasCentralExchangeNotification env, Show a )
+              , HasCentralExchangeNotification env
+              )
            => MkCorpusUser
            -> TermType Lang
            -> Maybe FlowSocialListWith
@@ -276,10 +279,11 @@ flow :: forall env err m a c.
         , HasTreeError err
         , HasValidationError err
         , FlowCorpus a
+        , ExtractNgrams m a
         , MkCorpus c
         , MonadJobStatus m
         , HasCentralExchangeNotification env
-        , MonadCatch m, Show a
+        , MonadCatch m
         )
         => Maybe c
         -> MkCorpusUser
@@ -317,9 +321,10 @@ addDocumentsToHyperCorpus :: ( IsDBCmd env err m
                              , HasNodeError err
                              , HasNLPServer env
                              , FlowCorpus document
+                             , ExtractNgrams m document
                              , MkCorpus corpus
                              , MonadLogger m
-                             , MonadCatch m, Show document
+                             , MonadCatch m
                              )
                              => Maybe corpus
                              -> TermType Lang
@@ -471,7 +476,7 @@ data InsertDocError
 
 extractNgramsFromDocument :: ( UniqParameters doc
                              , HasText doc
-                             , ExtractNgrams doc
+                             , ExtractNgrams m doc
                              , IsDBCmd err env m
                              , MonadLogger m
                              , MonadCatch m
@@ -487,7 +492,7 @@ extractNgramsFromDocument nlpServer lang doc =
   -- will still be added to the corpus and we can try to regen the ngrams at a later stage.
   UncommittedNgrams . Map.singleton docId <$>
     (documentIdWithNgrams (extractNgrams nlpServer $ withLang lang [doc]) (Indexed docId doc)
-     `catch` \(e :: SomeException) -> do
+     `catch` \(e :: MultitermsExtractionException) -> do
        $(logLocM) ERROR $ T.pack $ "Document with hash " <> show docId <> " failed ngrams extraction due to an exception: " <> displayException e
        pure $ DocumentIdWithNgrams (Indexed docId doc) mempty
     )
@@ -517,7 +522,7 @@ commitNgramsForDocument (UncommittedNgrams ng) (Indexed oldIx node) = do
 extractNgramsFromDocuments :: forall doc env err m.
                            ( HasText doc
                            , UniqParameters doc
-                           , ExtractNgrams doc
+                           , ExtractNgrams m doc
                            , IsDBCmd env err m
                            , MonadLogger m
                            , MonadCatch m
@@ -545,7 +550,7 @@ commitNgramsForDocuments ng nodes =
 insertMasterDocs :: ( HasNodeError err
                     , UniqParameters doc
                     , FlowCorpus doc
-                    , MkCorpus   c, Show doc
+                    , MkCorpus c
                     )
                  => GargConfig
                  -> UncommittedNgrams doc

src/Gargantext/Database/Action/Flow/Extract.hs

@@ -13,6 +13,7 @@ Portability : POSIX
 
 {-# LANGUAGE InstanceSigs            #-}
 {-# LANGUAGE ScopedTypeVariables     #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 
 module Gargantext.Database.Action.Flow.Extract
@@ -30,7 +31,6 @@ import Gargantext.Core.Types (POS(NP), TermsCount, TermsWeight)
 import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact, cw_lastName, hc_who )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument, hd_authors, hd_bdd, hd_institutes, hd_source )
 import Gargantext.Database.Admin.Types.Node ( Node )
-import Gargantext.Database.Prelude (DBCmd)
 import Gargantext.Database.Query.Table.NgramsPostag (NgramsPostag)
 import Gargantext.Database.Schema.Ngrams ( text2ngrams )
 import Gargantext.Database.Schema.Node (NodePoly(..))
@@ -39,7 +39,7 @@ import Gargantext.Prelude
 
 
 ------------------------------------------------------------------------
-instance ExtractNgrams HyperdataContact where
+instance Monad m => ExtractNgrams m HyperdataContact where
   extractNgrams _ncs _l = pure . HashMap.mapKeys (cleanExtractedNgrams 255) . extract
     where
       extract :: HyperdataContact
@@ -55,15 +55,15 @@ instance ExtractNgrams HyperdataContact where
 -- | Main ngrams extraction functionality.
 --   For NgramsTerms, this calls NLP server under the hood.
 --   For Sources, Institutes, Authors, this uses simple split on " ".
-instance ExtractNgrams HyperdataDocument where
+instance (Monad m, MonadBase IO m) => ExtractNgrams m HyperdataDocument where
   extractNgrams :: NLPServerConfig
                 -> TermType Lang
                 -> HyperdataDocument
-                -> DBCmd err (HashMap.HashMap ExtractedNgrams (Map NgramsType TermsWeight, TermsCount))
+                -> m (HashMap.HashMap ExtractedNgrams (Map NgramsType TermsWeight, TermsCount))
   extractNgrams ncs lang hd = HashMap.mapKeys (cleanExtractedNgrams 255) <$> extractNgramsT' hd
     where
       extractNgramsT' :: HyperdataDocument
-                      -> DBCmd err (HashMap.HashMap ExtractedNgrams (Map NgramsType TermsWeight, TermsCount))
+                      -> m (HashMap.HashMap ExtractedNgrams (Map NgramsType TermsWeight, TermsCount))
       extractNgramsT' doc = do
         let source    = text2ngrams
                       $ maybe "Nothing" identity
@@ -87,7 +87,7 @@ instance ExtractNgrams HyperdataDocument where
              <> [(SimpleNgrams     a', (DM.singleton Authors     1, 1)) | a' <- authors    ]
              <> [(EnrichedNgrams   t', (DM.singleton NgramsTerms 1, cnt')) | (t', cnt') <- termsWithCounts' ]
 
-instance (ExtractNgrams a, HasText a) => ExtractNgrams (Node a)
+instance (ExtractNgrams m a, HasText a) => ExtractNgrams m (Node a)
   where
     extractNgrams ncs l (Node { _node_hyperdata = h }) = extractNgrams ncs l h
 

src/Gargantext/Database/Action/Flow/Types.hs

@@ -25,7 +25,6 @@ import Gargantext.Core.NodeStory.Types ( HasNodeStory )
 import Gargantext.Core.Text ( HasText )
 import Gargantext.API.Admin.Orchestrator.Types qualified as API
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
-import Gargantext.Core.Text.Terms ( ExtractNgrams )
 import Gargantext.Core.Types (HasValidationError, TermsCount, TermsWeight)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument )
@@ -51,11 +50,10 @@ type FlowCmdM env err m =
   )
 
 type FlowCorpus a = ( UniqParameters a
-                    , InsertDb       a
-                    , ExtractNgrams  a
-                    , HasText        a
-                    , ToNode         a
-                    , ToJSON         a
+                    , InsertDb         a
+                    , HasText          a
+                    , ToNode           a
+                    , ToJSON           a
                     )
 
 type FlowInsertDB a = ( AddUniqId a