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