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