src/Gargantext/API/Node/Corpus/New.hs

   1 {-|
   2 Module      : Gargantext.API.Node.Corpus.New
   3 Description : New corpus API
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 New corpus means either:
  11 - new corpus
  12 - new data in existing corpus
  13 -}
  14
  15 {-# LANGUAGE TemplateHaskell    #-}
  16 {-# LANGUAGE TypeOperators      #-}
  17
  18 module Gargantext.API.Node.Corpus.New
  19       where
  20
  21
  22 import Conduit
  23 import Control.Lens hiding (elements, Empty)
  24 import Data.Aeson
  25 import Data.Aeson.TH (deriveJSON)
  26 import qualified Data.ByteString.Base64 as BSB64
  27 import Data.Either
  28 import Data.Maybe (fromMaybe)
  29 import Data.Swagger
  30 import Data.Text (Text)
  31 import qualified Data.Text as T
  32 import GHC.Generics (Generic)
  33 import Servant
  34 import Servant.Job.Utils (jsonOptions)
  35 -- import Servant.Multipart
  36 import qualified Data.Text.Encoding as TE
  37 -- import Test.QuickCheck (elements)
  38 import Test.QuickCheck.Arbitrary
  39
  40 import Gargantext.Prelude
  41
  42 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs, ScraperEvent(..), scst_events)
  43 import Gargantext.API.Admin.Types (HasSettings)
  44 import Gargantext.API.Job (addEvent, jobLogSuccess, jobLogFailTotal, jobLogFailTotalWithMessage)
  45 import Gargantext.API.Node.Corpus.New.File
  46 import Gargantext.API.Node.Corpus.Searx
  47 import Gargantext.API.Node.Corpus.Types
  48 import Gargantext.API.Node.Types
  49 import Gargantext.Core (Lang(..){-, allLangs-})
  50 import Gargantext.Core.Text.List.Social (FlowSocialListWith(..))
  51 import qualified Gargantext.Core.Text.Corpus.API as API
  52 import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileFormat(..), parseFormat)
  53 import Gargantext.Core.Types.Individu (User(..))
  54 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
  55 import Gargantext.Database.Action.Flow (flowCorpus, getDataText, flowDataText, TermType(..){-, allDataOrigins-})
  56 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  57 import Gargantext.Database.Action.Mail (sendMail)
  58 import Gargantext.Database.Action.Node (mkNodeWithParent)
  59 import Gargantext.Database.Action.User (getUserId)
  60 import Gargantext.Database.Admin.Types.Hyperdata
  61 import Gargantext.Database.Admin.Types.Node (CorpusId, NodeType(..), UserId)
  62 import Gargantext.Database.Prelude (hasConfig)
  63 import Gargantext.Database.Query.Table.Node (getNodeWith)
  64 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  65 import Gargantext.Database.Schema.Node (node_hyperdata)
  66 import qualified Gargantext.Database.GargDB as GargDB
  67 import Gargantext.Prelude.Config (gc_max_docs_parsers)
  68 ------------------------------------------------------------------------
  69 {-
  70 data Query = Query { query_query      :: Text
  71                    , query_node_id    :: Int
  72                    , query_lang       :: Lang
  73                    , query_databases  :: [DataOrigin]
  74                    }
  75                    deriving (Eq, Generic)
  76
  77 deriveJSON (unPrefix "query_") 'Query
  78
  79 instance Arbitrary Query where
  80     arbitrary = elements [ Query q n la fs
  81                          | q <- ["honeybee* AND collapse"
  82                                 ,"covid 19"
  83                                 ]
  84                          , n <- [0..10]
  85                          , la <- allLangs
  86                          , fs <- take 3 $ repeat allDataOrigins
  87                          ]
  88
  89 instance ToSchema Query where
  90   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
  91 -}
  92
  93 ------------------------------------------------------------------------
  94
  95 {-
  96 type Api = PostApi
  97         :<|> GetApi
  98
  99 type PostApi = Summary "New Corpus endpoint"
 100              :> ReqBody '[JSON] Query
 101              :> Post    '[JSON] CorpusId
 102 type GetApi = Get '[JSON] ApiInfo
 103 -}
 104
 105 -- | TODO manage several apis
 106 -- TODO-ACCESS
 107 -- TODO this is only the POST
 108 {-
 109 api :: (FlowCmdM env err m) => UserId -> Query -> m CorpusId
 110 api uid (Query q _ as) = do
 111   cId <- case head as of
 112     Nothing      -> flowCorpusSearchInDatabase (UserDBId uid) EN q
 113     Just API.All -> flowCorpusSearchInDatabase (UserDBId uid) EN q
 114     Just a   -> do
 115       docs <- liftBase $ API.get a q (Just 1000)
 116       cId' <- flowCorpus (UserDBId uid) (Left q) (Multi EN) [docs]
 117       pure cId'
 118
 119   pure cId
 120 -}
 121
 122 ------------------------------------------------
 123 -- TODO use this route for Client implementation
 124 data ApiInfo = ApiInfo { api_info :: [API.ExternalAPIs]}
 125   deriving (Generic)
 126 instance Arbitrary ApiInfo where
 127   arbitrary = ApiInfo <$> arbitrary
 128
 129 deriveJSON (unPrefix "") 'ApiInfo
 130
 131 instance ToSchema ApiInfo
 132
 133 info :: FlowCmdM env err m => UserId -> m ApiInfo
 134 info _u = pure $ ApiInfo API.externalAPIs
 135
 136 ------------------------------------------------------------------------
 137 ------------------------------------------------------------------------
 138 data WithQuery = WithQuery
 139   { _wq_query        :: !Text
 140   , _wq_databases    :: !Database
 141   , _wq_datafield    :: !(Maybe Datafield)
 142   , _wq_lang         :: !Lang
 143   , _wq_node_id      :: !Int
 144   , _wq_flowListWith :: !FlowSocialListWith
 145   }
 146   deriving Generic
 147
 148 makeLenses ''WithQuery
 149 instance FromJSON WithQuery where
 150   parseJSON = genericParseJSON $ jsonOptions "_wq_"
 151 instance ToJSON WithQuery where
 152   toJSON = genericToJSON $ jsonOptions "_wq_"
 153 instance ToSchema WithQuery where
 154   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wq_")
 155
 156 ------------------------------------------------------------------------
 157
 158 type AddWithQuery = Summary "Add with Query to corpus endpoint"
 159    :> "corpus"
 160      :> Capture "corpus_id" CorpusId
 161    :> "query"
 162      :> AsyncJobs JobLog '[JSON] WithQuery JobLog
 163
 164 {-
 165 type AddWithFile = Summary "Add with MultipartData to corpus endpoint"
 166    :> "corpus"
 167      :> Capture "corpus_id" CorpusId
 168    :> "add"
 169    :> "file"
 170      :> MultipartForm Mem (MultipartData Mem)
 171      :> QueryParam "fileType"  FileType
 172    :> "async"
 173      :> AsyncJobs JobLog '[JSON] () JobLog
 174 -}
 175
 176
 177 ------------------------------------------------------------------------
 178 -- TODO WithQuery also has a corpus id
 179 addToCorpusWithQuery :: FlowCmdM env err m
 180                        => User
 181                        -> CorpusId
 182                        -> WithQuery
 183                        -> Maybe Integer
 184                        -> (JobLog -> m ())
 185                        -> m JobLog
 186 addToCorpusWithQuery user cid (WithQuery { _wq_query = q
 187                                          , _wq_databases = dbs
 188                                          , _wq_datafield = datafield
 189                                          , _wq_lang = l
 190                                          , _wq_flowListWith = flw }) maybeLimit logStatus = do
 191   -- TODO ...
 192   logStatus JobLog { _scst_succeeded = Just 0
 193                    , _scst_failed    = Just 0
 194                    , _scst_remaining = Just 3
 195                    , _scst_events    = Just []
 196                    }
 197   printDebug "[addToCorpusWithQuery] (cid, dbs)" (cid, dbs)
 198   printDebug "[addToCorpusWithQuery] datafield" datafield
 199   printDebug "[addToCorpusWithQuery] flowListWith" flw
 200
 201   case datafield of
 202     Just Web -> do
 203       printDebug "[addToCorpusWithQuery] processing web request" datafield
 204
 205       _ <- triggerSearxSearch user cid q l logStatus
 206
 207       pure JobLog { _scst_succeeded = Just 3
 208                   , _scst_failed    = Just 0
 209                   , _scst_remaining = Just 0
 210                   , _scst_events    = Just []
 211                   }
 212
 213     _ -> do
 214       -- TODO add cid
 215       -- TODO if cid is folder -> create Corpus
 216       --      if cid is corpus -> add to corpus
 217       --      if cid is root   -> create corpus in Private
 218       eTxts <- mapM (\db -> getDataText db (Multi l) q maybeLimit) [database2origin dbs]
 219       let lTxts = lefts eTxts
 220       case lTxts of
 221         [] -> do
 222           let txts = rights eTxts
 223           -- TODO Sum lenghts of each txt elements
 224           logStatus $ JobLog { _scst_succeeded = Just 2
 225                              , _scst_failed    = Just 0
 226                              , _scst_remaining = Just $ 1 + length txts
 227                              , _scst_events    = Just []
 228                              }
 229
 230           cids <- mapM (\txt -> do
 231                            flowDataText user txt (Multi l) cid Nothing logStatus) txts
 232           printDebug "corpus id" cids
 233           printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
 234           sendMail user
 235           -- TODO ...
 236           pure JobLog { _scst_succeeded = Just 3
 237                       , _scst_failed    = Just 0
 238                       , _scst_remaining = Just 0
 239                       , _scst_events    = Just []
 240                       }
 241
 242         (err:_) -> do
 243           pure $ addEvent "ERROR" (T.pack $ show err) $
 244             JobLog { _scst_succeeded = Just 2
 245                    , _scst_failed    = Just 1
 246                    , _scst_remaining = Just 0
 247                    , _scst_events    = Just []
 248                    }
 249
 250
 251 type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint"
 252    :> "corpus"
 253      :> Capture "corpus_id" CorpusId
 254    :> "add"
 255    :> "form"
 256    :> "async"
 257      :> AsyncJobs JobLog '[FormUrlEncoded] NewWithForm JobLog
 258
 259 addToCorpusWithForm :: (FlowCmdM env err m)
 260                     => User
 261                     -> CorpusId
 262                     -> NewWithForm
 263                     -> (JobLog -> m ())
 264                     -> JobLog
 265                     -> m JobLog
 266 addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do
 267   printDebug "[addToCorpusWithForm] Parsing corpus: " cid
 268   printDebug "[addToCorpusWithForm] fileType" ft
 269   logStatus jobLog
 270   let
 271     parse = case ft of
 272       CSV_HAL   -> Parser.parseFormat Parser.CsvHal
 273       CSV       -> Parser.parseFormat Parser.CsvGargV3
 274       WOS       -> Parser.parseFormat Parser.WOS
 275       PresseRIS -> Parser.parseFormat Parser.RisPresse
 276       ZIP       -> Parser.parseFormat Parser.ZIP
 277
 278   -- TODO granularity of the logStatus
 279   let data' = case ft of
 280         ZIP -> case BSB64.decode $ TE.encodeUtf8 d of
 281           Left err -> panic $ T.pack "[addToCorpusWithForm] error decoding base64: " <> T.pack err
 282           Right decoded -> decoded
 283         _   -> cs d
 284   eDocs <- liftBase $ parse data'
 285   case eDocs of
 286     Right docs -> do
 287       -- TODO Add progress (jobStatus) update for docs - this is a
 288       -- long action
 289
 290       limit' <- view $ hasConfig . gc_max_docs_parsers
 291       let limit = fromIntegral limit'
 292       if length docs > limit then do
 293         printDebug "[addToCorpusWithForm] number of docs exceeds the limit" (show $ length docs)
 294         let panicMsg' = [ "[addToCorpusWithForm] number of docs ("
 295                         , show $ length docs
 296                         , ") exceeds the MAX_DOCS_PARSERS limit ("
 297                         , show limit
 298                         , ")" ]
 299         let panicMsg = T.concat $ T.pack <$> panicMsg'
 300         logStatus $ jobLogFailTotalWithMessage panicMsg jobLog
 301         panic panicMsg
 302       else
 303         pure ()
 304
 305       printDebug "Parsing corpus finished : " cid
 306       logStatus jobLog2
 307
 308       printDebug "Starting extraction     : " cid
 309       -- TODO granularity of the logStatus
 310       _cid' <- flowCorpus user
 311                           (Right [cid])
 312                           (Multi $ fromMaybe EN l)
 313                           Nothing
 314                           (Just $ fromIntegral $ length docs, yieldMany docs .| mapC toHyperdataDocument)
 315                           --(map (map toHyperdataDocument) docs)
 316                           logStatus
 317
 318       printDebug "Extraction finished   : " cid
 319       printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
 320       sendMail user
 321
 322       logStatus jobLog3
 323       pure $ jobLog3
 324     Left e -> do
 325       printDebug "[addToCorpusWithForm] parse error" e
 326
 327       let evt = ScraperEvent { _scev_message = Just $ T.pack e
 328                              , _scev_level = Just "ERROR"
 329                              , _scev_date = Nothing }
 330
 331       logStatus $ over (scst_events . _Just) (\evt' -> evt' <> [evt]) jobLogE
 332       pure jobLogE
 333     where
 334       jobLog2 = jobLogSuccess jobLog
 335       jobLog3 = jobLogSuccess jobLog2
 336       jobLogE = jobLogFailTotal jobLog
 337
 338 {-
 339 addToCorpusWithFile :: FlowCmdM env err m
 340                     => CorpusId
 341                     -> MultipartData Mem
 342                     -> Maybe FileType
 343                     -> (JobLog -> m ())
 344                     -> m JobLog
 345 addToCorpusWithFile cid input filetype logStatus = do
 346   logStatus JobLog { _scst_succeeded = Just 10
 347                           , _scst_failed    = Just 2
 348                           , _scst_remaining = Just 138
 349                           , _scst_events    = Just []
 350                           }
 351   printDebug "addToCorpusWithFile" cid
 352   _h <- postUpload cid filetype input
 353
 354   pure      JobLog { _scst_succeeded = Just 137
 355                           , _scst_failed    = Just 13
 356                           , _scst_remaining = Just 0
 357                           , _scst_events    = Just []
 358                           }
 359 -}
 360
 361
 362
 363 type AddWithFile = Summary "Add with FileUrlEncoded to corpus endpoint"
 364    :> "corpus"
 365      :> Capture "corpus_id" CorpusId
 366    :> "add"
 367    :> "file"
 368    :> "async"
 369      :> AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog
 370
 371 addToCorpusWithFile :: (HasSettings env, FlowCmdM env err m)
 372                     => User
 373                     -> CorpusId
 374                     -> NewWithFile
 375                     -> (JobLog -> m ())
 376                     -> m JobLog
 377 addToCorpusWithFile user cid nwf@(NewWithFile _d _l fName) logStatus = do
 378
 379   printDebug "[addToCorpusWithFile] Uploading file to corpus: " cid
 380   logStatus JobLog { _scst_succeeded = Just 0
 381                    , _scst_failed    = Just 0
 382                    , _scst_remaining = Just 1
 383                    , _scst_events    = Just []
 384                    }
 385
 386   fPath <- GargDB.writeFile nwf
 387   printDebug "[addToCorpusWithFile] File saved as: " fPath
 388
 389   uId <- getUserId user
 390   nIds <- mkNodeWithParent NodeFile (Just cid) uId fName
 391
 392   _ <- case nIds of
 393     [nId] -> do
 394         node <- getNodeWith nId (Proxy :: Proxy HyperdataFile)
 395         let hl = node ^. node_hyperdata
 396         _ <- updateHyperdata nId $ hl { _hff_name = fName
 397                                       , _hff_path = T.pack fPath }
 398
 399         printDebug "[addToCorpusWithFile] Created node with id: " nId
 400     _     -> pure ()
 401
 402   printDebug "[addToCorpusWithFile] File upload to corpus finished: " cid
 403
 404   printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
 405   sendMail user
 406
 407   pure $ JobLog { _scst_succeeded = Just 1
 408                 , _scst_failed    = Just 0
 409                 , _scst_remaining = Just 0
 410                 , _scst_events    = Just []
 411                 }
 412