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
153
Issues
153
List
Board
Labels
Milestones
Merge Requests
9
Merge Requests
9
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
458283b7
Commit
458283b7
authored
Sep 08, 2020
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[FIX] TextFlow insertDB done
parent
ee2b59e9
Changes
10
Hide whitespace changes
Inline
Side-by-side
Showing
10 changed files
with
98 additions
and
60 deletions
+98
-60
Main.hs
bin/gargantext-server/Main.hs
+4
-3
package.yaml
package.yaml
+1
-0
Export.hs
src/Gargantext/API/Node/Corpus/Export.hs
+4
-0
Types.hs
src/Gargantext/Core/Flow/Types.hs
+6
-2
Terms.hs
src/Gargantext/Core/Text/Terms.hs
+1
-2
Flow.hs
src/Gargantext/Database/Action/Flow.hs
+15
-31
Types.hs
src/Gargantext/Database/Action/Flow/Types.hs
+7
-1
Node.hs
src/Gargantext/Database/Admin/Types/Node.hs
+7
-2
Insert.hs
src/Gargantext/Database/Query/Table/Node/Document/Insert.hs
+52
-18
Prelude.hs
src/Gargantext/Prelude.hs
+1
-1
No files found.
bin/gargantext-server/Main.hs
View file @
458283b7
...
...
@@ -11,9 +11,10 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Strict #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module
Main
where
...
...
package.yaml
View file @
458283b7
...
...
@@ -211,6 +211,7 @@ library:
-
servant-xml
-
simple-reflect
-
singletons
# (IGraph)
-
template-haskell
-
wai-app-static
# for mail
...
...
src/Gargantext/API/Node/Corpus/Export.hs
View file @
458283b7
...
...
@@ -15,6 +15,7 @@ Main exports of Gargantext:
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module
Gargantext.API.Node.Corpus.Export
where
...
...
@@ -80,6 +81,9 @@ instance ToSchema Document where
instance
ToSchema
Ngrams
where
declareNamedSchema
=
genericDeclareNamedSchema
(
unPrefixSwagger
"_ng_"
)
instance
(
ToSchema
a
)
=>
ToSchema
(
Node
a
)
where
declareNamedSchema
=
genericDeclareNamedSchema
(
unPrefixSwagger
"_node_"
)
-------
instance
ToParamSchema
Corpus
where
toParamSchema
_
=
toParamSchema
(
Proxy
::
Proxy
TODO
)
...
...
src/Gargantext/Core/Flow/Types.hs
View file @
458283b7
...
...
@@ -14,13 +14,13 @@ Portability : POSIX
module
Gargantext.Core.Flow.Types
where
import
Control.Lens
(
Lens
'
)
import
Control.Lens
--
(Lens')
import
Data.Map
(
Map
)
import
Data.Maybe
(
Maybe
)
-- import Control.Applicative
import
Gargantext.Core.Text
(
HasText
(
..
))
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Schema.Node
(
node_hash_id
)
import
Gargantext.Database.Schema.Ngrams
(
Ngrams
,
NgramsType
)
import
Gargantext.Prelude
import
Gargantext.Prelude.Crypto.Hash
(
Hash
)
...
...
@@ -37,6 +37,10 @@ instance UniqId HyperdataContact
where
uniqId
=
hc_uniqId
instance
UniqId
(
Node
a
)
where
uniqId
=
node_hash_id
data
DocumentIdWithNgrams
a
=
DocumentIdWithNgrams
{
documentWithId
::
!
(
DocumentWithId
a
)
,
documentNgrams
::
!
(
Map
Ngrams
(
Map
NgramsType
Int
))
...
...
src/Gargantext/Core/Text/Terms.hs
View file @
458283b7
...
...
@@ -105,9 +105,8 @@ withLang (Unsupervised l n s m) ns = Unsupervised l n s m'
)
just_m
->
just_m
withLang
l
_
=
l
------------------------------------------------------------------------
------------------------------------------------------------------------
class
ExtractNgramsT
h
where
extractNgramsT
::
HasText
h
...
...
src/Gargantext/Database/Action/Flow.hs
View file @
458283b7
...
...
@@ -49,11 +49,10 @@ import Data.Either
import
Data.List
(
concat
)
import
qualified
Data.Map
as
Map
import
Data.Map
(
Map
,
lookup
)
import
Data.Maybe
(
Maybe
(
..
),
catMaybes
,
fromMaybe
)
import
Data.Maybe
(
Maybe
(
..
),
catMaybes
)
import
Data.Monoid
import
Data.Swagger
import
Data.Text
(
splitOn
,
intercalate
)
import
Data.Time.Segment
(
jour
)
import
Data.Traversable
(
traverse
)
import
Data.Tuple.Extra
(
first
,
second
)
import
GHC.Generics
(
Generic
)
...
...
@@ -71,7 +70,7 @@ import Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Query.Table.Node.Document.Insert
-- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
import
Gargantext.Database.Query.Tree.Root
(
getOrMkRoot
,
getOrMk_RootWithCorpus
)
import
Gargantext.Database.Action.Search
(
searchDocInDatabase
)
import
Gargantext.Database.Admin.Config
(
userMaster
,
corpusMasterName
,
nodeTypeId
)
import
Gargantext.Database.Admin.Config
(
userMaster
,
corpusMasterName
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
-- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
...
...
@@ -92,7 +91,6 @@ import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
import
Gargantext.Core.Text.Terms
import
qualified
Gargantext.Database.Query.Table.Node.Document.Add
as
Doc
(
add
)
import
qualified
Gargantext.Core.Text.Corpus.API
as
API
import
qualified
Data.Text
as
DT
------------------------------------------------------------------------
-- TODO use internal with API name (could be old data)
...
...
@@ -210,8 +208,8 @@ flowCorpusUser l user corpusName ctype ids = do
-- TODO: check if present already, ignore
_
<-
Doc
.
add
userCorpusId
ids
tId
<-
insertDefaultNode
NodeTexts
userCorpusId
userId
printDebug
"Node Text Ids:"
tId
_
tId
<-
insertDefaultNode
NodeTexts
userCorpusId
userId
--
printDebug "Node Text Ids:" tId
-- User List Flow
(
masterUserId
,
_masterRootId
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
""
)
ctype
...
...
@@ -230,7 +228,8 @@ flowCorpusUser l user corpusName ctype ids = do
-- TODO Type NodeDocumentUnicised
insertDocs
::
(
FlowCmdM
env
err
m
,
FlowCorpus
a
-- , FlowCorpus a
,
FlowInsertDB
a
)
=>
UserId
->
CorpusId
...
...
@@ -246,19 +245,6 @@ insertDocs uId cId hs = do
_
<-
Doc
.
add
cId
newIds'
pure
(
newIds'
,
documentsWithId
)
{-
-- TODO Maybe NodeId
toNode :: Hyperdata a => NodeType -> ParentId -> UserId -> a -> Node a
toNode NodeDocument p u h = Node 0 "" (nodeTypeId nt) u (Just p) n date h
where
n = maybe "No Title" (DT.take 255) (_hd_title h)
date = jour y m d
y = maybe 0 fromIntegral $ _hd_publication_year h
m = fromMaybe 1 $ _hd_publication_month h
d = fromMaybe 1 $ _hd_publication_day h
toNode _ _ _ _ = undefined
-}
insertMasterDocs
::
(
FlowCmdM
env
err
m
,
FlowCorpus
a
...
...
@@ -270,8 +256,7 @@ insertMasterDocs :: ( FlowCmdM env err m
->
m
[
DocId
]
insertMasterDocs
c
lang
hs
=
do
(
masterUserId
,
_
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
corpusMasterName
)
c
(
ids'
,
documentsWithId
)
<-
insertDocs
masterUserId
masterCorpusId
hs
-- (ids', documentsWithId) <- insertDocs masterUserId masterCorpusId (map (toNode NodeDocument masterCorpusId masterUserId ) hs )
(
ids'
,
documentsWithId
)
<-
insertDocs
masterUserId
masterCorpusId
(
map
(
toNode
masterUserId
masterCorpusId
)
hs
)
_
<-
Doc
.
add
masterCorpusId
ids'
-- TODO
-- create a corpus with database name (CSV or PubMed)
...
...
@@ -368,15 +353,6 @@ instance HasText HyperdataDocument
,
_hd_abstract
h
]
instance
HasText
(
Node
HyperdataDocument
)
where
hasText
n
=
catMaybes
[
_hd_title
h
,
_hd_abstract
h
]
where
h
=
_node_hyperdata
n
instance
ExtractNgramsT
HyperdataDocument
where
...
...
@@ -411,4 +387,12 @@ instance ExtractNgramsT HyperdataDocument
<>
[(
a'
,
Map
.
singleton
Authors
1
)
|
a'
<-
authors
]
<>
[(
t'
,
Map
.
singleton
NgramsTerms
1
)
|
t'
<-
terms'
]
instance
(
ExtractNgramsT
a
,
HasText
a
)
=>
ExtractNgramsT
(
Node
a
)
where
extractNgramsT
l
(
Node
_
_
_
_
_
_
_
h
)
=
extractNgramsT
l
h
instance
HasText
a
=>
HasText
(
Node
a
)
where
hasText
(
Node
_
_
_
_
_
_
_
h
)
=
hasText
h
src/Gargantext/Database/Action/Flow/Types.hs
View file @
458283b7
...
...
@@ -19,6 +19,7 @@ Portability : POSIX
module
Gargantext.Database.Action.Flow.Types
where
import
Data.Aeson
(
ToJSON
)
import
Gargantext.Core.Flow.Types
import
Gargantext.Core.Text
import
Gargantext.Core.Text.Terms
...
...
@@ -39,6 +40,11 @@ type FlowCorpus a = ( AddUniqId a
,
InsertDb
a
,
ExtractNgramsT
a
,
HasText
a
-- , ToNode a
,
ToNode
a
,
ToJSON
a
)
type
FlowInsertDB
a
=
(
AddUniqId
a
,
UniqId
a
,
InsertDb
a
)
src/Gargantext/Database/Admin/Types/Node.hs
View file @
458283b7
...
...
@@ -36,7 +36,7 @@ import GHC.Generics (Generic)
import
Prelude
(
Enum
,
Bounded
,
minBound
,
maxBound
)
import
Servant
import
qualified
Opaleye
as
O
import
Opaleye
(
QueryRunnerColumnDefault
,
queryRunnerColumnDefault
,
PGInt4
,
PGTSVector
,
Nullable
,
fieldQueryRunnerColumn
)
import
Opaleye
(
QueryRunnerColumnDefault
,
queryRunnerColumnDefault
,
PGInt4
,
PGT
ext
,
PGT
SVector
,
Nullable
,
fieldQueryRunnerColumn
)
import
Test.QuickCheck
(
elements
)
import
Gargantext.Prelude.Crypto.Hash
(
Hash
)
import
Test.QuickCheck.Arbitrary
...
...
@@ -54,7 +54,7 @@ type UserId = Int
type
MasterUserId
=
UserId
------------------------------------------------------------------------
-- | NodePoly indicates that Node has a Polymorphism Type
type
Node
json
=
NodePoly
NodeId
Hash
NodeTypeId
UserId
(
Maybe
ParentId
)
NodeName
UTCTime
json
type
Node
json
=
NodePoly
NodeId
(
Maybe
Hash
)
NodeTypeId
UserId
(
Maybe
ParentId
)
NodeName
UTCTime
json
-- | NodeSearch (queries)
-- type NodeSearch json = NodePolySearch NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json (Maybe TSVector)
...
...
@@ -347,3 +347,8 @@ instance (QueryRunnerColumnDefault (Nullable O.PGTimestamptz) UTCTime)
where
queryRunnerColumnDefault
=
fieldQueryRunnerColumn
instance
QueryRunnerColumnDefault
PGText
(
Maybe
Hash
)
where
queryRunnerColumnDefault
=
fieldQueryRunnerColumn
src/Gargantext/Database/Query/Table/Node/Document/Insert.hs
View file @
458283b7
...
...
@@ -57,8 +57,8 @@ module Gargantext.Database.Query.Table.Node.Document.Insert
import
Control.Lens
(
set
,
view
)
import
Control.Lens.Cons
import
Control.Lens.Prism
import
Data.Aeson
(
toJSON
,
encode
{-, ToJSON-}
)
import
Data.Maybe
(
maybe
)
import
Data.Aeson
(
toJSON
,
encode
,
ToJSON
)
import
Data.Maybe
(
maybe
,
fromMaybe
)
import
Data.Text
(
Text
)
-- import Data.ByteString (ByteString)
import
Data.Time.Segment
(
jour
)
...
...
@@ -66,7 +66,7 @@ import Database.PostgreSQL.Simple (FromRow, Query, Only(..))
import
Database.PostgreSQL.Simple.FromRow
(
fromRow
,
field
)
-- import Database.PostgreSQL.Simple.ToRow (toRow, ToRow)
import
Database.PostgreSQL.Simple.SqlQQ
import
Database.PostgreSQL.Simple.ToField
(
toField
,
Action
)
import
Database.PostgreSQL.Simple.ToField
(
toField
,
Action
{-, ToField-}
)
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
))
import
GHC.Generics
(
Generic
)
import
Gargantext.Database.Admin.Config
(
nodeTypeId
)
...
...
@@ -76,7 +76,7 @@ import Gargantext.Database.Prelude (Cmd, runPGSQuery{-, formatPGSQuery-})
import
Gargantext.Database.Schema.Node
(
NodePoly
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude.Crypto.Hash
(
hash
)
import
qualified
Data.Text
as
DT
(
pack
,
concat
,
take
)
import
qualified
Data.Text
as
DT
(
pack
,
concat
,
take
)
{-| To Print result query
import Data.ByteString.Internal (ByteString)
...
...
@@ -123,7 +123,7 @@ instance InsertDb HyperdataContact
,
(
toField
.
toJSON
)
h
]
instance
InsertDb
(
Node
HyperdataDocument
)
instance
ToJSON
a
=>
InsertDb
(
Node
a
)
where
insertDb'
_u
_p
(
Node
_nid
hashId
t
u
p
n
d
h
)
=
[
toField
hashId
,
toField
t
...
...
@@ -131,7 +131,7 @@ instance InsertDb (Node HyperdataDocument)
,
toField
p
,
toField
n
,
toField
d
,
toField
h
,
(
toField
.
toJSON
)
h
]
-- | Debug SQL function
...
...
@@ -217,17 +217,31 @@ secret :: Text
secret
=
"Database secret to change"
instance
AddUniqId
(
Node
HyperdataDocument
)
instance
(
AddUniqId
a
,
ToJSON
a
)
=>
AddUniqId
(
Node
a
)
where
addUniqId
(
Node
nid
_
t
u
p
n
d
h
)
=
Node
nid
hashId
t
u
p
n
d
h
where
hashId
=
"
\\
x"
<>
(
hash
$
DT
.
concat
params
)
params
=
[
secret
,
cs
$
show
$
nodeTypeId
NodeDocument
,
n
,
cs
$
show
p
,
cs
$
encode
h
]
addUniqId
(
Node
nid
_
t
u
p
n
d
h
)
=
Node
nid
hashId
t
u
p
n
d
h
where
hashId
=
Just
$
"
\\
x"
<>
(
hash
$
DT
.
concat
params
)
params
=
[
secret
,
cs
$
show
$
nodeTypeId
NodeDocument
,
n
,
cs
$
show
p
,
cs
$
encode
h
]
{-
addUniqId n@(Node nid _ t u p n d h) =
case n of
Node HyperdataDocument -> Node nid hashId t u p n d h
where
hashId = "\\x" <> (hash $ DT.concat params)
params = [ secret
, cs $ show $ nodeTypeId NodeDocument
, n
, cs $ show p
, cs $ encode h
]
_ -> undefined
-}
---------------------------------------------------------------------------
-- * Uniqueness of document definition
...
...
@@ -246,8 +260,8 @@ addUniqIdsContact hc = set (hc_uniqIdBdd) (Just shaBdd)
-- | TODO add more shaparameters
shaParametersContact
::
[(
HyperdataContact
->
Text
)]
shaParametersContact
=
[
\
d
->
maybeText
$
view
(
hc_who
.
_Just
.
cw_firstName
)
d
,
\
d
->
maybeText
$
view
(
hc_who
.
_Just
.
cw_lastName
)
d
shaParametersContact
=
[
\
d
->
maybeText
$
view
(
hc_who
.
_Just
.
cw_firstName
)
d
,
\
d
->
maybeText
$
view
(
hc_who
.
_Just
.
cw_lastName
)
d
,
\
d
->
maybeText
$
view
(
hc_where
.
_head
.
cw_touch
.
_Just
.
ct_mail
)
d
]
...
...
@@ -255,3 +269,23 @@ maybeText :: Maybe Text -> Text
maybeText
=
maybe
(
DT
.
pack
""
)
identity
---------------------------------------------------------------------------
class
ToNode
a
where
-- TODO Maybe NodeId
toNode
::
UserId
->
ParentId
->
a
->
Node
a
instance
ToNode
HyperdataDocument
where
toNode
u
p
h
=
Node
0
Nothing
(
nodeTypeId
NodeDocument
)
u
(
Just
p
)
n
date
h
where
n
=
maybe
"No Title"
(
DT
.
take
255
)
(
_hd_title
h
)
date
=
jour
y
m
d
y
=
maybe
0
fromIntegral
$
_hd_publication_year
h
m
=
fromMaybe
1
$
_hd_publication_month
h
d
=
fromMaybe
1
$
_hd_publication_day
h
-- TODO
instance
ToNode
HyperdataContact
where
toNode
=
undefined
src/Gargantext/Prelude.hs
View file @
458283b7
...
...
@@ -11,7 +11,7 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE TemplateHaskell #-}
module
Gargantext.Prelude
(
module
Gargantext
.
Prelude
...
...
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