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
158
Issues
158
List
Board
Labels
Milestones
Merge Requests
11
Merge Requests
11
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
3365b122
Verified
Commit
3365b122
authored
1 month ago
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[graphql] add some tests for un-prefix, metrics indent fixes
parent
d380aafa
Pipeline
#7196
passed with stages
in 54 minutes and 4 seconds
Changes
3
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
84 additions
and
27 deletions
+84
-27
Metrics.hs
src/Gargantext/Database/Action/Metrics.hs
+47
-18
GraphQL.hs
test/Test/API/GraphQL.hs
+17
-4
Utils.hs
test/Test/Utils.hs
+20
-5
No files found.
src/Gargantext/Database/Action/Metrics.hs
View file @
3365b122
...
...
@@ -11,6 +11,7 @@ Node API
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module
Gargantext.Database.Action.Metrics
where
...
...
@@ -42,7 +43,10 @@ import Gargantext.Database.Query.Table.Node.Select
import
Gargantext.Prelude
getMetrics
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashMap
NgramsTerm
(
ListType
,
Maybe
NgramsTerm
),
Vector
(
Scored
NgramsTerm
))
getMetrics
cId
listId
tabType
maybeLimit
=
do
(
ngs
,
_
,
myCooc
)
<-
getNgramsCooc
cId
listId
tabType
maybeLimit
...
...
@@ -51,7 +55,10 @@ getMetrics cId listId tabType maybeLimit = do
getNgramsCooc
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashMap
NgramsTerm
(
ListType
,
Maybe
NgramsTerm
)
,
HashMap
NgramsTerm
(
Maybe
RootTerm
)
,
HashMap
(
NgramsTerm
,
NgramsTerm
)
Int
...
...
@@ -83,7 +90,10 @@ updateNgramsOccurrences cId lId = do
updateNgramsOccurrences'
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
Maybe
Limit
->
TabType
=>
CorpusId
->
ListId
->
Maybe
Limit
->
TabType
->
m
[
Int
]
updateNgramsOccurrences'
cId
lId
maybeLimit
tabType
=
do
...
...
@@ -126,14 +136,20 @@ updateNgramsOccurrences' cId lId maybeLimit tabType = do
------------------------------------------------------------------------
-- Used for scores in Ngrams Table
getNgramsOccurrences
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashMap
NgramsTerm
Int
)
getNgramsOccurrences
c
l
t
ml
=
HM
.
map
Set
.
size
<$>
getNgramsContexts
c
l
t
ml
getNgramsContexts
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashMap
NgramsTerm
(
Set
ContextId
))
getNgramsContexts
cId
lId
tabType
maybeLimit
=
do
(
_ngs'
,
ngs
)
<-
getNgrams
lId
tabType
...
...
@@ -149,7 +165,8 @@ getNgramsContexts cId lId tabType maybeLimit = do
------------------------------------------------------------------------
updateContextScore
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
=>
CorpusId
->
ListId
->
m
[
Int
]
updateContextScore
cId
lId
=
do
...
...
@@ -186,26 +203,37 @@ updateContextScore cId lId = do
-- Used for scores in Doc Table
getContextsNgramsScore
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
->
ListType
->
Maybe
Limit
=>
CorpusId
->
ListId
->
TabType
->
ListType
->
Maybe
Limit
->
m
(
Map
ContextId
Int
)
getContextsNgramsScore
cId
lId
tabType
listType
maybeLimit
=
Map
.
map
Set
.
size
<$>
getContextsNgrams
cId
lId
tabType
listType
maybeLimit
-- | Given corpus, list, tabType, return a map of contexts to set of
-- ngrams terms
getContextsNgrams
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
->
ListType
->
Maybe
Limit
=>
CorpusId
->
ListId
->
TabType
->
ListType
->
Maybe
Limit
->
m
(
Map
ContextId
(
Set
NgramsTerm
))
getContextsNgrams
cId
lId
tabType
listType
maybeLimit
=
do
(
ngs'
,
ngs
)
<-
getNgrams
lId
tabType
lIds
<-
selectNodesWithUsername
NodeList
userMaster
result
<-
groupNodesByNgrams
ngs
<$>
getContextsByNgramsOnlyUser
cId
(
lIds
<>
[
lId
]
)
(
ngramsTypeFromTabType
tabType
)
(
take'
maybeLimit
$
HM
.
keys
$
HM
.
filter
(
\
v
->
fst
v
==
listType
)
ngs'
)
result
<-
groupNodesByNgrams
ngs
<$>
getContextsByNgramsOnlyUser
cId
(
lIds
<>
[
lId
])
(
ngramsTypeFromTabType
tabType
)
(
take'
maybeLimit
$
HM
.
keys
$
HM
.
filter
(
\
v
->
fst
v
==
listType
)
ngs'
)
-- printDebug "getCoocByNgrams" result
pure
$
Map
.
fromListWith
(
<>
)
$
List
.
concat
...
...
@@ -218,18 +246,19 @@ getContextsNgrams cId lId tabType listType maybeLimit = do
getNgrams
::
(
HasNodeStory
env
err
m
)
=>
ListId
->
TabType
=>
ListId
->
TabType
->
m
(
HashMap
NgramsTerm
(
ListType
,
Maybe
NgramsTerm
)
,
HashMap
NgramsTerm
(
Maybe
RootTerm
)
)
getNgrams
lId
tabType
=
do
lists
<-
mapTermListRoot
[
lId
]
(
ngramsTypeFromTabType
tabType
)
<$>
getRepo
[
lId
]
-- TODO filterListWithRoot [MapTerm, StopTerm, CandidateTerm] lists
let
maybeSyn
=
HM
.
unions
$
map
(
\
t
->
filterListWithRoot
t
lists
)
[[
MapTerm
],
[
StopTerm
],
[
CandidateTerm
]]
pure
(
lists
,
maybeSyn
)
-- Some useful Tools
take'
::
Maybe
Limit
->
[
a
]
->
[
a
]
take'
Nothing
xs
=
xs
...
...
This diff is collapsed.
Click to expand it.
test/Test/API/GraphQL.hs
View file @
3365b122
...
...
@@ -7,14 +7,16 @@ module Test.API.GraphQL (
tests
)
where
import
Gargantext.API.Admin.Auth.Types
(
authRes_token
,
authRes_tree_id
,
authRes_user_id
)
import
Gargantext.Core.Types.Individu
import
Prelude
import
Gargantext.Database.Admin.Types.Node
(
UserId
(
..
))
import
Gargantext.Prelude
import
Servant.Auth.Client
()
import
Test.API.Setup
(
withTestDBAndPort
,
dbEnvSetup
,
SpecContext
(
..
))
import
Test.Hspec
import
Test.Hspec.Wai.Internal
(
withApplication
)
import
Test.Hspec.Wai.JSON
(
json
)
import
Test.Utils
(
protected
,
protectedNewError
,
shouldRespondWithFragment
,
shouldRespondWithFragmentCustomStatus
,
withValidLogin
)
import
Test.Utils
(
protected
,
protectedNewError
,
shouldRespondWithFragment
,
shouldRespondWithFragmentCustomStatus
,
withValidLogin
,
withValidLoginA
)
import
Text.RawString.QQ
(
r
)
tests
::
Spec
...
...
@@ -23,10 +25,21 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
describe
"get_user_infos"
$
do
it
"allows 'alice' to see her own info"
$
\
SpecContext
{
..
}
->
do
withApplication
_sctx_app
$
do
withValidLogin
_sctx_port
"alice"
(
GargPassword
"alice"
)
$
\
_clientEnv
token
->
do
withValidLoginA
_sctx_port
"alice"
(
GargPassword
"alice"
)
$
\
_clientEnv
authRes
->
do
liftIO
$
(
authRes
^.
authRes_user_id
)
`
shouldBe
`
(
UnsafeMkUserId
2
)
let
query
=
[
r
|
{ "query": "{ user_infos(user_id: 2) { ui_id, ui_email } }" }
|]
let
expected
=
[
json
|
{"data":{"user_infos":[{"ui_id":2,"ui_email":"alice@gargan.text"}]}}
|]
protected
token
"POST"
"/gql"
query
`
shouldRespondWithFragment
`
expected
protected
(
authRes
^.
authRes_token
)
"POST"
"/gql"
query
`
shouldRespondWithFragment
`
expected
describe
"get_users"
$
do
it
"allows 'alice' to see her user info"
$
\
SpecContext
{
..
}
->
do
withApplication
_sctx_app
$
do
withValidLoginA
_sctx_port
"alice"
(
GargPassword
"alice"
)
$
\
_clientEnv
authRes
->
do
-- epo_api_user is a renamed field, we check if it's correctly un-prefixed
liftIO
$
(
authRes
^.
authRes_tree_id
)
`
shouldBe
`
8
let
query
=
[
r
|
{ "query": "{ users(user_id: 8) { u_username, u_hyperdata { epo_api_user } } }" }
|]
let
expected
=
[
json
|
{"data":{"users":[{"u_username":"alice","u_hyperdata":{"epo_api_user": null}}]}}
|]
protected
(
authRes
^.
authRes_token
)
"POST"
"/gql"
query
`
shouldRespondWithFragment
`
expected
describe
"nodes"
$
do
it
"returns node_type"
$
\
(
SpecContext
_testEnv
port
app
_
)
->
do
...
...
This diff is collapsed.
Click to expand it.
test/Test/Utils.hs
View file @
3365b122
...
...
@@ -27,6 +27,7 @@ module Test.Utils (
,
waitForTSem
,
waitUntil
,
withValidLogin
,
withValidLoginA
)
where
import
Control.Concurrent.STM.TChan
(
TChan
,
readTChan
)
...
...
@@ -44,7 +45,7 @@ import Data.Text.Encoding qualified as TE
import
Data.Text.Lazy
qualified
as
TL
import
Data.Text.Lazy.Encoding
qualified
as
TLE
import
Data.TreeDiff
import
Gargantext.API.Admin.Auth.Types
(
AuthRequest
(
..
),
Token
,
authRes_token
)
import
Gargantext.API.Admin.Auth.Types
(
AuthRequest
(
..
),
AuthResponse
,
Token
,
authRes_token
)
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Routes.Types
(
xGargErrorScheme
)
import
Gargantext.Core.Notifications.Dispatcher.Types
qualified
as
DT
...
...
@@ -208,8 +209,13 @@ postJSONUrlEncoded tkn url queryPaths = do
Left
err
->
Prelude
.
fail
$
"postJSONUrlEncoded failed when parsing "
<>
show
(
typeRep
$
Proxy
@
a
)
<>
": "
<>
err
<>
"
\n
Payload was: "
<>
(
T
.
unpack
.
TL
.
toStrict
.
TLE
.
decodeUtf8
$
simpleBody
)
Right
x
->
pure
x
withValidLogin
::
(
MonadFail
m
,
MonadIO
m
)
=>
Port
->
Username
->
GargPassword
->
(
ClientEnv
->
Token
->
m
a
)
->
m
a
withValidLogin
port
ur
pwd
act
=
do
withValidLoginA
::
(
MonadFail
m
,
MonadIO
m
)
=>
Port
->
Username
->
GargPassword
->
(
ClientEnv
->
AuthResponse
->
m
a
)
->
m
a
withValidLoginA
port
ur
pwd
act
=
do
baseUrl
<-
liftIO
$
parseBaseUrl
"http://localhost"
manager
<-
liftIO
$
newManager
defaultManagerSettings
let
clientEnv0
=
mkClientEnv
manager
(
baseUrl
{
baseUrlPort
=
port
})
...
...
@@ -219,8 +225,17 @@ withValidLogin port ur pwd act = do
Left
err
->
liftIO
$
throwIO
$
Prelude
.
userError
(
show
err
)
Right
res
->
do
traceEnabled
<-
isJust
<$>
liftIO
(
lookupEnv
"GARG_DEBUG_LOGS"
)
let
token
=
res
^.
authRes_token
act
(
clientEnv0
{
makeClientRequest
=
gargMkRequest
traceEnabled
})
token
act
(
clientEnv0
{
makeClientRequest
=
gargMkRequest
traceEnabled
})
res
withValidLogin
::
(
MonadFail
m
,
MonadIO
m
)
=>
Port
->
Username
->
GargPassword
->
(
ClientEnv
->
Token
->
m
a
)
->
m
a
withValidLogin
port
ur
pwd
act
=
withValidLoginA
port
ur
pwd
(
\
clientEnv
authRes
->
act
clientEnv
$
authRes
^.
authRes_token
)
-- | Allows to enable/disable logging of the input 'Request' to check what the
-- client is actually sending to the server.
...
...
This diff is collapsed.
Click to expand it.
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