Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
H
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
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
Przemyslaw Kaminski
haskell-gargantext
Commits
8f521836
Commit
8f521836
authored
Dec 07, 2018
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[TSVector] added for full text queries.
parent
53e751d3
Changes
10
Hide whitespace changes
Inline
Side-by-side
Showing
10 changed files
with
127 additions
and
97 deletions
+127
-97
install
install
+1
-0
package.yaml
package.yaml
+1
-1
Facet.hs
src/Gargantext/Database/Facet.hs
+1
-3
Utils.hs
src/Gargantext/Database/Flow/Utils.hs
+1
-1
Node.hs
src/Gargantext/Database/Node.hs
+73
-59
Children.hs
src/Gargantext/Database/Node/Children.hs
+1
-1
Queries.hs
src/Gargantext/Database/Queries.hs
+3
-5
TextSearch.hs
src/Gargantext/Database/TextSearch.hs
+18
-3
Node.hs
src/Gargantext/Database/Types/Node.hs
+26
-23
stack.yaml
stack.yaml
+2
-1
No files found.
install
View file @
8f521836
...
@@ -27,6 +27,7 @@ git clone ssh://git@gitlab.iscpif.fr:20022/gargantext/clustering-louvain.git
...
@@ -27,6 +27,7 @@ git clone ssh://git@gitlab.iscpif.fr:20022/gargantext/clustering-louvain.git
git clone https://github.com/np/servant-job.git
git clone https://github.com/np/servant-job.git
git clone https://github.com/np/patches-map
git clone https://github.com/np/patches-map
git clone https://gitlab.com/npouillard/patches-class.git
git clone https://gitlab.com/npouillard/patches-class.git
git clone https://github.com:delanoe/haskell-opaleye.git
cd
..
cd
..
~/.local/bin/stack docker pull
~/.local/bin/stack docker pull
...
...
package.yaml
View file @
8f521836
name
:
gargantext
name
:
gargantext
version
:
'
4.0.0.
2
'
version
:
'
4.0.0.
3
'
synopsis
:
Search, map, share
synopsis
:
Search, map, share
description
:
Please see README.md
description
:
Please see README.md
category
:
Data
category
:
Data
...
...
src/Gargantext/Database/Facet.hs
View file @
8f521836
...
@@ -50,7 +50,7 @@ import Gargantext.Database.NodeNgram
...
@@ -50,7 +50,7 @@ import Gargantext.Database.NodeNgram
import
Gargantext.Database.NodeNode
import
Gargantext.Database.NodeNode
import
Gargantext.Database.Queries
import
Gargantext.Database.Queries
import
Opaleye
import
Opaleye
import
Opaleye.Internal.Join
(
NullMaker
)
import
Opaleye.Internal.Join
(
NullMaker
(
..
)
)
import
Prelude
(
Enum
,
Bounded
,
minBound
,
maxBound
)
import
Prelude
(
Enum
,
Bounded
,
minBound
,
maxBound
)
import
Prelude
hiding
(
null
,
id
,
map
,
sum
,
not
,
read
)
import
Prelude
hiding
(
null
,
id
,
map
,
sum
,
not
,
read
)
import
Servant.API
import
Servant.API
...
@@ -193,8 +193,6 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
...
@@ -193,8 +193,6 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
cond45
(
contact
,
(
nodeNgram2
,
(
_
,
(
_
,
_
))))
=
_node_id
contact
.==
nodeNgram_NodeNgramNodeId
nodeNgram2
cond45
(
contact
,
(
nodeNgram2
,
(
_
,
(
_
,
_
))))
=
_node_id
contact
.==
nodeNgram_NodeNgramNodeId
nodeNgram2
------------------------------------------------------------------------
------------------------------------------------------------------------
runViewDocuments
::
CorpusId
->
Trash
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
Cmd
[
FacetDoc
]
runViewDocuments
::
CorpusId
->
Trash
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
Cmd
[
FacetDoc
]
...
...
src/Gargantext/Database/Flow/Utils.hs
View file @
8f521836
...
@@ -26,7 +26,7 @@ import Gargantext.Database.NodeNgram
...
@@ -26,7 +26,7 @@ import Gargantext.Database.NodeNgram
toMaps
::
Hyperdata
a
=>
(
a
->
Map
(
NgramsT
Ngrams
)
Int
)
->
[
Node
a
]
->
Map
(
NgramsT
Ngrams
)
(
Map
NodeId
Int
)
toMaps
::
Hyperdata
a
=>
(
a
->
Map
(
NgramsT
Ngrams
)
Int
)
->
[
Node
a
]
->
Map
(
NgramsT
Ngrams
)
(
Map
NodeId
Int
)
toMaps
fun
ns
=
mapNodeIdNgrams
$
documentIdWithNgrams
fun
ns'
toMaps
fun
ns
=
mapNodeIdNgrams
$
documentIdWithNgrams
fun
ns'
where
where
ns'
=
map
(
\
(
Node
nId
_
_
_
_
_
json
)
->
DocumentWithId
nId
json
)
ns
ns'
=
map
(
\
(
Node
nId
_
_
_
_
_
json
_
)
->
DocumentWithId
nId
json
)
ns
mapNodeIdNgrams
::
Hyperdata
a
=>
[
DocumentIdWithNgrams
a
]
->
Map
(
NgramsT
Ngrams
)
(
Map
NodeId
Int
)
mapNodeIdNgrams
::
Hyperdata
a
=>
[
DocumentIdWithNgrams
a
]
->
Map
(
NgramsT
Ngrams
)
(
Map
NodeId
Int
)
mapNodeIdNgrams
ds
=
DM
.
map
(
DM
.
fromListWith
(
+
))
$
DM
.
fromListWith
(
<>
)
xs
mapNodeIdNgrams
ds
=
DM
.
map
(
DM
.
fromListWith
(
+
))
$
DM
.
fromListWith
(
<>
)
xs
...
...
src/Gargantext/Database/Node.hs
View file @
8f521836
...
@@ -18,48 +18,42 @@ Portability : POSIX
...
@@ -18,48 +18,42 @@ Portability : POSIX
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings
#-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell #-}
module
Gargantext.Database.Node
where
module
Gargantext.Database.Node
where
import
Data.Text
(
pack
)
import
GHC.Int
(
Int64
)
import
Control.Lens
(
set
)
import
Data.Maybe
import
Data.Time
(
UTCTime
)
import
Database.PostgreSQL.Simple.FromField
(
FromField
,
fromField
)
import
Prelude
hiding
(
null
,
id
,
map
,
sum
)
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Individu
(
Username
)
import
Gargantext.Database.Utils
(
fromField'
)
import
Gargantext.Database.Types.Node
(
NodeType
,
defaultCorpus
,
Hyperdata
)
import
Gargantext.Database.Queries
import
Gargantext.Database.Config
(
nodeTypeId
)
import
Gargantext.Prelude
hiding
(
sum
,
head
)
import
Gargantext.Core.Types.Main
(
UserId
)
import
Control.Applicative
(
Applicative
)
import
Control.Applicative
(
Applicative
)
import
Control.Arrow
(
returnA
)
import
Control.Arrow
(
returnA
)
import
Control.Lens
(
set
)
import
Control.Lens.TH
(
makeLensesWith
,
abbreviatedFields
)
import
Control.Lens.TH
(
makeLensesWith
,
abbreviatedFields
)
import
Control.Monad.IO.Class
import
Control.Monad.IO.Class
import
Control.Monad.Reader
import
Control.Monad.Reader
import
Data.Aeson
import
Data.Aeson
import
Data.Maybe
(
Maybe
,
fromMaybe
)
import
Data.Text
(
Text
)
import
Data.Profunctor.Product.TH
(
makeAdaptorAndInstance
)
import
qualified
Data.ByteString
as
DB
import
qualified
Data.ByteString.Lazy
as
DBL
import
Data.ByteString
(
ByteString
)
import
Data.ByteString
(
ByteString
)
import
Data.Maybe
(
Maybe
(
..
),
fromMaybe
)
import
Data.Profunctor.Product.TH
(
makeAdaptorAndInstance
)
import
Data.Text
(
Text
,
unpack
,
pack
)
import
Data.Time
(
UTCTime
)
import
Database.PostgreSQL.Simple
(
Connection
)
import
Database.PostgreSQL.Simple
(
Connection
)
import
Database.PostgreSQL.Simple.FromField
(
FromField
,
fromField
)
import
GHC.Int
(
Int64
)
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Individu
(
Username
)
import
Gargantext.Core.Types.Main
(
UserId
)
import
Gargantext.Database.Config
(
nodeTypeId
)
import
Gargantext.Database.Queries
import
Gargantext.Database.Types.Node
(
NodeType
,
defaultCorpus
,
Hyperdata
)
import
Gargantext.Database.Utils
(
fromField'
)
import
Gargantext.Prelude
hiding
(
sum
,
head
)
import
Opaleye
hiding
(
FromField
)
import
Opaleye
hiding
(
FromField
)
import
Opaleye.Internal.QueryArr
(
Query
)
import
Opaleye.Internal.QueryArr
(
Query
)
import
Prelude
hiding
(
null
,
id
,
map
,
sum
)
import
qualified
Data.ByteString
as
DB
import
qualified
Data.ByteString.Lazy
as
DBL
import
qualified
Data.Profunctor.Product
as
PP
import
qualified
Data.Profunctor.Product
as
PP
------------------------------------------------------------------------
------------------------------------------------------------------------
...
@@ -141,6 +135,12 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataList
...
@@ -141,6 +135,12 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataList
instance
QueryRunnerColumnDefault
PGJsonb
HyperdataAnnuaire
instance
QueryRunnerColumnDefault
PGJsonb
HyperdataAnnuaire
where
where
queryRunnerColumnDefault
=
fieldQueryRunnerColumn
queryRunnerColumnDefault
=
fieldQueryRunnerColumn
instance
QueryRunnerColumnDefault
PGTSVector
(
Maybe
TSVector
)
where
queryRunnerColumnDefault
=
fieldQueryRunnerColumn
------------------------------------------------------------------------
------------------------------------------------------------------------
$
(
makeAdaptorAndInstance
"pNode"
''
N
odePoly
)
$
(
makeAdaptorAndInstance
"pNode"
''
N
odePoly
)
...
@@ -148,15 +148,17 @@ $(makeLensesWith abbreviatedFields ''NodePoly)
...
@@ -148,15 +148,17 @@ $(makeLensesWith abbreviatedFields ''NodePoly)
nodeTable
::
Table
NodeWrite
NodeRead
nodeTable
::
Table
NodeWrite
NodeRead
nodeTable
=
Table
"nodes"
(
pNode
Node
{
_node_id
=
optional
"id"
nodeTable
=
Table
"nodes"
(
pNode
Node
{
_node_id
=
optional
"id"
,
_node_typename
=
required
"typename"
,
_node_typename
=
required
"typename"
,
_node_userId
=
required
"user_id"
,
_node_userId
=
required
"user_id"
,
_node_parentId
=
required
"parent_id"
,
_node_name
=
required
"name"
,
_node_parentId
=
required
"parent_id"
,
_node_date
=
optional
"date"
,
_node_name
=
required
"name"
,
_node_hyperdata
=
required
"hyperdata"
,
_node_date
=
optional
"date"
-- , node_titleAbstract = optional "title_abstract"
}
,
_node_hyperdata
=
required
"hyperdata"
,
_node_search
=
optional
"search"
}
)
)
...
@@ -167,6 +169,7 @@ nodeTable' :: Table (Maybe (Column PGInt4)
...
@@ -167,6 +169,7 @@ nodeTable' :: Table (Maybe (Column PGInt4)
,
Column
PGText
,
Column
PGText
,
Maybe
(
Column
PGTimestamptz
)
,
Maybe
(
Column
PGTimestamptz
)
,
Column
PGJsonb
,
Column
PGJsonb
,
Maybe
(
Column
PGTSVector
)
)
)
((
Column
PGInt4
)
((
Column
PGInt4
)
,
Column
PGInt4
,
Column
PGInt4
...
@@ -175,15 +178,19 @@ nodeTable' :: Table (Maybe (Column PGInt4)
...
@@ -175,15 +178,19 @@ nodeTable' :: Table (Maybe (Column PGInt4)
,
Column
PGText
,
Column
PGText
,(
Column
PGTimestamptz
)
,(
Column
PGTimestamptz
)
,
Column
PGJsonb
,
Column
PGJsonb
,
Column
PGTSVector
)
)
nodeTable'
=
Table
"nodes"
(
PP
.
p
7
(
optional
"id"
nodeTable'
=
Table
"nodes"
(
PP
.
p
8
(
optional
"id"
,
required
"typename"
,
required
"typename"
,
required
"user_id"
,
required
"user_id"
,
optional
"parent_id"
,
optional
"parent_id"
,
required
"name"
,
required
"name"
,
optional
"date"
,
optional
"date"
,
required
"hyperdata"
,
required
"hyperdata"
,
optional
"search"
)
)
)
)
...
@@ -197,6 +204,7 @@ selectNode id = proc () -> do
...
@@ -197,6 +204,7 @@ selectNode id = proc () -> do
restrict
-<
_node_id
row
.==
id
restrict
-<
_node_id
row
.==
id
returnA
-<
row
returnA
-<
row
runGetNodes
::
Query
NodeRead
->
Cmd
[
NodeAny
]
runGetNodes
::
Query
NodeRead
->
Cmd
[
NodeAny
]
runGetNodes
q
=
mkCmd
$
\
conn
->
runQuery
conn
q
runGetNodes
q
=
mkCmd
$
\
conn
->
runQuery
conn
q
...
@@ -216,7 +224,7 @@ selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
...
@@ -216,7 +224,7 @@ selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
selectNodesWith'
::
ParentId
->
Maybe
NodeType
->
Query
NodeRead
selectNodesWith'
::
ParentId
->
Maybe
NodeType
->
Query
NodeRead
selectNodesWith'
parentId
maybeNodeType
=
proc
()
->
do
selectNodesWith'
parentId
maybeNodeType
=
proc
()
->
do
node
<-
(
proc
()
->
do
node
<-
(
proc
()
->
do
row
@
(
Node
_
typeId
_
parentId'
_
_
_
)
<-
queryNodeTable
-<
()
row
@
(
Node
_
typeId
_
parentId'
_
_
_
_
)
<-
queryNodeTable
-<
()
restrict
-<
parentId'
.==
(
toNullable
$
pgInt4
parentId
)
restrict
-<
parentId'
.==
(
toNullable
$
pgInt4
parentId
)
let
typeId'
=
maybe
0
nodeTypeId
maybeNodeType
let
typeId'
=
maybe
0
nodeTypeId
maybeNodeType
...
@@ -237,12 +245,12 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
...
@@ -237,12 +245,12 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
deleteNode
::
Int
->
Cmd
Int
deleteNode
::
Int
->
Cmd
Int
deleteNode
n
=
mkCmd
$
\
conn
->
deleteNode
n
=
mkCmd
$
\
conn
->
fromIntegral
<$>
runDelete
conn
nodeTable
fromIntegral
<$>
runDelete
conn
nodeTable
(
\
(
Node
n_id
_
_
_
_
_
_
)
->
n_id
.==
pgInt4
n
)
(
\
(
Node
n_id
_
_
_
_
_
_
_
)
->
n_id
.==
pgInt4
n
)
deleteNodes
::
[
Int
]
->
Cmd
Int
deleteNodes
::
[
Int
]
->
Cmd
Int
deleteNodes
ns
=
mkCmd
$
\
conn
->
deleteNodes
ns
=
mkCmd
$
\
conn
->
fromIntegral
<$>
runDelete
conn
nodeTable
fromIntegral
<$>
runDelete
conn
nodeTable
(
\
(
Node
n_id
_
_
_
_
_
_
)
->
in_
((
map
pgInt4
ns
))
n_id
)
(
\
(
Node
n_id
_
_
_
_
_
_
_
)
->
in_
((
map
pgInt4
ns
))
n_id
)
getNodesWith
::
JSONB
a
=>
Connection
->
Int
->
proxy
a
->
Maybe
NodeType
getNodesWith
::
JSONB
a
=>
Connection
->
Int
->
proxy
a
->
Maybe
NodeType
...
@@ -281,7 +289,7 @@ getCorporaWithParentId' n = mkCmd $ \conn -> runQuery conn $ selectNodesWith' n
...
@@ -281,7 +289,7 @@ getCorporaWithParentId' n = mkCmd $ \conn -> runQuery conn $ selectNodesWith' n
------------------------------------------------------------------------
------------------------------------------------------------------------
selectNodesWithParentID
::
Int
->
Query
NodeRead
selectNodesWithParentID
::
Int
->
Query
NodeRead
selectNodesWithParentID
n
=
proc
()
->
do
selectNodesWithParentID
n
=
proc
()
->
do
row
@
(
Node
_
_
_
parent_id
_
_
_
)
<-
queryNodeTable
-<
()
row
@
(
Node
_
_
_
parent_id
_
_
_
_
)
<-
queryNodeTable
-<
()
restrict
-<
if
n
>
0
restrict
-<
if
n
>
0
then
parent_id
.==
(
toNullable
$
pgInt4
n
)
then
parent_id
.==
(
toNullable
$
pgInt4
n
)
else
isNull
parent_id
else
isNull
parent_id
...
@@ -289,7 +297,7 @@ selectNodesWithParentID n = proc () -> do
...
@@ -289,7 +297,7 @@ selectNodesWithParentID n = proc () -> do
selectNodesWithType
::
Column
PGInt4
->
Query
NodeRead
selectNodesWithType
::
Column
PGInt4
->
Query
NodeRead
selectNodesWithType
type_id
=
proc
()
->
do
selectNodesWithType
type_id
=
proc
()
->
do
row
@
(
Node
_
tn
_
_
_
_
_
)
<-
queryNodeTable
-<
()
row
@
(
Node
_
tn
_
_
_
_
_
_
)
<-
queryNodeTable
-<
()
restrict
-<
tn
.==
type_id
restrict
-<
tn
.==
type_id
returnA
-<
row
returnA
-<
row
...
@@ -308,7 +316,7 @@ getNodesWithType conn type_id = do
...
@@ -308,7 +316,7 @@ getNodesWithType conn type_id = do
-- TODO Classe HasDefault where
-- TODO Classe HasDefault where
-- default NodeType = Hyperdata
-- default NodeType = Hyperdata
------------------------------------------------------------------------
------------------------------------------------------------------------
type
NodeWrite'
=
NodePoly
(
Maybe
Int
)
Int
Int
(
Maybe
ParentId
)
Text
(
Maybe
UTCTime
)
ByteString
type
NodeWrite'
=
NodePoly
(
Maybe
Int
)
Int
Int
(
Maybe
ParentId
)
Text
(
Maybe
UTCTime
)
ByteString
(
Maybe
TSVector
)
------------------------------------------------------------------------
------------------------------------------------------------------------
defaultUser
::
HyperdataUser
defaultUser
::
HyperdataUser
defaultUser
=
HyperdataUser
(
Just
$
(
pack
.
show
)
EN
)
defaultUser
=
HyperdataUser
(
Just
$
(
pack
.
show
)
EN
)
...
@@ -388,25 +396,30 @@ nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard
...
@@ -388,25 +396,30 @@ nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard
------------------------------------------------------------------------
------------------------------------------------------------------------
node
::
(
ToJSON
a
,
Hyperdata
a
)
=>
NodeType
->
Name
->
a
->
Maybe
ParentId
->
UserId
->
NodeWrite'
node
::
(
ToJSON
a
,
Hyperdata
a
)
=>
NodeType
->
Name
->
a
->
Maybe
ParentId
->
UserId
->
NodeWrite'
node
nodeType
name
hyperData
parentId
userId
=
Node
Nothing
typeId
userId
parentId
name
Nothing
byteData
node
nodeType
name
hyperData
parentId
userId
=
Node
Nothing
typeId
userId
parentId
name
Nothing
byteData
Nothing
where
where
typeId
=
nodeTypeId
nodeType
typeId
=
nodeTypeId
nodeType
byteData
=
DB
.
pack
.
DBL
.
unpack
$
encode
hyperData
byteData
=
DB
.
pack
.
DBL
.
unpack
$
encode
hyperData
-------------------------------
-------------------------------
node2row
::
(
Functor
maybe1
,
Functor
maybe2
,
Functor
maybe3
)
=>
node2row
::
(
Functor
maybe1
,
Functor
maybe2
,
Functor
maybe3
,
Functor
maybe4
)
=>
NodePoly
(
maybe2
Int
)
Int
Int
(
maybe1
Int
)
NodePoly
(
maybe1
Int
)
Int
Int
Text
(
maybe3
UTCTime
)
ByteString
(
maybe2
Int
)
Text
(
maybe3
UTCTime
)
->
(
maybe2
(
Column
PGInt4
),
Column
PGInt4
,
Column
PGInt4
,
maybe1
(
Column
PGInt4
)
ByteString
(
maybe4
TSVector
)
,
Column
PGText
,
maybe3
(
Column
PGTimestamptz
),
Column
PGJsonb
)
->
(
maybe1
(
Column
PGInt4
),
Column
PGInt4
,
Column
PGInt4
node2row
(
Node
id
tn
ud
pid
nm
dt
hp
)
=
((
pgInt4
<$>
id
)
,
maybe2
(
Column
PGInt4
),
Column
PGText
,
maybe3
(
Column
PGTimestamptz
)
,(
pgInt4
tn
)
,
Column
PGJsonb
,
maybe4
(
Column
PGTSVector
))
,(
pgInt4
ud
)
node2row
(
Node
id
tn
ud
pid
nm
dt
hp
tv
)
=
((
pgInt4
<$>
id
)
,(
pgInt4
<$>
pid
)
,(
pgInt4
tn
)
,(
pgStrictText
nm
)
,(
pgInt4
ud
)
,(
pgUTCTime
<$>
dt
)
,(
pgStrictJSONB
hp
)
,(
pgInt4
<$>
pid
)
)
,(
pgStrictText
nm
)
,(
pgUTCTime
<$>
dt
)
,(
pgStrictJSONB
hp
)
,(
pgTSVector
.
unpack
<$>
tv
)
)
------------------------------------------------------------------------
------------------------------------------------------------------------
insertNodesR'
::
[
NodeWrite'
]
->
Cmd
[
Int
]
insertNodesR'
::
[
NodeWrite'
]
->
Cmd
[
Int
]
insertNodesR'
ns
=
mkCmd
$
\
c
->
insertNodesR
ns
c
insertNodesR'
ns
=
mkCmd
$
\
c
->
insertNodesR
ns
c
...
@@ -415,7 +428,7 @@ insertNodes :: [NodeWrite'] -> Connection -> IO Int64
...
@@ -415,7 +428,7 @@ insertNodes :: [NodeWrite'] -> Connection -> IO Int64
insertNodes
ns
conn
=
runInsertMany
conn
nodeTable'
(
map
node2row
ns
)
insertNodes
ns
conn
=
runInsertMany
conn
nodeTable'
(
map
node2row
ns
)
insertNodesR
::
[
NodeWrite'
]
->
Connection
->
IO
[
Int
]
insertNodesR
::
[
NodeWrite'
]
->
Connection
->
IO
[
Int
]
insertNodesR
ns
conn
=
runInsertManyReturning
conn
nodeTable'
(
map
node2row
ns
)
(
\
(
i
,
_
,
_
,
_
,
_
,
_
,
_
)
->
i
)
insertNodesR
ns
conn
=
runInsertManyReturning
conn
nodeTable'
(
map
node2row
ns
)
(
\
(
i
,
_
,
_
,
_
,
_
,
_
,
_
,
_
)
->
i
)
-------------------------
-------------------------
insertNodesWithParent
::
Maybe
ParentId
->
[
NodeWrite'
]
->
Connection
->
IO
Int64
insertNodesWithParent
::
Maybe
ParentId
->
[
NodeWrite'
]
->
Connection
->
IO
Int64
insertNodesWithParent
pid
ns
conn
=
insertNodes
(
map
(
set
node_parentId
pid
)
ns
)
conn
insertNodesWithParent
pid
ns
conn
=
insertNodes
(
map
(
set
node_parentId
pid
)
ns
)
conn
...
@@ -441,7 +454,7 @@ post c uid pid [ Node' NodeCorpus "name" "{}" []
...
@@ -441,7 +454,7 @@ post c uid pid [ Node' NodeCorpus "name" "{}" []
-- needs a Temporary type between Node' and NodeWriteT
-- needs a Temporary type between Node' and NodeWriteT
node2table
::
UserId
->
Maybe
ParentId
->
Node'
->
NodeWriteT
node2table
::
UserId
->
Maybe
ParentId
->
Node'
->
NodeWriteT
node2table
uid
pid
(
Node'
nt
txt
v
[]
)
=
(
Nothing
,
(
pgInt4
$
nodeTypeId
nt
),
(
pgInt4
uid
),
(
fmap
pgInt4
pid
)
node2table
uid
pid
(
Node'
nt
txt
v
[]
)
=
(
Nothing
,
(
pgInt4
$
nodeTypeId
nt
),
(
pgInt4
uid
),
(
fmap
pgInt4
pid
)
,
pgStrictText
txt
,
Nothing
,
pgStrictJSONB
$
DB
.
pack
$
DBL
.
unpack
$
encode
v
)
,
pgStrictText
txt
,
Nothing
,
pgStrictJSONB
$
DB
.
pack
$
DBL
.
unpack
$
encode
v
,
Nothing
)
node2table
_
_
(
Node'
_
_
_
_
)
=
panic
"node2table: should not happen, Tree insert not implemented yet"
node2table
_
_
(
Node'
_
_
_
_
)
=
panic
"node2table: should not happen, Tree insert not implemented yet"
...
@@ -459,6 +472,7 @@ type NodeWriteT = ( Maybe (Column PGInt4)
...
@@ -459,6 +472,7 @@ type NodeWriteT = ( Maybe (Column PGInt4)
,
Column
PGText
,
Column
PGText
,
Maybe
(
Column
PGTimestamptz
)
,
Maybe
(
Column
PGTimestamptz
)
,
Column
PGJsonb
,
Column
PGJsonb
,
Maybe
(
Column
PGTSVector
)
)
)
...
@@ -466,7 +480,7 @@ mkNode' :: [NodeWriteT] -> Cmd Int64
...
@@ -466,7 +480,7 @@ mkNode' :: [NodeWriteT] -> Cmd Int64
mkNode'
ns
=
mkCmd
$
\
conn
->
runInsertMany
conn
nodeTable'
ns
mkNode'
ns
=
mkCmd
$
\
conn
->
runInsertMany
conn
nodeTable'
ns
mkNodeR'
::
[
NodeWriteT
]
->
Cmd
[
Int
]
mkNodeR'
::
[
NodeWriteT
]
->
Cmd
[
Int
]
mkNodeR'
ns
=
mkCmd
$
\
conn
->
runInsertManyReturning
conn
nodeTable'
ns
(
\
(
i
,
_
,
_
,
_
,
_
,
_
,
_
)
->
i
)
mkNodeR'
ns
=
mkCmd
$
\
conn
->
runInsertManyReturning
conn
nodeTable'
ns
(
\
(
i
,
_
,
_
,
_
,
_
,
_
,
_
,
_
)
->
i
)
------------------------------------------------------------------------
------------------------------------------------------------------------
...
...
src/Gargantext/Database/Node/Children.hs
View file @
8f521836
...
@@ -40,7 +40,7 @@ getChildren c pId _ maybeNodeType maybeOffset maybeLimit = runQuery c
...
@@ -40,7 +40,7 @@ getChildren c pId _ maybeNodeType maybeOffset maybeLimit = runQuery c
selectChildren
::
ParentId
->
Maybe
NodeType
->
Query
NodeRead
selectChildren
::
ParentId
->
Maybe
NodeType
->
Query
NodeRead
selectChildren
parentId
maybeNodeType
=
proc
()
->
do
selectChildren
parentId
maybeNodeType
=
proc
()
->
do
row
@
(
Node
nId
typeName
_
parent_id
_
_
_
)
<-
queryNodeTable
-<
()
row
@
(
Node
nId
typeName
_
parent_id
_
_
_
_
)
<-
queryNodeTable
-<
()
(
NodeNode
n1id
n2id
_
_
_
)
<-
queryNodeNodeTable
-<
()
(
NodeNode
n1id
n2id
_
_
_
)
<-
queryNodeNodeTable
-<
()
let
nodeType
=
maybe
0
nodeTypeId
maybeNodeType
let
nodeType
=
maybe
0
nodeTypeId
maybeNodeType
...
...
src/Gargantext/Database/Queries.hs
View file @
8f521836
...
@@ -37,7 +37,7 @@ type NodeWrite = NodePoly (Maybe (Column PGInt4 ))
...
@@ -37,7 +37,7 @@ type NodeWrite = NodePoly (Maybe (Column PGInt4 ))
(
Column
(
PGText
))
(
Column
(
PGText
))
(
Maybe
(
Column
PGTimestamptz
))
(
Maybe
(
Column
PGTimestamptz
))
(
Column
PGJsonb
)
(
Column
PGJsonb
)
--
(Maybe (Column PGTSVector))
(
Maybe
(
Column
PGTSVector
))
type
NodeRead
=
NodePoly
(
Column
PGInt4
)
type
NodeRead
=
NodePoly
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
PGInt4
)
...
@@ -46,8 +46,7 @@ type NodeRead = NodePoly (Column PGInt4 )
...
@@ -46,8 +46,7 @@ type NodeRead = NodePoly (Column PGInt4 )
(
Column
(
PGText
))
(
Column
(
PGText
))
(
Column
PGTimestamptz
)
(
Column
PGTimestamptz
)
(
Column
PGJsonb
)
(
Column
PGJsonb
)
-- (Column PGTSVector)
(
Column
PGTSVector
)
type
NodeReadNull
=
NodePoly
(
Column
(
Nullable
PGInt4
))
type
NodeReadNull
=
NodePoly
(
Column
(
Nullable
PGInt4
))
...
@@ -57,8 +56,7 @@ type NodeReadNull = NodePoly (Column (Nullable PGInt4 ))
...
@@ -57,8 +56,7 @@ type NodeReadNull = NodePoly (Column (Nullable PGInt4 ))
(
Column
(
Nullable
PGText
))
(
Column
(
Nullable
PGText
))
(
Column
(
Nullable
PGTimestamptz
))
(
Column
(
Nullable
PGTimestamptz
))
(
Column
(
Nullable
PGJsonb
))
(
Column
(
Nullable
PGJsonb
))
(
Column
(
Nullable
PGTSVector
))
join3
::
Query
columnsA
->
Query
columnsB
->
Query
columnsC
join3
::
Query
columnsA
->
Query
columnsB
->
Query
columnsC
...
...
src/Gargantext/Database/TextSearch.hs
View file @
8f521836
...
@@ -10,6 +10,7 @@ Portability : POSIX
...
@@ -10,6 +10,7 @@ Portability : POSIX
-}
-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
...
@@ -26,13 +27,30 @@ import Database.PostgreSQL.Simple.ToField
...
@@ -26,13 +27,30 @@ import Database.PostgreSQL.Simple.ToField
import
Gargantext.Database.Config
(
nodeTypeId
)
import
Gargantext.Database.Config
(
nodeTypeId
)
import
Gargantext.Database.Types.Node
(
NodeType
(
..
))
import
Gargantext.Database.Types.Node
(
NodeType
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Database.Node
import
Gargantext.Database.Queries
import
Gargantext.Core.Types
import
Control.Arrow
(
returnA
)
import
qualified
Opaleye
as
O
hiding
(
Order
)
import
Opaleye
hiding
(
Query
,
Order
)
newtype
TSQuery
=
UnsafeTSQuery
[
Text
]
newtype
TSQuery
=
UnsafeTSQuery
[
Text
]
searchQuery
::
O
.
Query
NodeRead
searchQuery
=
proc
()
->
do
row
<-
queryNodeTable
-<
()
restrict
-<
(
_node_search
row
)
@@
(
pgTSQuery
"test"
)
returnA
-<
row
-- | TODO [""] -> panic "error"
-- | TODO [""] -> panic "error"
toTSQuery
::
[
Text
]
->
TSQuery
toTSQuery
::
[
Text
]
->
TSQuery
toTSQuery
txt
=
UnsafeTSQuery
txt
toTSQuery
txt
=
UnsafeTSQuery
txt
instance
IsString
TSQuery
instance
IsString
TSQuery
where
where
fromString
=
UnsafeTSQuery
.
words
.
cs
fromString
=
UnsafeTSQuery
.
words
.
cs
...
@@ -48,9 +66,6 @@ instance ToField TSQuery
...
@@ -48,9 +66,6 @@ instance ToField TSQuery
]
]
)
xs
)
xs
type
ParentId
=
Int
type
Limit
=
Int
type
Offset
=
Int
data
Order
=
Asc
|
Desc
data
Order
=
Asc
|
Desc
instance
ToField
Order
instance
ToField
Order
...
...
src/Gargantext/Database/Types/Node.hs
View file @
8f521836
...
@@ -63,8 +63,6 @@ type UTCTime' = UTCTime
...
@@ -63,8 +63,6 @@ type UTCTime' = UTCTime
instance
Arbitrary
UTCTime'
where
instance
Arbitrary
UTCTime'
where
arbitrary
=
elements
$
timesAfter
100
D
(
jour
2000
01
01
)
arbitrary
=
elements
$
timesAfter
100
D
(
jour
2000
01
01
)
------------------------------------------------------------------------
------------------------------------------------------------------------
data
Status
=
Status
{
status_failed
::
Int
data
Status
=
Status
{
status_failed
::
Int
,
status_succeeded
::
Int
,
status_succeeded
::
Int
...
@@ -324,18 +322,15 @@ instance Hyperdata HyperdataNotebook
...
@@ -324,18 +322,15 @@ instance Hyperdata HyperdataNotebook
-- | NodePoly indicates that Node has a Polymorphism Type
-- | NodePoly indicates that Node has a Polymorphism Type
type
Node
json
=
NodePoly
NodeId
NodeTypeId
NodeUserId
(
Maybe
NodeParentId
)
NodeName
UTCTime
json
-- NodeVector
type
Node
json
=
NodePoly
NodeId
NodeTypeId
NodeUserId
(
Maybe
NodeParentId
)
NodeName
UTCTime
json
(
Maybe
TSVector
)
-- type Node json = NodePoly NodeId NodeTypeId UserId ParentId NodeName UTCTime json
-- type Node json = NodePoly NodeId NodeTypeId UserId ParentId NodeName UTCTime json
type
NodeTypeId
=
Int
type
NodeTypeId
=
Int
type
NodeParentId
=
Int
type
NodeParentId
=
Int
type
NodeUserId
=
Int
type
NodeUserId
=
Int
type
NodeName
=
Text
type
NodeName
=
Text
--type NodeVector = Vector
type
TSVector
=
Text
--type NodeUser = Node HyperdataUser
type
NodeAny
=
Node
HyperdataAny
-- | Then a Node can be either a Folder or a Corpus or a Document
-- | Then a Node can be either a Folder or a Corpus or a Document
type
NodeUser
=
Node
HyperdataUser
type
NodeUser
=
Node
HyperdataUser
...
@@ -347,6 +342,9 @@ type NodeDocument = Node HyperdataDocument
...
@@ -347,6 +342,9 @@ type NodeDocument = Node HyperdataDocument
type
NodeAnnuaire
=
Node
HyperdataAnnuaire
type
NodeAnnuaire
=
Node
HyperdataAnnuaire
-- | Any others nodes
type
NodeAny
=
Node
HyperdataAny
---- | Then a Node can be either a Graph or a Phylo or a Notebook
---- | Then a Node can be either a Graph or a Phylo or a Notebook
type
NodeList
=
Node
HyperdataList
type
NodeList
=
Node
HyperdataList
type
NodeGraph
=
Node
HyperdataGraph
type
NodeGraph
=
Node
HyperdataGraph
...
@@ -379,24 +377,30 @@ instance ToParamSchema NodeType
...
@@ -379,24 +377,30 @@ instance ToParamSchema NodeType
instance
ToSchema
NodeType
instance
ToSchema
NodeType
------------------------------------------------------------------------
------------------------------------------------------------------------
data
NodePoly
id
typename
userId
parentId
name
date
hyperdata
=
Node
{
_node_id
::
id
data
NodePoly
id
typename
userId
,
_node_typename
::
typename
parentId
name
date
,
_node_userId
::
userId
hyperdata
search
=
Node
{
_node_id
::
id
,
_node_typename
::
typename
,
_node_userId
::
userId
-- , nodeUniqId :: hashId
-- , nodeUniqId :: hashId
,
_node_parentId
::
parentId
,
_node_parentId
::
parentId
,
_node_name
::
name
,
_node_name
::
name
,
_node_date
::
date
,
_node_date
::
date
,
_node_hyperdata
::
hyperdata
}
deriving
(
Show
,
Generic
)
,
_node_hyperdata
::
hyperdata
,
_node_search
::
search
}
deriving
(
Show
,
Generic
)
$
(
deriveJSON
(
unPrefix
"_node_"
)
''
N
odePoly
)
$
(
deriveJSON
(
unPrefix
"_node_"
)
''
N
odePoly
)
$
(
makeLenses
''
N
odePoly
)
$
(
makeLenses
''
N
odePoly
)
instance
Arbitrary
hyperdata
=>
Arbitrary
(
NodePoly
NodeId
NodeTypeId
(
Maybe
NodeUserId
)
NodeParentId
NodeName
UTCTime
hyperdata
)
where
arbitrary
=
Node
1
1
(
Just
1
)
1
"name"
(
jour
2018
01
01
)
<$>
arbitrary
instance
Arbitrary
hyperdata
=>
Arbitrary
(
NodePoly
NodeId
NodeTypeId
NodeUserId
(
Maybe
NodeParentId
)
NodeName
UTCTime
hyperdata
)
where
arbitrary
=
Node
1
1
1
(
Just
1
)
"name"
(
jour
2018
01
01
)
<$>
arbitrary
instance
Arbitrary
hyperdata
=>
Arbitrary
(
NodePoly
NodeId
NodeTypeId
(
Maybe
NodeUserId
)
NodeParentId
NodeName
UTCTime
hyperdata
(
Maybe
TSVector
))
where
--arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
arbitrary
=
Node
<$>
arbitrary
<*>
arbitrary
<*>
arbitrary
<*>
arbitrary
<*>
arbitrary
<*>
arbitrary
<*>
arbitrary
<*>
arbitrary
------------------------------------------------------------------------
------------------------------------------------------------------------
hyperdataDocument
::
HyperdataDocument
hyperdataDocument
::
HyperdataDocument
hyperdataDocument
=
case
decode
docExample
of
hyperdataDocument
=
case
decode
docExample
of
...
@@ -438,18 +442,17 @@ instance ToSchema hyperdata =>
...
@@ -438,18 +442,17 @@ instance ToSchema hyperdata =>
ToSchema
(
NodePoly
NodeId
NodeTypeId
ToSchema
(
NodePoly
NodeId
NodeTypeId
(
Maybe
NodeUserId
)
(
Maybe
NodeUserId
)
NodeParentId
NodeName
NodeParentId
NodeName
UTCTime
hyperdata
UTCTime
hyperdata
TSVector
)
)
instance
ToSchema
hyperdata
=>
instance
ToSchema
hyperdata
=>
ToSchema
(
NodePoly
NodeId
NodeTypeId
ToSchema
(
NodePoly
NodeId
NodeTypeId
NodeUserId
NodeUserId
(
Maybe
NodeParentId
)
NodeName
(
Maybe
NodeParentId
)
NodeName
UTCTime
hyperdata
UTCTime
hyperdata
TSVector
)
)
instance
ToSchema
Status
instance
ToSchema
Status
stack.yaml
View file @
8f521836
...
@@ -7,6 +7,7 @@ packages:
...
@@ -7,6 +7,7 @@ packages:
-
'
deps/clustering-louvain'
-
'
deps/clustering-louvain'
-
'
deps/patches-map'
-
'
deps/patches-map'
-
'
deps/patches-class'
-
'
deps/patches-class'
-
'
deps/haskell-opaleye'
allow-newer
:
true
allow-newer
:
true
extra-deps
:
extra-deps
:
...
@@ -17,7 +18,7 @@ extra-deps:
...
@@ -17,7 +18,7 @@ extra-deps:
-
git
:
https://github.com/delanoe/servant-static-th.git
-
git
:
https://github.com/delanoe/servant-static-th.git
commit
:
ba5347e7d8a13ce5275af8470c15b2305fbb23af
commit
:
ba5347e7d8a13ce5275af8470c15b2305fbb23af
-
accelerate-1.2.0.0
-
accelerate-1.2.0.0
-
opaleye-0.6.7002.0
#
- opaleye-0.6.7002.0
-
aeson-lens-0.5.0.0
-
aeson-lens-0.5.0.0
-
duckling-0.1.3.0
-
duckling-0.1.3.0
-
full-text-search-0.2.1.4
-
full-text-search-0.2.1.4
...
...
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