Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
195
Issues
195
List
Board
Labels
Milestones
Merge Requests
12
Merge Requests
12
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
c62480c7
Commit
c62480c7
authored
Jan 13, 2025
by
Alfredo Di Napoli
1
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Proper support for importing documents
parent
6019587c
Pipeline
#7206
passed with stages
in 50 minutes and 56 seconds
Changes
6
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
140 additions
and
41 deletions
+140
-41
New.hs
src/Gargantext/API/Node/Corpus/New.hs
+12
-6
Types.hs
src/Gargantext/API/Node/Document/Export/Types.hs
+11
-4
DocumentUpload.hs
src/Gargantext/API/Node/DocumentUpload.hs
+42
-4
Remote.hs
src/Gargantext/API/Server/Named/Remote.hs
+31
-19
Worker.hs
src/Gargantext/Core/Worker.hs
+7
-2
Types.hs
src/Gargantext/Core/Worker/Jobs/Types.hs
+37
-6
No files found.
src/Gargantext/API/Node/Corpus/New.hs
View file @
c62480c7
...
...
@@ -25,8 +25,8 @@ import Control.Lens ( view, non )
import
Data.ByteString.Base64
qualified
as
BSB64
import
Data.Conduit.Internal
(
zipSources
)
import
Data.Swagger
(
ToSchema
(
..
)
)
import
Data.Text
qualified
as
T
import
Data.Text.Encoding
qualified
as
TE
import
Data.Text
qualified
as
T
import
EPO.API.Client.Types
qualified
as
EPO
import
Gargantext.API.Admin.Orchestrator.Types
qualified
as
API
import
Gargantext.API.Ngrams
(
commitStatePatch
,
Versioned
(
..
))
...
...
@@ -35,14 +35,14 @@ import Gargantext.API.Node.Corpus.Searx ( triggerSearxSearch )
import
Gargantext.API.Node.Corpus.Types
(
Datafield
(
Web
),
database2origin
)
import
Gargantext.API.Node.Corpus.Update
(
addLanguageToCorpus
)
import
Gargantext.API.Node.Types
import
Gargantext.Core
(
withDefaultLanguage
,
defaultLanguage
)
import
Gargantext.Core.Config
(
gc_jobs
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
jc_max_docs_parsers
)
import
Gargantext.Core.NodeStory
(
HasNodeStoryImmediateSaver
,
HasNodeArchiveStoryImmediateSaver
,
currentVersion
,
NgramsStatePatch
'
)
import
Gargantext.Core.NodeStory
(
HasNodeStoryImmediateSaver
,
HasNodeArchiveStoryImmediateSaver
,
currentVersion
,
NgramsStatePatch
'
,
HasNodeStoryEnv
)
import
Gargantext.Core.Text.Corpus.Parsers
qualified
as
Parser
(
FileType
(
..
),
parseFormatC
,
_ParseFormatError
)
import
Gargantext.Core.Text.Corpus.Query
qualified
as
API
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Core.Utils.Prefix
(
unPrefix
)
import
Gargantext.Core
(
withDefaultLanguage
,
defaultLanguage
)
import
Gargantext.Database.Action.Flow
(
flowCorpus
,
getDataText
,
flowDataText
,
TermType
(
..
)
{-, allDataOrigins-}
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Action.Mail
(
sendMail
)
...
...
@@ -52,6 +52,8 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(
import
Gargantext.Database.Admin.Types.Hyperdata.File
(
HyperdataFile
(
..
)
)
import
Gargantext.Database.Admin.Types.Node
(
CorpusId
,
NodeType
(
..
),
ParentId
)
import
Gargantext.Database.GargDB
qualified
as
GargDB
import
Gargantext.Database.Prelude
(
IsDBCmd
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node
(
getNodeWith
,
getOrMkList
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Tree.Root
(
MkCorpusUser
(
MkCorpusUserNormalCorpusIds
))
...
...
@@ -366,11 +368,15 @@ addToCorpusWithFile user cid nwf@(NewWithFile _d (withDefaultLanguage -> l) fNam
--- UTILITIES
commitCorpus
::
(
FlowCmdM
env
err
m
commitCorpus
::
(
IsDBCmd
env
err
m
,
HasNodeStoryEnv
env
,
HasNodeError
err
,
HasNodeArchiveStoryImmediateSaver
env
,
HasNodeStoryImmediateSaver
env
)
=>
ParentId
->
User
->
m
(
Versioned
NgramsStatePatch'
)
commitCorpus
cid
user
=
do
=>
ParentId
->
User
->
m
(
Versioned
NgramsStatePatch'
)
commitCorpus
cid
user
=
do
userId
<-
getUserId
user
listId
<-
getOrMkList
cid
userId
v
<-
currentVersion
listId
...
...
src/Gargantext/API/Node/Document/Export/Types.hs
View file @
c62480c7
...
...
@@ -29,13 +29,14 @@ import Gargantext.Utils.Servant (ZIP)
import
Gargantext.Utils.Zip
(
zipContentsPureWithLastModified
)
import
Protolude
import
Servant
(
MimeRender
(
..
),
MimeUnrender
(
..
))
import
Prelude
(
show
)
-- | Document Export
data
DocumentExport
=
DocumentExport
{
_de_documents
::
[
Document
]
,
_de_garg_version
::
Text
}
deriving
(
Generic
)
}
deriving
(
Generic
,
Show
,
Eq
)
instance
Serialise
DocumentExport
where
...
...
@@ -44,14 +45,20 @@ data DocumentExportZIP =
DocumentExportZIP
{
_dez_dexp
::
DocumentExport
,
_dez_doc_id
::
DocId
,
_dez_last_modified
::
Integer
}
deriving
(
Generic
)
data
Document
=
Document
{
_d_document
::
Node
HyperdataDocument
,
_d_ngrams
::
Ngrams
,
_d_hash
::
Hash
}
deriving
(
Generic
)
instance
Eq
Document
where
(
Document
_
_
h1
)
==
(
Document
_
_
h2
)
=
h1
==
h2
-- compare by their hashes
instance
Show
Document
where
show
(
Document
_
_
h1
)
=
"Document "
<>
Prelude
.
show
h1
instance
Serialise
Document
where
--instance Read Document where
-- read "" = panic "not implemented"
...
...
@@ -119,7 +126,7 @@ $(deriveJSON (unPrefix "_de_") ''DocumentExport)
-- Needs to be here because of deriveJSON TH above
dezFileName
::
DocumentExportZIP
->
Text
dezFileName
(
DocumentExportZIP
{
..
})
=
"GarganText_DocsList-"
<>
show
_dez_doc_id
<>
".json"
dezFileName
(
DocumentExportZIP
{
..
})
=
"GarganText_DocsList-"
<>
Protolude
.
show
_dez_doc_id
<>
".json"
instance
MimeRender
ZIP
DocumentExportZIP
where
mimeRender
_
dexpz
@
(
DocumentExportZIP
{
..
})
=
...
...
src/Gargantext/API/Node/DocumentUpload.hs
View file @
c62480c7
...
...
@@ -11,33 +11,43 @@ Portability : POSIX
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TemplateHaskell #-}
module
Gargantext.API.Node.DocumentUpload
where
import
Control.Lens
(
view
)
import
Data.Text
qualified
as
T
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
..
))
import
Gargantext.API.Admin.EnvTypes
(
Env
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
(
..
)
)
import
Gargantext.API.Node.Corpus.New
(
commitCorpus
)
import
Gargantext.API.Node.Document.Export.Types
(
Document
(
..
))
import
Gargantext.API.Node.Document.Export.Types
(
DocumentExport
(
..
))
import
Gargantext.API.Node.DocumentUpload.Types
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Routes.Named.Document
qualified
as
Named
import
Gargantext.API.Worker
(
serveWorkerAPI
)
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core.NLP
(
nlpServerGet
)
import
Gargantext.Core.NLP
(
nlpServerGet
,
HasNLPServer
)
import
Gargantext.Core.NodeStory.Types
(
HasNodeStoryEnv
,
HasNodeArchiveStoryImmediateSaver
)
import
Gargantext.Core.Text.Corpus.Parsers.Date
(
mDateSplit
)
import
Gargantext.Core.Text.Terms
(
TermType
(
..
))
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Core.Worker.Jobs.Types
qualified
as
Jobs
import
Gargantext.Database.Action.Flow
(
addDocumentsToHyperCorpus
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Admin.Types.Hyperdata.Corpus
(
HyperdataCorpus
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
DocId
,
NodeId
,
NodeType
(
NodeCorpus
)
)
import
Gargantext.Database.Query.Table.Node
(
getClosestParentIdByType'
)
import
Gargantext.Database.Prelude
(
IsDBCmd
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node
(
getClosestParentIdByType'
,
getClosestParentIdByType
)
import
Gargantext.Database.Schema.Node
(
_node_hyperdata
)
import
Gargantext.Prelude
import
Gargantext.System.Logging
(
logLocM
,
LogLevel
(
..
),
MonadLogger
)
import
Gargantext.Utils.Jobs.Monad
(
MonadJobStatus
(
..
))
import
Servant.Server.Generic
(
AsServerT
)
api
::
NodeId
->
Named
.
DocumentUploadAPI
(
AsServerT
(
GargM
Env
BackendInternalError
))
api
nId
=
Named
.
DocumentUploadAPI
{
uploadDocAsyncEp
=
serveWorkerAPI
$
\
p
->
...
...
@@ -91,3 +101,31 @@ documentUpload nId doc = do
let
lang
=
EN
ncs
<-
view
$
nlpServerGet
lang
addDocumentsToHyperCorpus
ncs
(
Nothing
::
Maybe
HyperdataCorpus
)
(
Multi
lang
)
cId
[
hd
]
-- | Imports the documents contained into this 'DocumentExport' into this (local) version
-- of the running node.
-- /NOTE(adn)/: We should compare the gargantext version and ensure that we are importing
-- only compatible versions.
remoteImportDocuments
::
(
HasNodeError
err
,
HasNLPServer
env
,
HasNodeArchiveStoryImmediateSaver
env
,
HasNodeStoryEnv
env
,
IsDBCmd
env
err
m
,
MonadLogger
m
,
MonadIO
m
)
=>
AuthenticatedUser
->
NodeId
->
DocumentExport
->
m
[
NodeId
]
remoteImportDocuments
loggedInUser
nodeId
(
DocumentExport
documents
_gargVersion
)
=
do
mb_corpusId
<-
getClosestParentIdByType
nodeId
NodeCorpus
case
mb_corpusId
of
Nothing
->
panicTrace
$
"remoteImportDocuments: impossible, freshly imported doc node without parent corpus"
Just
corpusId
->
do
let
la
=
Multi
EN
nlpServerConfig
<-
view
$
nlpServerGet
(
_tt_lang
la
)
$
(
logLocM
)
INFO
$
"Importing "
<>
T
.
pack
(
show
$
length
documents
)
<>
" documents for corpus node "
<>
T
.
pack
(
show
nodeId
)
docs
<-
addDocumentsToHyperCorpus
nlpServerConfig
(
Nothing
::
Maybe
HyperdataCorpus
)
la
corpusId
(
map
(
_node_hyperdata
.
_d_document
)
documents
)
_versioned
<-
commitCorpus
corpusId
(
RootId
$
_auth_node_id
loggedInUser
)
$
(
logLocM
)
INFO
$
"Done importing "
<>
T
.
pack
(
show
$
length
documents
)
<>
" documents for corpus node "
<>
T
.
pack
(
show
nodeId
)
pure
docs
src/Gargantext/API/Server/Named/Remote.hs
View file @
c62480c7
{-# LANGUAGE
ViewPatterns
#-}
{-# LANGUAGE
OverloadedStrings
#-}
{-# LANGUAGE
LambdaCase
#-}
{-# LANGUAGE
BangPatterns
#-}
{-# LANGUAGE
LambdaCase
#-}
{-# LANGUAGE
OverloadedStrings
#-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module
Gargantext.API.Server.Named.Remote
(
remoteAPI
...
...
@@ -30,22 +31,24 @@ import Gargantext.API.Errors.Types
import
Gargantext.API.Ngrams.Prelude
(
getNgramsList
)
import
Gargantext.API.Ngrams.Types
(
NgramsList
)
import
Gargantext.API.Node.Document.Export
(
get_document_json
)
import
Gargantext.API.Node.Document.Export.Types
(
DocumentExport
)
import
Gargantext.API.Node.Document.Export.Types
import
Gargantext.API.Prelude
(
IsGargServer
)
import
Gargantext.API.Routes.Client
(
remoteImportClient
)
import
Gargantext.API.Routes.Named.Remote
qualified
as
Named
import
Gargantext.Core.Config
import
Gargantext.Core
(
lookupDBid
)
import
Gargantext.Core.NodeStory.Types
(
HasNodeStoryEnv
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.NodeStory.Types
(
HasNodeStoryEnv
,
HasNodeArchiveStoryImmediateSaver
)
import
Gargantext.Core.Types.Main
import
Gargantext.Core.Worker.Jobs
(
sendJob
)
import
Gargantext.Core.Worker.Jobs.Types
qualified
as
Jobs
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Admin.Types.Node
hiding
(
INFO
)
import
Gargantext.Database.Prelude
(
IsDBCmd
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
,
nodeError
,
NodeError
(
..
))
import
Gargantext.Database.Query.Table.Node
(
insertNodeWithHyperdata
,
getNodes
,
getUserRootPrivateNode
)
import
Gargantext.Database.Schema.Node
(
NodePoly
(
..
))
import
Gargantext.Orphans
()
import
Gargantext.System.Logging
(
logLocM
,
LogLevel
(
..
),
MonadLogger
)
import
GHC.Generics
(
Generic
)
import
Prelude
import
Servant.Client.Streaming
(
mkClientEnv
,
withClientM
,
ClientError
)
...
...
@@ -64,7 +67,7 @@ data ExportableNode =
instance
Serialise
ExportableNode
where
remoteAPI
::
(
MonadIO
m
,
IsGargServer
env
BackendInternalError
m
)
remoteAPI
::
(
MonadIO
m
,
IsGargServer
env
BackendInternalError
m
,
HasNodeArchiveStoryImmediateSaver
env
)
=>
AuthenticatedUser
->
Named
.
RemoteAPI
(
AsServerT
m
)
remoteAPI
authenticatedUser
=
Named
.
RemoteAPI
$
...
...
@@ -80,7 +83,10 @@ remoteImportHandler :: forall err env m.
(
HasNodeStoryEnv
env
,
HasNodeError
err
,
HasBackendInternalError
err
,
HasNodeArchiveStoryImmediateSaver
env
,
IsDBCmd
env
err
m
,
HasNLPServer
env
,
MonadLogger
m
,
MonadIO
m
)
=>
AuthenticatedUser
->
ConduitT
()
Named
.
RemoteBinaryData
IO
()
...
...
@@ -92,25 +98,33 @@ remoteImportHandler loggedInUser c = do
case
deserialiseOrFail
@
ExpectedPayload
(
B
.
toLazyByteString
$
mconcat
chunks
)
of
Left
err
->
throwError
$
_BackendInternalError
#
InternalUnexpectedError
(
toException
$
userError
$
"Deserialization error: "
++
show
err
)
Right
(
TreeN
x
xs
)
->
do
$
(
logLocM
)
INFO
$
"Importing "
<>
T
.
pack
(
show
$
_node_id
$
_en_node
$
x
)
-- NOTE(adn) By default, we append the imported node(s) to the user's
-- private folder.
privateFolderId
<-
_node_id
<$>
getUserRootPrivateNode
(
_auth_user_id
loggedInUser
)
$
(
logLocM
)
INFO
$
"Attaching "
<>
T
.
pack
(
show
$
_node_id
$
_en_node
$
x
)
<>
" to private folder "
<>
T
.
pack
(
show
privateFolderId
)
-- Attempts to insert nodes a we go along.
rootNode
<-
insertNode
(
Just
privateFolderId
)
x
foldlM
(
insertTrees
(
Just
rootNode
))
[
rootNode
]
xs
nodes
<-
foldlM
(
insertTrees
(
Just
rootNode
))
[
rootNode
]
xs
$
(
logLocM
)
INFO
$
"Successfully imported all the requested nodes."
pure
nodes
where
insertNode
::
Maybe
NodeId
->
ExportableNode
->
m
NodeId
insertNode
mb_parent
(
ExportableNode
x
_
mb_docs
mb_terms
)
=
case
lookupDBid
$
_node_typename
x
of
insertNode
mb_parent
(
ExportableNode
x
mb_docs
mb_terms
)
=
case
lookupDBid
$
_node_typename
x
of
Nothing
->
throwError
$
_BackendInternalError
#
InternalUnexpectedError
(
toException
$
userError
$
"remoteImportHandler: impossible, node with invalid type."
)
Just
ty
->
do
new_node
<-
insertNodeWithHyperdata
ty
(
_node_name
x
)
(
_node_hyperdata
x
)
mb_parent
(
_auth_user_id
loggedInUser
)
$
(
logLocM
)
INFO
$
"Created a new node "
<>
T
.
pack
(
show
$
new_node
)
<>
" of type "
<>
T
.
pack
(
show
ty
)
for_
mb_docs
$
\
docsList
->
do
$
(
logLocM
)
INFO
$
"Found document list to import..."
let
payload
=
Jobs
.
ImportRemoteDocumentsPayload
loggedInUser
new_node
docsList
void
$
sendJob
$
Jobs
.
ImportRemoteDocuments
payload
for_
mb_terms
$
\
ngramsList
->
do
$
(
logLocM
)
INFO
$
"Found ngrams list to import..."
void
$
sendJob
$
Jobs
.
JSONPost
{
_jp_list_id
=
new_node
,
_jp_ngrams_list
=
ngramsList
}
--for_ mb_docs $ \docsList -> do
-- addToCorpusWithForm user corpusId new_with_form (noJobHandle @m Proxy)
,
_jp_ngrams_list
=
ngramsList
}
pure
new_node
insertTrees
::
Maybe
NodeId
->
[
NodeId
]
->
Tree
ExportableNode
->
m
[
NodeId
]
...
...
@@ -118,8 +132,6 @@ remoteImportHandler loggedInUser c = do
childrenRoot
<-
insertNode
currentParent
x
(`
mappend
`
acc
)
<$>
foldlM
(
insertTrees
(
Just
childrenRoot
))
[
childrenRoot
]
xs
remoteExportHandler
::
(
MonadIO
m
,
Safe
.
MonadCatch
m
,
IsGargServer
err
env
m
)
...
...
@@ -142,8 +154,8 @@ makeExportable userNodeId (TreeN x xs)
|
Just
nty
<-
lookupDBid
(
_node_typename
x
)
=
do
mb_docs
<-
case
nty
of
Node
Document
->
Just
<$>
get_document_json
userNodeId
(
_node_id
x
)
_
->
pure
Nothing
Node
Texts
->
Just
<$>
get_document_json
userNodeId
(
_node_id
x
)
_
->
pure
Nothing
mb_ngrams
<-
case
nty
of
NodeList
->
Just
<$>
getNgramsList
(
_node_id
x
)
_
->
pure
Nothing
...
...
src/Gargantext/Core/Worker.hs
View file @
c62480c7
...
...
@@ -30,7 +30,7 @@ import Gargantext.API.Node.Corpus.Annuaire qualified as Annuaire
import
Gargantext.API.Node.Contact
(
addContact
)
import
Gargantext.API.Node.Corpus.New
(
addToCorpusWithForm
,
addToCorpusWithQuery
)
import
Gargantext.API.Node.DocumentsFromWriteNodes
(
documentsFromWriteNodes
)
import
Gargantext.API.Node.DocumentUpload
(
documentUploadAsync
)
import
Gargantext.API.Node.DocumentUpload
(
documentUploadAsync
,
remoteImportDocuments
)
import
Gargantext.API.Node.FrameCalcUpload
(
frameCalcUploadAsync
)
import
Gargantext.API.Node.File
(
addWithFile
)
import
Gargantext.API.Node.New
(
postNode'
)
...
...
@@ -45,7 +45,7 @@ import Gargantext.Core.Viz.Graph.API (graphRecompute)
import
Gargantext.Core.Worker.Broker
(
initBrokerWithDBCreate
)
import
Gargantext.Core.Worker.Env
import
Gargantext.Core.Worker.PGMQTypes
(
BrokerMessage
,
HasWorkerBroker
,
WState
)
import
Gargantext.Core.Worker.Jobs.Types
(
Job
(
..
),
getWorkerMNodeId
)
import
Gargantext.Core.Worker.Jobs.Types
(
Job
(
..
),
getWorkerMNodeId
,
ImportRemoteDocumentsPayload
(
..
)
)
import
Gargantext.Core.Worker.Types
(
JobInfo
(
..
))
import
Gargantext.Database.Query.Table.User
(
getUsersWithEmail
)
import
Gargantext.Prelude
hiding
(
to
)
...
...
@@ -296,3 +296,8 @@ performAction env _state bm = do
UploadDocument
{
..
}
->
runWorkerMonad
env
$
do
$
(
logLocM
)
DEBUG
$
"[performAction] upload document"
void
$
documentUploadAsync
_ud_node_id
_ud_args
jh
-- | Remotely import documents
ImportRemoteDocuments
(
ImportRemoteDocumentsPayload
loggedInUser
corpusId
docs
)
->
runWorkerMonad
env
$
do
$
(
logLocM
)
DEBUG
$
"[performAction] import remote documents"
void
$
remoteImportDocuments
loggedInUser
corpusId
docs
src/Gargantext/Core/Worker/Jobs/Types.hs
View file @
c62480c7
...
...
@@ -9,26 +9,51 @@ Portability : POSIX
-}
{-# LANGUAGE TypeApplications #-}
module
Gargantext.Core.Worker.Jobs.Types
where
import
Data.Aeson
((
.:
),
(
.=
),
object
,
withObject
)
import
Data.Aeson.Types
(
prependFailure
,
typeMismatch
)
import
Data.Aeson
qualified
as
JS
import
Data.Aeson.KeyMap
qualified
as
KM
import
Data.Text
qualified
as
T
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
,
ForgotPasswordAsyncParams
)
import
Gargantext.API.Ngrams.Types
(
NgramsList
,
UpdateTableNgramsCharts
(
_utn_list_id
))
import
Gargantext.API.Node.Corpus.Annuaire
(
AnnuaireWithForm
)
import
Gargantext.API.Node.Contact.Types
(
AddContactParams
)
import
Gargantext.API.Node.Corpus.Annuaire
(
AnnuaireWithForm
)
import
Gargantext.API.Node.Document.Export.Types
(
DocumentExport
)
import
Gargantext.API.Node.DocumentsFromWriteNodes.Types
qualified
as
DFWN
import
Gargantext.API.Node.DocumentUpload.Types
(
DocumentUpload
)
import
Gargantext.API.Node.FrameCalcUpload.Types
(
FrameCalcUpload
)
import
Gargantext.API.Node.New.Types
(
PostNode
(
..
)
)
import
Gargantext.API.Node.Update.Types
(
UpdateNodeParams
)
import
Gargantext.API.Node.Types
(
NewWithFile
,
NewWithForm
,
WithQuery
(
..
))
import
Gargantext.API.Node.Update.Types
(
UpdateNodeParams
)
import
Gargantext.Core.Types.Individu
(
User
)
import
Gargantext.Database.Admin.Types.Node
(
AnnuaireId
,
CorpusId
,
ListId
,
NodeId
(
UnsafeMkNodeId
))
import
Gargantext.Prelude
data
ImportRemoteDocumentsPayload
=
ImportRemoteDocumentsPayload
{
_irdp_user
::
AuthenticatedUser
,
_irdp_corpus_id
::
NodeId
,
_irdp_document_export
::
DocumentExport
}
deriving
(
Show
,
Eq
)
instance
ToJSON
ImportRemoteDocumentsPayload
where
toJSON
ImportRemoteDocumentsPayload
{
..
}
=
object
[
"user"
.=
_irdp_user
,
"corpus_id"
.=
_irdp_corpus_id
,
"document_export"
.=
_irdp_document_export
]
instance
FromJSON
ImportRemoteDocumentsPayload
where
parseJSON
=
withObject
"ImportRemoteDocumentsPayload"
$
\
o
->
do
_irdp_user
<-
o
.:
"user"
_irdp_corpus_id
<-
o
.:
"corpus_id"
_irdp_document_export
<-
o
.:
"document_export"
pure
ImportRemoteDocumentsPayload
{
..
}
data
Job
=
Ping
...
...
@@ -65,6 +90,7 @@ data Job =
,
_un_args
::
UpdateNodeParams
}
|
UploadDocument
{
_ud_node_id
::
NodeId
,
_ud_args
::
DocumentUpload
}
|
ImportRemoteDocuments
!
ImportRemoteDocumentsPayload
deriving
(
Show
,
Eq
)
instance
FromJSON
Job
where
parseJSON
=
withObject
"Job"
$
\
o
->
do
...
...
@@ -132,6 +158,8 @@ instance FromJSON Job where
_ud_node_id
<-
o
.:
"node_id"
_ud_args
<-
o
.:
"args"
return
$
UploadDocument
{
..
}
"ImportRemoteDocuments"
->
ImportRemoteDocuments
<$>
parseJSON
(
JS
.
Object
o
)
s
->
prependFailure
"parsing job type failed, "
(
typeMismatch
"type"
s
)
instance
ToJSON
Job
where
toJSON
Ping
=
object
[
"type"
.=
(
"Ping"
::
Text
)
]
...
...
@@ -196,10 +224,12 @@ instance ToJSON Job where
object
[
"type"
.=
(
"UploadDocument"
::
Text
)
,
"node_id"
.=
_ud_node_id
,
"args"
.=
_ud_args
]
toJSON
(
ImportRemoteDocuments
payload
)
=
case
toJSON
payload
of
(
JS
.
Object
o
)
->
let
o1
=
KM
.
fromList
[
(
"type"
,
toJSON
@
T
.
Text
"ImportRemoteDocuments"
)
]
in
JS
.
Object
$
o1
<>
o
_
->
errorTrace
"impossible, toJSON ImportRemoteDocuments did not return an Object."
-- | We want to have a way to specify 'Maybe NodeId' from given worker
-- parameters. The given 'Maybe CorpusId' is an alternative, when
...
...
@@ -223,3 +253,4 @@ getWorkerMNodeId (PostNodeAsync { _pna_node_id }) = Just _pna_node_id
getWorkerMNodeId
(
RecomputeGraph
{
_rg_node_id
})
=
Just
_rg_node_id
getWorkerMNodeId
(
UpdateNode
{
_un_node_id
})
=
Just
_un_node_id
getWorkerMNodeId
(
UploadDocument
{
_ud_node_id
})
=
Just
_ud_node_id
getWorkerMNodeId
(
ImportRemoteDocuments
(
ImportRemoteDocumentsPayload
_
corpusId
_
))
=
Just
corpusId
Przemyslaw Kaminski
@cgenie
mentioned in commit
942e663f
·
Jan 29, 2025
mentioned in commit
942e663f
mentioned in commit 942e663f539b287b4cc0469fe2bcf735813b4ff2
Toggle commit list
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment