src/Gargantext/Database/Action/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 -- TODO-ACCESS:
  11 --   check userId       CanFillUserCorpus   userCorpusId
  12 --   check masterUserId CanFillMasterCorpus masterCorpusId
  13
  14 -- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
  15 -- TODO-EVENTS: InsertedNodes
  16 -}
  17
  18 {-# OPTIONS_GHC -fno-warn-orphans #-}
  19
  20 {-# LANGUAGE ConstraintKinds         #-}
  21 {-# LANGUAGE ConstrainedClassMethods #-}
  22 {-# LANGUAGE ConstraintKinds         #-}
  23 {-# LANGUAGE InstanceSigs            #-}
  24 {-# LANGUAGE TemplateHaskell         #-}
  25
  26 module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
  27   ( FlowCmdM
  28   , getDataText
  29   , flowDataText
  30   , flow
  31
  32   , flowCorpusFile
  33   , flowCorpus
  34   , flowAnnuaire
  35   , insertMasterDocs
  36
  37   , getOrMkRoot
  38   , getOrMk_RootWithCorpus
  39   , TermType(..)
  40   , DataOrigin(..)
  41   , allDataOrigins
  42
  43   , do_api
  44   )
  45     where
  46
  47 import Control.Lens ((^.), view, _Just, makeLenses)
  48 import Data.Aeson.TH (deriveJSON)
  49 import Data.Either
  50 import Data.List (concat)
  51 import qualified Data.Map as Map
  52 import Data.Map (Map, lookup)
  53 import Data.Maybe (catMaybes)
  54 import Data.Monoid
  55 import Data.Swagger
  56 import Data.Text (splitOn, intercalate)
  57 import Data.Traversable (traverse)
  58 import Data.Tuple.Extra (first, second)
  59 import GHC.Generics (Generic)
  60 import System.FilePath (FilePath)
  61
  62 import Gargantext.Core (Lang(..))
  63 import Gargantext.Core.Ext.IMT (toSchoolName)
  64 import Gargantext.Core.Ext.IMTUser (deserialiseImtUsersFromFile)
  65 import Gargantext.Core.Flow.Types
  66 import Gargantext.Core.Text
  67 import Gargantext.Core.Text.List.Group.WithStem (StopSize(..), GroupParams(..))
  68 import Gargantext.Core.Text.Corpus.Parsers (parseFile, FileFormat)
  69 import Gargantext.Core.Text.List (buildNgramsLists)
  70 import Gargantext.Core.Text.Terms
  71 import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
  72 import Gargantext.Core.Types (Terms(..))
  73 import Gargantext.Core.Types.Individu (User(..))
  74 import Gargantext.Core.Types.Main
  75 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
  76 import Gargantext.Database.Action.Flow.List
  77 import Gargantext.Database.Action.Flow.Types
  78 import Gargantext.Database.Action.Flow.Utils (insertDocNgrams)
  79 import Gargantext.Database.Action.Search (searchDocInDatabase)
  80 import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
  81 import Gargantext.Database.Admin.Types.Hyperdata
  82 import Gargantext.Database.Admin.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
  83 import Gargantext.Database.Prelude
  84 import Gargantext.Database.Query.Table.Ngrams
  85 import Gargantext.Database.Query.Table.Node
  86 import Gargantext.Database.Query.Table.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
  87 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
  88 import Gargantext.Database.Query.Table.NodeNgrams (listInsertDb , getCgramsId)
  89 import Gargantext.Database.Query.Table.NodeNodeNgrams2
  90 import Gargantext.Database.Query.Tree.Root (getOrMkRoot, getOrMk_RootWithCorpus)
  91 import Gargantext.Database.Schema.Node (NodePoly(..))
  92 import Gargantext.Prelude
  93 import Gargantext.Prelude.Crypto.Hash (Hash)
  94 import qualified Gargantext.Core.Text.Corpus.API as API
  95 import qualified Gargantext.Database.Query.Table.Node.Document.Add  as Doc  (add)
  96
  97 ------------------------------------------------------------------------
  98 -- TODO use internal with API name (could be old data)
  99 data DataOrigin = InternalOrigin { _do_api :: API.ExternalAPIs }
 100                 | ExternalOrigin { _do_api :: API.ExternalAPIs }
 101                -- TODO Web
 102   deriving (Generic, Eq)
 103
 104 makeLenses ''DataOrigin
 105 deriveJSON (unPrefix "_do_") ''DataOrigin
 106 instance ToSchema DataOrigin where
 107   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_do_")
 108
 109 allDataOrigins :: [DataOrigin]
 110 allDataOrigins = map InternalOrigin API.externalAPIs
 111               <> map ExternalOrigin API.externalAPIs
 112
 113 ---------------
 114 data DataText = DataOld ![NodeId]
 115               | DataNew ![[HyperdataDocument]]
 116
 117 -- TODO use the split parameter in config file
 118 getDataText :: FlowCmdM env err m
 119             => DataOrigin
 120             -> TermType Lang
 121             -> API.Query
 122             -> Maybe API.Limit
 123             -> m DataText
 124 getDataText (ExternalOrigin api) la q li = liftBase $ DataNew
 125                                   <$> splitEvery 500
 126                                   <$> API.get api (_tt_lang la) q li
 127
 128 getDataText (InternalOrigin _) _la q _li = do
 129   (_masterUserId, _masterRootId, cId) <- getOrMk_RootWithCorpus
 130                                            (UserName userMaster)
 131                                            (Left "")
 132                                            (Nothing :: Maybe HyperdataCorpus)
 133   ids <-  map fst <$> searchDocInDatabase cId (stemIt q)
 134   pure $ DataOld ids
 135
 136 -------------------------------------------------------------------------------
 137 flowDataText :: ( FlowCmdM env err m
 138                 )
 139                 => User
 140                 -> DataText
 141                 -> TermType Lang
 142                 -> CorpusId
 143                 -> m CorpusId
 144 flowDataText u (DataOld ids) tt cid = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids
 145   where
 146     corpusType = (Nothing :: Maybe HyperdataCorpus)
 147 flowDataText u (DataNew txt) tt cid = flowCorpus u (Right [cid]) tt txt
 148
 149 ------------------------------------------------------------------------
 150 -- TODO use proxy
 151 flowAnnuaire :: (FlowCmdM env err m)
 152              => User
 153              -> Either CorpusName [CorpusId]
 154              -> (TermType Lang)
 155              -> FilePath
 156              -> m AnnuaireId
 157 flowAnnuaire u n l filePath = do
 158   docs <- liftBase $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
 159   flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
 160
 161 ------------------------------------------------------------------------
 162 flowCorpusFile :: (FlowCmdM env err m)
 163            => User
 164            -> Either CorpusName [CorpusId]
 165            -> Limit -- Limit the number of docs (for dev purpose)
 166            -> TermType Lang -> FileFormat -> FilePath
 167            -> m CorpusId
 168 flowCorpusFile u n l la ff fp = do
 169   docs <- liftBase ( splitEvery 500
 170                  <$> take l
 171                  <$> parseFile ff fp
 172                  )
 173   flowCorpus u n la (map (map toHyperdataDocument) docs)
 174
 175 ------------------------------------------------------------------------
 176 -- | TODO improve the needed type to create/update a corpus
 177 -- (For now, Either is enough)
 178 flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
 179            => User
 180            -> Either CorpusName [CorpusId]
 181            -> TermType Lang
 182            -> [[a]]
 183            -> m CorpusId
 184 flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
 185
 186
 187 flow :: ( FlowCmdM env err m
 188         , FlowCorpus a
 189         , MkCorpus c
 190         )
 191         => Maybe c
 192         -> User
 193         -> Either CorpusName [CorpusId]
 194         -> TermType Lang
 195         -> [[a]]
 196         -> m CorpusId
 197 flow c u cn la docs = do
 198   -- TODO if public insertMasterDocs else insertUserDocs
 199   ids <- traverse (insertMasterDocs c la) docs
 200   flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
 201
 202 ------------------------------------------------------------------------
 203 flowCorpusUser :: ( FlowCmdM env err m
 204                   , MkCorpus c
 205                   )
 206                => Lang
 207                -> User
 208                -> Either CorpusName [CorpusId]
 209                -> Maybe c
 210                -> [NodeId]
 211                -> m CorpusId
 212 flowCorpusUser l user corpusName ctype ids = do
 213   -- User Flow
 214   (userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus user corpusName ctype
 215   -- NodeTexts is first
 216   _tId <- insertDefaultNode NodeTexts userCorpusId userId
 217   -- printDebug "NodeTexts: " tId
 218
 219   -- NodeList is second
 220   listId <- getOrMkList userCorpusId userId
 221   -- _cooc  <- insertDefaultNode NodeListCooc listId userId
 222   -- TODO: check if present already, ignore
 223   _ <- Doc.add userCorpusId ids
 224
 225   -- printDebug "Node Text Ids:" tId
 226
 227   -- User List Flow
 228   (masterUserId, _masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left "") ctype
 229   ngs         <- buildNgramsLists user (GroupParams l 2 3 (StopSize 3)) userCorpusId masterCorpusId
 230   _userListId <- flowList_DbRepo listId ngs
 231   _mastListId <- getOrMkList masterCorpusId masterUserId
 232   -- _ <- insertOccsUpdates userCorpusId mastListId
 233   -- printDebug "userListId" userListId
 234   -- User Graph Flow
 235   _ <- insertDefaultNode NodeDashboard userCorpusId userId
 236   _ <- insertDefaultNode NodeGraph     userCorpusId userId
 237   --_ <- mkPhylo  userCorpusId userId
 238   -- Annuaire Flow
 239   -- _ <- mkAnnuaire  rootUserId userId
 240   pure userCorpusId
 241
 242
 243 insertMasterDocs :: ( FlowCmdM env err m
 244                     , FlowCorpus a
 245                     , MkCorpus   c
 246                     )
 247                  => Maybe c
 248                  -> TermType Lang
 249                  -> [a]
 250                  -> m [DocId]
 251 insertMasterDocs c lang hs  =  do
 252   (masterUserId, _, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left corpusMasterName) c
 253   (ids', documentsWithId) <- insertDocs masterUserId masterCorpusId (map (toNode masterUserId masterCorpusId) hs )
 254   _ <- Doc.add masterCorpusId ids'
 255   -- TODO
 256   -- create a corpus with database name (CSV or PubMed)
 257   -- add documents to the corpus (create node_node link)
 258   -- this will enable global database monitoring
 259
 260   -- maps :: IO Map Ngrams (Map NgramsType (Map NodeId Int))
 261   mapNgramsDocs <- mapNodeIdNgrams <$> documentIdWithNgrams (extractNgramsT $ withLang lang documentsWithId) documentsWithId
 262
 263   terms2id <- insertNgrams $ Map.keys mapNgramsDocs
 264   -- to be removed
 265   let indexedNgrams = Map.mapKeys (indexNgrams terms2id) mapNgramsDocs
 266
 267   -- new
 268   lId      <- getOrMkList masterCorpusId masterUserId
 269   mapCgramsId <- listInsertDb lId toNodeNgramsW'
 270                 $ map (first _ngramsTerms . second Map.keys)
 271                 $ Map.toList mapNgramsDocs
 272   -- insertDocNgrams
 273   _return <- insertNodeNodeNgrams2
 274            $ catMaybes [ NodeNodeNgrams2 <$> Just nId
 275                                          <*> getCgramsId mapCgramsId ngrams_type (_ngramsTerms terms'')
 276                                          <*> Just (fromIntegral w :: Double)
 277                        | (terms'', mapNgramsTypes) <- Map.toList mapNgramsDocs
 278                        , (ngrams_type, mapNodeIdWeight) <- Map.toList mapNgramsTypes
 279                        , (nId, w) <- Map.toList mapNodeIdWeight
 280                        ]
 281
 282   -- _cooc <- insertDefaultNode NodeListCooc lId masterUserId
 283   -- to be removed
 284   _   <- insertDocNgrams lId indexedNgrams
 285   pure ids'
 286
 287 ------------------------------------------------------------------------
 288 -- TODO Type NodeDocumentUnicised
 289 insertDocs :: ( FlowCmdM env err m
 290               -- , FlowCorpus a
 291               , FlowInsertDB a
 292               )
 293               => UserId
 294               -> CorpusId
 295               -> [a]
 296               -> m ([DocId], [DocumentWithId a])
 297 insertDocs uId cId hs = do
 298   let docs = map addUniqId hs
 299   newIds <- insertDb uId cId docs
 300   -- printDebug "newIds" newIds
 301   let
 302     newIds' = map reId newIds
 303     documentsWithId = mergeData (toInserted newIds) (Map.fromList $ map viewUniqId' docs)
 304   _ <- Doc.add cId newIds'
 305   pure (newIds', documentsWithId)
 306
 307
 308
 309 ------------------------------------------------------------------------
 310 viewUniqId' :: UniqId a
 311             => a
 312             -> (Hash, a)
 313 viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
 314       where
 315         err = panic "[ERROR] Database.Flow.toInsert"
 316
 317
 318 toInserted :: [ReturnId]
 319            -> Map Hash ReturnId
 320 toInserted =
 321   Map.fromList . map    (\r -> (reUniqId r, r)     )
 322                . filter (\r -> reInserted r == True)
 323
 324 mergeData :: Map Hash ReturnId
 325           -> Map Hash a
 326           -> [DocumentWithId a]
 327 mergeData rs = catMaybes . map toDocumentWithId . Map.toList
 328   where
 329     toDocumentWithId (sha,hpd) =
 330       DocumentWithId <$> fmap reId (lookup sha rs)
 331                      <*> Just hpd
 332
 333 ------------------------------------------------------------------------
 334 instance HasText HyperdataContact
 335   where
 336     hasText = undefined
 337 ------------------------------------------------------------------------
 338 ------------------------------------------------------------------------
 339 documentIdWithNgrams :: HasNodeError err
 340                      => (a
 341                      -> Cmd err (Map Ngrams (Map NgramsType Int)))
 342                      -> [DocumentWithId a]
 343                      -> Cmd err [DocumentIdWithNgrams a]
 344 documentIdWithNgrams f = traverse toDocumentIdWithNgrams
 345   where
 346     toDocumentIdWithNgrams d = do
 347       e <- f $ documentData         d
 348       pure   $ DocumentIdWithNgrams d e
 349
 350 ------------------------------------------------------------------------
 351 instance ExtractNgramsT HyperdataContact
 352   where
 353     extractNgramsT l hc = filterNgramsT 255 <$> extract l hc
 354       where
 355         extract :: TermType Lang -> HyperdataContact
 356                 -> Cmd err (Map Ngrams (Map NgramsType Int))
 357         extract _l hc' = do
 358           let authors = map text2ngrams
 359                      $ maybe ["Nothing"] (\a -> [a])
 360                      $ view (hc_who . _Just . cw_lastName) hc'
 361
 362           pure $ Map.fromList $ [(a', Map.singleton Authors     1) | a' <- authors    ]
 363
 364 instance HasText HyperdataDocument
 365   where
 366     hasText h = catMaybes [ _hd_title    h
 367                           , _hd_abstract h
 368                           ]
 369
 370
 371 instance ExtractNgramsT HyperdataDocument
 372   where
 373     extractNgramsT :: TermType Lang
 374                    -> HyperdataDocument
 375                    -> Cmd err (Map Ngrams (Map NgramsType Int))
 376     extractNgramsT lang hd = filterNgramsT 255 <$> extractNgramsT' lang hd
 377       where
 378         extractNgramsT' :: TermType Lang
 379                         -> HyperdataDocument
 380                        -> Cmd err (Map Ngrams (Map NgramsType Int))
 381         extractNgramsT' lang' doc = do
 382           let source    = text2ngrams
 383                         $ maybe "Nothing" identity
 384                         $ _hd_source doc
 385
 386               institutes = map text2ngrams
 387                          $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
 388                          $ _hd_institutes doc
 389
 390               authors    = map text2ngrams
 391                          $ maybe ["Nothing"] (splitOn ", ")
 392                          $ _hd_authors doc
 393
 394           terms' <- map text2ngrams
 395                  <$> map (intercalate " " . _terms_label)
 396                  <$> concat
 397                  <$> liftBase (extractTerms lang' $ hasText doc)
 398
 399           pure $ Map.fromList $  [(source, Map.singleton Sources 1)]
 400                              <> [(i', Map.singleton Institutes  1) | i' <- institutes ]
 401                              <> [(a', Map.singleton Authors     1) | a' <- authors    ]
 402                              <> [(t', Map.singleton NgramsTerms 1) | t' <- terms'     ]
 403
 404 instance (ExtractNgramsT a, HasText a) => ExtractNgramsT (Node a)
 405   where
 406     extractNgramsT l (Node _ _ _ _ _ _ _ h) = extractNgramsT l h
 407
 408 instance HasText a => HasText (Node a)
 409   where
 410     hasText (Node _ _ _ _ _ _ _ h) = hasText h
 411
 412