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
12 -- check userId CanFillUserCorpus userCorpusId
13 -- check masterUserId CanFillMasterCorpus masterCorpusId
15 -- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
16 -- TODO-EVENTS: InsertedNodes
21 {-# LANGUAGE ConstraintKinds #-}
22 {-# LANGUAGE DeriveGeneric #-}
23 {-# LANGUAGE NoImplicitPrelude #-}
24 {-# LANGUAGE OverloadedStrings #-}
25 {-# LANGUAGE RankNTypes #-}
26 {-# LANGUAGE FlexibleContexts #-}
28 module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
31 --import Debug.Trace (trace)
32 import Control.Lens ((^.), view, Lens', _Just)
33 import Control.Monad (mapM_)
34 import Control.Monad.IO.Class (liftIO)
35 import Data.List (concat)
36 import Data.Map (Map, lookup, toList)
37 import Data.Maybe (Maybe(..), catMaybes)
39 import Data.Text (Text, splitOn, intercalate)
40 import GHC.Show (Show)
41 import Gargantext.API.Ngrams (HasRepoVar)
42 import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams, RepoCmdM)
43 import Gargantext.Core (Lang(..))
44 import Gargantext.Core.Types (NodePoly(..), Terms(..))
45 import Gargantext.Core.Types.Individu (Username)
46 import Gargantext.Core.Types.Main
47 import Gargantext.Database.Config (userMaster, corpusMasterName)
48 import Gargantext.Database.Flow.Utils (insertDocNgrams)
49 import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..))
50 import Gargantext.Database.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
51 import Gargantext.Database.Root (getRoot)
52 import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams, NgramsType(..), text2ngrams, ngramsTypeId)
53 import Gargantext.Database.Schema.Node -- (mkRoot, mkCorpus, getOrMkList, mkGraph, mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError, NodeError(..), nodeError)
54 import Gargantext.Database.Schema.User (getUser, UserLight(..))
55 import Gargantext.Database.TextSearch (searchInDatabase)
56 import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
57 import Gargantext.Database.Utils (Cmd, CmdM)
58 import Gargantext.Ext.IMT (toSchoolName)
59 import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
60 import Gargantext.Prelude
61 import Gargantext.Text.List (buildNgramsLists,StopSize(..))
62 import Gargantext.Text.Parsers (parseFile, FileFormat)
63 import Gargantext.Text.Terms (TermType(..), tt_lang)
64 import Gargantext.Text.Terms (extractTerms)
65 import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
66 import Servant (ServantErr)
67 import System.FilePath (FilePath)
68 --import qualified Data.List as List
69 import qualified Data.Map as Map
70 import qualified Data.Text as Text
71 import qualified Gargantext.Database.Node.Document.Add as Doc (add)
72 import qualified Gargantext.Text.Parsers.GrandDebat as GD
74 type FlowCmdM env err m =
81 type FlowCorpus a = ( AddUniqId a
87 ------------------------------------------------------------------------
89 flowAnnuaire :: FlowCmdM env ServantErr m
90 => Username -> CorpusName -> (TermType Lang) -> FilePath -> m AnnuaireId
91 flowAnnuaire u n l filePath = do
92 docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
93 flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
96 flowCorpusDebat :: FlowCmdM env ServantErr m
97 => Username -> CorpusName
100 flowCorpusDebat u n l fp = do
101 docs <- liftIO ( splitEvery 500
104 :: IO [[GD.GrandDebatReference ]]
106 flowCorpus u n (Multi FR) (map (map toHyperdataDocument) docs)
109 flowCorpusFile :: FlowCmdM env ServantErr m
110 => Username -> CorpusName
111 -> Limit -- Limit the number of docs (for dev purpose)
112 -> TermType Lang -> FileFormat -> FilePath
114 flowCorpusFile u n l la ff fp = do
115 docs <- liftIO ( splitEvery 500
119 flowCorpus u n la (map (map toHyperdataDocument) docs)
121 -- TODO query with complex query
122 flowCorpusSearchInDatabase :: FlowCmdM env ServantErr m
123 => Username -> Lang -> Text -> m CorpusId
124 flowCorpusSearchInDatabase u la q = do
125 (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster "" (Nothing :: Maybe HyperdataCorpus)
126 ids <- map fst <$> searchInDatabase cId (stemIt q)
127 flowCorpusUser la u q (Nothing :: Maybe HyperdataCorpus) ids
129 ------------------------------------------------------------------------
131 flow :: (FlowCmdM env ServantErr m, FlowCorpus a, MkCorpus c)
132 => Maybe c -> Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
133 flow c u cn la docs = do
134 ids <- mapM (insertMasterDocs c la ) docs
135 flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
137 flowCorpus :: (FlowCmdM env ServantErr m, FlowCorpus a)
138 => Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
139 flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
142 flowCorpusUser :: (FlowCmdM env ServantErr m, MkCorpus c)
143 => Lang -> Username -> CorpusName -> Maybe c -> [NodeId] -> m CorpusId
144 flowCorpusUser l userName corpusName ctype ids = do
146 (userId, _rootId, userCorpusId) <- getOrMkRootWithCorpus userName corpusName ctype
147 -- TODO: check if present already, ignore
148 _ <- Doc.add userCorpusId ids
152 (_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster "" ctype
153 ngs <- buildNgramsLists l 2 3 (StopSize 3) userCorpusId masterCorpusId
154 userListId <- flowList userId userCorpusId ngs
155 printDebug "userListId" userListId
157 _ <- mkGraph userCorpusId userId
160 -- User Dashboard Flow
161 _ <- mkDashboard userCorpusId userId
164 -- _ <- mkAnnuaire rootUserId userId
168 insertMasterDocs :: ( FlowCmdM env ServantErr m
172 => Maybe c -> TermType Lang -> [a] -> m [DocId]
173 insertMasterDocs c lang hs = do
174 (masterUserId, _, masterCorpusId) <- getOrMkRootWithCorpus userMaster corpusMasterName c
176 -- TODO Type NodeDocumentUnicised
177 let hs' = map addUniqId hs
178 ids <- insertDb masterUserId masterCorpusId hs'
179 let documentsWithId = mergeData (toInserted ids) (Map.fromList $ map viewUniqId' hs')
181 maps <- mapNodeIdNgrams <$> documentIdWithNgrams (extractNgramsT lang) documentsWithId
182 terms2id <- insertNgrams $ Map.keys maps
183 let indexedNgrams = Map.mapKeys (indexNgrams terms2id) maps
185 lId <- getOrMkList masterCorpusId masterUserId
186 _ <- insertDocNgrams lId indexedNgrams
191 type CorpusName = Text
193 getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
194 => Username -> CorpusName -> Maybe a
195 -> Cmd err (UserId, RootId, CorpusId)
196 getOrMkRootWithCorpus username cName c = do
197 maybeUserId <- getUser username
198 userId <- case maybeUserId of
199 Nothing -> nodeError NoUserFound
200 Just user -> pure $ userLight_id user
202 rootId' <- map _node_id <$> getRoot username
204 rootId'' <- case rootId' of
205 [] -> mkRoot username userId
206 n -> case length n >= 2 of
207 True -> nodeError ManyNodeUsers
208 False -> pure rootId'
210 rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
212 corpusId'' <- if username == userMaster
214 ns <- getCorporaWithParentId rootId
215 pure $ map _node_id ns
219 corpusId' <- if corpusId'' /= []
221 else mk (Just cName) c rootId userId
223 corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
225 pure (userId, rootId, corpusId)
228 ------------------------------------------------------------------------
233 uniqId :: Lens' a (Maybe HashId)
236 instance UniqId HyperdataDocument
238 uniqId = hyperdataDocument_uniqId
240 instance UniqId HyperdataContact
244 viewUniqId' :: UniqId a => a -> (HashId, a)
245 viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
247 err = panic "[ERROR] Database.Flow.toInsert"
250 toInserted :: [ReturnId] -> Map HashId ReturnId
251 toInserted = Map.fromList . map (\r -> (reUniqId r, r) )
252 . filter (\r -> reInserted r == True)
254 data DocumentWithId a = DocumentWithId
255 { documentId :: !NodeId
259 mergeData :: Map HashId ReturnId
261 -> [DocumentWithId a]
262 mergeData rs = catMaybes . map toDocumentWithId . Map.toList
264 toDocumentWithId (hash,hpd) =
265 DocumentWithId <$> fmap reId (lookup hash rs)
268 ------------------------------------------------------------------------
269 data DocumentIdWithNgrams a = DocumentIdWithNgrams
270 { documentWithId :: !(DocumentWithId a)
271 , document_ngrams :: !(Map Ngrams (Map NgramsType Int))
274 -- TODO extractNgrams according to Type of Data
276 class ExtractNgramsT h
278 extractNgramsT :: TermType Lang -> h -> Cmd err (Map Ngrams (Map NgramsType Int))
281 instance ExtractNgramsT HyperdataContact
283 extractNgramsT l hc = filterNgramsT 255 <$> extract l hc
285 extract :: TermType Lang -> HyperdataContact
286 -> Cmd err (Map Ngrams (Map NgramsType Int))
288 let authors = map text2ngrams
289 $ maybe ["Nothing"] (\a -> [a])
290 $ view (hc_who . _Just . cw_lastName) hc'
292 pure $ Map.fromList $ [(a', Map.singleton Authors 1) | a' <- authors ]
297 instance ExtractNgramsT HyperdataDocument
299 extractNgramsT = extractNgramsT'
301 extractNgramsT' :: TermType Lang -> HyperdataDocument
302 -> Cmd err (Map Ngrams (Map NgramsType Int))
303 extractNgramsT' lang hd = filterNgramsT 255 <$> extractNgramsT'' lang hd
305 extractNgramsT'' :: TermType Lang -> HyperdataDocument
306 -> Cmd err (Map Ngrams (Map NgramsType Int))
307 extractNgramsT'' lang' doc = do
308 let source = text2ngrams
309 $ maybe "Nothing" identity
310 $ _hyperdataDocument_source doc
312 institutes = map text2ngrams
313 $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
314 $ _hyperdataDocument_institutes doc
316 authors = map text2ngrams
317 $ maybe ["Nothing"] (splitOn ", ")
318 $ _hyperdataDocument_authors doc
320 leText = catMaybes [ _hyperdataDocument_title doc
321 , _hyperdataDocument_abstract doc
324 terms' <- map text2ngrams
325 <$> map (intercalate " " . _terms_label)
327 <$> liftIO (extractTerms lang' leText)
329 pure $ Map.fromList $ [(source, Map.singleton Sources 1)]
330 <> [(i', Map.singleton Institutes 1) | i' <- institutes ]
331 <> [(a', Map.singleton Authors 1) | a' <- authors ]
332 <> [(t', Map.singleton NgramsTerms 1) | t' <- terms' ]
335 filterNgramsT :: Int -> Map Ngrams (Map NgramsType Int)
336 -> Map Ngrams (Map NgramsType Int)
337 filterNgramsT s ms = Map.fromList $ map (\a -> filter' s a) $ Map.toList ms
339 filter' s' (ng@(Ngrams t n),y) = case (Text.length t) < s' of
341 False -> (Ngrams (Text.take s' t) n , y)
344 documentIdWithNgrams :: HasNodeError err
346 -> Cmd err (Map Ngrams (Map NgramsType Int)))
347 -> [DocumentWithId a]
348 -> Cmd err [DocumentIdWithNgrams a]
349 documentIdWithNgrams f = mapM toDocumentIdWithNgrams
351 toDocumentIdWithNgrams d = do
352 e <- f $ documentData d
353 pure $ DocumentIdWithNgrams d e
358 -- | TODO check optimization
359 mapNodeIdNgrams :: [DocumentIdWithNgrams a]
360 -> Map Ngrams (Map NgramsType (Map NodeId Int))
361 mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
363 f :: DocumentIdWithNgrams a
364 -> Map Ngrams (Map NgramsType (Map NodeId Int))
365 f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
367 nId = documentId $ documentWithId d
369 ------------------------------------------------------------------------
370 listInsert :: FlowCmdM env err m
371 => ListId -> Map NgramsType [NgramsElement]
373 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
374 -> putListNgrams lId typeList ngElmts
377 flowList :: FlowCmdM env err m => UserId -> CorpusId
378 -> Map NgramsType [NgramsElement]
380 flowList uId cId ngs = do
381 lId <- getOrMkList cId uId
382 printDebug "listId flowList" lId
384 --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs