src/Gargantext/API/Node/DocumentUpload.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE MonoLocalBinds      #-}
   3 {-# LANGUAGE TemplateHaskell     #-}
   4 {-# LANGUAGE TypeOperators       #-}
   5
   6 module Gargantext.API.Node.DocumentUpload where
   7
   8 import Control.Lens (makeLenses, view)
   9 import Data.Aeson
  10 import Data.Swagger (ToSchema)
  11 import qualified Data.Text as T
  12 import Data.Time.Clock
  13 import Data.Time.Calendar
  14 import GHC.Generics (Generic)
  15 import Servant
  16 import Servant.Job.Async
  17 import Web.FormUrlEncoded (FromForm)
  18
  19 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
  20 import Gargantext.API.Job (jobLogSuccess)
  21 import Gargantext.API.Prelude
  22 import Gargantext.Core (Lang(..))
  23 import Gargantext.Core.Text.Terms (TermType(..))
  24 import Gargantext.Core.Types.Individu (User(..))
  25 import Gargantext.Database.Action.Flow (flowDataText, DataText(..))
  26 import Gargantext.Database.Action.Flow.Types
  27 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
  28 import Gargantext.Database.Admin.Types.Node
  29 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType')
  30 import Gargantext.Prelude
  31
  32 data DocumentUpload = DocumentUpload
  33   { _abstract :: T.Text
  34   , _authors  :: T.Text
  35   , _sources  :: T.Text
  36   , _title    :: T.Text }
  37   deriving (Generic)
  38
  39 $(makeLenses ''DocumentUpload)
  40
  41 instance FromForm DocumentUpload
  42 instance FromJSON DocumentUpload
  43 instance ToJSON DocumentUpload
  44 instance ToSchema DocumentUpload
  45
  46 type API = Summary " Document upload"
  47            :> "document"
  48            :> "upload"
  49            :> "async"
  50            :> AsyncJobs JobLog '[JSON] DocumentUpload JobLog
  51
  52 api :: UserId -> NodeId -> GargServer API
  53 api uId nId =
  54   serveJobsAPI $
  55     JobFunction (\q log' -> do
  56       documentUpload uId nId q (liftBase . log')
  57     )
  58
  59 documentUpload :: (FlowCmdM env err m)
  60                => UserId
  61                -> NodeId
  62                -> DocumentUpload
  63                -> (JobLog -> m ())
  64                -> m JobLog
  65 documentUpload uId nId doc logStatus = do
  66   let jl = JobLog { _scst_succeeded = Just 0
  67                   , _scst_failed    = Just 0
  68                   , _scst_remaining = Just 1
  69                   , _scst_events    = Just [] }
  70   logStatus jl
  71
  72   mcId <- getClosestParentIdByType' nId NodeCorpus
  73   let cId = case mcId of
  74         Just c  -> c
  75         Nothing -> panic $ T.pack $ "[G.A.N.DU] Node has no corpus parent: " <> show nId
  76
  77   (year, month, day) <- liftBase $ getCurrentTime >>= return . toGregorian . utctDay
  78   let nowS = T.pack $ show year <> "-" <> show month <> "-" <> show day
  79
  80   let hd = HyperdataDocument { _hd_bdd = Nothing
  81                              , _hd_doi = Nothing
  82                              , _hd_url = Nothing
  83                              , _hd_uniqId = Nothing
  84                              , _hd_uniqIdBdd = Nothing
  85                              , _hd_page = Nothing
  86                              , _hd_title = Just $ view title doc
  87                              , _hd_authors = Just $ view authors doc
  88                              , _hd_institutes = Nothing
  89                              , _hd_source = Just $ view sources doc
  90                              , _hd_abstract = Just $ view abstract doc
  91                              , _hd_publication_date = Just nowS
  92                              , _hd_publication_year = Just $ fromIntegral year
  93                              , _hd_publication_month = Just month
  94                              , _hd_publication_day = Just day
  95                              , _hd_publication_hour = Nothing
  96                              , _hd_publication_minute = Nothing
  97                              , _hd_publication_second = Nothing
  98                              , _hd_language_iso2 = Just $ T.pack $ show EN }
  99
 100   _ <- flowDataText (RootId (NodeId uId)) (DataNew [[hd]]) (Multi EN) cId Nothing
 101
 102   pure $ jobLogSuccess jl