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   , _du_language :: T.Text
  41   }
  42   deriving (Generic)
  43
  44 $(makeLenses ''DocumentUpload)
  45
  46 instance ToSchema DocumentUpload
  47 instance FromJSON DocumentUpload
  48   where
  49     parseJSON = genericParseJSON
  50             ( defaultOptions { sumEncoding = ObjectWithSingleField
  51                             , fieldLabelModifier = unCapitalize . dropPrefix "_du_"
  52                             , omitNothingFields = True
  53                             }
  54             )
  55 instance ToJSON DocumentUpload
  56   where
  57     toJSON = genericToJSON
  58            ( defaultOptions { sumEncoding = ObjectWithSingleField
  59                             , fieldLabelModifier = unCapitalize . dropPrefix "_du_"
  60                             , omitNothingFields = True
  61                             }
  62            )
  63
  64 type API = Summary " Document upload"
  65            :> "document"
  66            :> "upload"
  67            :> "async"
  68            :> AsyncJobs JobLog '[JSON] DocumentUpload JobLog
  69
  70 api :: UserId -> NodeId -> ServerT API (GargM Env GargError)
  71 api uId nId =
  72   serveJobsAPI UploadDocumentJob $ \q log' -> do
  73       documentUploadAsync uId nId q (liftBase . log')
  74
  75 documentUploadAsync :: (FlowCmdM env err m)
  76                => UserId
  77                -> NodeId
  78                -> DocumentUpload
  79                -> (JobLog -> m ())
  80                -> m JobLog
  81 documentUploadAsync _uId nId doc logStatus = do
  82   let jl = JobLog { _scst_succeeded = Just 0
  83                   , _scst_failed    = Just 0
  84                   , _scst_remaining = Just 1
  85                   , _scst_events    = Just [] }
  86   logStatus jl
  87   _docIds <- documentUpload nId doc
  88   -- printDebug "documentUploadAsync" docIds
  89   pure $ jobLogSuccess jl
  90
  91
  92
  93 documentUpload :: (FlowCmdM env err m)
  94                => NodeId
  95                -> DocumentUpload
  96                -> m [DocId]
  97 documentUpload nId doc = do
  98   mcId <- getClosestParentIdByType' nId NodeCorpus
  99   let cId = case mcId of
 100         Just c  -> c
 101         Nothing -> panic $ T.pack $ "[G.A.N.DU] Node has no corpus parent: " <> show nId
 102
 103   (theFullDate, (year, month, day)) <- liftBase $ dateSplit EN
 104                                                         $ Just
 105                                                         $ view du_date doc <> "T:0:0:0"
 106
 107   let hd = HyperdataDocument { _hd_bdd = Nothing
 108                              , _hd_doi = Nothing
 109                              , _hd_url = Nothing
 110                              , _hd_uniqId = Nothing
 111                              , _hd_uniqIdBdd = Nothing
 112                              , _hd_page = Nothing
 113                              , _hd_title = Just $ if view du_title doc == "" then T.take 50 (view du_abstract doc) else view du_title doc
 114                              , _hd_authors = Just $ view du_authors doc
 115                              , _hd_institutes = Nothing
 116                              , _hd_source             = Just $ view du_sources doc
 117                              , _hd_abstract           = Just $ view du_abstract doc
 118                              , _hd_publication_date   = fmap (T.pack . show) theFullDate
 119                              , _hd_publication_year   = year
 120                              , _hd_publication_month  = month
 121                              , _hd_publication_day    = day
 122                              , _hd_publication_hour   = Nothing
 123                              , _hd_publication_minute = Nothing
 124                              , _hd_publication_second = Nothing
 125                              , _hd_language_iso2 = Just $ view du_language doc }
 126
 127   docIds <- insertMasterDocs (Nothing :: Maybe HyperdataCorpus) (Multi EN) [hd]
 128   _ <- Doc.add cId docIds
 129   pure docIds