[search] fix json serialization of search objects
[gargantext.git] / src / Gargantext / Database / Action / Flow.hs
index 6b054a0c432a7a279831fbd540f174fad16dbff3..57bb18490475aa0fcf513b4169b7d13dfac2c9ee 100644 (file)
@@ -24,8 +24,7 @@ Portability : POSIX
 {-# LANGUAGE TemplateHaskell         #-}
 
 module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
-  ( FlowCmdM
-  , getDataText
+  ( getDataText
   , flowDataText
   , flow
 
@@ -33,6 +32,7 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
   , flowCorpus
   , flowAnnuaire
   , insertMasterDocs
+  , saveDocNgramsWith
 
   , getOrMkRoot
   , getOrMk_RootWithCorpus
@@ -41,6 +41,7 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
   , allDataOrigins
 
   , do_api
+  , indexAllDocumentsWithPosTag
   )
     where
 
@@ -54,7 +55,7 @@ import Data.Map (Map, lookup)
 import Data.Maybe (catMaybes)
 import Data.Monoid
 import Data.Swagger
-import Data.Text (splitOn)
+import qualified Data.Text as T
 import Data.Traversable (traverse)
 import Data.Tuple.Extra (first, second)
 import GHC.Generics (Generic)
@@ -65,12 +66,13 @@ import qualified Data.Map as Map
 
 import Gargantext.Core (Lang(..), PosTagAlgo(..))
 import Gargantext.Core.Ext.IMT (toSchoolName)
-import Gargantext.Core.Ext.IMTUser (deserialiseImtUsersFromFile)
+import Gargantext.Core.Ext.IMTUser (readFile_Annuaire)
 import Gargantext.Core.Flow.Types
 import Gargantext.Core.Text
 import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(..))
 import Gargantext.Core.Text.Corpus.Parsers (parseFile, FileFormat)
 import Gargantext.Core.Text.List (buildNgramsLists)
+import Gargantext.Core.Text.List.Social (FlowSocialListWith)
 import Gargantext.Core.Text.Terms
 import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
 import Gargantext.Core.Types (POS(NP))
@@ -92,13 +94,18 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Database.Query.Table.NodeNgrams (listInsertDb , getCgramsId)
 import Gargantext.Database.Query.Table.NodeNodeNgrams2
 import Gargantext.Database.Query.Tree.Root (getOrMkRoot, getOrMk_RootWithCorpus)
-import Gargantext.Database.Schema.Node (NodePoly(..))
+import Gargantext.Database.Schema.Node (NodePoly(..), node_id)
 import Gargantext.Database.Types
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Hash (Hash)
 import qualified Gargantext.Core.Text.Corpus.API as API
 import qualified Gargantext.Database.Query.Table.Node.Document.Add  as Doc  (add)
 
+------------------------------------------------------------------------
+-- Impots for upgrade function
+import Gargantext.Database.Query.Tree.Root (getRootId)
+import Gargantext.Database.Query.Tree (findNodesId)
+import qualified Data.List as List
 ------------------------------------------------------------------------
 -- TODO use internal with API name (could be old data)
 data DataOrigin = InternalOrigin { _do_api :: API.ExternalAPIs }
@@ -145,11 +152,12 @@ flowDataText :: ( FlowCmdM env err m
                 -> DataText
                 -> TermType Lang
                 -> CorpusId
+                -> Maybe FlowSocialListWith
                 -> m CorpusId
-flowDataText u (DataOld ids) tt cid = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids
+flowDataText u (DataOld ids) tt cid mfslw = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids mfslw
   where
     corpusType = (Nothing :: Maybe HyperdataCorpus)
-flowDataText u (DataNew txt) tt cid = flowCorpus u (Right [cid]) tt txt
+flowDataText u (DataNew txt) tt cid mfslw = flowCorpus u (Right [cid]) tt mfslw txt
 
 ------------------------------------------------------------------------
 -- TODO use proxy
@@ -160,8 +168,8 @@ flowAnnuaire :: (FlowCmdM env err m)
              -> FilePath
              -> m AnnuaireId
 flowAnnuaire u n l filePath = do
-  docs <- liftBase $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
-  flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
+  docs <- liftBase $ (( splitEvery 500 <$> readFile_Annuaire filePath) :: IO [[HyperdataContact]])
+  flow (Nothing :: Maybe HyperdataAnnuaire) u n l Nothing docs
 
 ------------------------------------------------------------------------
 flowCorpusFile :: (FlowCmdM env err m)
@@ -169,13 +177,15 @@ flowCorpusFile :: (FlowCmdM env err m)
            -> Either CorpusName [CorpusId]
            -> Limit -- Limit the number of docs (for dev purpose)
            -> TermType Lang -> FileFormat -> FilePath
+           -> Maybe FlowSocialListWith
            -> m CorpusId
-flowCorpusFile u n l la ff fp = do
-  docs <- liftBase ( splitEvery 500
-                 <$> take l
-                 <$> parseFile ff fp
-                 )
-  flowCorpus u n la (map (map toHyperdataDocument) docs)
+flowCorpusFile u n l la ff fp mfslw = do
+  eParsed <- liftBase $ parseFile ff fp
+  case eParsed of
+    Right parsed -> do
+      let docs = splitEvery 500 $ take l parsed
+      flowCorpus u n la mfslw (map (map toHyperdataDocument) docs)
+    Left e       -> panic $ "Error: " <> (T.pack e)
 
 ------------------------------------------------------------------------
 -- | TODO improve the needed type to create/update a corpus
@@ -184,6 +194,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
            => User
            -> Either CorpusName [CorpusId]
            -> TermType Lang
+           -> Maybe FlowSocialListWith
            -> [[a]]
            -> m CorpusId
 flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
@@ -197,12 +208,13 @@ flow :: ( FlowCmdM env err m
         -> User
         -> Either CorpusName [CorpusId]
         -> TermType Lang
+        -> Maybe FlowSocialListWith
         -> [[a]]
         -> m CorpusId
-flow c u cn la docs = do
+flow c u cn la mfslw docs = do
   -- TODO if public insertMasterDocs else insertUserDocs
   ids <- traverse (insertMasterDocs c la) docs
-  flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
+  flowCorpusUser (la ^. tt_lang) u cn c (concat ids) mfslw
 
 ------------------------------------------------------------------------
 flowCorpusUser :: ( FlowCmdM env err m
@@ -213,8 +225,9 @@ flowCorpusUser :: ( FlowCmdM env err m
                -> Either CorpusName [CorpusId]
                -> Maybe c
                -> [NodeId]
+               -> Maybe FlowSocialListWith
                -> m CorpusId
-flowCorpusUser l user corpusName ctype ids = do
+flowCorpusUser l user corpusName ctype ids mfslw = do
   -- User Flow
   (userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus user corpusName ctype
   -- NodeTexts is first
@@ -230,11 +243,12 @@ flowCorpusUser l user corpusName ctype ids = do
   -- printDebug "Node Text Ids:" tId
 
   -- User List Flow
-  (masterUserId, _masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left "") ctype
+  (masterUserId, _masterRootId, masterCorpusId)
+    <- getOrMk_RootWithCorpus (UserName userMaster) (Left "") ctype
 
-  -- let gp = (GroupParams l 2 3 (StopSize 3)) 
+  --let gp = (GroupParams l 2 3 (StopSize 3)) 
   let gp = GroupWithPosTag l CoreNLP HashMap.empty 
-  ngs         <- buildNgramsLists gp user userCorpusId masterCorpusId
+  ngs         <- buildNgramsLists user userCorpusId masterCorpusId mfslw gp
 
   _userListId <- flowList_DbRepo listId ngs
   _mastListId <- getOrMkList masterCorpusId masterUserId
@@ -273,6 +287,17 @@ insertMasterDocs c lang hs  =  do
                     (extractNgramsT $ withLang lang documentsWithId)
                     documentsWithId
 
+  lId      <- getOrMkList masterCorpusId masterUserId
+  _ <- saveDocNgramsWith lId mapNgramsDocs'
+
+  -- _cooc <- insertDefaultNode NodeListCooc lId masterUserId
+  pure ids'
+
+saveDocNgramsWith :: ( FlowCmdM env err m)
+                  => ListId
+                  -> HashMap ExtractedNgrams (Map NgramsType (Map NodeId Int))
+                  -> m ()
+saveDocNgramsWith lId mapNgramsDocs' = do
   terms2id <- insertExtractedNgrams $ HashMap.keys mapNgramsDocs'
   let mapNgramsDocs = HashMap.mapKeys extracted2ngrams mapNgramsDocs'
 
@@ -280,10 +305,10 @@ insertMasterDocs c lang hs  =  do
   let indexedNgrams = HashMap.mapKeys (indexNgrams terms2id) mapNgramsDocs
 
   -- new
-  lId      <- getOrMkList masterCorpusId masterUserId
   mapCgramsId <- listInsertDb lId toNodeNgramsW'
                $ map (first _ngramsTerms . second Map.keys)
                $ HashMap.toList mapNgramsDocs
+
   -- insertDocNgrams
   _return <- insertNodeNodeNgrams2
            $ catMaybes [ NodeNodeNgrams2 <$> Just nId
@@ -293,11 +318,11 @@ insertMasterDocs c lang hs  =  do
                        , (ngrams_type, mapNodeIdWeight) <- Map.toList mapNgramsTypes
                        , (nId, w)                       <- Map.toList mapNodeIdWeight
                        ]
-
-  -- _cooc <- insertDefaultNode NodeListCooc lId masterUserId
   -- to be removed
   _   <- insertDocNgrams lId indexedNgrams
-  pure ids'
+
+  pure ()
+
 
 ------------------------------------------------------------------------
 -- TODO Type NodeDocumentUnicised
@@ -406,11 +431,11 @@ instance ExtractNgramsT HyperdataDocument
                         $ _hd_source doc
 
               institutes = map text2ngrams
-                         $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
+                         $ maybe ["Nothing"] (map toSchoolName . (T.splitOn ", "))
                          $ _hd_institutes doc
 
               authors    = map text2ngrams
-                         $ maybe ["Nothing"] (splitOn ", ")
+                         $ maybe ["Nothing"] (T.splitOn ", ")
                          $ _hd_authors doc
 
           terms' <- map (enrichedTerms (lang' ^. tt_lang) CoreNLP NP)
@@ -432,3 +457,31 @@ instance HasText a => HasText (Node a)
     hasText (Node _ _ _ _ _ _ _ h) = hasText h
 
 
+
+-- | TODO putelsewhere
+-- | Upgrade function
+-- Suppose all documents are English (this is the case actually)
+indexAllDocumentsWithPosTag :: FlowCmdM env err m => m ()
+indexAllDocumentsWithPosTag = do
+  rootId    <- getRootId (UserName userMaster)
+  corpusIds <- findNodesId rootId [NodeCorpus]
+  docs      <- List.concat <$> mapM getDocumentsWithParentId corpusIds
+
+  _ <- mapM extractInsert (splitEvery 1000 docs)
+
+  pure ()
+
+extractInsert :: FlowCmdM env err m => [Node HyperdataDocument] -> m ()
+extractInsert docs = do
+  let documentsWithId = map (\doc -> Indexed (doc ^. node_id) doc) docs
+
+  mapNgramsDocs' <- mapNodeIdNgrams
+                <$> documentIdWithNgrams
+                    (extractNgramsT $ withLang (Multi EN) documentsWithId)
+                    documentsWithId
+
+  _ <- insertExtractedNgrams $ HashMap.keys mapNgramsDocs'
+
+  pure ()
+
+