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 GHC.Generics (Generic)
  12 import Servant
  13 import qualified Data.Text as T
  14
  15 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
  16 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
  17 import Gargantext.API.Job (jobLogSuccess)
  18 import Gargantext.API.Prelude
  19 import Gargantext.Core (Lang(..))
  20 import Gargantext.Core.Text.Corpus.Parsers.Date (dateSplit)
  21 import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
  22 import Gargantext.Database.Action.Flow.Types
  23 import Gargantext.Core.Text.Terms (TermType(..))
  24 import Gargantext.Database.Action.Flow (insertMasterDocs)
  25 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
  26 import qualified Gargantext.Database.Query.Table.Node.Document.Add  as Doc  (add)
  27 import Gargantext.Database.Admin.Types.Node
  28 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType')
  29 import Gargantext.Prelude
  30 import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus(..))
  31 import Gargantext.Utils.Jobs (serveJobsAPI)
  32
  33
  34 data DocumentUpload = DocumentUpload
  35   { _du_abstract :: T.Text
  36   , _du_authors  :: T.Text
  37   , _du_sources  :: T.Text
  38   , _du_title    :: T.Text
  39   , _du_date     :: T.Text
  40   }
  41   deriving (Generic)
  42
  43 $(makeLenses ''DocumentUpload)
  44
  45 instance ToSchema DocumentUpload
  46 instance FromJSON DocumentUpload
  47   where
  48     parseJSON = genericParseJSON
  49             ( defaultOptions { sumEncoding = ObjectWithSingleField
  50                             , fieldLabelModifier = unCapitalize . dropPrefix "_du_"
  51                             , omitNothingFields = True
  52                             }
  53             )
  54 instance ToJSON DocumentUpload
  55   where
  56     toJSON = genericToJSON
  57            ( defaultOptions { sumEncoding = ObjectWithSingleField
  58                             , fieldLabelModifier = unCapitalize . dropPrefix "_du_"
  59                             , omitNothingFields = True
  60                             }
  61            )
  62
  63 type API = Summary " Document upload"
  64            :> "document"
  65            :> "upload"
  66            :> "async"
  67            :> AsyncJobs JobLog '[JSON] DocumentUpload JobLog
  68
  69 api :: UserId -> NodeId -> ServerT API (GargM Env GargError)
  70 api uId nId =
  71   serveJobsAPI UploadDocumentJob $ \q log' -> do
  72       documentUploadAsync uId nId q (liftBase . log')
  73
  74 documentUploadAsync :: (FlowCmdM env err m)
  75                => UserId
  76                -> NodeId
  77                -> DocumentUpload
  78                -> (JobLog -> m ())
  79                -> m JobLog
  80 documentUploadAsync _uId nId doc logStatus = do
  81   let jl = JobLog { _scst_succeeded = Just 0
  82                   , _scst_failed    = Just 0
  83                   , _scst_remaining = Just 1
  84                   , _scst_events    = Just [] }
  85   logStatus jl
  86   docIds <- documentUpload nId doc
  87   printDebug "documentUploadAsync" docIds
  88   pure $ jobLogSuccess jl
  89
  90
  91
  92 documentUpload :: (FlowCmdM env err m)
  93                => NodeId
  94                -> DocumentUpload
  95                -> m [DocId]
  96 documentUpload nId doc = do
  97   mcId <- getClosestParentIdByType' nId NodeCorpus
  98   let cId = case mcId of
  99         Just c  -> c
 100         Nothing -> panic $ T.pack $ "[G.A.N.DU] Node has no corpus parent: " <> show nId
 101
 102   (theFullDate, (year, month, day)) <- liftBase $ dateSplit EN
 103                                                         $ Just
 104                                                         $ view du_date doc <> "T:0:0:0"
 105
 106   let hd = HyperdataDocument { _hd_bdd = Nothing
 107                              , _hd_doi = Nothing
 108                              , _hd_url = Nothing
 109                              , _hd_uniqId = Nothing
 110                              , _hd_uniqIdBdd = Nothing
 111                              , _hd_page = Nothing
 112                              , _hd_title = Just $ view du_title doc
 113                              , _hd_authors = Just $ view du_authors doc
 114                              , _hd_institutes = Nothing
 115                              , _hd_source             = Just $ view du_sources doc
 116                              , _hd_abstract           = Just $ view du_abstract doc
 117                              , _hd_publication_date   = fmap (T.pack . show) theFullDate
 118                              , _hd_publication_year   = year
 119                              , _hd_publication_month  = month
 120                              , _hd_publication_day    = day
 121                              , _hd_publication_hour   = Nothing
 122                              , _hd_publication_minute = Nothing
 123                              , _hd_publication_second = Nothing
 124                              , _hd_language_iso2 = Just $ T.pack $ show EN }
 125
 126   docIds <- insertMasterDocs (Nothing :: Maybe HyperdataCorpus) (Multi EN) [hd]
 127   _ <- Doc.add cId docIds
 128   pure docIds