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
119
Issues
119
List
Board
Labels
Milestones
Merge Requests
7
Merge Requests
7
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
346eaf67
Commit
346eaf67
authored
Jun 19, 2023
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Plain Diff
Merge remote-tracking branch 'origin/adinapoli/fix-datafield-instance' into dev-merge
parents
79c3f984
5fbdc1ed
Changes
9
Show whitespace changes
Inline
Side-by-side
Showing
9 changed files
with
114 additions
and
30 deletions
+114
-30
gargantext.cabal
gargantext.cabal
+4
-2
package.yaml
package.yaml
+3
-0
Main.hs
src-test/Main.hs
+2
-0
JSON.hs
src-test/Offline/JSON.hs
+38
-0
New.hs
src/Gargantext/API/Node/Corpus/New.hs
+9
-1
Types.hs
src/Gargantext/API/Node/Corpus/Types.hs
+27
-18
Core.hs
src/Gargantext/Core.hs
+5
-1
Query.hs
src/Gargantext/Core/Text/Corpus/Query.hs
+4
-0
Social.hs
src/Gargantext/Core/Text/List/Social.hs
+22
-8
No files found.
gargantext.cabal
View file @
346eaf67
...
...
@@ -43,6 +43,8 @@ library
Gargantext.API.Ngrams.Tools
Gargantext.API.Ngrams.Types
Gargantext.API.Node
Gargantext.API.Node.Corpus.New
Gargantext.API.Node.Corpus.Types
Gargantext.API.Node.File
Gargantext.API.Node.Share
Gargantext.API.Prelude
...
...
@@ -149,11 +151,9 @@ library
Gargantext.API.Node.Corpus.Annuaire
Gargantext.API.Node.Corpus.Export
Gargantext.API.Node.Corpus.Export.Types
Gargantext.API.Node.Corpus.New
Gargantext.API.Node.Corpus.New.File
Gargantext.API.Node.Corpus.New.Types
Gargantext.API.Node.Corpus.Searx
Gargantext.API.Node.Corpus.Types
Gargantext.API.Node.Document.Export
Gargantext.API.Node.Document.Export.Types
Gargantext.API.Node.DocumentsFromWriteNodes
...
...
@@ -863,6 +863,7 @@ test-suite garg-test
Ngrams.NLP
Ngrams.Query
Ngrams.Query.PaginationCorpus
Offline.JSON
Parsers.Date
Parsers.Types
Parsers.WOS
...
...
@@ -917,6 +918,7 @@ test-suite garg-test
, patches-class
, patches-map
, quickcheck-instances
, raw-strings-qq
, servant-job
, stm
, tasty
...
...
package.yaml
View file @
346eaf67
...
...
@@ -71,6 +71,8 @@ library:
-
Gargantext.API.Ngrams.Tools
-
Gargantext.API.Ngrams.Types
-
Gargantext.API.Node
-
Gargantext.API.Node.Corpus.New
-
Gargantext.API.Node.Corpus.Types
-
Gargantext.API.Node.File
-
Gargantext.API.Node.Share
-
Gargantext.API.Prelude
...
...
@@ -536,6 +538,7 @@ tests:
-
patches-map
-
duckling
-
quickcheck-instances
-
raw-strings-qq
-
servant-job
-
stm
-
tasty
...
...
src-test/Main.hs
View file @
346eaf67
...
...
@@ -22,6 +22,7 @@ import qualified Parsers.Date as PD
import
qualified
Graph.Clustering
as
Graph
import
qualified
Utils.Crypto
as
Crypto
import
qualified
Utils.Jobs
as
Jobs
import
qualified
Offline.JSON
as
JSON
import
Test.Tasty
import
Test.Tasty.Hspec
...
...
@@ -44,6 +45,7 @@ main = do
,
jobsSpec
,
NgramsQuery
.
tests
,
CorpusQuery
.
tests
,
JSON
.
tests
]
-- Occ.parsersTest
-- Lang.ngramsExtractionTest FR
...
...
src-test/Offline/JSON.hs
0 → 100644
View file @
346eaf67
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE QuasiQuotes #-}
module
Offline.JSON
(
tests
)
where
import
Data.Aeson
import
Data.Either
import
Gargantext.API.Node.Corpus.New
import
Gargantext.API.Node.Corpus.Types
import
Prelude
import
Test.Tasty
import
Test.Tasty.HUnit
import
Test.Tasty.QuickCheck
import
Text.RawString.QQ
import
qualified
Data.ByteString.Lazy.Char8
as
C8
jsonRoundtrip
::
(
Show
a
,
FromJSON
a
,
ToJSON
a
,
Eq
a
)
=>
a
->
Property
jsonRoundtrip
a
=
eitherDecode
(
encode
a
)
===
Right
a
tests
::
TestTree
tests
=
testGroup
"JSON"
[
testProperty
"Datafield roundtrips"
(
jsonRoundtrip
@
Datafield
)
,
testProperty
"WithQuery roundtrips"
(
jsonRoundtrip
@
WithQuery
)
,
testCase
"WithQuery frontend compliance"
testWithQueryFrontend
]
testWithQueryFrontend
::
Assertion
testWithQueryFrontend
=
do
assertBool
"JSON instance will break frontend!"
(
isRight
$
eitherDecode
@
WithQuery
(
C8
.
pack
cannedWithQueryPayload
))
-- The aim of this type is to catch regressions in the frontend serialisation; this
-- is what the frontend currently expects, and therefore if we were to change the JSON
-- instances, this test would fail, and we will be notified.
cannedWithQueryPayload
::
String
cannedWithQueryPayload
=
[
r
|
{"query":"Haskell","node_id":138,"lang":"EN","flowListWith":{"type":"MyListsFirst"},"datafield":"External Arxiv","databases":"Arxiv"}
|]
src/Gargantext/API/Node/Corpus/New.hs
View file @
346eaf67
...
...
@@ -144,7 +144,7 @@ data WithQuery = WithQuery
,
_wq_node_id
::
!
Int
,
_wq_flowListWith
::
!
FlowSocialListWith
}
deriving
Generic
deriving
(
Show
,
Eq
,
Generic
)
makeLenses
''
W
ithQuery
instance
FromJSON
WithQuery
where
...
...
@@ -154,6 +154,14 @@ instance ToJSON WithQuery where
instance
ToSchema
WithQuery
where
declareNamedSchema
=
genericDeclareNamedSchema
(
unPrefixSwagger
"_wq_"
)
instance
Arbitrary
WithQuery
where
arbitrary
=
WithQuery
<$>
arbitrary
<*>
arbitrary
<*>
arbitrary
<*>
arbitrary
<*>
arbitrary
<*>
arbitrary
------------------------------------------------------------------------
type
AddWithQuery
=
Summary
"Add with Query to corpus endpoint"
...
...
src/Gargantext/API/Node/Corpus/Types.hs
View file @
346eaf67
...
...
@@ -3,11 +3,14 @@
module
Gargantext.API.Node.Corpus.Types
where
import
Control.Lens
hiding
(
elements
,
Empty
)
import
Control.Monad.Fail
(
fail
)
import
Data.Aeson
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Monoid
(
mempty
)
import
Data.Swagger
import
GHC.Generics
(
Generic
)
import
Test.QuickCheck
import
qualified
Data.Text
as
T
import
Gargantext.Prelude
...
...
@@ -23,6 +26,9 @@ data Database = Empty
|
Isidore
deriving
(
Eq
,
Show
,
Generic
,
Enum
,
Bounded
)
instance
Arbitrary
Database
where
arbitrary
=
arbitraryBoundedEnum
deriveJSON
(
unPrefix
""
)
''
D
atabase
instance
ToSchema
Database
where
declareNamedSchema
=
genericDeclareNamedSchemaUnrestricted
defaultSchemaOptions
...
...
@@ -42,24 +48,27 @@ data Datafield = Gargantext
|
Files
deriving
(
Eq
,
Show
,
Generic
)
instance
FromJSON
Datafield
instance
ToJSON
Datafield
-- instance FromJSON Datafield where
-- parseJSON = withText "Datafield" $ \text ->
-- case text of
-- "Gargantext" -> pure Gargantext
-- "Web" -> pure Web
-- "Files" -> pure Files
-- v ->
-- let (preExternal, _, postExternal) = v =~ ("External " :: Text) :: (Text, Text, Text)
-- in
-- if preExternal == "" then do
-- db <- parseJSON $ String postExternal
-- pure $ External db
-- else fail $ "Cannot match patterh 'External <db>' for string " ++ (T.unpack v)
-- instance ToJSON Datafield where
-- toJSON (External db) = toJSON $ "External " ++ (show db)
-- toJSON s = toJSON $ show s
instance
FromJSON
Datafield
where
parseJSON
=
withText
"Datafield"
$
\
text
->
case
text
of
"Gargantext"
->
pure
Gargantext
"Web"
->
pure
Web
"Files"
->
pure
Files
v
->
case
T
.
breakOnEnd
" "
v
of
(
"External "
,
dbName
)
->
External
<$>
parseJSON
(
String
dbName
)
_
->
fail
$
"Cannot match patterh 'External <db>' for string "
<>
T
.
unpack
v
instance
ToJSON
Datafield
where
toJSON
(
External
db
)
=
toJSON
$
"External "
<>
show
db
toJSON
s
=
toJSON
$
show
s
instance
Arbitrary
Datafield
where
arbitrary
=
oneof
[
pure
Gargantext
,
pure
Web
,
pure
Files
,
External
<$>
arbitrary
]
instance
ToSchema
Datafield
where
declareNamedSchema
_
=
do
return
$
NamedSchema
(
Just
"Datafield"
)
$
mempty
...
...
src/Gargantext/Core.hs
View file @
346eaf67
...
...
@@ -24,6 +24,7 @@ import Data.Tuple.Extra (swap)
import
GHC.Generics
(
Generic
)
import
Gargantext.Prelude
import
Servant.API
import
Test.QuickCheck
import
qualified
Data.Map
as
Map
------------------------------------------------------------------------
...
...
@@ -80,8 +81,11 @@ instance ToHttpApiData Lang where
toUrlPiece
=
pack
.
show
instance
Hashable
Lang
instance
Arbitrary
Lang
where
arbitrary
=
arbitraryBoundedEnum
allLangs
::
[
Lang
]
allLangs
=
[
minBound
..
]
allLangs
=
[
minBound
..
maxBound
]
class
HasDBid
a
where
toDBid
::
a
->
Int
...
...
src/Gargantext/Core/Text/Corpus/Query.hs
View file @
346eaf67
...
...
@@ -21,6 +21,7 @@ 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
...
...
@@ -37,6 +38,9 @@ newtype RawQuery = RawQuery { getRawQuery :: T.Text }
,
Aeson
.
FromJSON
,
Aeson
.
ToJSON
,
Swagger
.
ToParamSchema
,
Swagger
.
ToSchema
)
instance
Arbitrary
RawQuery
where
arbitrary
=
RawQuery
<$>
arbitrary
-- | A limit to the number of results we want to retrieve.
newtype
Limit
=
Limit
{
getLimit
::
Int
}
deriving
newtype
(
Show
,
Eq
,
Num
...
...
src/Gargantext/Core/Text/List/Social.hs
View file @
346eaf67
...
...
@@ -34,13 +34,12 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import
Gargantext.Database.Query.Tree
(
NodeMode
(
Private
),
HasTreeError
)
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
)
import
Gargantext.Prelude
import
Test.QuickCheck
import
Web.Internal.HttpApiData
(
ToHttpApiData
,
FromHttpApiData
,
parseUrlPiece
,
toUrlPiece
)
import
qualified
Data.List
as
List
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Scientific
as
Scientific
import
qualified
Data.Text
as
T
import
qualified
Data.Vector
as
V
import
qualified
Prelude
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Main parameters
...
...
@@ -61,16 +60,28 @@ instance FromJSON FlowSocialListWith where
case
typ
of
"MyListsFirst"
->
pure
$
FlowSocialListWithPriority
{
fslw_priority
=
MySelfFirst
}
"OtherListsFirst"
->
pure
$
FlowSocialListWithPriority
{
fslw_priority
=
OthersFirst
}
"OthersFirst"
->
pure
$
FlowSocialListWithPriority
{
fslw_priority
=
OthersFirst
}
"SelectedLists"
->
pure
$
FlowSocialListWithLists
{
fslw_lists
=
value
}
"NoList"
->
pure
$
NoList
True
"NoList"
->
do
mkList
<-
v
.:
"makeList"
pure
$
NoList
mkList
_
->
pure
$
FlowSocialListWithPriority
{
fslw_priority
=
MySelfFirst
}
parseJSON
_
=
mzero
instance
ToJSON
FlowSocialListWith
where
toJSON
(
FlowSocialListWithPriority
{
fslw_priority
=
MySelfFirst
})
=
object
[
(
"type"
,
String
"MyListsFirst"
)
]
toJSON
(
FlowSocialListWithPriority
{
fslw_priority
=
OthersFirst
})
=
object
[
(
"type"
,
String
"ListsFirst"
)
]
toJSON
(
NoList
_
)
=
object
[
(
"type"
,
String
"NoList"
)
]
toJSON
(
FlowSocialListWithLists
{
fslw_lists
=
ids
})
=
object
[
(
"type"
,
String
"SelectedLists"
)
,
(
"value"
,
Array
$
V
.
fromList
$
(
map
(
\
(
NodeId
id
)
->
Number
$
Scientific
.
scientific
(
Prelude
.
toInteger
id
)
1
)
ids
))
]
toJSON
(
FlowSocialListWithPriority
{
fslw_priority
=
OthersFirst
})
=
object
[
(
"type"
,
String
"OthersFirst"
)
]
toJSON
(
NoList
v
)
=
object
[
(
"type"
,
String
"NoList"
),
(
"makeList"
,
toJSON
v
)
]
toJSON
(
FlowSocialListWithLists
{
fslw_lists
=
ids
})
=
object
[
(
"type"
,
String
"SelectedLists"
)
,
(
"value"
,
Array
$
V
.
fromList
(
map
(
\
(
NodeId
id
)
->
toJSON
id
)
ids
))
]
instance
Arbitrary
FlowSocialListWith
where
arbitrary
=
oneof
[
FlowSocialListWithPriority
<$>
arbitrary
,
FlowSocialListWithLists
<$>
arbitrary
,
NoList
<$>
arbitrary
]
instance
ToSchema
FlowSocialListWith
where
declareNamedSchema
=
genericDeclareNamedSchema
defaultSchemaOptions
instance
FromHttpApiData
FlowSocialListWith
...
...
@@ -87,10 +98,13 @@ instance ToHttpApiData FlowSocialListWith where
toUrlPiece
(
FlowSocialListWithLists
_
)
=
panic
"[G.C.T.L.Social] TODO ToHttpApiData FlowSocialListWith"
data
FlowSocialListPriority
=
MySelfFirst
|
OthersFirst
deriving
(
Eq
,
Show
,
Generic
)
deriving
(
Eq
,
Show
,
Generic
,
Enum
,
Bounded
)
instance
ToSchema
FlowSocialListPriority
where
declareNamedSchema
=
genericDeclareNamedSchema
defaultSchemaOptions
instance
Arbitrary
FlowSocialListPriority
where
arbitrary
=
arbitraryBoundedEnum
flowSocialListPriority
::
FlowSocialListPriority
->
[
NodeMode
]
flowSocialListPriority
MySelfFirst
=
[
Private
{-, Shared, Public -}
]
flowSocialListPriority
OthersFirst
=
reverse
$
flowSocialListPriority
MySelfFirst
...
...
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