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
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
Grégoire Locqueville
haskell-gargantext
Commits
c72d6334
Verified
Commit
c72d6334
authored
Feb 16, 2024
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[refactor] more refactoring and cleanup of imports
parent
ec216edf
Changes
14
Hide whitespace changes
Inline
Side-by-side
Showing
14 changed files
with
186 additions
and
230 deletions
+186
-230
gargantext.cabal
gargantext.cabal
+0
-1
Contact.hs
src/Gargantext/API/Node/Contact.hs
+9
-11
Share.hs
src/Gargantext/API/Node/Share.hs
+5
-5
Parsers.hs
src/Gargantext/Core/Text/Corpus/Parsers.hs
+0
-1
CSV.hs
src/Gargantext/Core/Text/Corpus/Parsers/CSV.hs
+13
-15
Query.hs
src/Gargantext/Core/Text/Corpus/Query.hs
+27
-15
Eleve.hs
src/Gargantext/Core/Text/Terms/Eleve.hs
+23
-11
List.hs
src/Gargantext/Database/Action/Flow/List.hs
+3
-1
Pairing.hs
src/Gargantext/Database/Action/Flow/Pairing.hs
+60
-52
Learn.hs
src/Gargantext/Database/Action/Learn.hs
+15
-9
Share.hs
src/Gargantext/Database/Action/Share.hs
+17
-12
TSQuery.hs
src/Gargantext/Database/Action/TSQuery.hs
+0
-88
User.hs
src/Gargantext/Database/Action/User.hs
+13
-8
NodeStory.hs
test/Test/Database/Operations/NodeStory.hs
+1
-1
No files found.
gargantext.cabal
View file @
c72d6334
...
...
@@ -356,7 +356,6 @@ library
Gargantext.Database.Action.Metrics.TFICF
Gargantext.Database.Action.Node
Gargantext.Database.Action.Share
Gargantext.Database.Action.TSQuery
Gargantext.Database.Admin.Access
Gargantext.Database.Admin.Bashql
Gargantext.Database.Admin.Trigger.ContextNodeNgrams
...
...
src/Gargantext/API/Node/Contact.hs
View file @
c72d6334
...
...
@@ -26,19 +26,14 @@ import Conduit
import
Data.Aeson
import
Data.Either
(
Either
(
Right
))
import
Data.Maybe
(
Maybe
(
..
))
import
Data.Swagger
import
Data.Text
(
Text
)
import
Data.Swagger
(
ToSchema
)
import
GHC.Generics
(
Generic
)
import
Servant
import
Test.QuickCheck
(
elements
)
import
Test.QuickCheck.Arbitrary
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Admin.EnvTypes
(
Env
,
GargJob
(
..
))
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
(
..
),
AsyncJobs
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
import
Gargantext.API.Node
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Node
(
NodeNodeAPI
,
nodeNodeAPI
)
import
Gargantext.API.Prelude
(
GargM
,
simuLogs
)
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core.Text.Terms
(
TermType
(
..
))
...
...
@@ -47,10 +42,13 @@ import Gargantext.Database.Action.Flow (flow)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataAnnuaire
(
..
),
HyperdataContact
)
import
Gargantext.Database.Admin.Types.Hyperdata.Contact
(
hyperdataContact
)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Prelude
((
$
),
{-printDebug,-}
)
import
Gargantext.Database.Admin.Types.Node
(
CorpusId
,
NodeId
)
import
Gargantext.Prelude
((
$
),
Proxy
(
..
),
Text
)
import
Gargantext.Utils.Aeson
qualified
as
GUA
import
Gargantext.Utils.Jobs
(
serveJobsAPI
,
MonadJobStatus
(
..
))
import
qualified
Gargantext.Utils.Aeson
as
GUA
import
Servant
((
:>
),
(
:<|>
)(
..
),
Capture
,
JSON
,
ServerT
,
Summary
)
import
Test.QuickCheck
(
elements
)
import
Test.QuickCheck.Arbitrary
------------------------------------------------------------------------
type
API
=
"contact"
:>
Summary
"Contact endpoint"
...
...
src/Gargantext/API/Node/Share.hs
View file @
c72d6334
...
...
@@ -17,22 +17,22 @@ module Gargantext.API.Node.Share
import
Data.Aeson
import
Data.List
qualified
as
List
import
Data.Swagger
import
Data.Swagger
(
ToSchema
)
import
Data.Text
qualified
as
Text
import
Gargantext.API.Prelude
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.Types.Individu
(
User
(
..
),
arbitraryUsername
)
import
Gargantext.Database.Action.Share
(
ShareNodeWith
(
..
))
import
Gargantext.Database.Action.Share
as
DB
(
shareNodeWith
,
unPublish
)
import
Gargantext.Database.Action.User
import
Gargantext.Database.Action.User.New
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Action.User
(
getUserId'
,
getUsername
)
import
Gargantext.Database.Action.User.New
(
guessUserName
,
newUser
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
UnsafeMkNodeId
),
NodeType
(
..
),
UserId
(
UnsafeMkUserId
))
import
Gargantext.Database.Prelude
(
CmdRandom
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Query.Tree
(
findNodesWithType
)
import
Gargantext.Prelude
import
Gargantext.Utils.Aeson
qualified
as
GUA
import
Servant
import
Servant
((
:>
),
Capture
,
JSON
,
Post
,
Put
,
ReqBody
,
Summary
)
import
Test.QuickCheck
(
elements
)
import
Test.QuickCheck.Arbitrary
...
...
src/Gargantext/Core/Text/Corpus/Parsers.hs
View file @
c72d6334
...
...
@@ -23,7 +23,6 @@ please follow the types.
module
Gargantext.Core.Text.Corpus.Parsers
(
FileFormat
(
..
),
FileType
(
..
),
clean
,
parseFile
,
cleanText
,
parseFormatC
,
splitOn
,
etale
)
where
-- import Gargantext.Core.Text.Learn (detectLangDefault)
import
"zip"
Codec.Archive.Zip
(
EntrySelector
,
withArchive
,
getEntry
,
getEntries
,
unEntrySelector
)
import
Conduit
import
Control.Concurrent.Async
as
CCA
(
mapConcurrently
)
...
...
src/Gargantext/Core/Text/Corpus/Parsers/CSV.hs
View file @
c72d6334
...
...
@@ -12,23 +12,21 @@ CSV parser for Gargantext corpus files.
-}
module
Gargantext.Core.Text.Corpus.Parsers.CSV
where
module
Gargantext.Core.Text.Corpus.Parsers.CSV
where
import
Conduit
import
Control.Applicative
import
Data.ByteString
qualified
as
BS
import
Data.ByteString.Lazy
qualified
as
BL
import
Data.Csv
import
Data.Text
(
pack
)
import
Data.Csv
(
DecodeOptions
(
..
),
EncodeOptions
(
..
),
FromField
,
FromNamedRecord
(
..
),
Header
,
Parser
,
ToField
(
..
),
ToNamedRecord
(
..
),
(
.:
),
(
.=
),
decodeByNameWith
,
defaultDecodeOptions
,
defaultEncodeOptions
,
encodeByNameWith
,
header
,
namedRecord
,
parseField
,
parseNamedRecord
,
runParser
)
import
Data.Text
qualified
as
T
import
Data.Time.Segment
(
jour
)
import
Data.Vector
(
Vector
)
import
Data.Vector
qualified
as
V
import
Gargantext.Core.Text
import
Gargantext.Core.Text.Context
import
Gargantext.Core.Text
(
sentences
,
unsentences
)
import
Gargantext.Core.Text.Context
(
SplitContext
(
..
),
splitBy
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataDocument
(
..
))
import
Gargantext.Prelude
hiding
(
length
,
show
)
import
Protolude
import
Gargantext.Prelude
---------------------------------------------------------------
headerCsvGargV3
::
Header
...
...
@@ -58,7 +56,7 @@ data CsvGargV3 = CsvGargV3
toDoc
::
CsvGargV3
->
HyperdataDocument
toDoc
(
CsvGargV3
did
dt
_
dpy
dpm
dpd
dab
dau
)
=
HyperdataDocument
{
_hd_bdd
=
Just
"CSV"
,
_hd_doi
=
Just
.
pack
.
show
$
did
,
_hd_doi
=
Just
.
T
.
pack
.
show
$
did
,
_hd_url
=
Nothing
,
_hd_uniqId
=
Nothing
,
_hd_uniqIdBdd
=
Nothing
...
...
@@ -246,7 +244,7 @@ readByteStringLazy :: (FromNamedRecord a)
->
Delimiter
->
BL
.
ByteString
->
Either
Text
(
Header
,
Vector
a
)
readByteStringLazy
_f
d
bs
=
first
pack
$
decodeByNameWith
(
csvDecodeOptions
d
)
bs
readByteStringLazy
_f
d
bs
=
first
T
.
pack
$
decodeByNameWith
(
csvDecodeOptions
d
)
bs
readByteStringStrict
::
(
FromNamedRecord
a
)
=>
proxy
a
...
...
@@ -270,7 +268,7 @@ readCSVFile fp = do
readCsvLazyBS
::
Delimiter
->
BL
.
ByteString
->
Either
Text
(
Header
,
Vector
CsvDoc
)
readCsvLazyBS
d
bs
=
first
pack
$
decodeByNameWith
(
csvDecodeOptions
d
)
bs
readCsvLazyBS
d
bs
=
first
T
.
pack
$
decodeByNameWith
(
csvDecodeOptions
d
)
bs
------------------------------------------------------------------------
-- | TODO use readFileLazy
...
...
@@ -281,7 +279,7 @@ readCsvHal fp = do
-- | TODO use readByteStringLazy
readCsvHalLazyBS
::
BL
.
ByteString
->
Either
Text
(
Header
,
Vector
CsvHal
)
readCsvHalLazyBS
bs
=
first
pack
$
decodeByNameWith
(
csvDecodeOptions
Tab
)
bs
readCsvHalLazyBS
bs
=
first
T
.
pack
$
decodeByNameWith
(
csvDecodeOptions
Tab
)
bs
readCsvHalBSStrict
::
BS
.
ByteString
->
Either
Text
(
Header
,
Vector
CsvHal
)
readCsvHalBSStrict
bs
=
readCsvHalLazyBS
$
BL
.
fromStrict
bs
...
...
@@ -390,7 +388,7 @@ csvHal2doc (CsvHal { .. }) =
,
_hd_institutes
=
Just
csvHal_instStructId_i
,
_hd_source
=
Just
csvHal_source
,
_hd_abstract
=
Just
csvHal_abstract
,
_hd_publication_date
=
Just
$
pack
.
show
$
jour
csvHal_publication_year
,
_hd_publication_date
=
Just
$
T
.
pack
.
show
$
jour
csvHal_publication_year
csvHal_publication_month
csvHal_publication_day
,
_hd_publication_year
=
Just
$
fromIntegral
csvHal_publication_year
...
...
@@ -415,7 +413,7 @@ csv2doc (CsvDoc { .. })
,
_hd_institutes
=
Nothing
,
_hd_source
=
Just
csv_source
,
_hd_abstract
=
Just
csv_abstract
,
_hd_publication_date
=
Just
$
pack
.
show
$
jour
(
fromIntegral
pubYear
)
,
_hd_publication_date
=
Just
$
T
.
pack
.
show
$
jour
(
fromIntegral
pubYear
)
pubMonth
pubDay
,
_hd_publication_year
=
Just
pubYear
...
...
@@ -496,6 +494,6 @@ readWeightedCsv :: FilePath -> IO (Header, Vector Csv')
readWeightedCsv
fp
=
fmap
(
\
bs
->
case
decodeByNameWith
(
csvDecodeOptions
Tab
)
bs
of
Left
e
->
panicTrace
(
pack
e
)
Left
e
->
panicTrace
(
T
.
pack
e
)
Right
corpus
->
corpus
)
$
BL
.
readFile
fp
src/Gargantext/Core/Text/Corpus/Query.hs
View file @
c72d6334
{-|
Module : Gargantext.Core.Text.Corpus.Query
Description : Query parsing functionality
Copyright : (c) CNRS, 2017 - present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DerivingStrategies #-}
module
Gargantext.Core.Text.Corpus.Query
(
...
...
@@ -16,21 +27,22 @@ module Gargantext.Core.Text.Corpus.Query (
,
unsafeMkQuery
)
where
import
Data.Bifunctor
import
Data.String
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.Core.Types
import
Prelude
import
Text.ParserCombinators.Parsec
import
Test.QuickCheck
import
qualified
Data.Aeson
as
Aeson
import
Data.BoolExpr
as
BoolExpr
import
Data.BoolExpr.Parser
as
BoolExpr
import
Data.BoolExpr.Printer
as
BoolExpr
import
qualified
Data.Swagger
as
Swagger
import
qualified
Data.Text
as
T
import
qualified
Servant.API
as
Servant
import
qualified
Text.Parsec
as
P
import
Data.Aeson
qualified
as
Aeson
import
Data.BoolExpr
(
BoolExpr
(
..
),
Signed
(
..
))
import
Data.BoolExpr
qualified
as
BoolExpr
import
Data.BoolExpr.Parser
qualified
as
BoolExpr
import
Data.BoolExpr.Printer
qualified
as
BoolExpr
import
Data.String
import
Data.Swagger
qualified
as
Swagger
import
Data.Text
qualified
as
T
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.Core.Types
import
Gargantext.Prelude
hiding
((
<|>
),
try
)
import
Servant.API
qualified
as
Servant
import
Test.QuickCheck
import
Text.Parsec
qualified
as
P
import
Text.ParserCombinators.Parsec
import
Text.Show
(
showsPrec
)
-- | A raw query, as typed by the user from the frontend.
newtype
RawQuery
=
RawQuery
{
getRawQuery
::
T
.
Text
}
...
...
src/Gargantext/Core/Text/Terms/Eleve.hs
View file @
c72d6334
...
...
@@ -40,10 +40,21 @@ Notes for current implementation:
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module
Gargantext.Core.Text.Terms.Eleve
where
module
Gargantext.Core.Text.Terms.Eleve
(
Token
,
Tries
-- import Debug.Trace (trace)
-- import Debug.SimpleReflect
,
buildTries
,
mainEleveWith
,
toToken
-- tests
,
runTestsEleve
-- debug
,
mainEleve
,
mainEleve''
)
where
import
Control.Lens
hiding
(
levels
,
children
)
import
Data.List
qualified
as
L
...
...
@@ -55,22 +66,23 @@ import Data.Tree qualified as Tree
import
Gargantext.Prelude
hiding
(
cs
)
import
Prelude
qualified
as
P
nan
::
Floating
e
=>
e
nan
=
0
/
0
noNaNs
::
P
.
RealFloat
e
=>
[
e
]
->
[
e
]
noNaNs
=
filter
(
not
.
P
.
isNaN
)
updateIfDefined
::
P
.
RealFloat
e
=>
e
->
e
->
e
updateIfDefined
e0
e
|
P
.
isNaN
e
=
e0
|
otherwise
=
e
--
updateIfDefined :: P.RealFloat e => e -> e -> e
--
updateIfDefined e0 e | P.isNaN e = e0
--
| otherwise = e
sim
::
Entropy
e
=>
e
->
e
->
Bool
sim
x
y
=
x
==
y
||
(
P
.
isNaN
x
&&
P
.
isNaN
y
)
subst
::
Entropy
e
=>
(
e
,
e
)
->
e
->
e
subst
(
src
,
dst
)
x
|
sim
src
x
=
dst
|
otherwise
=
x
--
subst :: Entropy e => (e, e) -> e -> e
--
subst (src, dst) x | sim src x = dst
--
| otherwise = x
------------------------------------------------------------------------
-- | TODO: Show Instance only used for debugging
...
...
@@ -139,7 +151,7 @@ data Trie k e
|
Leaf
{
_node_count
::
Int
}
deriving
(
Show
)
makeLenses
''
T
rie
--
makeLenses ''Trie
insertTrie
::
Ord
k
=>
[
k
]
->
Trie
k
()
->
Trie
k
()
insertTrie
[]
n
=
n
{
_node_count
=
_node_count
n
+
1
}
...
...
@@ -278,7 +290,7 @@ data Tries k e = Tries
,
_bwd
::
Trie
k
e
}
makeLenses
''
T
ries
--
makeLenses ''Tries
deriving
instance
(
Show
k
,
Show
e
)
=>
Show
(
Tries
k
e
)
...
...
src/Gargantext/Database/Action/Flow/List.hs
View file @
c72d6334
...
...
@@ -15,7 +15,9 @@ Portability : POSIX
{-# LANGUAGE InstanceSigs #-}
module
Gargantext.Database.Action.Flow.List
where
(
flowList_DbRepo
,
toNodeNgramsW'
)
where
import
Control.Lens
((
^.
),
(
+~
),
(
%~
),
at
,
(
.~
))
import
Control.Monad.Reader
...
...
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @
c72d6334
...
...
@@ -11,12 +11,13 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE QuasiQuotes #-}
module
Gargantext.Database.Action.Flow.Pairing
-- (pairing)
where
(
isPairedWith
,
pairing
)
where
import
Control.Lens
(
_Just
,
(
^.
),
view
)
import
Data.HashMap.Strict
(
HashMap
)
...
...
@@ -25,30 +26,30 @@ import Data.HashMap.Strict qualified as HashMap
import
Data.List
qualified
as
List
import
Data.Set
qualified
as
Set
import
Data.Text
qualified
as
Text
import
Gargantext.API.Ngrams.Tools
import
Gargantext.API.Ngrams.Tools
(
filterListWithRoot
,
getRepo
,
groupNodesByNgrams
,
mapTermListRoot
)
import
Gargantext.API.Ngrams.Types
(
NgramsTerm
(
..
))
import
Gargantext.Core
import
Gargantext.Core
(
toDBid
)
import
Gargantext.Core.NodeStory
(
HasNodeStory
)
import
Gargantext.Core.Text.Metrics.CharByChar
(
levenshtein
)
import
Gargantext.Core.Types
(
TableResult
(
..
))
import
Gargantext.Core.Types.Main
import
Gargantext.Database
import
Gargantext.Core.Types.Main
(
ListType
(
..
))
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
getContextsByNgramsOnlyUser
)
import
Gargantext.Database.Admin.Config
import
Gargantext.Database.Admin.Types.Hyperdata
-- (HyperdataContact(..))
import
Gargantext.Database.Admin.Types.Node
-- (AnnuaireId, CorpusId, ListId, DocId, ContactId, NodeId)
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataContact
(
..
),
cw_firstName
,
cw_lastName
,
hc_who
)
import
Gargantext.Database.Admin.Types.Node
(
AnnuaireId
,
CorpusId
,
ListId
,
DocId
,
ContactId
,
Node
,
NodeId
,
NodeType
(
NodeList
),
contextId2NodeId
,
pgNodeId
)
import
Gargantext.Database.Prelude
(
Cmd
,
DBCmd
,
runOpaQuery
)
import
Gargantext.Database.Query.Prelude
(
returnA
,
queryNodeNodeTable
)
import
Gargantext.Database.Query.Table.Node
(
defaultList
)
import
Gargantext.Database.Query.Table.Node.Children
(
getAllContacts
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node.Select
(
selectNodesWithUsername
)
import
Gargantext.Database.Query.Table.NodeContext_NodeContext
(
insertNodeContext_NodeContext
)
import
Gargantext.Database.Query.Table.NodeNode
(
insertNodeNode
)
import
Gargantext.Database.
Prelude
(
Cmd
,
runOpaQuery
)
import
Gargantext.Database.Schema.N
grams
-- (NgramsType(..)
)
import
Gargantext.
Database.Schema.No
de
import
Gargantext.Prelude
hiding
(
sum
)
import
Opaleye
import
Gargantext.Database.Query.Table.NodeNode
(
NodeNodePoly
(
..
),
insertNodeNode
,
nn_node1_id
,
nn_node2_id
)
import
Gargantext.Database.
Schema.Ngrams
(
NgramsType
(
..
)
)
import
Gargantext.Database.Schema.N
ode
(
node_hyperdata
,
node_id
,
node_typename
,
queryNodeTable
)
import
Gargantext.
Prelu
de
import
Opaleye
((
.==
),
(
.===
),
Column
,
Select
,
SqlInt4
,
justFields
,
optionalRestrict
,
restrict
,
sqlInt4
)
-- | isPairedWith
-- All NodeAnnuaire paired with a Corpus of NodeId nId:
...
...
@@ -107,7 +108,6 @@ prepareInsert corpusId annuaireId mapContactDocs =
------------------------------------------------------------------------
type
ContactName
=
NgramsTerm
type
DocAuthor
=
NgramsTerm
type
Projected
=
NgramsTerm
fusion
::
HashMap
ContactName
(
Set
ContactId
)
->
HashMap
DocAuthor
(
Set
DocId
)
...
...
@@ -124,35 +124,6 @@ fusion mc md = HM.fromListWith (<>)
)
$
HM
.
toList
md
fusion''
::
HashMap
ContactName
(
Set
ContactId
)
->
HashMap
DocAuthor
(
Set
DocId
)
->
HashMap
ContactId
(
Set
DocId
)
fusion''
mc
md
=
hashmapReverse
$
fusion'
mc
(
hashmapReverse
md
)
fusion'
::
HashMap
ContactName
(
Set
ContactId
)
->
HashMap
DocId
(
Set
DocAuthor
)
->
HashMap
DocId
(
Set
ContactId
)
fusion'
mc
md
=
HM
.
fromListWith
(
<>
)
$
map
(
\
(
docId
,
setAuthors
)
->
(
docId
,
getContactIds
mc
$
getClosest'
setAuthors
(
HM
.
keys
mc
)))
$
HM
.
toList
md
getContactIds
::
HashMap
ContactName
(
Set
ContactId
)
->
Set
ContactName
->
Set
ContactId
getContactIds
mapContactNames
contactNames
=
if
Set
.
null
contactNames
then
Set
.
empty
else
Set
.
unions
$
catMaybes
$
map
(
\
contactName
->
HM
.
lookup
contactName
mapContactNames
)
$
Set
.
toList
contactNames
getClosest'
::
Set
DocAuthor
->
[
ContactName
]
->
Set
ContactName
getClosest'
setAuthors
contactNames
=
trace
(
show
(
setAuthors
,
setContactNames
)
::
Text
)
$
setContactNames
where
setContactNames
=
if
Set
.
null
xs
then
ys
else
xs
xs
=
Set
.
fromList
$
catMaybes
$
map
(
\
author
->
getClosest
Text
.
toLower
author
contactNames
)
$
Set
.
toList
setAuthors
ys
=
Set
.
fromList
$
catMaybes
$
map
(
\
(
NgramsTerm
author
)
->
case
((
lastMay
.
(
Text
.
splitOn
" "
))
author
)
of
Nothing
->
Nothing
Just
authorReduced
->
getClosest
Text
.
toLower
(
NgramsTerm
authorReduced
)
contactNames
)
$
Set
.
toList
setAuthors
getClosest
::
(
Text
->
Text
)
->
NgramsTerm
->
[
NgramsTerm
]
->
Maybe
NgramsTerm
getClosest
f
(
NgramsTerm
from'
)
candidates
=
fst
<$>
head
scored
...
...
@@ -195,9 +166,46 @@ getNgramsDocId cId lId nt = do
-- FIXME(adinapoli) we should audit this, we are converting from 'ContextId' to 'NodeId'.
HM
.
map
(
Set
.
map
contextId2NodeId
)
.
groupNodesByNgrams
ngs
<$>
getContextsByNgramsOnlyUser
cId
(
lIds
<>
[
lId
])
nt
(
HashMap
.
keys
ngs
)
hashmapReverse
::
(
Ord
a
,
Eq
b
,
Hashable
b
)
=>
HashMap
a
(
Set
b
)
->
HashMap
b
(
Set
a
)
hashmapReverse
m
=
HM
.
fromListWith
(
<>
)
$
List
.
concat
$
map
(
\
(
k
,
vs
)
->
[
(
v
,
Set
.
singleton
k
)
|
v
<-
Set
.
toList
vs
])
$
HM
.
toList
m
---------------------------------
-- Unused functions
-- type Projected = NgramsTerm
-- fusion' :: HashMap ContactName (Set ContactId)
-- -> HashMap DocId (Set DocAuthor)
-- -> HashMap DocId (Set ContactId)
-- fusion' mc md = HM.fromListWith (<>)
-- $ map (\(docId, setAuthors) -> (docId, getContactIds mc $ getClosest' setAuthors (HM.keys mc)))
-- $ HM.toList md
-- fusion'' :: HashMap ContactName (Set ContactId)
-- -> HashMap DocAuthor (Set DocId)
-- -> HashMap ContactId (Set DocId)
-- fusion'' mc md = hashmapReverse $ fusion' mc (hashmapReverse md)
-- hashmapReverse :: (Ord a, Eq b, Hashable b)
-- => HashMap a (Set b) -> HashMap b (Set a)
-- hashmapReverse m = HM.fromListWith (<>)
-- $ List.concat
-- $ map (\(k,vs) -> [ (v, Set.singleton k) | v <- Set.toList vs])
-- $ HM.toList m
-- getContactIds :: HashMap ContactName (Set ContactId) -> Set ContactName -> Set ContactId
-- getContactIds mapContactNames contactNames =
-- if Set.null contactNames
-- then Set.empty
-- else Set.unions $ catMaybes $ map (\contactName -> HM.lookup contactName mapContactNames) $ Set.toList contactNames
-- getClosest' :: Set DocAuthor -> [ContactName] -> Set ContactName
-- getClosest' setAuthors contactNames = trace (show (setAuthors, setContactNames) :: Text) $ setContactNames
-- where
-- setContactNames = if Set.null xs then ys else xs
-- xs = Set.fromList $ catMaybes $ map (\author -> getClosest Text.toLower author contactNames) $ Set.toList setAuthors
-- ys = Set.fromList $ catMaybes $ map (\(NgramsTerm author) -> case ((lastMay . (Text.splitOn " ")) author) of
-- Nothing -> Nothing
-- Just authorReduced -> getClosest Text.toLower (NgramsTerm authorReduced) contactNames)
-- $ Set.toList setAuthors
src/Gargantext/Database/Action/Learn.hs
View file @
c72d6334
...
...
@@ -9,25 +9,29 @@ Portability : POSIX
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE QuasiQuotes #-}
module
Gargantext.Database.Action.Learn
where
(
FavOrTrash
(
..
)
,
moreLike
)
where
import
Control.Lens
((
^.
))
import
Data.List
qualified
as
List
import
Data.Maybe
import
Data.Text
qualified
as
Text
import
Gargantext.Core
import
Gargantext.Core.Text.Learn
import
Gargantext.Core
(
HasDBid
)
import
Gargantext.Core.Text.Learn
(
Events
,
detectDefaultWithPriors
,
priorEventsWith
)
import
Gargantext.Core.Types.Query
(
Offset
,
Limit
(
..
))
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Admin.Types.Hyperdata
(
hd_abstract
,
hd_title
)
import
Gargantext.Database.Admin.Types.Node
(
CorpusId
,
NodeType
)
import
Gargantext.Database.Prelude
(
DBCmd
)
import
Gargantext.Database.Query.Facet
import
Gargantext.Database.Query.Facet
(
Facet
(
..
),
FacetDoc
,
OrderBy
,
runViewDocuments
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Prelude
data
FavOrTrash
=
IsFav
|
IsTrash
deriving
(
Eq
)
...
...
@@ -40,6 +44,8 @@ moreLike cId o _l order ft = do
moreLikeWith
cId
o
(
Just
3
)
order
ft
priors
---------------------------------------------------------------------------
-- Helper functions
getPriors
::
(
HasDBid
NodeType
,
HasNodeError
err
)
=>
FavOrTrash
->
CorpusId
->
DBCmd
err
(
Events
Bool
)
getPriors
ft
cId
=
do
...
...
@@ -79,8 +85,8 @@ fav2bool ft = if (==) ft IsFav then True else False
text
::
FacetDoc
->
Text
text
(
FacetDoc
_
_
_
h
_
_
_
)
=
title
<>
""
<>
Text
.
take
100
abstr
where
title
=
maybe
""
identity
(
_hd_title
h
)
abstr
=
maybe
""
identity
(
_hd_abstract
h
)
title
=
maybe
""
identity
(
h
^.
hd_title
)
abstr
=
maybe
""
identity
(
h
^.
hd_abstract
)
---------------------------------------------------------------------------
...
...
src/Gargantext/Database/Action/Share.hs
View file @
c72d6334
...
...
@@ -14,27 +14,32 @@ Portability : POSIX
{-# LANGUAGE ViewPatterns #-}
module
Gargantext.Database.Action.Share
where
(
ShareNodeWith
(
..
)
,
delFolderTeam
,
deleteMemberShip
,
membersOf
,
shareNodeWith
,
unPublish
)
where
import
Control.Arrow
(
returnA
)
import
Control.Lens
(
view
,
(
^.
))
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database
import
Gargantext.Database
(
insertDB
)
import
Gargantext.Database.Action.User
(
getUserId
)
import
Gargantext.Database.Admin.Config
(
hasNodeType
,
isInNodeTypes
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataAny
(
..
))
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Admin.Types.Node
(
_NodeId
,
NodeId
,
NodeType
(
..
),
ParentId
)
import
Gargantext.Database.Query.Table.Node
(
getNode
,
getNodesWith
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
,
errorWith
)
import
Gargantext.Database.Query.Table.NodeNode
(
deleteNodeNode
,
queryNodeNodeTable
)
import
Gargantext.Database.Query.Table.User
import
Gargantext.Database.Query.Table.NodeNode
(
NodeNode
,
NodeNodePoly
(
..
),
NodeNodeRead
,
deleteNodeNode
,
nn_node1_id
,
nn_node2_id
,
queryNodeNodeTable
)
import
Gargantext.Database.Query.Table.User
(
UserRead
,
queryUserTable
,
user_id
,
user_username
)
import
Gargantext.Database.Query.Tree.Root
(
getRootId
)
import
Gargantext.Database.Prelude
(
Cmd
,
runOpaQuery
)
import
Gargantext.Database.Schema.Node
import
Gargantext.Database.Schema.Node
(
NodeRead
,
node_id
,
node_user_id
,
queryNodeTable
)
import
Gargantext.Prelude
import
Gargantext.Utils.Tuple
(
uncurryMaybe
)
import
Opaleye
hiding
(
not
)
import
Opaleye
qualified
as
O
import
Opaleye
((
.==
),
(
.===
),
Field
,
MaybeFields
,
Select
,
SelectArr
,
SqlInt4
,
SqlText
,
justFields
,
optionalRestrict
,
restrict
,
sqlInt4
)
-- | TODO move in PhyloConfig of Gargantext
publicNodeTypes
::
[
NodeType
]
...
...
@@ -75,9 +80,9 @@ membersOfQuery (_NodeId -> teamId) = proc () -> do
,
view
node_id
<$>
n
)
nodeNode_node_User
::
O
.
Select
(
NodeNodeRead
,
MaybeFields
NodeRead
,
MaybeFields
UserRead
)
nodeNode_node_User
::
Select
(
NodeNodeRead
,
MaybeFields
NodeRead
,
MaybeFields
UserRead
)
nodeNode_node_User
=
proc
()
->
do
nn
<-
queryNodeNodeTable
-<
()
n
<-
optionalRestrict
queryNodeTable
-<
...
...
@@ -132,7 +137,7 @@ getFolderId u nt = do
s
<-
getNodesWith
rootId
HyperdataAny
(
Just
nt
)
Nothing
Nothing
case
head
s
of
Nothing
->
errorWith
"[G.D.A.S.getFolderId] No folder shared found"
Just
f
->
pure
(
_node_id
f
)
Just
f
->
pure
(
f
^.
node_id
)
------------------------------------------------------------------------
type
TeamId
=
NodeId
...
...
src/Gargantext/Database/Action/TSQuery.hs
deleted
100644 → 0
View file @
ec216edf
{-|
Module : Gargantext.Database.Action.TSQuery
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Here is a longer description of this module, containing some
commentary with @some markup@.
-}
module
Gargantext.Database.Action.TSQuery
where
import
Data.Aeson
import
Data.Maybe
import
Data.String
(
IsString
(
..
))
import
Database.PostgreSQL.Simple
(
Query
)
import
Database.PostgreSQL.Simple.ToField
import
Gargantext.Core
import
Gargantext.Core.Text.Terms.Mono.Stem.En
(
stemIt
)
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Query
(
Limit
,
Offset
)
import
Gargantext.Database.Prelude
(
DBCmd
,
runPGSQuery
)
import
Gargantext.Prelude
newtype
TSQuery
=
UnsafeTSQuery
[
Text
]
-- | TODO [""] -> panic "error"
toTSQuery
::
[
Text
]
->
TSQuery
toTSQuery
txt
=
UnsafeTSQuery
$
map
stemIt
txt
instance
IsString
TSQuery
where
fromString
=
UnsafeTSQuery
.
words
.
cs
instance
ToField
TSQuery
where
toField
(
UnsafeTSQuery
xs
)
=
Many
$
intersperse
(
Plain
" && "
)
$
map
(
\
q
->
Many
[
Plain
"plainto_tsquery("
,
Escape
(
cs
q
)
,
Plain
")"
]
)
xs
data
Order
=
Asc
|
Desc
instance
ToField
Order
where
toField
Asc
=
Plain
"ASC"
toField
Desc
=
Plain
"DESC"
-- TODO
-- FIX fav
-- ADD ngrams count
-- TESTS
textSearchQuery
::
Query
textSearchQuery
=
"SELECT n.id, n.hyperdata->'publication_year'
\
\
, n.hyperdata->'title'
\
\
, n.hyperdata->'source'
\
\
, n.hyperdata->'authors'
\
\
, COALESCE(nn.score,null)
\
\
FROM nodes n
\
\
LEFT JOIN nodes_nodes nn ON nn.node2_id = n.id
\
\
WHERE
\
\
n.search @@ (?::tsquery)
\
\
AND (n.parent_id = ? OR nn.node1_id = ?)
\
\
AND n.typename = ?
\
\
ORDER BY n.hyperdata -> 'publication_date' ?
\
\
offset ? limit ?;"
-- | Text Search Function for Master Corpus
-- TODO : text search for user corpus
-- Example:
-- textSearchTest :: ParentId -> TSQuery -> Cmd err [(Int, Value, Value, Value, Value, Maybe Int)]
-- textSearchTest pId q = textSearch q pId 5 0 Asc
textSearch
::
HasDBid
NodeType
=>
TSQuery
->
ParentId
->
Limit
->
Offset
->
Order
->
DBCmd
err
[(
Int
,
Value
,
Value
,
Value
,
Value
,
Maybe
Int
)]
textSearch
q
p
l
o
ord'
=
runPGSQuery
textSearchQuery
(
q
,
p
,
p
,
typeId
,
ord'
,
o
,
l
)
where
typeId
=
toDBid
NodeDocument
src/Gargantext/Database/Action/User.hs
View file @
c72d6334
...
...
@@ -11,15 +11,20 @@ Portability : POSIX
module
Gargantext.Database.Action.User
where
(
getUserId
,
getUserId'
,
getUserLightDB
,
getUsername
)
where
import
Control.Lens
((
^.
))
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Admin.Types.Node
(
UserId
)
import
Gargantext.Database.Prelude
(
DBCmd
)
import
Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Query.Table.
User
import
Gargantext.Database.Query.Table.
Node.Error
import
Gargantext.Database.Schema.Node
import
Gargantext.Database.Query.Table.Node
(
getNode
)
import
Gargantext.Database.Query.Table.
Node.Error
(
HasNodeError
,
NodeError
(
NodeLookupFailed
),
NodeLookupError
(
UserDoesNotExist
,
UserNameDoesNotExist
),
errorWith
,
nodeError
)
import
Gargantext.Database.Query.Table.
User
(
UserLight
,
getUser
,
getUsersWithId
,
userLight_id
,
userLight_username
)
import
Gargantext.Database.Schema.Node
(
node_user_id
)
import
Gargantext.Prelude
------------------------------------------------------------------------
...
...
@@ -52,7 +57,7 @@ getUserId' :: HasNodeError err
getUserId'
(
UserDBId
uid
)
=
pure
(
Right
uid
)
getUserId'
(
RootId
rid
)
=
do
n
<-
getNode
rid
pure
$
Right
$
_node_user_id
n
pure
$
Right
$
n
^.
node_user_id
getUserId'
(
UserName
u
)
=
do
muser
<-
getUser
u
case
muser
of
...
...
@@ -75,7 +80,7 @@ getUsername user@(UserDBId _) = do
Nothing
->
errorWith
"G.D.A.U.getUserName: User not found with that id"
getUsername
(
RootId
rid
)
=
do
n
<-
getNode
rid
getUsername
(
UserDBId
$
_node_user_id
n
)
getUsername
(
UserDBId
$
n
^.
node_user_id
)
--------------------------------------------------------------------------
-- getRootId is in Gargantext.Database.Query.Tree.Root
test/Test/Database/Operations/NodeStory.hs
View file @
c72d6334
...
...
@@ -25,7 +25,7 @@ import Gargantext.API.Ngrams.Types (MSet(..), NgramsPatch(..), NgramsRepoElement
import
Gargantext.API.Ngrams.Tools
(
getNodeStory
)
import
Gargantext.Core.NodeStory
(
ArchiveList
,
a_state
,
a_version
,
currentVersion
,
initArchive
)
import
Gargantext.Core.NodeStory.Utils
(
saveNodeStory
)
import
Gargantext.Core.Types.Individu
()
import
Gargantext.Core.Types.Individu
(
User
(
UserName
)
)
import
Gargantext.Core.Types
(
ListType
(
..
),
ListId
,
NodeId
,
UserId
)
import
Gargantext.Database.Action.User
(
getUserId
)
import
Gargantext.Database.Admin.Config
(
userMaster
)
...
...
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