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 -- TODO-ACCESS:
  12 --   check userId       CanFillUserCorpus   userCorpusId
  13 --   check masterUserId CanFillMasterCorpus masterCorpusId
  14
  15 -- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
  16 -- TODO-EVENTS: InsertedNodes
  17
  18
  19 -}
  20
  21 {-# OPTIONS_GHC -fno-warn-orphans    #-}
  22
  23 {-# LANGUAGE ConstraintKinds         #-}
  24 {-# LANGUAGE RankNTypes              #-}
  25 {-# LANGUAGE ConstrainedClassMethods #-}
  26 {-# LANGUAGE ConstraintKinds         #-}
  27 {-# LANGUAGE DeriveGeneric           #-}
  28 {-# LANGUAGE FlexibleContexts        #-}
  29 {-# LANGUAGE InstanceSigs            #-}
  30 {-# LANGUAGE NoImplicitPrelude       #-}
  31 {-# LANGUAGE OverloadedStrings       #-}
  32
  33 module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
  34     where
  35 import Prelude (String)
  36 import Data.Either
  37 import Debug.Trace (trace)
  38 import Control.Lens ((^.), view, _Just)
  39 import Control.Monad (mapM_)
  40 import Control.Monad.IO.Class (liftIO)
  41 import Data.List (concat)
  42 import Data.Map (Map, lookup, toList)
  43 import Data.Maybe (Maybe(..), catMaybes)
  44 import Data.Monoid
  45 import Data.Text (Text, splitOn, intercalate)
  46 import GHC.Show (Show)
  47 import Gargantext.API.Ngrams (HasRepoVar)
  48 import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams, RepoCmdM)
  49 import Gargantext.Core (Lang(..))
  50 import Gargantext.Core.Types (NodePoly(..), Terms(..))
  51 import Gargantext.Core.Types.Individu (Username)
  52 import Gargantext.Core.Flow
  53 import Gargantext.Core.Types.Main
  54 import Gargantext.Database.Config (userMaster, corpusMasterName)
  55 import Gargantext.Database.Flow.Utils (insertDocNgrams)
  56 import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..))
  57 import Gargantext.Database.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
  58 import Gargantext.Database.Root (getRoot)
  59 import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams,  NgramsType(..), text2ngrams, ngramsTypeId)
  60 import Gargantext.Database.Schema.Node -- (mkRoot, mkCorpus, getOrMkList, mkGraph, {-mkPhylo,-} mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError, NodeError(..), nodeError)
  61 import Gargantext.Database.Schema.User (getUser, UserLight(..))
  62 import Gargantext.Database.TextSearch (searchInDatabase)
  63 import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
  64 import Gargantext.Database.Utils (Cmd, CmdM)
  65 import Gargantext.Ext.IMT (toSchoolName)
  66 import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
  67 import Gargantext.Prelude
  68 import Gargantext.Text.Terms.Eleve (buildTries, toToken)
  69 import Gargantext.Text.List (buildNgramsLists,StopSize(..))
  70 import Gargantext.Text.Corpus.Parsers (parseFile, FileFormat)
  71 import qualified Gargantext.Text.Corpus.API.Isidore as Isidore
  72 import Gargantext.Text.Terms (TermType(..), tt_lang, extractTerms, uniText)
  73 import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
  74 import Gargantext.Prelude.Utils hiding (hash)
  75 import System.FilePath (FilePath)
  76 import qualified Data.List as List
  77 import qualified Data.Map  as Map
  78 import qualified Data.Text as Text
  79 import qualified Gargantext.Database.Node.Document.Add  as Doc  (add)
  80 import qualified Gargantext.Text.Corpus.Parsers.GrandDebat as GD
  81
  82 type FlowCmdM env err m =
  83   ( CmdM     env err m
  84   , RepoCmdM env err m
  85   , HasNodeError err
  86   , HasRepoVar env
  87   )
  88
  89 ------------------------------------------------------------------------
  90
  91 data ApiQuery = ApiIsidoreQuery Text | ApiIsidoreAuth Text
  92 -- | APIs
  93 -- TODO instances
  94 getDataApi :: Lang
  95            -> Maybe Limit
  96            -> ApiQuery
  97            -> IO [HyperdataDocument]
  98 getDataApi lang limit (ApiIsidoreQuery q) = Isidore.get lang limit (Just q) Nothing
  99 getDataApi lang limit (ApiIsidoreAuth  q) = Isidore.get lang limit Nothing  (Just q)
 100
 101
 102 flowCorpusApi :: ( FlowCmdM env err m)
 103            => Username -> Either CorpusName [CorpusId]
 104            -> TermType Lang
 105            -> Maybe Limit
 106            -> ApiQuery
 107            -> m CorpusId
 108 flowCorpusApi u n tt l q = do
 109   docs <- liftIO $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
 110   flowCorpus u n tt docs
 111
 112 ------------------------------------------------------------------------
 113
 114 flowAnnuaire :: FlowCmdM env err m
 115              => Username -> Either CorpusName [CorpusId] -> (TermType Lang) -> FilePath -> m AnnuaireId
 116 flowAnnuaire u n l filePath = do
 117   docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
 118   flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
 119
 120
 121 flowCorpusDebat :: FlowCmdM env err m
 122             => Username -> Either CorpusName [CorpusId]
 123             -> Limit -> FilePath
 124             -> m CorpusId
 125 flowCorpusDebat u n l fp = do
 126   docs <- liftIO ( splitEvery 500
 127                  <$> take l
 128                  <$> readFile' fp
 129                  :: IO [[GD.GrandDebatReference ]]
 130                  )
 131   flowCorpus u n (Multi FR) (map (map toHyperdataDocument) docs)
 132
 133 flowCorpusFile :: FlowCmdM env err m
 134            => Username -> Either CorpusName [CorpusId]
 135            -> Limit -- Limit the number of docs (for dev purpose)
 136            -> TermType Lang -> FileFormat -> FilePath
 137            -> m CorpusId
 138 flowCorpusFile u n l la ff fp = do
 139   docs <- liftIO ( splitEvery 500
 140                  <$> take l
 141                  <$> parseFile ff fp
 142                  )
 143   flowCorpus u n la (map (map toHyperdataDocument) docs)
 144
 145 -- TODO query with complex query
 146 flowCorpusSearchInDatabase :: FlowCmdM env err m
 147           => Username -> Lang -> Text -> m CorpusId
 148 flowCorpusSearchInDatabase u la q = do
 149   (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster (Left "") (Nothing :: Maybe HyperdataCorpus)
 150   ids <-  map fst <$> searchInDatabase cId (stemIt q)
 151   flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
 152
 153
 154 flowCorpusSearchInDatabaseApi :: FlowCmdM env err m
 155           => Username -> Lang -> Text -> m CorpusId
 156 flowCorpusSearchInDatabaseApi u la q = do
 157   (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster (Left "") (Nothing :: Maybe HyperdataCorpus)
 158   ids <-  map fst <$> searchInDatabase cId (stemIt q)
 159   flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
 160
 161 ------------------------------------------------------------------------
 162 -- | TODO improve the needed type to create/update a corpus
 163 data UserInfo = Username Text
 164               | UserId   NodeId
 165 data CorpusInfo = CorpusName Lang Text
 166                 | CorpusId   Lang NodeId
 167
 168
 169 flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)
 170      => Maybe c -> Username -> Either CorpusName [CorpusId] -> TermType Lang -> [[a]] -> m CorpusId
 171 flow c u cn la docs = do
 172   ids <- mapM (insertMasterDocs c la ) docs
 173   flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
 174
 175 flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
 176      => Username -> Either CorpusName [CorpusId] -> TermType Lang -> [[a]] -> m CorpusId
 177 flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
 178
 179 ------------------------------------------------------------------------
 180 flowCorpusUser :: (FlowCmdM env err m, MkCorpus c)
 181                => Lang -> Username -> Either CorpusName [CorpusId] -> Maybe c -> [NodeId] -> m CorpusId
 182 flowCorpusUser l userName corpusName ctype ids = do
 183   -- User Flow
 184   (userId, _rootId, userCorpusId) <- getOrMkRootWithCorpus userName corpusName ctype
 185   -- TODO: check if present already, ignore
 186   _ <- Doc.add userCorpusId ids
 187   tId <- mkNode NodeTexts userCorpusId userId
 188
 189   printDebug "Node Text Id" tId
 190
 191   -- User List Flow
 192   --{-
 193   (_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster (Left "") ctype
 194   ngs         <- buildNgramsLists l 2 3 (StopSize 3) userCorpusId masterCorpusId
 195   userListId  <- flowList userId userCorpusId ngs
 196   printDebug "userListId" userListId
 197   -- User Graph Flow
 198   _ <- mkDashboard userCorpusId userId
 199   _ <- mkGraph  userCorpusId userId
 200   --_ <- mkPhylo  userCorpusId userId
 201   --}
 202
 203
 204   -- Annuaire Flow
 205   -- _ <- mkAnnuaire  rootUserId userId
 206   pure userCorpusId
 207
 208
 209 insertMasterDocs :: ( FlowCmdM env err m
 210                     , FlowCorpus a
 211                     , MkCorpus   c
 212                     )
 213                  => Maybe c -> TermType Lang -> [a] -> m [DocId]
 214 insertMasterDocs c lang hs  =  do
 215   (masterUserId, _, masterCorpusId) <- getOrMkRootWithCorpus userMaster (Left corpusMasterName) c
 216
 217   -- TODO Type NodeDocumentUnicised
 218   let hs' = map addUniqId hs
 219   ids <- insertDb masterUserId masterCorpusId hs'
 220   let documentsWithId = mergeData (toInserted ids) (Map.fromList $ map viewUniqId' hs')
 221
 222   let
 223     fixLang (Unsupervised l n s m) = Unsupervised l n s m'
 224       where
 225         m' = case m of
 226           Nothing -> trace ("buildTries here" :: String)
 227                   $ Just
 228                   $ buildTries n ( fmap toToken $ uniText
 229                                                 $ Text.intercalate " . "
 230                                                 $ List.concat
 231                                                 $ map hasText documentsWithId
 232                                  )
 233           just_m -> just_m
 234     fixLang l = l
 235
 236     lang' = fixLang lang
 237   -- maps :: IO Map Ngrams (Map NgramsType (Map NodeId Int))
 238   maps <- mapNodeIdNgrams <$> documentIdWithNgrams (extractNgramsT lang') documentsWithId
 239   terms2id <- insertNgrams $ Map.keys maps
 240   let indexedNgrams = Map.mapKeys (indexNgrams terms2id) maps
 241
 242   lId <- getOrMkList masterCorpusId masterUserId
 243   _   <- insertDocNgrams lId indexedNgrams
 244   pure $ map reId ids
 245
 246
 247
 248 type CorpusName = Text
 249
 250 getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
 251               => Username -> Either CorpusName [CorpusId] -> Maybe a
 252               -> Cmd err (UserId, RootId, CorpusId)
 253 getOrMkRootWithCorpus username cName c = do
 254   maybeUserId <- getUser username
 255   userId <- case maybeUserId of
 256         Nothing   -> nodeError NoUserFound
 257         Just user -> pure $ userLight_id user
 258
 259   rootId' <- map _node_id <$> getRoot username
 260
 261   rootId'' <- case rootId' of
 262         []  -> mkRoot username userId
 263         n   -> case length n >= 2 of
 264             True  -> nodeError ManyNodeUsers
 265             False -> pure rootId'
 266
 267   rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
 268
 269   corpusId'' <- if username == userMaster
 270                   then do
 271                     ns <- getCorporaWithParentId rootId
 272                     pure $ map _node_id ns
 273                   else
 274                     pure $ fromRight [] cName
 275
 276   corpusId' <- if corpusId'' /= []
 277                   then pure corpusId''
 278                   else mk (Just $ fromLeft "Default" cName) c rootId userId
 279
 280   corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
 281
 282   pure (userId, rootId, corpusId)
 283
 284
 285 ------------------------------------------------------------------------
 286
 287
 288 viewUniqId' :: UniqId a => a -> (HashId, a)
 289 viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
 290       where
 291         err = panic "[ERROR] Database.Flow.toInsert"
 292
 293
 294 toInserted :: [ReturnId] -> Map HashId ReturnId
 295 toInserted = Map.fromList . map    (\r ->  (reUniqId r, r)    )
 296                          . filter (\r -> reInserted r == True)
 297
 298 data DocumentWithId a = DocumentWithId
 299   { documentId   :: !NodeId
 300   , documentData :: !a
 301   } deriving (Show)
 302
 303 instance HasText a => HasText (DocumentWithId a)
 304   where
 305     hasText (DocumentWithId _ a) = hasText a
 306
 307 mergeData :: Map HashId ReturnId
 308           -> Map HashId a
 309           -> [DocumentWithId a]
 310 mergeData rs = catMaybes . map toDocumentWithId . Map.toList
 311   where
 312     toDocumentWithId (hash,hpd) =
 313       DocumentWithId <$> fmap reId (lookup hash rs)
 314                      <*> Just hpd
 315
 316 ------------------------------------------------------------------------
 317 data DocumentIdWithNgrams a = DocumentIdWithNgrams
 318   { documentWithId  :: !(DocumentWithId a)
 319   , document_ngrams :: !(Map Ngrams (Map NgramsType Int))
 320   } deriving (Show)
 321
 322
 323 instance HasText HyperdataContact
 324   where
 325     hasText = undefined
 326
 327 instance ExtractNgramsT HyperdataContact
 328   where
 329     extractNgramsT l hc = filterNgramsT 255 <$> extract l hc
 330       where
 331         extract :: TermType Lang -> HyperdataContact
 332                 -> Cmd err (Map Ngrams (Map NgramsType Int))
 333         extract _l hc' = do
 334           let authors = map text2ngrams
 335                      $ maybe ["Nothing"] (\a -> [a])
 336                      $ view (hc_who . _Just . cw_lastName) hc'
 337
 338           pure $ Map.fromList $ [(a', Map.singleton Authors     1) | a' <- authors    ]
 339
 340 instance HasText HyperdataDocument
 341   where
 342     hasText h = catMaybes [ _hyperdataDocument_title    h
 343                           , _hyperdataDocument_abstract h
 344                           ]
 345
 346 instance ExtractNgramsT HyperdataDocument
 347   where
 348     extractNgramsT :: TermType Lang -> HyperdataDocument -> Cmd err (Map Ngrams (Map NgramsType Int))
 349     extractNgramsT lang hd = filterNgramsT 255 <$> extractNgramsT' lang hd
 350       where
 351         extractNgramsT' :: TermType Lang -> HyperdataDocument
 352                        -> Cmd err (Map Ngrams (Map NgramsType Int))
 353         extractNgramsT' lang' doc = do
 354           let source    = text2ngrams
 355                         $ maybe "Nothing" identity
 356                         $ _hyperdataDocument_source doc
 357
 358               institutes = map text2ngrams
 359                          $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
 360                          $ _hyperdataDocument_institutes doc
 361
 362               authors    = map text2ngrams
 363                          $ maybe ["Nothing"] (splitOn ", ")
 364                          $ _hyperdataDocument_authors doc
 365
 366           terms' <- map text2ngrams
 367                  <$> map (intercalate " " . _terms_label)
 368                  <$> concat
 369                  <$> liftIO (extractTerms lang' $ hasText doc)
 370
 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'     ]
 375
 376
 377 filterNgramsT :: Int -> Map Ngrams (Map NgramsType Int)
 378                      -> Map Ngrams (Map NgramsType Int)
 379 filterNgramsT s ms = Map.fromList $ map (\a -> filter' s a) $ Map.toList ms
 380   where
 381     filter' s' (ng@(Ngrams t n),y) = case (Text.length t) < s' of
 382           True  -> (ng,y)
 383           False -> (Ngrams (Text.take s' t) n , y)
 384
 385
 386 documentIdWithNgrams :: HasNodeError err
 387                      => (a
 388                      -> Cmd err (Map Ngrams (Map NgramsType Int)))
 389                      -> [DocumentWithId a]
 390                      -> Cmd err [DocumentIdWithNgrams a]
 391 documentIdWithNgrams f = mapM toDocumentIdWithNgrams
 392   where
 393     toDocumentIdWithNgrams d = do
 394       e <- f $ documentData         d
 395       pure   $ DocumentIdWithNgrams d e
 396
 397
 398 -- FLOW LIST
 399 -- | TODO check optimization
 400 mapNodeIdNgrams :: [DocumentIdWithNgrams a]
 401                 -> Map Ngrams (Map NgramsType (Map NodeId Int))
 402 mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
 403   where
 404     f :: DocumentIdWithNgrams a
 405       -> Map Ngrams (Map NgramsType (Map NodeId Int))
 406     f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
 407       where
 408         nId = documentId $ documentWithId d
 409
 410 ------------------------------------------------------------------------
 411 listInsert :: FlowCmdM env err m
 412              => ListId -> Map NgramsType [NgramsElement]
 413              -> m ()
 414 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 415                              -> putListNgrams lId typeList ngElmts
 416                              ) $ toList ngs
 417
 418 flowList :: FlowCmdM env err m => UserId -> CorpusId
 419          -> Map NgramsType [NgramsElement]
 420          -> m ListId
 421 flowList uId cId ngs = do
 422   lId <- getOrMkList cId uId
 423   printDebug "listId flowList" lId
 424   listInsert lId ngs
 425   --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
 426   pure lId
 427