[FIX] Clean Text before sending it to NLP micro services + tests + clean code for...
[gargantext.git] / src / Gargantext / Database / Action / Flow / List.hs
index 35170a9b337c48e9a407cd5725d57f785c4c42e8..8843e0dd34b27b6606d46e069e0ac05ad06e86cd 100644 (file)
@@ -9,46 +9,35 @@ Portability : POSIX
 
 -}
 
-{-# OPTIONS_GHC -fno-warn-orphans    #-}
-
 {-# LANGUAGE ConstraintKinds         #-}
-{-# LANGUAGE RankNTypes              #-}
 {-# LANGUAGE ConstrainedClassMethods #-}
 {-# LANGUAGE ConstraintKinds         #-}
-{-# LANGUAGE DeriveGeneric           #-}
-{-# LANGUAGE FlexibleContexts        #-}
 {-# LANGUAGE InstanceSigs            #-}
-{-# LANGUAGE NoImplicitPrelude       #-}
-{-# LANGUAGE OverloadedStrings       #-}
 
 module Gargantext.Database.Action.Flow.List
     where
 
-import Control.Monad (mapM_)
-import Data.Map (Map, toList)
-import Data.Either
-import Data.Maybe (Maybe(..), catMaybes)
-import Data.Set (Set)
+import Control.Concurrent
+import Control.Lens ((^.), (+~), (%~), at, (.~), _Just)
+import Control.Monad.Reader
+import Data.Map.Strict (Map, toList)
 import Data.Text (Text)
-import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams)
-import Gargantext.Core (Lang(..))
-import Gargantext.Core.Types.Individu
-import Gargantext.Core.Flow.Types
+import Gargantext.API.Ngrams (saveNodeStory)
+import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
+import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Types (HasInvalidError(..), assertValid)
 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
+import Gargantext.Core.NodeStory
 import Gargantext.Database.Action.Flow.Types
-import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
-import Gargantext.Database.Admin.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
-import Gargantext.Database.Admin.Utils (Cmd)
-import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams,  NgramsType(..), text2ngrams, ngramsTypeId)
-import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
-import Gargantext.Database.Schema.Node_NodeNgramsNodeNgrams -- (insert_Node_NodeNgrams_NodeNgrams, Node_NodeNgrams_NodeNgrams(..))
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb,{- getCgramsId -})
+-- import Gargantext.Database.Query.Table.Node_NodeNgramsNodeNgrams
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
 import Gargantext.Prelude
-import Gargantext.Text.List
 import qualified Data.List as List
-import qualified Data.Map  as Map
-import qualified Data.Set as Set
-import Gargantext.Database.Action.Metrics.NgramsByNode
-import Gargantext.Database.Action.Query.Tree.Root (getOrMk_RootWithCorpus)
+import qualified Data.Map.Strict as Map
+import qualified Data.Map.Strict.Patch as PM
+import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 
 -- FLOW LIST
 -- 1. select specific terms of the corpus when compared with others langs
@@ -92,21 +81,6 @@ flowList_Tficf' u m nt f = do
 -}
 
 
-
-
-
-
--- | TODO check optimization
-mapNodeIdNgrams :: [DocumentIdWithNgrams a]
-                -> Map Ngrams (Map NgramsType (Map NodeId Int))
-mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
-  where
-    f :: DocumentIdWithNgrams a
-      -> Map Ngrams (Map NgramsType (Map NodeId Int))
-    f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
-      where
-        nId = documentId $ documentWithId d
-
 ------------------------------------------------------------------------
 flowList_DbRepo :: FlowCmdM env err m
          => ListId
@@ -114,16 +88,20 @@ flowList_DbRepo :: FlowCmdM env err m
          -> m ListId
 flowList_DbRepo lId ngs = do
   -- printDebug "listId flowList" lId
-  mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
-  let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> parent)
+  _mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
+{-
+  let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> (unNgramsTerm <$> parent))
                                  <*>  getCgramsId mapCgramsId ntype ngram
                            | (ntype, ngs') <- Map.toList ngs
-                           , NgramsElement ngram _ _ _ _ parent _ <- ngs'
+                           , NgramsElement { _ne_ngrams = NgramsTerm ngram
+                                           , _ne_parent = parent } <- ngs'
                            ]
+-}
   -- Inserting groups of ngrams
-  _r <- insert_Node_NodeNgrams_NodeNgrams
-     $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
+  -- _r <- insert_Node_NodeNgrams_NodeNgrams
+  --   $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
 
+  -- printDebug "flowList_Tficf':ngs" ngs
   listInsert lId ngs
 
   --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
@@ -140,15 +118,40 @@ toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
                   -> (NgramsType, [NgramsElement])
                   -> [NodeNgramsW]
     toNodeNgramsW'' l' (ngrams_type, elms) =
-      [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
-       (NgramsElement ngrams_terms' _size list_type _occ _root _parent _children) <- elms
+      [ NodeNgrams { _nng_id            = Nothing
+                   , _nng_node_id       = l'
+                   , _nng_node_subtype  = list_type
+                   , _nng_ngrams_id     = ngrams_terms'
+                   , _nng_ngrams_type   = ngrams_type
+                   , _nng_ngrams_field  = Nothing
+                   , _nng_ngrams_tag    = Nothing
+                   , _nng_ngrams_class  = Nothing
+                   , _nng_ngrams_weight = 0 } |
+       (NgramsElement { _ne_ngrams      = NgramsTerm ngrams_terms'
+                      , _ne_size        = _size
+                      , _ne_list        = list_type
+                      , _ne_occurrences = _occ
+                      , _ne_root        = _root
+                      , _ne_parent      = _parent
+                      , _ne_children    = _children
+                      }
+        ) <- elms
       ]
 
 
 toNodeNgramsW' :: ListId
                -> [(Text, [NgramsType])]
                -> [NodeNgramsW]
-toNodeNgramsW' l'' ngs = [ NodeNgrams Nothing l'' CandidateTerm terms ngrams_type Nothing Nothing Nothing 0
+toNodeNgramsW' l'' ngs = [ NodeNgrams { _nng_id            = Nothing
+                                      , _nng_node_id       = l''
+                                      , _nng_node_subtype  = CandidateTerm
+                                      , _nng_ngrams_id     = terms
+                                      , _nng_ngrams_type   = ngrams_type
+                                      , _nng_ngrams_field  = Nothing
+                                      , _nng_ngrams_tag    = Nothing
+                                      , _nng_ngrams_class  = Nothing
+                                      , _nng_ngrams_weight = 0
+                                      }
                          | (terms, ngrams_types) <- ngs
                          , ngrams_type <- ngrams_types
                          ]
@@ -163,3 +166,47 @@ listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
+-- NOTE
+-- This is no longer part of the API.
+-- This function is maintained for its usage in Database.Action.Flow.List.
+-- If the given list of ngrams elements contains ngrams already in
+-- the repo, they will be ignored.
+putListNgrams :: (HasInvalidError err, HasNodeStory env err m)
+              => NodeId
+              -> TableNgrams.NgramsType
+              -> [NgramsElement]
+              -> m ()
+putListNgrams _ _ [] = pure ()
+putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
+  where
+    m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
+
+    putListNgrams' :: (HasInvalidError err, HasNodeStory env err m)
+                   => NodeId
+                   -> TableNgrams.NgramsType
+                   -> Map NgramsTerm NgramsRepoElement
+                   -> m ()
+    putListNgrams' listId ngramsType' ns = do
+      -- printDebug "[putListNgrams'] nodeId" nodeId
+      -- printDebug "[putListNgrams'] ngramsType" ngramsType
+      -- printDebug "[putListNgrams'] ns" ns
+
+      let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
+          (p, p_validity) = PM.singleton ngramsType' p1
+      assertValid p_validity
+      {-
+      -- TODO
+      v <- currentVersion
+      q <- commitStatePatch (Versioned v p)
+      assert empty q
+      -- What if another commit comes in between?
+      -- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
+      -- The modifyMVar_ would test the patch with applicable first.
+      -- If valid the rest would be atomic and no merge is required.
+      -}
+      var <- getNodeStoryVar [listId]
+      liftBase $ modifyMVar_ var $ \r -> do
+        pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
+                 & unNodeStory . at listId . _Just . a_history %~ (p :)
+                 & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
+      saveNodeStory