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.Ext.IMT (toSchoolName)
82 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
83 import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
84 import Gargantext.Text
85 import Gargantext.Prelude
86 import Gargantext.Text.Corpus.Parsers (parseFile, FileFormat)
87 import Gargantext.Text.List (buildNgramsLists,StopSize(..))
88 import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
89 import Gargantext.Text.Terms
90 import qualified Gargantext.Database.Query.Table.Node.Document.Add as Doc (add)
91 import qualified Gargantext.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
223 -- _ <- mkAnnuaire rootUserId userId
227 insertMasterDocs :: ( FlowCmdM env err m
235 insertMasterDocs c lang hs = do
236 (masterUserId, _, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left corpusMasterName) c
238 -- TODO Type NodeDocumentUnicised
239 let docs = map addUniqId hs
240 ids <- insertDb masterUserId masterCorpusId docs
243 documentsWithId = mergeData (toInserted ids) (Map.fromList $ map viewUniqId' docs)
245 -- create a corpus with database name (CSV or PubMed)
246 -- add documents to the corpus (create node_node link)
247 -- this will enable global database monitoring
249 -- maps :: IO Map Ngrams (Map NgramsType (Map NodeId Int))
250 maps <- mapNodeIdNgrams
251 <$> documentIdWithNgrams (extractNgramsT $ withLang lang documentsWithId) documentsWithId
253 terms2id <- insertNgrams $ Map.keys maps
255 let indexedNgrams = Map.mapKeys (indexNgrams terms2id) maps
258 lId <- getOrMkList masterCorpusId masterUserId
259 mapCgramsId <- listInsertDb lId toNodeNgramsW'
260 $ map (first _ngramsTerms . second Map.keys)
263 _return <- insertNodeNodeNgrams2
264 $ catMaybes [ NodeNodeNgrams2 <$> Just nId
265 <*> getCgramsId mapCgramsId ngrams_type (_ngramsTerms terms'')
266 <*> Just (fromIntegral w :: Double)
267 | (terms'', mapNgramsTypes) <- Map.toList maps
268 , (ngrams_type, mapNodeIdWeight) <- Map.toList mapNgramsTypes
269 , (nId, w) <- Map.toList mapNodeIdWeight
272 _ <- Doc.add masterCorpusId ids'
273 _cooc <- insertDefaultNode NodeListCooc lId masterUserId
275 _ <- insertDocNgrams lId indexedNgrams
280 ------------------------------------------------------------------------
284 ------------------------------------------------------------------------
285 viewUniqId' :: UniqId a
288 viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
290 err = panic "[ERROR] Database.Flow.toInsert"
293 toInserted :: [ReturnId]
294 -> Map HashId ReturnId
296 Map.fromList . map (\r -> (reUniqId r, r) )
297 . filter (\r -> reInserted r == True)
299 mergeData :: Map HashId ReturnId
301 -> [DocumentWithId a]
302 mergeData rs = catMaybes . map toDocumentWithId . Map.toList
304 toDocumentWithId (sha,hpd) =
305 DocumentWithId <$> fmap reId (lookup sha rs)
308 ------------------------------------------------------------------------
310 instance HasText HyperdataContact
314 ------------------------------------------------------------------------
315 ------------------------------------------------------------------------
317 documentIdWithNgrams :: HasNodeError err
319 -> Cmd err (Map Ngrams (Map NgramsType Int)))
320 -> [DocumentWithId a]
321 -> Cmd err [DocumentIdWithNgrams a]
322 documentIdWithNgrams f = traverse toDocumentIdWithNgrams
324 toDocumentIdWithNgrams d = do
325 e <- f $ documentData d
326 pure $ DocumentIdWithNgrams d e
329 ------------------------------------------------------------------------
332 instance ExtractNgramsT HyperdataContact
334 extractNgramsT l hc = filterNgramsT 255 <$> extract l hc
336 extract :: TermType Lang -> HyperdataContact
337 -> Cmd err (Map Ngrams (Map NgramsType Int))
339 let authors = map text2ngrams
340 $ maybe ["Nothing"] (\a -> [a])
341 $ view (hc_who . _Just . cw_lastName) hc'
343 pure $ Map.fromList $ [(a', Map.singleton Authors 1) | a' <- authors ]
345 instance HasText HyperdataDocument
347 hasText h = catMaybes [ _hd_title h
351 instance ExtractNgramsT HyperdataDocument
353 extractNgramsT :: TermType Lang
355 -> Cmd err (Map Ngrams (Map NgramsType Int))
356 extractNgramsT lang hd = filterNgramsT 255 <$> extractNgramsT' lang hd
358 extractNgramsT' :: TermType Lang
360 -> Cmd err (Map Ngrams (Map NgramsType Int))
361 extractNgramsT' lang' doc = do
362 let source = text2ngrams
363 $ maybe "Nothing" identity
366 institutes = map text2ngrams
367 $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
370 authors = map text2ngrams
371 $ maybe ["Nothing"] (splitOn ", ")
374 terms' <- map text2ngrams
375 <$> map (intercalate " " . _terms_label)
377 <$> liftBase (extractTerms lang' $ hasText doc)
379 pure $ Map.fromList $ [(source, Map.singleton Sources 1)]
380 <> [(i', Map.singleton Institutes 1) | i' <- institutes ]
381 <> [(a', Map.singleton Authors 1) | a' <- authors ]
382 <> [(t', Map.singleton NgramsTerms 1) | t' <- terms' ]