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            :> "framecalc"
  48            :> "async"
  49            :> AsyncJobs JobLog '[JSON] DocumentUpload JobLog
  50
  51 api :: UserId -> NodeId -> GargServer API
  52 api uId nId =
  53   serveJobsAPI $
  54     JobFunction (\q log' -> do
  55       documentUpload uId nId q (liftBase . log')
  56     )
  57
  58 documentUpload :: (FlowCmdM env err m)
  59                => UserId
  60                -> NodeId
  61                -> DocumentUpload
  62                -> (JobLog -> m ())
  63                -> m JobLog
  64 documentUpload uId nId doc logStatus = do
  65   let jl = JobLog { _scst_succeeded = Just 0
  66                   , _scst_failed    = Just 0
  67                   , _scst_remaining = Just 1
  68                   , _scst_events    = Just [] }
  69   logStatus jl
  70
  71   mcId <- getClosestParentIdByType' nId NodeCorpus
  72   let cId = case mcId of
  73         Just c  -> c
  74         Nothing -> panic $ T.pack $ "[G.A.N.DU] Node has no corpus parent: " <> show nId
  75
  76   (year, month, day) <- liftBase $ getCurrentTime >>= return . toGregorian . utctDay
  77   let nowS = T.pack $ show year <> "-" <> show month <> "-" <> show day
  78
  79   let hd = HyperdataDocument { _hd_bdd = Nothing
  80                              , _hd_doi = Nothing
  81                              , _hd_url = Nothing
  82                              , _hd_uniqId = Nothing
  83                              , _hd_uniqIdBdd = Nothing
  84                              , _hd_page = Nothing
  85                              , _hd_title = Just $ view title doc
  86                              , _hd_authors = Just $ view authors doc
  87                              , _hd_institutes = Nothing
  88                              , _hd_source = Just $ view sources doc
  89                              , _hd_abstract = Just $ view abstract doc
  90                              , _hd_publication_date = Just nowS
  91                              , _hd_publication_year = Just $ fromIntegral year
  92                              , _hd_publication_month = Just month
  93                              , _hd_publication_day = Just day
  94                              , _hd_publication_hour = Nothing
  95                              , _hd_publication_minute = Nothing
  96                              , _hd_publication_second = Nothing
  97                              , _hd_language_iso2 = Just $ T.pack $ show EN }
  98
  99   _ <- flowDataText (RootId (NodeId uId)) (DataNew [[hd]]) (Multi EN) cId Nothing
 100
 101   pure $ jobLogSuccess jl