src/Gargantext/Database/Flow.hs

   1 {-|
   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
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# LANGUAGE DeriveGeneric     #-}
  13 {-# LANGUAGE NoImplicitPrelude #-}
  14 {-# LANGUAGE OverloadedStrings #-}
  15 {-# LANGUAGE RankNTypes        #-}
  16
  17 module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
  18     where
  19
  20 --import Control.Lens (view)
  21 import Control.Monad.IO.Class (liftIO)
  22 --import Gargantext.Core.Types
  23 --import Gargantext.Database.Node.Contact (HyperdataContact(..))
  24 import Data.Map (Map, lookup)
  25 import Data.Maybe (Maybe(..), catMaybes)
  26 import Data.Text (Text, splitOn, intercalate)
  27 import Data.Tuple.Extra (both, second)
  28 import Data.List (concat)
  29 import GHC.Show (Show)
  30 import Gargantext.Core.Types (NodePoly(..), ListType(..), listTypeId, Terms(..))
  31 import Gargantext.Core.Types.Individu (Username)
  32 import Gargantext.Core.Types.Main
  33 import Gargantext.Core (Lang(..))
  34 import Gargantext.Database.Config (userMaster, userArbitrary, corpusMasterName)
  35 import Gargantext.Database.Flow.Utils (insertToNodeNgrams)
  36 import Gargantext.Text.Terms (extractTerms)
  37 import Gargantext.Database.Node.Document.Add    (add)
  38 import Gargantext.Database.Node.Document.Insert (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
  39 import Gargantext.Database.Root (getRoot)
  40 import Gargantext.Database.Schema.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT,  NgramsType(..), text2ngrams)
  41 import Gargantext.Database.Schema.Node (mkRoot, mkCorpus, getOrMkList, mkGraph, mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError)
  42 import Gargantext.Database.Schema.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
  43 import Gargantext.Database.Schema.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
  44 import Gargantext.Database.Schema.User (getUser, UserLight(..))
  45 import Gargantext.Database.Types.Node (HyperdataDocument(..))
  46 import Gargantext.Database.Types.Node (NodeType(..), NodeId)
  47 import Gargantext.Database.Utils (Cmd)
  48 import Gargantext.Text.Terms (TermType(..))
  49 import Gargantext.Ext.IMT (toSchoolName)
  50 import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
  51 import Gargantext.Prelude
  52 import Gargantext.Text.Parsers (parseDocs, FileFormat)
  53 import System.FilePath (FilePath)
  54 import qualified Data.Map as DM
  55
  56 flowCorpus :: HasNodeError err => FileFormat -> FilePath -> CorpusName -> Cmd err CorpusId
  57 flowCorpus ff fp cName = do
  58   hyperdataDocuments' <- map addUniqIdsDoc <$> liftIO (parseDocs ff fp)
  59   params <- flowInsert NodeCorpus hyperdataDocuments' cName
  60   flowCorpus' NodeCorpus hyperdataDocuments' params
  61
  62
  63 flowInsert :: NodeType -> [HyperdataDocument] -> CorpusName
  64      -> Cmd err ([ReturnId], MasterUserId, MasterCorpusId, UserId, CorpusId)
  65 flowInsert _nt hyperdataDocuments cName = do
  66   let hyperdataDocuments' = map (\h -> ToDbDocument h) hyperdataDocuments
  67
  68   (masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
  69   ids  <- insertDocuments masterUserId masterCorpusId NodeDocument hyperdataDocuments'
  70
  71   (userId, _, userCorpusId) <- subFlowCorpus userArbitrary cName
  72   _ <- add userCorpusId (map reId ids)
  73
  74   pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
  75
  76
  77 flowAnnuaire :: FilePath -> Cmd err ()
  78 flowAnnuaire filePath = do
  79   contacts <- liftIO $ deserialiseImtUsersFromFile filePath
  80   ps <- flowInsertAnnuaire "Annuaire" $ map (\h-> ToDbContact h) $ map addUniqIdsContact contacts
  81   printDebug "length annuaire" ps
  82
  83
  84 flowInsertAnnuaire :: CorpusName -> [ToDbData]
  85                     -> Cmd err ([ReturnId], UserId, CorpusId, UserId, CorpusId)
  86 flowInsertAnnuaire name children = do
  87
  88   (masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
  89   ids  <- insertDocuments masterUserId masterCorpusId NodeContact children
  90
  91   (userId, _, userCorpusId) <- subFlowAnnuaire userArbitrary name
  92   _ <- add userCorpusId (map reId ids)
  93
  94   printDebug "AnnuaireID" userCorpusId
  95
  96   pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
  97
  98
  99 flowCorpus' :: HasNodeError err
 100             => NodeType -> [HyperdataDocument]
 101             -> ([ReturnId], UserId, CorpusId, UserId, CorpusId)
 102             -> Cmd err CorpusId
 103 flowCorpus' NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, userId,userCorpusId) = do
 104 --------------------------------------------------
 105   -- List Ngrams Flow
 106   userListId <- flowListUser userId userCorpusId
 107   printDebug "Working on User ListId : " userListId
 108
 109   let documentsWithId = mergeData (toInserted ids) (toInsert hyperdataDocuments)
 110   -- printDebug "documentsWithId" documentsWithId
 111   docsWithNgrams <- documentIdWithNgrams extractNgramsT documentsWithId
 112   -- printDebug "docsWithNgrams" docsWithNgrams
 113   let maps            = mapNodeIdNgrams docsWithNgrams
 114
 115   -- printDebug "maps" (maps)
 116   indexedNgrams <- indexNgrams maps
 117   -- printDebug "inserted ngrams" indexedNgrams
 118   _             <- insertToNodeNgrams indexedNgrams
 119
 120   listId2    <- flowList masterUserId masterCorpusId indexedNgrams
 121   printDebug "Working on ListId : " listId2
 122   --}
 123 --------------------------------------------------
 124   _ <- mkDashboard userCorpusId userId
 125   _ <- mkGraph     userCorpusId userId
 126
 127   -- Annuaire Flow
 128   -- _ <- mkAnnuaire  rootUserId userId
 129
 130   pure userCorpusId
 131   -- del [corpusId2, corpusId]
 132
 133 flowCorpus' NodeAnnuaire _hyperdataDocuments (_ids,_masterUserId,_masterCorpusId,_userId,_userCorpusId) = undefined
 134 flowCorpus' _ _ _ = undefined
 135
 136
 137 type CorpusName = Text
 138
 139 subFlowCorpus :: Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
 140 subFlowCorpus username cName = do
 141   maybeUserId <- getUser username
 142
 143   let userId = case maybeUserId of
 144         Nothing   -> panic "Error: User does not exist (yet)"
 145         -- mk NodeUser gargantua_id "Node Gargantua"
 146         Just user -> userLight_id user
 147
 148   rootId' <- map _node_id <$> getRoot username
 149
 150   rootId'' <- case rootId' of
 151         []  -> mkRoot username userId
 152         n   -> case length n >= 2 of
 153             True  -> panic "Error: more than 1 userNode / user"
 154             False -> pure rootId'
 155   let rootId = maybe (panic "error rootId") identity (head rootId'')
 156
 157   corpusId'' <- if username == userMaster
 158                   then do
 159                     ns <- getCorporaWithParentId rootId
 160                     pure $ map _node_id ns
 161                   else
 162                     pure []
 163
 164   corpusId' <- if corpusId'' /= []
 165                   then pure corpusId''
 166                   else mkCorpus (Just cName) Nothing rootId userId
 167
 168   let corpusId = maybe (panic "error corpusId") identity (head corpusId')
 169
 170   printDebug "(username, userId, rootId, corpusId)"
 171               (username, userId, rootId, corpusId)
 172   pure (userId, rootId, corpusId)
 173
 174
 175 subFlowAnnuaire :: Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
 176 subFlowAnnuaire username _cName = do
 177   maybeUserId <- getUser username
 178
 179   let userId = case maybeUserId of
 180         Nothing   -> panic "Error: User does not exist (yet)"
 181         -- mk NodeUser gargantua_id "Node Gargantua"
 182         Just user -> userLight_id user
 183
 184   rootId' <- map _node_id <$> getRoot username
 185
 186   rootId'' <- case rootId' of
 187         []  -> mkRoot username userId
 188         n   -> case length n >= 2 of
 189             True  -> panic "Error: more than 1 userNode / user"
 190             False -> pure rootId'
 191   let rootId = maybe (panic "error rootId") identity (head rootId'')
 192
 193   corpusId' <- mkAnnuaire rootId userId
 194
 195   let corpusId = maybe (panic "error corpusId") identity (head corpusId')
 196
 197   printDebug "(username, userId, rootId, corpusId)"
 198               (username, userId, rootId, corpusId)
 199   pure (userId, rootId, corpusId)
 200
 201 ------------------------------------------------------------------------
 202 toInsert :: [HyperdataDocument] -> Map HashId HyperdataDocument
 203 toInsert = DM.fromList . map (\d -> (maybe err identity (_hyperdataDocument_uniqId d), d))
 204   where
 205     err = "Database.Flow.toInsert"
 206
 207 toInserted :: [ReturnId] -> Map HashId ReturnId
 208 toInserted = DM.fromList . map    (\r ->  (reUniqId r, r)    )
 209                          . filter (\r -> reInserted r == True)
 210
 211 data DocumentWithId =
 212      DocumentWithId { documentId   :: !NodeId
 213                     , documentData :: !HyperdataDocument
 214                     } deriving (Show)
 215
 216 mergeData :: Map HashId ReturnId -> Map HashId HyperdataDocument -> [DocumentWithId]
 217 mergeData rs = catMaybes . map toDocumentWithId . DM.toList
 218   where
 219     toDocumentWithId (hash,hpd) =
 220       DocumentWithId <$> fmap reId (lookup hash rs)
 221                      <*> Just hpd
 222
 223 ------------------------------------------------------------------------
 224 data DocumentIdWithNgrams =
 225      DocumentIdWithNgrams
 226      { documentWithId  :: !DocumentWithId
 227      , document_ngrams :: !(Map (NgramsT Ngrams) Int)
 228      } deriving (Show)
 229
 230 -- TODO group terms
 231 extractNgramsT :: HyperdataDocument -> Cmd err (Map (NgramsT Ngrams) Int)
 232 extractNgramsT doc = do
 233
 234   let source    = text2ngrams $ maybe "Nothing" identity $ _hyperdataDocument_source doc
 235   let institutes = map text2ngrams $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))  $ _hyperdataDocument_institutes doc
 236   let authors    = map text2ngrams $ maybe ["Nothing"] (splitOn ", ") $ _hyperdataDocument_authors doc
 237   let leText = catMaybes [_hyperdataDocument_title doc, _hyperdataDocument_abstract doc]
 238   terms' <- map text2ngrams <$> map (intercalate " " . _terms_label) <$> concat <$> liftIO (extractTerms (Multi EN) leText)
 239
 240   pure $ DM.fromList $  [(NgramsT Sources source, 1)]
 241                      <> [(NgramsT Institutes  i' , 1)| i' <- institutes ]
 242                      <> [(NgramsT Authors     a' , 1)| a' <- authors    ]
 243                      <> [(NgramsT NgramsTerms t' , 1)| t' <- terms'     ]
 244
 245
 246
 247 documentIdWithNgrams :: (HyperdataDocument -> Cmd err (Map (NgramsT Ngrams) Int))
 248                      -> [DocumentWithId]   -> Cmd err [DocumentIdWithNgrams]
 249 documentIdWithNgrams f = mapM toDocumentIdWithNgrams
 250   where
 251     toDocumentIdWithNgrams d = do
 252       e <- f $ documentData d
 253       pure $ DocumentIdWithNgrams d e
 254
 255 -- | TODO check optimization
 256 mapNodeIdNgrams :: [DocumentIdWithNgrams] -> Map (NgramsT Ngrams) (Map NodeId Int)
 257 mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
 258   where
 259     xs  = [(ng, [(nId, i)]) | (nId, n2i') <- n2i ds, (ng, i) <- DM.toList n2i']
 260     n2i = map (\d -> ((documentId . documentWithId) d, document_ngrams d))
 261
 262 indexNgrams :: Map (NgramsT Ngrams       ) (Map NodeId Int)
 263   -> Cmd err (Map (NgramsT NgramsIndexed) (Map NodeId Int))
 264 indexNgrams ng2nId = do
 265   terms2id <- insertNgrams (map _ngramsT $ DM.keys ng2nId)
 266   pure $ DM.mapKeys (indexNgramsT terms2id) ng2nId
 267
 268 ------------------------------------------------------------------------
 269 flowList :: HasNodeError err => UserId -> CorpusId -> Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd err ListId
 270 flowList uId cId ngs = do
 271   -- printDebug "ngs:" ngs
 272   lId <- getOrMkList cId uId
 273   --printDebug "ngs" (DM.keys ngs)
 274   -- TODO add stemming equivalence of 2 ngrams
 275   let groupEd = groupNgramsBy (\(NgramsT t1 n1) (NgramsT t2 n2) -> if (((==) t1 t2) && ((==) n1 n2)) then (Just (n1,n2)) else Nothing) ngs
 276   _ <- insertGroups lId groupEd
 277
 278 -- compute Candidate / Map
 279   let lists = ngrams2list ngs
 280   -- printDebug "lists:" lists
 281
 282   is <- insertLists lId lists
 283   printDebug "listNgrams inserted :" is
 284
 285   pure lId
 286
 287 flowListUser :: HasNodeError err => UserId -> CorpusId -> Cmd err Int
 288 flowListUser uId cId = getOrMkList cId uId
 289
 290 ------------------------------------------------------------------------
 291
 292 groupNgramsBy :: (NgramsT NgramsIndexed -> NgramsT NgramsIndexed -> Maybe (NgramsIndexed, NgramsIndexed))
 293               -> Map (NgramsT NgramsIndexed) (Map NodeId Int)
 294               -> Map NgramsIndexed NgramsIndexed
 295 groupNgramsBy isEqual cId = DM.fromList $ catMaybes [ isEqual n1 n2 | n1 <- DM.keys cId, n2 <- DM.keys cId]
 296
 297
 298
 299 -- TODO check: do not insert duplicates
 300 insertGroups :: ListId -> Map NgramsIndexed NgramsIndexed -> Cmd err Int
 301 insertGroups lId ngrs =
 302   insertNodeNgramsNgramsNew [ NodeNgramsNgrams lId ng1 ng2 (Just 1)
 303                             | (ng1, ng2) <- map (both _ngramsId) $ DM.toList ngrs
 304                             , ng1 /= ng2
 305                             ]
 306
 307 ------------------------------------------------------------------------
 308 -- TODO: verify NgramsT lost here
 309 ngrams2list :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> [(ListType,NgramsIndexed)]
 310 ngrams2list = zip (repeat CandidateList) . map (\(NgramsT _lost_t ng) -> ng) . DM.keys
 311
 312 -- | TODO: weight of the list could be a probability
 313 insertLists :: ListId -> [(ListType,NgramsIndexed)] -> Cmd err Int
 314 insertLists lId lngs =
 315   insertNodeNgrams [ NodeNgram Nothing lId ngr (fromIntegral $ listTypeId l) (listTypeId l)
 316                      | (l,ngr) <- map (second _ngramsId) lngs
 317                    ]
 318 ------------------------------------------------------------------------