2 Module : Gargantext.Database.Flow
3 Description : Database Flow
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
11 -- check userId CanFillUserCorpus userCorpusId
12 -- check masterUserId CanFillMasterCorpus masterCorpusId
14 -- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
15 -- TODO-EVENTS: InsertedNodes
18 {-# OPTIONS_GHC -fno-warn-orphans #-}
20 {-# LANGUAGE ConstraintKinds #-}
21 {-# LANGUAGE ConstrainedClassMethods #-}
22 {-# LANGUAGE ConstraintKinds #-}
23 {-# LANGUAGE InstanceSigs #-}
24 {-# LANGUAGE TemplateHaskell #-}
26 module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
37 , getOrMk_RootWithCorpus
46 import Control.Lens ((^.), view, _Just, makeLenses)
47 import Data.Aeson.TH (deriveJSON)
49 import Data.List (concat)
50 import qualified Data.Map as Map
51 import Data.Map (Map, lookup)
52 import Data.Maybe (Maybe(..), catMaybes)
55 import Data.Text (splitOn, intercalate)
56 import Data.Traversable (traverse)
57 import Data.Tuple.Extra (first, second)
58 import GHC.Generics (Generic)
59 import System.FilePath (FilePath)
61 import Gargantext.Core (Lang(..))
62 import Gargantext.Core.Flow.Types
63 import Gargantext.Core.Types (Terms(..))
64 import Gargantext.Core.Types.Individu (User(..))
65 import Gargantext.Core.Types.Main
66 import Gargantext.Database.Action.Flow.List
67 import Gargantext.Database.Action.Flow.Types
68 import Gargantext.Database.Action.Flow.Utils (insertDocNgrams)
69 import Gargantext.Database.Query.Table.Node
70 import Gargantext.Database.Query.Table.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
71 import Gargantext.Database.Query.Tree.Root (getOrMkRoot, getOrMk_RootWithCorpus)
72 import Gargantext.Database.Action.Search (searchDocInDatabase)
73 import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
74 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
75 import Gargantext.Database.Admin.Types.Hyperdata
76 import Gargantext.Database.Admin.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
77 import Gargantext.Database.Prelude
78 import Gargantext.Database.Query.Table.Ngrams
79 import Gargantext.Database.Query.Table.NodeNgrams (listInsertDb , getCgramsId)
80 import Gargantext.Database.Query.Table.NodeNodeNgrams2
81 import Gargantext.Core.Ext.IMT (toSchoolName)
82 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
83 import Gargantext.Core.Ext.IMTUser (deserialiseImtUsersFromFile)
84 import Gargantext.Core.Text
85 import Gargantext.Prelude
86 import Gargantext.Core.Text.Corpus.Parsers (parseFile, FileFormat)
87 import Gargantext.Core.Text.List (buildNgramsLists,StopSize(..))
88 import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
89 import Gargantext.Core.Text.Terms
90 import qualified Gargantext.Database.Query.Table.Node.Document.Add as Doc (add)
91 import qualified Gargantext.Core.Text.Corpus.API as API
93 ------------------------------------------------------------------------
94 -- TODO use internal with API name (could be old data)
95 data DataOrigin = InternalOrigin { _do_api :: API.ExternalAPIs }
96 | ExternalOrigin { _do_api :: API.ExternalAPIs }
98 deriving (Generic, Eq)
100 makeLenses ''DataOrigin
101 deriveJSON (unPrefix "_do_") ''DataOrigin
102 instance ToSchema DataOrigin where
103 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_do_")
105 allDataOrigins :: [DataOrigin]
106 allDataOrigins = map InternalOrigin API.externalAPIs
107 <> map ExternalOrigin API.externalAPIs
110 data DataText = DataOld ![NodeId]
111 | DataNew ![[HyperdataDocument]]
113 -- TODO use the split parameter in config file
114 getDataText :: FlowCmdM env err m
120 getDataText (ExternalOrigin api) la q li = liftBase $ DataNew
122 <$> API.get api (_tt_lang la) q li
123 getDataText (InternalOrigin _) _la q _li = do
124 (_masterUserId, _masterRootId, cId) <- getOrMk_RootWithCorpus
125 (UserName userMaster)
127 (Nothing :: Maybe HyperdataCorpus)
128 ids <- map fst <$> searchDocInDatabase cId (stemIt q)
131 -------------------------------------------------------------------------------
132 flowDataText :: FlowCmdM env err m
138 flowDataText u (DataOld ids) tt cid = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids
140 corpusType = (Nothing :: Maybe HyperdataCorpus)
141 flowDataText u (DataNew txt) tt cid = flowCorpus u (Right [cid]) tt txt
143 ------------------------------------------------------------------------
145 flowAnnuaire :: FlowCmdM env err m
147 -> Either CorpusName [CorpusId]
151 flowAnnuaire u n l filePath = do
152 docs <- liftBase $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
153 flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
155 ------------------------------------------------------------------------
156 flowCorpusFile :: FlowCmdM env err m
158 -> Either CorpusName [CorpusId]
159 -> Limit -- Limit the number of docs (for dev purpose)
160 -> TermType Lang -> FileFormat -> FilePath
162 flowCorpusFile u n l la ff fp = do
163 docs <- liftBase ( splitEvery 500
167 flowCorpus u n la (map (map toHyperdataDocument) docs)
169 ------------------------------------------------------------------------
170 -- | TODO improve the needed type to create/update a corpus
171 -- (For now, Either is enough)
172 flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
174 -> Either CorpusName [CorpusId]
178 flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
181 flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)
184 -> Either CorpusName [CorpusId]
188 flow c u cn la docs = do
189 ids <- traverse (insertMasterDocs c la) docs
190 flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
192 ------------------------------------------------------------------------
193 flowCorpusUser :: (FlowCmdM env err m, MkCorpus c)
196 -> Either CorpusName [CorpusId]
200 flowCorpusUser l user corpusName ctype ids = do
202 (userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus user corpusName ctype
203 listId <- getOrMkList userCorpusId userId
204 _cooc <- insertDefaultNode NodeListCooc listId userId
205 -- TODO: check if present already, ignore
206 _ <- Doc.add userCorpusId ids
208 _tId <- insertDefaultNode NodeTexts userCorpusId userId
209 -- printDebug "Node Text Id" tId
212 (masterUserId, _masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left "") ctype
213 ngs <- buildNgramsLists l 2 3 (StopSize 3) userCorpusId masterCorpusId
214 _userListId <- flowList_DbRepo listId ngs
215 _mastListId <- getOrMkList masterCorpusId masterUserId
216 -- _ <- insertOccsUpdates userCorpusId mastListId
217 -- printDebug "userListId" userListId
219 _ <- insertDefaultNode NodeDashboard userCorpusId userId
220 _ <- insertDefaultNode NodeGraph userCorpusId userId
221 --_ <- mkPhylo userCorpusId userId
224 -- _ <- mkAnnuaire rootUserId userId
228 insertMasterDocs :: ( FlowCmdM env err m
236 insertMasterDocs c lang hs = do
237 (masterUserId, _, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left corpusMasterName) c
239 -- TODO Type NodeDocumentUnicised
240 let docs = map addUniqId hs
241 ids <- insertDb masterUserId masterCorpusId docs
244 documentsWithId = mergeData (toInserted ids) (Map.fromList $ map viewUniqId' docs)
246 -- create a corpus with database name (CSV or PubMed)
247 -- add documents to the corpus (create node_node link)
248 -- this will enable global database monitoring
250 -- maps :: IO Map Ngrams (Map NgramsType (Map NodeId Int))
251 maps <- mapNodeIdNgrams
252 <$> documentIdWithNgrams (extractNgramsT $ withLang lang documentsWithId) documentsWithId
254 terms2id <- insertNgrams $ Map.keys maps
256 let indexedNgrams = Map.mapKeys (indexNgrams terms2id) maps
259 lId <- getOrMkList masterCorpusId masterUserId
260 mapCgramsId <- listInsertDb lId toNodeNgramsW'
261 $ map (first _ngramsTerms . second Map.keys)
264 _return <- insertNodeNodeNgrams2
265 $ catMaybes [ NodeNodeNgrams2 <$> Just nId
266 <*> getCgramsId mapCgramsId ngrams_type (_ngramsTerms terms'')
267 <*> Just (fromIntegral w :: Double)
268 | (terms'', mapNgramsTypes) <- Map.toList maps
269 , (ngrams_type, mapNodeIdWeight) <- Map.toList mapNgramsTypes
270 , (nId, w) <- Map.toList mapNodeIdWeight
273 _ <- Doc.add masterCorpusId ids'
274 _cooc <- insertDefaultNode NodeListCooc lId masterUserId
276 _ <- insertDocNgrams lId indexedNgrams
280 ------------------------------------------------------------------------
281 ------------------------------------------------------------------------
282 viewUniqId' :: UniqId a
285 viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
287 err = panic "[ERROR] Database.Flow.toInsert"
290 toInserted :: [ReturnId]
291 -> Map HashId ReturnId
293 Map.fromList . map (\r -> (reUniqId r, r) )
294 . filter (\r -> reInserted r == True)
296 mergeData :: Map HashId ReturnId
298 -> [DocumentWithId a]
299 mergeData rs = catMaybes . map toDocumentWithId . Map.toList
301 toDocumentWithId (sha,hpd) =
302 DocumentWithId <$> fmap reId (lookup sha rs)
305 ------------------------------------------------------------------------
306 instance HasText HyperdataContact
309 ------------------------------------------------------------------------
310 ------------------------------------------------------------------------
311 documentIdWithNgrams :: HasNodeError err
313 -> Cmd err (Map Ngrams (Map NgramsType Int)))
314 -> [DocumentWithId a]
315 -> Cmd err [DocumentIdWithNgrams a]
316 documentIdWithNgrams f = traverse toDocumentIdWithNgrams
318 toDocumentIdWithNgrams d = do
319 e <- f $ documentData d
320 pure $ DocumentIdWithNgrams d e
323 ------------------------------------------------------------------------
324 instance ExtractNgramsT HyperdataContact
326 extractNgramsT l hc = filterNgramsT 255 <$> extract l hc
328 extract :: TermType Lang -> HyperdataContact
329 -> Cmd err (Map Ngrams (Map NgramsType Int))
331 let authors = map text2ngrams
332 $ maybe ["Nothing"] (\a -> [a])
333 $ view (hc_who . _Just . cw_lastName) hc'
335 pure $ Map.fromList $ [(a', Map.singleton Authors 1) | a' <- authors ]
337 instance HasText HyperdataDocument
339 hasText h = catMaybes [ _hd_title h
343 instance ExtractNgramsT HyperdataDocument
345 extractNgramsT :: TermType Lang
347 -> Cmd err (Map Ngrams (Map NgramsType Int))
348 extractNgramsT lang hd = filterNgramsT 255 <$> extractNgramsT' lang hd
350 extractNgramsT' :: TermType Lang
352 -> Cmd err (Map Ngrams (Map NgramsType Int))
353 extractNgramsT' lang' doc = do
354 let source = text2ngrams
355 $ maybe "Nothing" identity
358 institutes = map text2ngrams
359 $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
362 authors = map text2ngrams
363 $ maybe ["Nothing"] (splitOn ", ")
366 terms' <- map text2ngrams
367 <$> map (intercalate " " . _terms_label)
369 <$> liftBase (extractTerms lang' $ hasText doc)
371 pure $ Map.fromList $ [(source, Map.singleton Sources 1)]
372 <> [(i', Map.singleton Institutes 1) | i' <- institutes ]
373 <> [(a', Map.singleton Authors 1) | a' <- authors ]
374 <> [(t', Map.singleton NgramsTerms 1) | t' <- terms' ]