[ngrams] fix for json/csv upload for older terms

Also, some test refactoring and add servant-client to tests.

.envrc

 use_nix
+#use_flake
 export LANG=C.UTF-8

cabal.project

@@ -121,7 +121,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git
-    tag: cd179f6dda15d77a085c0176284c921b7bc50c46
+    tag: ceb8f2cebd4890b6d9d151ab01ee14e925bc0499
 
 source-repository-package
     type: git

gargantext.cabal

@@ -840,7 +840,9 @@ test-suite garg-test-tasty
   type: exitcode-stdio-1.0
   main-is: drivers/tasty/Main.hs
   other-modules:
+      Test.API.Routes
       Test.API.Setup
+      Test.Core.Similarity
       Test.Core.Text
       Test.Core.Text.Corpus.Query
       Test.Core.Text.Examples
@@ -868,6 +870,7 @@ test-suite garg-test-tasty
       Test.Parsers.Date
       Test.Parsers.Types
       Test.Parsers.WOS
+      Test.Types
       Test.Utils
       Test.Utils.Crypto
       Test.Utils.Jobs
@@ -920,6 +923,7 @@ test-suite garg-test-tasty
     , servant-auth
     , servant-auth-client
     , servant-client
+    , servant-client-core
     , servant-job
     , servant-server
     , shelly >= 1.9 && < 2
@@ -952,6 +956,7 @@ test-suite garg-test-hspec
       Test.API.Errors
       Test.API.GraphQL
       Test.API.Private
+      Test.API.Routes
       Test.API.Setup
       Test.API.UpdateList
       Test.Database.Operations
@@ -960,6 +965,7 @@ test-suite garg-test-hspec
       Test.Database.Setup
       Test.Database.Types
       Test.Utils
+      Test.Types
       Paths_gargantext
   hs-source-dirs:
       test
@@ -1007,6 +1013,7 @@ test-suite garg-test-hspec
     , servant-auth
     , servant-auth-client
     , servant-client
+    , servant-client-core
     , servant-job
     , servant-server
     , shelly >= 1.9 && < 2

src/Gargantext/API/Dev.hs

@@ -12,20 +12,23 @@ Portability : POSIX
 -- Use only for dev/repl
 module Gargantext.API.Dev where
 
+import Control.Lens (view)
 import Control.Monad (fail)
-import Gargantext.API.Admin.EnvTypes
-import Gargantext.API.Admin.Settings
-import Gargantext.API.Errors.Types
-import Gargantext.API.Prelude
+import Data.Pool (withResource)
+import Database.PostgreSQL.Simple qualified as PGS
+import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) )
+import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool )
+import Gargantext.API.Errors.Types ( BackendInternalError )
+import Gargantext.API.Prelude ( GargM )
 import Gargantext.Core.NLP (nlpServerMap)
-import Gargantext.Core.NodeStory
-import Gargantext.Database.Prelude (Cmd', Cmd'', databaseParameters, runCmd)
+import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
+import Gargantext.Database.Prelude (Cmd', Cmd'', connPool, databaseParameters, runCmd)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (readConfig)
 import Gargantext.Prelude.Mail qualified as Mail
 import Gargantext.Prelude.NLP qualified as NLP
-import Gargantext.System.Logging
-import Servant
+import Gargantext.System.Logging ( withLoggerHoisted )
+import Servant ( ServerError )
 
 type IniPath  = FilePath
 -------------------------------------------------------------------
@@ -67,7 +70,7 @@ runCmdReplServantErr = runCmdRepl
 -- using HasConnectionPool and HasRepoVar.
 runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
 runCmdDev env f =
-  (either (fail . show) pure =<< runCmd env f)
+  either (fail . show) pure =<< runCmd env f
 
 runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a
 runCmdGargDev env cmd =
@@ -81,3 +84,9 @@ runCmdDevServantErr = runCmdDev
 
 runCmdReplEasy :: Cmd'' DevEnv BackendInternalError a -> IO a
 runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
+
+-- | Execute a function that takes PSQL.Connection from the DB pool as
+--   first parameter.
+--   e.g.: runCmdReplEasyDB $ \c -> getNodeStory' c
+runCmdReplEasyDB :: (PGS.Connection -> IO a) -> IO a
+runCmdReplEasyDB f = runCmdReplEasy $ view connPool >>= (\p -> liftBase $ withResource p f)

src/Gargantext/API/Ngrams.hs

@@ -25,13 +25,14 @@ add get
 
 {-# LANGUAGE IncoherentInstances #-}
 
+
 module Gargantext.API.Ngrams
   ( TableNgramsApi
   , TableNgramsApiGet
   , TableNgramsApiPut
 
   , commitStatePatch
-  
+
   , searchTableNgrams
   , getTableNgrams
   , getTableNgramsCorpus
@@ -86,38 +87,35 @@ module Gargantext.API.Ngrams
   )
   where
 
-import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), msumOf, at, _Just, Each(..), (%%~), mapped, ifolded, to, withIndex, over)
-import Control.Monad.Reader
+import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), msumOf, at, ix, _Just, Each(..), (%%~), ifolded, to, withIndex, over)
 import Data.Aeson.Text qualified as DAT
-import Data.Foldable
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
-import Data.Monoid
 import Data.Patch.Class (Action(act), Transformable(..), ours)
 import Data.Set qualified as Set
 import Data.Text (isInfixOf, toLower, unpack)
-import Data.Text.Lazy.IO as DTL
+import Data.Text.Lazy.IO as DTL ( writeFile )
 import Formatting (hprint, int, (%))
 import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
-import Gargantext.API.Errors.Types
+import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Metrics qualified as Metrics
 import Gargantext.API.Ngrams.Tools (getNodeStory)
 import Gargantext.API.Ngrams.Types
-import Gargantext.API.Prelude
+import Gargantext.API.Prelude ( GargM )
 import Gargantext.Core.NodeStory (ArchiveList, HasNodeStory, HasNodeArchiveStoryImmediateSaver(..), HasNodeStoryImmediateSaver(..), NgramsStatePatch', a_history, a_state, a_version, currentVersion)
 import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, TODO, assertValid, HasValidationError, ContextId)
 import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
 import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast)
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Types.Node (NodeType(..))
-import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngramsType, ngrams_terms)
-import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
+import Gargantext.Database.Query.Table.Ngrams ( text2ngrams, Ngrams, insertNgrams, selectNgramsByDoc )
+import Gargantext.Database.Schema.Ngrams qualified as TableNgrams
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
-import Gargantext.Database.Query.Table.Node.Select
+import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername )
 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)
@@ -321,7 +319,7 @@ commitStatePatch listId (Versioned _p_version p) = do
   --      )
 
   let newA = Versioned (a' ^. a_version) q'
-  
+
   -- NOTE Now is the only good time to save the archive history. We
   -- have the handle to the MVar and we need to save its exact
   -- snapshot. Node Story archive is a linear table, so it's only
@@ -370,7 +368,7 @@ tableNgramsPull listId ngramsType p_version = do
   let
     -- a = r ^. unNodeStory . at listId . non initArchive
     q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
-    q_table = q ^. _PatchMap . at ngramsType . _Just
+    q_table = q ^. _PatchMap . ix ngramsType
 
   pure (Versioned (a ^. a_version) q_table)
 
@@ -404,7 +402,7 @@ tableNgramsPut tabType listId (Versioned p_version p_table)
       assertValid p_validity
 
       ret <- commitStatePatch listId (Versioned p_version p)
-        <&> v_data %~ (view (_PatchMap . at ngramsType . _Just))
+        <&> v_data %~ view (_PatchMap . ix ngramsType)
 
       pure ret
 
@@ -474,7 +472,7 @@ tableNgramsPostChartsAsync utn jobHandle = do
               _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
 -}
               markComplete jobHandle
-            _ -> do
+            _otherTabType -> do
               -- printDebug "[tableNgramsPostChartsAsync] no update for tabType = " tabType
               markStarted 1 jobHandle
               markFailed Nothing jobHandle
@@ -494,7 +492,7 @@ getNgramsTableMap :: HasNodeStory env err m
 getNgramsTableMap nodeId ngramsType = do
   a <- getNodeStory nodeId
   pure $ Versioned (a ^. a_version)
-                   (a ^. a_state . at ngramsType . _Just)
+                   (a ^. a_state . ix ngramsType)
 
 
 dumpJsonTableMap :: HasNodeStory env err m
@@ -551,8 +549,8 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} =
     matchingNode inputNode =
       let nodeSize        = inputNode ^. ne_size
           matchesListType = maybe (const True) (==) _nsq_listType
-          respectsMinSize = maybe (const True) (<=) (getMinSize <$> _nsq_minSize)
-          respectsMaxSize = maybe (const True) (>=) (getMaxSize <$> _nsq_maxSize)
+          respectsMinSize = maybe (const True) ((<=) . getMinSize) _nsq_minSize
+          respectsMaxSize = maybe (const True) ((>=) . getMaxSize) _nsq_maxSize
 
       in    respectsMinSize nodeSize
          && respectsMaxSize nodeSize
@@ -623,7 +621,7 @@ getNgramsTable' :: forall env err m.
                 -> m (Versioned (Map.Map NgramsTerm NgramsElement))
 getNgramsTable' nId listId ngramsType = do
   tableMap <- getNgramsTableMap listId ngramsType
-  tableMap & v_data %%~ (setNgramsTableScores nId listId ngramsType)
+  tableMap & v_data %%~ setNgramsTableScores nId listId ngramsType
                         . Map.mapWithKey ngramsElementFromRepo
 
 -- | Helper function to set scores on an `NgramsTable`.
@@ -648,7 +646,7 @@ setNgramsTableScores nId listId ngramsType table = do
       ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
       (length ngrams_terms) t1 t2
   let
-    setOcc ne = ne & ne_occurrences .~ Set.fromList (msumOf (at (ne ^. ne_ngrams) . _Just) occurrences)
+    setOcc ne = ne & ne_occurrences .~ Set.fromList (msumOf (ix (ne ^. ne_ngrams)) occurrences)
 
   --printDebug "[setNgramsTableScores] with occurences" $ table & each %~ setOcc
 
@@ -734,7 +732,7 @@ getTableNgramsCorpus :: ( HasNodeStory env err m
 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
   getTableNgrams nId listId tabType searchQuery
     where
-      searchQueryFn (NgramsTerm nt) = maybe (const True) isInfixOf (toLower <$> mt) (toLower nt)
+      searchQueryFn (NgramsTerm nt) = maybe (const True) (isInfixOf . toLower) mt (toLower nt)
       searchQuery = NgramsSearchQuery {
                     _nsq_limit       = limit_
                   , _nsq_offset      = offset
@@ -778,7 +776,7 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
   ns <- selectNodesWithUsername NodeList userMaster
   let ngramsType = ngramsTypeFromTabType tabType
   ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
-  let searchQueryFn (NgramsTerm nt) = flip Set.member (Set.fromList ngs) nt
+  let searchQueryFn (NgramsTerm nt) = Set.member nt (Set.fromList ngs)
       searchQuery = NgramsSearchQuery {
                     _nsq_limit       = limit_
                   , _nsq_offset      = offset
@@ -828,4 +826,4 @@ listNgramsChangedSince listId ngramsType version
   | version < 0 =
       Versioned <$> currentVersion listId <*> pure True
   | otherwise   =
-      tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
+      tableNgramsPull listId ngramsType version <&> v_data %~ (== mempty)

src/Gargantext/API/Ngrams/List.hs

@@ -152,7 +152,7 @@ postAsyncJSON l ngramsList jobHandle = do
     setList :: HasNodeStory env err m => m ()
     setList = do
       -- TODO check with Version for optim
-      mapM_ (\(nt, Versioned _v ns) -> (setListNgrams l nt ns)) $ toList ngramsList
+      mapM_ (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList ngramsList
       -- TODO reindex
 
 

src/Gargantext/API/Ngrams/Tools.hs

@@ -11,22 +11,23 @@ Portability : POSIX
 
 {-# LANGUAGE TypeFamilies  #-}
 {-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use infix" #-}
 
 module Gargantext.API.Ngrams.Tools
   where
 
 -- import Gargantext.Core.NodeStoryFile qualified as NSF
-import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
-import Control.Monad.Reader
+import Control.Lens (_Just, (^.), at, ix, view, At, Index, IxValue)
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
-import Data.Validity
 -- import GHC.Conc (TVar, readTVar)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory
-import Gargantext.Core.Types (ListType(..), NodeId, ListId)
+import Gargantext.Core.Types.Main ( ListType(..) )
+import Gargantext.Database.Admin.Types.Node ( NodeId, ListId )
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
 
@@ -93,7 +94,7 @@ listNgramsFromRepo nodeIds ngramsType repo =
                ^. unNodeStory
                 . at nodeId . _Just
                 . a_state
-                . at ngramsType . _Just
+                . ix ngramsType
                 | nodeId <- nodeIds
                 ]
 
@@ -153,7 +154,7 @@ filterListWithRoot :: [ListType]
 filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
   where
     isMapTerm (l, maybeRoot) = case maybeRoot of
-      Nothing -> elem l lt
+      Nothing -> l `elem` lt
       Just  r -> case HM.lookup r m of
         Nothing -> panicTrace $ "[Garg.API.Ngrams.Tools] filterListWithRoot, unknown key: " <> unNgramsTerm r
         Just  (l',_) -> elem l' lt
@@ -175,7 +176,7 @@ groupNodesByNgrams syn occs = HM.fromListWith (<>) occs'
         Nothing  -> (t, ns)
         Just  r' -> (r',ns)
 
-data Diagonal = Diagonal Bool
+newtype Diagonal = Diagonal Bool
 
 getCoocByNgrams :: Diagonal
                 -> HashMap NgramsTerm (Set NodeId)

src/Gargantext/API/Ngrams/Types.hs

@@ -25,9 +25,10 @@ import Data.Aeson.TH (deriveJSON)
 import Data.Csv (defaultEncodeOptions, encodeByNameWith, header, namedRecord, EncodeOptions(..), NamedRecord, Quoting(QuoteNone))
 import Data.Csv qualified as Csv
 import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
+import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
-import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, MaybePatch(Mod), unMod, old, new)
+import Data.Patch.Class (Replace(Keep), replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, MaybePatch(Mod), unMod, old, new)
 import Data.Set qualified as Set
 import Data.String (IsString(..))
 import Data.Swagger ( NamedSchema(NamedSchema), declareSchemaRef, genericDeclareNamedSchema, SwaggerType(SwaggerObject), ToParamSchema, ToSchema(..), HasProperties(properties), HasRequired(required), HasType(type_) )
@@ -848,3 +849,13 @@ instance Arbitrary NgramsRepoElement where
   arbitrary = elements $ map ngramsElementToRepo ns
     where
       NgramsTable ns = mockTable
+
+
+toNgramsPatch :: [NgramsTerm] -> NgramsPatch
+toNgramsPatch children = NgramsPatch children' Keep
+  where
+    children' :: PatchMSet NgramsTerm
+    children' = PatchMSet
+              $ fst
+              $ PM.fromList
+              $ List.zip children (List.cycle [addPatch])

src/Gargantext/API/Node.hs

@@ -134,7 +134,7 @@ type NodeAPI a = PolicyChecked (NodeNodeAPI a)
 
              :<|> "category"   :> CatApi
              :<|> "score"      :> ScoreApi
-             :<|> "search"     :> (Search.API Search.SearchResult)
+             :<|> "search"     :> Search.API Search.SearchResult
              :<|> "share"      :> Share.API
 
              -- Pairing utilities

src/Gargantext/API/Node/Contact.hs

@@ -12,9 +12,7 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-# LANGUAGE ConstraintKinds      #-}
-{-# LANGUAGE KindSignatures       #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
-{-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
 
@@ -22,35 +20,34 @@ Portability : POSIX
 module Gargantext.API.Node.Contact
       where
 
-import Conduit
+import Conduit ( yield )
 import Data.Aeson
 import Data.Either (Either(Right))
 import Data.Maybe (Maybe(..))
-import Data.Swagger
+import Data.Swagger ( ToSchema )
 import Data.Text (Text)
 import GHC.Generics (Generic)
-import Servant
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary
-
-import Gargantext.API.Admin.Auth.Types
+import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(AuthenticatedUser) )
 import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
-import Gargantext.API.Errors.Types
-import Gargantext.API.Node
+import Gargantext.API.Errors.Types ( BackendInternalError )
+import Gargantext.API.Node ( nodeNodeAPI, NodeNodeAPI )
 import Gargantext.API.Prelude (GargM, simuLogs)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Text.Terms (TermType(..))
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Action.Flow (flow)
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
-import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAnnuaire(..), HyperdataContact)
-import Gargantext.Database.Admin.Types.Hyperdata.Contact (hyperdataContact)
-import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact, hyperdataContact )
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataAnnuaire(..) )
+import Gargantext.Database.Admin.Types.Node ( CorpusId, NodeId )
 import Gargantext.Prelude (($), {-printDebug,-})
+import Gargantext.Utils.Aeson qualified as GUA
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
-import qualified Gargantext.Utils.Aeson as GUA
+import Servant
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary ( Arbitrary(arbitrary) )
 
 ------------------------------------------------------------------------
 type API = "contact" :> Summary "Contact endpoint"

src/Gargantext/API/Node/FrameCalcUpload.hs

@@ -16,36 +16,36 @@ Portability : POSIX
 module Gargantext.API.Node.FrameCalcUpload where
 
 import Control.Lens ((^.))
-import Data.Aeson
+import Data.Aeson ( FromJSON, ToJSON )
 import Data.ByteString.Lazy qualified as BSL
 import Data.ByteString.UTF8 qualified as BSU8
-import Data.Swagger
+import Data.Swagger ( ToSchema )
 import Data.Text qualified as T
-import Network.HTTP.Client (newManager, httpLbs, parseRequest, responseBody)
-import Network.HTTP.Client.TLS (tlsManagerSettings)
-import Servant
-import Web.FormUrlEncoded (FromForm)
-
-import Gargantext.API.Admin.Auth.Types
+import Gargantext.API.Admin.Auth.Types ( auth_node_id, AuthenticatedUser )
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
-import Gargantext.API.Errors.Types
+import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Node.Corpus.New (addToCorpusWithForm)
 import Gargantext.API.Node.Corpus.New.Types (FileFormat(..), FileType(..))
 import Gargantext.API.Node.Types (NewWithForm(..))
-import Gargantext.API.Prelude
+import Gargantext.API.Prelude ( GargM )
 import Gargantext.Core (Lang)
-import Gargantext.Core.NodeStory (HasNodeArchiveStoryImmediateSaver)
+import Gargantext.Core.NodeStory.Types ( HasNodeArchiveStoryImmediateSaver )
 import Gargantext.Core.Text.List.Social (FlowSocialListWith(..))
 import Gargantext.Core.Types.Individu (User(..))
-import Gargantext.Database.Action.Flow.Types
-import Gargantext.Database.Admin.Types.Hyperdata.Frame
-import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Action.Flow.Types ( FlowCmdM )
+import Gargantext.Database.Admin.Types.Hyperdata.Frame ( HyperdataFrame(..) )
+import Gargantext.Database.Admin.Types.Node ( NodeId, NodeType(NodeCorpus) )
 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 Network.HTTP.Client (newManager, httpLbs, parseRequest, responseBody)
+import Network.HTTP.Client.TLS (tlsManagerSettings)
+import Servant ( type (:>), JSON, Summary, HasServer(ServerT) )
+import Web.FormUrlEncoded (FromForm)
+
 
 data FrameCalcUpload = FrameCalcUpload {
   _wf_lang      :: !(Maybe Lang)

src/Gargantext/Core/NodeStory.hs

@@ -43,7 +43,6 @@ TODO:
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell   #-}
 
 module Gargantext.Core.NodeStory
   ( module Gargantext.Core.NodeStory.Types
@@ -54,17 +53,18 @@ module Gargantext.Core.NodeStory
   , fromDBNodeStoryEnv
   , upsertNodeStories
   -- , getNodeStory
+  , getNodeStory'
   , nodeStoriesQuery
   , currentVersion
   , archiveStateFromList
   , archiveStateToList
-  , fixNodeStoryVersions )
+  , fixNodeStoryVersions
+  , fixChildrenDuplicatedAsParents
+  , getParentsChildren )
 where
 
-import Control.Lens ((^.), (.~), (%~), non, _Just, at, view)
-import Control.Monad.Except
+import Control.Lens ((^.), (.~), (%~), non, _Just, at, over, view)
 import Data.Map.Strict qualified as Map
-import Data.Monoid
 import Data.Pool (Pool, withResource)
 import Data.Set qualified as Set
 import Database.PostgreSQL.Simple qualified as PGS
@@ -73,12 +73,12 @@ import Database.PostgreSQL.Simple.ToField qualified as PGS
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory.DB
 import Gargantext.Core.NodeStory.Types
-import Gargantext.Core.Types (ListId, NodeId(..))
+import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
 import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Prelude (HasConnectionPool(..))
 import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
 import Gargantext.Prelude hiding (to)
-import Gargantext.Prelude.Database
+import Gargantext.Prelude.Database ( runPGSAdvisoryXactLock, runPGSExecute, runPGSQuery )
 
 
 getNodeStory' :: PGS.Connection -> NodeId -> IO ArchiveList
@@ -105,7 +105,7 @@ getNodeStory' c nId = do
     pure ()
 -}
 
-  pure $ foldl combine initArchive dbData
+  pure $ foldl' combine initArchive dbData
   where
     -- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine`
     combine a1 a2 = a1 & a_state %~ combineState (a2 ^. a_state)
@@ -221,15 +221,12 @@ nodeStoryInc c ns@(NodeStory nls) nId = do
 -- `nre_parent` and `nre_children`. We want to make sure that all
 -- children entries (i.e. ones that have `nre_parent`) have the same
 -- `list` as their parent entry.
-fixChildrenInNgramsStatePatch :: NgramsState' -> NgramsState'
-fixChildrenInNgramsStatePatch ns = archiveStateFromList $ nsParents <> nsChildrenFixed
+fixChildrenInNgrams :: NgramsState' -> NgramsState'
+fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
   where
-    nls = archiveStateToList ns
-    
-    nsParents = filter (\(_nt, _t, nre) -> isNothing $ nre ^. nre_parent) nls
+    (nsParents, nsChildren) = getParentsChildren ns
     parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_list)) <$> nsParents
-    
-    nsChildren = filter (\(_nt, _t, nre) -> isJust $ nre ^. nre_parent) nls
+
     nsChildrenFixed = (\(nt, t, nre) ->
                          ( nt
                          , t
@@ -241,15 +238,12 @@ fixChildrenInNgramsStatePatch ns = archiveStateFromList $ nsParents <> nsChildre
 -- | Sometimes, when we upload a new list, a child can be left without
 -- a parent. Find such ngrams and set their 'root' and 'parent' to
 -- 'Nothing'.
-fixChildrenWithNoParentStatePatch :: NgramsState' -> NgramsState'
-fixChildrenWithNoParentStatePatch ns = archiveStateFromList $ nsParents <> nsChildrenFixed
+fixChildrenWithNoParent :: NgramsState' -> NgramsState'
+fixChildrenWithNoParent ns = archiveStateFromList $ nsParents <> nsChildrenFixed
   where
-    nls = archiveStateToList ns
-    
-    nsParents = filter (\(_nt, _t, nre) -> isNothing $ nre ^. nre_parent) nls
+    (nsParents, nsChildren) = getParentsChildren ns
     parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents
-    
-    nsChildren = filter (\(_nt, _t, nre) -> isJust $ nre ^. nre_parent) nls
+
     nsChildrenFixFunc (nt, t, nre) =
       ( nt
       , t
@@ -263,6 +257,30 @@ fixChildrenWithNoParentStatePatch ns = archiveStateFromList $ nsParents <> nsChi
 
     nsChildrenFixed = nsChildrenFixFunc <$> nsChildren
 
+-- | Sometimes children can also become parents (e.g. #313). Find such
+-- | children and remove them from the list.
+fixChildrenDuplicatedAsParents :: NgramsState' -> NgramsState'
+fixChildrenDuplicatedAsParents ns = archiveStateFromList $ nsChildren <> nsParentsFixed
+  where
+    (nsParents, nsChildren) = getParentsChildren ns
+    parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents
+    parentsSet = Set.fromList $ Map.keys parentNtMap
+
+    nsParentsFixed = (\(nt, t, nre) ->
+                       ( nt
+                       , t
+                       , over nre_children
+                             (\c -> mSetFromSet $ Set.difference (mSetToSet c) parentsSet)
+                             nre ) ) <$> nsParents
+
+getParentsChildren :: NgramsState' -> (ArchiveStateList, ArchiveStateList)
+getParentsChildren ns = (nsParents, nsChildren)
+  where
+    nls = archiveStateToList ns
+
+    nsParents = filter (\(_nt, _t, nre) -> isNothing $ nre ^. nre_parent) nls
+    nsChildren = filter (\(_nt, _t, nre) -> isJust $ nre ^. nre_parent) nls
+
 ------------------------------------
 
 fromDBNodeStoryEnv :: Pool PGS.Connection -> IO NodeStoryEnv
@@ -280,8 +298,15 @@ fromDBNodeStoryEnv pool = do
         withResource pool $ \c -> do
           --printDebug "[mkNodeStorySaver] will call writeNodeStories, ns" ns
           -- writeNodeStories c $ fixChildrenWithNoParent $ fixChildrenTermTypes ns
+
+          -- |NOTE Fixing a_state is kinda a hack. We shouldn't land
+          -- |with bad state in the first place.
           upsertNodeStories c nId $
-            a & a_state %~ (fixChildrenInNgramsStatePatch . fixChildrenWithNoParentStatePatch)
+            a & a_state %~ (
+                       fixChildrenDuplicatedAsParents
+                    .  fixChildrenInNgrams
+                    . fixChildrenWithNoParent
+                    )
   let archive_saver_immediate nId a = withResource pool $ \c -> do
         insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
         pure $ a & a_history .~ []
@@ -289,13 +314,13 @@ fromDBNodeStoryEnv pool = do
         --           insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
         --       ) $ Map.toList nls
         -- pure $ clearHistory ns
-        
+
   pure $ NodeStoryEnv { _nse_saver_immediate = saver_immediate
                       , _nse_archive_saver_immediate = archive_saver_immediate
                       , _nse_getter = \nId -> withResource pool $ \c ->
                           getNodeStory' c nId
                       , _nse_getter_multi = \nIds -> withResource pool $ \c ->
-                          foldM (\m nId -> nodeStoryInc c m nId) (NodeStory Map.empty) nIds
+                          foldM (nodeStoryInc c) (NodeStory Map.empty) nIds
                       }
 
 currentVersion :: (HasNodeStory env err m) => ListId -> m Version

src/Gargantext/Core/NodeStory/Types.hs

@@ -47,23 +47,19 @@ module Gargantext.Core.NodeStory.Types
   , ArchiveStateList )
 where
 
-import Codec.Serialise.Class
+import Codec.Serialise.Class ( Serialise )
 import Control.Lens (makeLenses, Getter, (^.))
-import Control.Monad.Except
-import Control.Monad.Reader
 import Data.Aeson hiding ((.=), decode)
 import Data.Map.Strict qualified as Map
-import Data.Monoid
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
-import Data.Semigroup
 import Data.Set qualified as Set
 import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
 import Gargantext.API.Ngrams.Types
-import Gargantext.Core.Types (NodeId(..))
+import Gargantext.Database.Admin.Types.Node ( NodeId(..) )
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Prelude (DbCmd')
-import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
+import Gargantext.Database.Schema.Ngrams qualified as TableNgrams
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
 import Gargantext.Prelude hiding (to)
 import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)

src/Gargantext/Core/Text/List/Group/WithStem.hs

@@ -24,8 +24,6 @@ import Data.HashSet (HashSet)
 import Data.HashSet qualified as Set
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
-import Data.Map.Strict.Patch qualified as PatchMap
-import Data.Patch.Class qualified as Patch (Replace(..))
 import Data.Text qualified as Text
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core (Lang(..), Form, Lem, NLPServerConfig)
@@ -120,14 +118,5 @@ patch s = case Set.size s > 1 of
     let children = List.tail ngrams
     pure (parent, toNgramsPatch children)
 
-toNgramsPatch :: [NgramsTerm] -> NgramsPatch
-toNgramsPatch children = NgramsPatch children' Patch.Keep
-  where
-    children' :: PatchMSet NgramsTerm
-    children' = PatchMSet
-              $ fst
-              $ PatchMap.fromList
-              $ List.zip children (List.cycle [addPatch])
-
 -- | Instances
 makeLenses ''GroupParams

src/Gargantext/Utils/Jobs.hs

@@ -20,19 +20,19 @@ module Gargantext.Utils.Jobs (
   , MonadJobStatus(..)
   ) where
 
-import Control.Monad.Except
-import Control.Monad.Reader
+import Control.Monad.Except ( runExceptT )
+import Control.Monad.Reader ( MonadReader(ask), ReaderT(runReaderT) )
 import Data.Aeson (ToJSON)
 import Prelude
 import System.Directory (doesFileExist)
 import Text.Read (readMaybe)
 import qualified Data.Text as T
 
-import Gargantext.API.Admin.EnvTypes
-import Gargantext.API.Errors.Types
-import Gargantext.API.Prelude