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.Prelude
  18 import Gargantext.Core (Lang(..))
  19 import Gargantext.Core.Text.Corpus.Parsers.Date (dateSplit)
  20 import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
  21 import Gargantext.Database.Action.Flow.Types
  22 import Gargantext.Core.Text.Terms (TermType(..))
  23 import Gargantext.Database.Action.Flow (insertMasterDocs)
  24 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
  25 import qualified Gargantext.Database.Query.Table.Node.Document.Add  as Doc  (add)
  26 import Gargantext.Database.Admin.Types.Node
  27 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType')
  28 import Gargantext.Prelude
  29 import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus(..))
  30 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
  31
  32
  33 data DocumentUpload = DocumentUpload
  34   { _du_abstract :: T.Text
  35   , _du_authors  :: T.Text
  36   , _du_sources  :: T.Text
  37   , _du_title    :: T.Text
  38   , _du_date     :: T.Text
  39   , _du_language :: 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 $ \jHandle q -> do
  72       documentUploadAsync uId nId q jHandle
  73
  74 documentUploadAsync :: (FlowCmdM env err m, MonadJobStatus m)
  75                => UserId
  76                -> NodeId
  77                -> DocumentUpload
  78                -> JobHandle m
  79                -> m ()
  80 documentUploadAsync _uId nId doc jobHandle = do
  81   markStarted 1 jobHandle
  82   _docIds <- documentUpload nId doc
  83   -- printDebug "documentUploadAsync" docIds
  84   markComplete jobHandle
  85
  86 documentUpload :: (FlowCmdM env err m)
  87                => NodeId
  88                -> DocumentUpload
  89                -> m [DocId]
  90 documentUpload nId doc = do
  91   mcId <- getClosestParentIdByType' nId NodeCorpus
  92   let cId = case mcId of
  93         Just c  -> c
  94         Nothing -> panic $ T.pack $ "[G.A.N.DU] Node has no corpus parent: " <> show nId
  95
  96   (theFullDate, (year, month, day)) <- liftBase $ dateSplit EN
  97                                                         $ Just
  98                                                         $ view du_date doc <> "T:0:0:0"
  99
 100   let hd = HyperdataDocument { _hd_bdd = Nothing
 101                              , _hd_doi = Nothing
 102                              , _hd_url = Nothing
 103                              , _hd_uniqId = Nothing
 104                              , _hd_uniqIdBdd = Nothing
 105                              , _hd_page = Nothing
 106                              , _hd_title = Just $ if view du_title doc == "" then T.take 50 (view du_abstract doc) else view du_title doc
 107                              , _hd_authors = Just $ view du_authors doc
 108                              , _hd_institutes = Nothing
 109                              , _hd_source             = Just $ view du_sources doc
 110                              , _hd_abstract           = Just $ view du_abstract doc
 111                              , _hd_publication_date   = fmap (T.pack . show) theFullDate
 112                              , _hd_publication_year   = year
 113                              , _hd_publication_month  = month
 114                              , _hd_publication_day    = day
 115                              , _hd_publication_hour   = Nothing
 116                              , _hd_publication_minute = Nothing
 117                              , _hd_publication_second = Nothing
 118                              , _hd_language_iso2 = Just $ view du_language doc }
 119
 120   docIds <- insertMasterDocs (Nothing :: Maybe HyperdataCorpus) (Multi EN) [hd]
 121   _ <- Doc.add cId docIds
 122   pure docIds