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
a4fa6344
Commit
a4fa6344
authored
3 years ago
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Plain Diff
[FIX] merge
parents
6dd37683
a14e83bf
Pipeline
#2114
failed with stage
in 10 minutes and 34 seconds
Changes
21
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
21 changed files
with
812 additions
and
92 deletions
+812
-92
README.md
README.md
+33
-0
package.yaml
package.yaml
+6
-0
API.hs
src/Gargantext/API.hs
+1
-2
Types.hs
src/Gargantext/API/Admin/Orchestrator/Types.hs
+9
-7
GraphQL.hs
src/Gargantext/API/GraphQL.hs
+152
-0
AsyncTask.hs
src/Gargantext/API/GraphQL/AsyncTask.hs
+71
-0
Node.hs
src/Gargantext/API/GraphQL/Node.hs
+78
-0
User.hs
src/Gargantext/API/GraphQL/User.hs
+59
-0
UserInfo.hs
src/Gargantext/API/GraphQL/UserInfo.hs
+193
-0
Utils.hs
src/Gargantext/API/GraphQL/Utils.hs
+11
-0
Prelude.hs
src/Gargantext/API/Prelude.hs
+2
-0
Routes.hs
src/Gargantext/API/Routes.hs
+2
-1
Server.hs
src/Gargantext/API/Server.hs
+7
-1
ThrowAll.hs
src/Gargantext/API/ThrowAll.hs
+1
-0
Core.hs
src/Gargantext/Core.hs
+5
-2
Contact.hs
src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs
+97
-69
User.hs
src/Gargantext/Database/Admin/Types/Hyperdata/User.hs
+19
-4
Node.hs
src/Gargantext/Database/Admin/Types/Node.hs
+2
-0
User.hs
src/Gargantext/Database/Query/Table/User.hs
+22
-3
User.hs
src/Gargantext/Database/Schema/User.hs
+9
-3
UTCTime.hs
src/Gargantext/Utils/UTCTime.hs
+33
-0
No files found.
README.md
View file @
a4fa6344
...
...
@@ -196,3 +196,36 @@ To build documentation, run:
stack
--docker
build
--haddock
--no-haddock-deps
--fast
```
## GraphQL
Some introspection information.
Playground is located at http://localhost:8008/gql
### List all GraphQL types in the Playground
```
{
__schema {
types {
name
}
}
}
```
### List details about a type in GraphQL
```
{
__type(name:"User") {
fields {
name
description
type {
name
}
}
}
}
```
This diff is collapsed.
Click to expand it.
package.yaml
View file @
a4fa6344
...
...
@@ -182,6 +182,10 @@ library:
-
matrix
-
monad-control
-
monad-logger
-
morpheus-graphql
-
morpheus-graphql-app
-
morpheus-graphql-core
-
morpheus-graphql-subscriptions
-
mtl
-
natural-transformation
-
opaleye
...
...
@@ -251,8 +255,10 @@ library:
-
wai-app-static
-
wai-cors
-
wai-extra
-
wai-websockets
-
warp
-
wikiparsec
-
websockets
-
wreq
-
xml-conduit
-
xml-types
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/API.hs
View file @
a4fa6344
...
...
@@ -193,8 +193,7 @@ serverGargAdminAPI = roots
--gargMock = mock apiGarg Proxy
---------------------------------------------------------------------
makeApp
::
EnvC
env
=>
env
->
IO
Application
makeApp
::
(
Typeable
env
,
EnvC
env
)
=>
env
->
IO
Application
makeApp
env
=
do
serv
<-
server
env
(
ekgStore
,
ekgMid
)
<-
newEkgStore
api
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/API/Admin/Orchestrator/Types.hs
View file @
a4fa6344
...
...
@@ -7,6 +7,9 @@ module Gargantext.API.Admin.Orchestrator.Types
import
Control.Lens
hiding
(
elements
)
import
Data.Aeson
import
Data.Morpheus.Types
(
GQLType
,
typeOptions
)
import
Data.Proxy
import
Data.Swagger
hiding
(
URL
,
url
,
port
)
import
Data.Text
(
Text
)
...
...
@@ -18,6 +21,7 @@ import Servant.Job.Utils (jsonOptions)
import
Test.QuickCheck
(
elements
)
import
Test.QuickCheck.Arbitrary
import
qualified
Gargantext.API.GraphQL.Utils
as
GQLU
import
Gargantext.Core.Types
(
TODO
(
..
))
import
Gargantext.Prelude
...
...
@@ -84,13 +88,13 @@ instance Arbitrary ScraperEvent where
arbitrary
=
ScraperEvent
<$>
elements
[
Nothing
,
Just
"test message"
]
<*>
elements
[
Nothing
,
Just
"INFO"
,
Just
"WARN"
]
<*>
elements
[
Nothing
,
Just
"2018-04-18"
]
instance
ToJSON
ScraperEvent
where
toJSON
=
genericToJSON
$
jsonOptions
"_scev_"
instance
FromJSON
ScraperEvent
where
parseJSON
=
genericParseJSON
$
jsonOptions
"_scev_"
instance
ToSchema
ScraperEvent
-- TODO _scev_ prefix
instance
GQLType
ScraperEvent
where
typeOptions
_
=
GQLU
.
unPrefix
"_scev_"
data
JobLog
=
JobLog
...
...
@@ -109,17 +113,15 @@ instance Arbitrary JobLog where
<*>
arbitrary
<*>
arbitrary
<*>
arbitrary
instance
ToJSON
JobLog
where
toJSON
=
genericToJSON
$
jsonOptions
"_scst_"
instance
FromJSON
JobLog
where
parseJSON
=
genericParseJSON
$
jsonOptions
"_scst_"
instance
ToSchema
JobLog
-- TODO _scst_ prefix
instance
GQLType
JobLog
where
typeOptions
_
=
GQLU
.
unPrefix
"_scst_"
instance
ToSchema
ScraperInput
-- TODO _scin_ prefix
instance
ToSchema
ScraperEvent
-- TODO _scev_ prefix
instance
ToParamSchema
Offset
-- where
-- toParamSchema = panic "TODO"
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/API/GraphQL.hs
0 → 100644
View file @
a4fa6344
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
-- permit duplications for field names in multiple constructors
{-# LANGUAGE KindSignatures #-}
-- for use of Endpoint (name :: Symbol)
{-# LANGUAGE PartialTypeSignatures #-}
-- to automatically use suggested type hole signatures during compilation
{-# LANGUAGE TypeOperators #-}
module
Gargantext.API.GraphQL
where
import
Data.ByteString.Lazy.Char8
(
ByteString
)
import
Data.List.NonEmpty
(
NonEmpty
((
:|
)))
import
Data.Map
(
Map
)
import
Data.Morpheus
(
App
,
deriveApp
)
import
Data.Morpheus.Server
(
httpPlayground
)
import
Data.Morpheus.Subscriptions
(
Event
(
..
)
,
Hashable
,
httpPubApp
)
import
Data.Morpheus.Types
(
GQLRequest
,
GQLResponse
,
GQLType
,
RootResolver
(
..
)
,
Undefined
(
..
)
)
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
)
import
Gargantext.API.Prelude
(
HasJobEnv
'
)
import
qualified
Gargantext.API.GraphQL.AsyncTask
as
GQLAT
import
qualified
Gargantext.API.GraphQL.Node
as
GQLNode
import
qualified
Gargantext.API.GraphQL.User
as
GQLUser
import
qualified
Gargantext.API.GraphQL.UserInfo
as
GQLUserInfo
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Prelude
import
GHC.Generics
(
Generic
)
import
Network.HTTP.Media
((
//
),
(
/:
))
import
qualified
Prelude
as
Prelude
import
Servant
(
(
:<|>
)
(
..
)
,
(
:>
)
,
Accept
(
..
)
,
Get
,
JSON
,
MimeRender
(
..
)
,
Post
,
ReqBody
,
ServerT
)
import
qualified
Servant.Auth
as
SA
import
qualified
Servant.Auth.Server
as
SAS
-- | Represents possible GraphQL queries.
data
Query
m
=
Query
{
job_logs
::
GQLAT
.
JobLogArgs
->
m
(
Map
Int
JobLog
)
,
nodes
::
GQLNode
.
NodeArgs
->
m
[
GQLNode
.
Node
]
,
node_parent
::
GQLNode
.
NodeParentArgs
->
m
[
GQLNode
.
Node
]
,
user_infos
::
GQLUserInfo
.
UserInfoArgs
->
m
[
GQLUserInfo
.
UserInfo
]
,
users
::
GQLUser
.
UserArgs
->
m
[
GQLUser
.
User
m
]
}
deriving
(
Generic
,
GQLType
)
data
Mutation
m
=
Mutation
{
update_user_info
::
GQLUserInfo
.
UserInfoMArgs
->
m
Int
}
deriving
(
Generic
,
GQLType
)
-- | Possible GraphQL Events, i.e. here we describe how we will
-- manipulate the data.
type
EVENT
m
=
Event
Channel
(
Contet
m
)
-- | Channels are possible actions to call when manipulating the data.
data
Channel
=
Update
|
New
deriving
(
Eq
,
Show
,
Generic
,
Hashable
)
-- | This type describes what data we will operate on.
data
Contet
m
=
UserContet
[
GQLUser
.
User
m
]
|
UserInfoContet
[
GQLUserInfo
.
UserInfo
]
-- | The main GraphQL resolver: how queries, mutations and
-- subscriptions are handled.
rootResolver
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
,
HasJobEnv'
env
)
=>
RootResolver
(
GargM
env
GargError
)
e
Query
Mutation
Undefined
rootResolver
=
RootResolver
{
queryResolver
=
Query
{
job_logs
=
GQLAT
.
resolveJobLogs
,
nodes
=
GQLNode
.
resolveNodes
,
node_parent
=
GQLNode
.
resolveNodeParent
,
user_infos
=
GQLUserInfo
.
resolveUserInfos
,
users
=
GQLUser
.
resolveUsers
}
,
mutationResolver
=
Mutation
{
update_user_info
=
GQLUserInfo
.
updateUserInfo
}
,
subscriptionResolver
=
Undefined
}
-- | Main GraphQL "app".
app
::
(
Typeable
env
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
,
HasJobEnv'
env
)
=>
App
(
EVENT
(
GargM
env
GargError
))
(
GargM
env
GargError
)
app
=
deriveApp
rootResolver
----------------------------------------------
-- Now for some boilerplate to integrate the above GraphQL app with
-- servant.
-- | HTML type is needed for the GraphQL Playground.
data
HTML
deriving
(
Typeable
)
instance
Accept
HTML
where
contentTypes
_
=
"text"
//
"html"
/:
(
"charset"
,
"utf-8"
)
:|
[
"text"
//
"html"
]
instance
MimeRender
HTML
ByteString
where
mimeRender
_
=
Prelude
.
id
-- | Servant route for the app we defined above.
type
GQAPI
=
ReqBody
'[
J
SON
]
GQLRequest
:>
Post
'[
J
SON
]
GQLResponse
-- type Schema = "schema" :> Get '[PlainText] Text
-- | Servant route for the playground.
type
Playground
=
Get
'[
H
TML
]
ByteString
-- type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
-- | Our API consists of `GQAPI` and `Playground`.
type
API
=
SA
.
Auth
'[
S
A
.
JWT
,
SA
.
Cookie
]
AuthenticatedUser
:>
"gql"
:>
(
GQAPI
:<|>
Playground
)
-- serveEndpoint ::
-- ( SubApp ServerApp e
-- , PubApp e
-- ) =>
-- [e -> IO ()] ->
-- App e IO ->
-- Server (API name)
-- serveEndpoint publish app' = (liftIO . httpPubApp publish app') :<|> withSchema app' :<|> pure httpPlayground
--
-- withSchema :: (Applicative f) => App e m -> f Text
-- withSchema = pure . LT.toStrict . decodeUtf8 . render
-- | Implementation of our API.
--api :: Server API
api
::
(
Typeable
env
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
,
HasJobEnv'
env
)
=>
ServerT
API
(
GargM
env
GargError
)
api
(
SAS
.
Authenticated
_auser
)
=
httpPubApp
[]
app
:<|>
pure
httpPlayground
api
_
=
panic
"401 in graphql"
--SAS.throwAll (_ServerError # err401)
--api _ = httpPubApp [] app :<|> pure httpPlayground
This diff is collapsed.
Click to expand it.
src/Gargantext/API/GraphQL/AsyncTask.hs
0 → 100644
View file @
a4fa6344
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
module
Gargantext.API.GraphQL.AsyncTask
where
import
Control.Concurrent.Async
(
poll
)
import
Control.Concurrent.MVar
(
readMVar
)
import
Control.Lens
import
Data.Map
(
Map
)
import
qualified
Data.Map
as
Map
import
Control.Monad.Base
(
liftBase
)
import
Control.Monad.Reader
(
ask
,
liftIO
)
import
Data.Either
(
Either
(
..
))
import
qualified
Data.IntMap.Strict
as
IntMap
import
Data.Maybe
(
Maybe
(
..
),
catMaybes
)
import
Data.Morpheus.Types
(
GQLType
,
Resolver
,
ResolverM
,
QUERY
,
lift
)
import
Data.Text
(
Text
)
import
qualified
Data.Text
as
T
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
(
..
))
import
Gargantext.API.Prelude
(
GargM
,
GargError
,
HasJobEnv
'
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Prelude
import
GHC.Generics
(
Generic
)
import
Servant.Job.Async
(
HasJobEnv
(
job_env
),
jenv_jobs
,
job_async
)
import
Servant.Job.Core
(
env_item
,
env_map
,
env_state_mvar
)
data
JobLogArgs
=
JobLogArgs
{
job_log_id
::
Int
}
deriving
(
Generic
,
GQLType
)
type
GqlM
e
env
=
Resolver
QUERY
e
(
GargM
env
GargError
)
resolveJobLogs
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasJobEnv'
env
)
=>
JobLogArgs
->
GqlM
e
env
(
Map
Int
JobLog
)
resolveJobLogs
JobLogArgs
{
job_log_id
}
=
dbJobLogs
job_log_id
dbJobLogs
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasJobEnv'
env
)
=>
Int
->
GqlM
e
env
(
Map
Int
JobLog
)
dbJobLogs
job_log_id
=
do
--getJobLogs job_log_id
lift
$
do
env
<-
ask
--val <- liftBase $ readMVar $ env ^. job_env . jenv_jobs . env_state_mvar
var
<-
liftIO
$
readMVar
(
env
^.
job_env
.
jenv_jobs
.
env_state_mvar
)
let
envItems
=
var
^.
env_map
printDebug
"[dbJobLogs] env ^. job_env ^. jenv_jobs"
$
length
$
IntMap
.
keys
envItems
printDebug
"[dbJobLogs] job_log_id"
job_log_id
--pure $ IntMap.elems val
liftIO
$
do
let
jobsList
=
IntMap
.
toList
$
IntMap
.
map
(
\
e
->
e
^.
env_item
.
job_async
)
envItems
results
<-
mapM
(
\
(
k
,
v
)
->
do
p
<-
poll
v
let
kv
=
case
p
of
Nothing
->
Nothing
Just
p'
->
case
p'
of
Left
_
->
Nothing
Right
p''
->
Just
(
k
,
p''
)
pure
kv
)
jobsList
pure
$
Map
.
fromList
$
catMaybes
results
This diff is collapsed.
Click to expand it.
src/Gargantext/API/GraphQL/Node.hs
0 → 100644
View file @
a4fa6344
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
module
Gargantext.API.GraphQL.Node
where
import
Data.Morpheus.Types
(
GQLType
,
Resolver
,
QUERY
,
lift
)
import
Data.Text
(
Text
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Admin.Config
(
fromNodeTypeId
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
))
import
qualified
Gargantext.Database.Admin.Types.Node
as
NN
import
Gargantext.Database.Query.Table.Node
(
getClosestParentIdByType
,
getNode
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
qualified
Gargantext.Database.Schema.Node
as
N
import
Gargantext.Prelude
import
GHC.Generics
(
Generic
)
data
Node
=
Node
{
id
::
Int
,
name
::
Text
,
parent_id
::
Maybe
Int
,
type_id
::
Int
}
deriving
(
Show
,
Generic
,
GQLType
)
data
NodeArgs
=
NodeArgs
{
node_id
::
Int
}
deriving
(
Generic
,
GQLType
)
type
GqlM
e
env
=
Resolver
QUERY
e
(
GargM
env
GargError
)
-- | Function to resolve user from a query.
resolveNodes
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
NodeArgs
->
GqlM
e
env
[
Node
]
resolveNodes
NodeArgs
{
node_id
}
=
dbNodes
node_id
dbNodes
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
Int
->
GqlM
e
env
[
Node
]
dbNodes
node_id
=
do
node
<-
lift
$
getNode
$
NodeId
node_id
pure
[
toNode
node
]
data
NodeParentArgs
=
NodeParentArgs
{
node_id
::
Int
,
parent_type_id
::
Int
}
deriving
(
Generic
,
GQLType
)
resolveNodeParent
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
NodeParentArgs
->
GqlM
e
env
[
Node
]
resolveNodeParent
NodeParentArgs
{
node_id
,
parent_type_id
}
=
dbParentNodes
node_id
parent_type_id
dbParentNodes
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
Int
->
Int
->
GqlM
e
env
[
Node
]
dbParentNodes
node_id
parent_type_id
=
do
mNodeId
<-
lift
$
getClosestParentIdByType
(
NodeId
node_id
)
(
fromNodeTypeId
parent_type_id
)
case
mNodeId
of
Nothing
->
pure
[]
Just
id
->
do
node
<-
lift
$
getNode
id
pure
[
toNode
node
]
toNode
::
NN
.
Node
json
->
Node
toNode
(
N
.
Node
{
..
})
=
Node
{
id
=
NN
.
unNodeId
_node_id
,
name
=
_node_name
,
parent_id
=
NN
.
unNodeId
<$>
_node_parent_id
,
type_id
=
_node_typename
}
This diff is collapsed.
Click to expand it.
src/Gargantext/API/GraphQL/User.hs
0 → 100644
View file @
a4fa6344
{-# LANGUAGE DeriveAnyClass #-}
module
Gargantext.API.GraphQL.User
where
import
Data.Maybe
(
listToMaybe
)
import
Data.Morpheus.Types
(
GQLType
,
Resolver
,
QUERY
,
lift
)
import
Data.Text
(
Text
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataUser
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Query.Table.User
(
getUsersWithId
,
getUserHyperdata
)
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Prelude
import
GHC.Generics
(
Generic
)
data
User
m
=
User
{
u_email
::
Text
,
u_hyperdata
::
m
(
Maybe
HyperdataUser
)
,
u_id
::
Int
,
u_username
::
Text
}
deriving
(
Generic
,
GQLType
)
-- | Arguments to the "user" query.
data
UserArgs
=
UserArgs
{
user_id
::
Int
}
deriving
(
Generic
,
GQLType
)
type
GqlM
e
env
=
Resolver
QUERY
e
(
GargM
env
GargError
)
-- | Function to resolve user from a query.
resolveUsers
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
UserArgs
->
GqlM
e
env
[
User
(
GqlM
e
env
)]
resolveUsers
UserArgs
{
user_id
}
=
dbUsers
user_id
-- | Inner function to fetch the user from DB.
dbUsers
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
Int
->
GqlM
e
env
([
User
(
GqlM
e
env
)])
dbUsers
user_id
=
lift
(
map
toUser
<$>
getUsersWithId
user_id
)
toUser
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
UserLight
->
User
(
GqlM
e
env
)
toUser
(
UserLight
{
..
})
=
User
{
u_email
=
userLight_email
,
u_hyperdata
=
resolveHyperdata
userLight_id
,
u_id
=
userLight_id
,
u_username
=
userLight_username
}
resolveHyperdata
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
Int
->
GqlM
e
env
(
Maybe
HyperdataUser
)
resolveHyperdata
userid
=
lift
(
listToMaybe
<$>
getUserHyperdata
userid
)
This diff is collapsed.
Click to expand it.
src/Gargantext/API/GraphQL/UserInfo.hs
0 → 100644
View file @
a4fa6344
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
module
Gargantext.API.GraphQL.UserInfo
where
import
Control.Lens
import
Data.Morpheus.Types
(
GQLType
,
Resolver
,
ResolverM
,
QUERY
,
lift
)
import
Data.Text
(
Text
)
import
qualified
Data.Text
as
T
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataUser
(
..
)
,
hc_source
,
hc_title
,
hu_shared
)
import
Gargantext.Database.Admin.Types.Hyperdata.Contact
(
HyperdataContact
,
ContactWho
,
ContactWhere
,
cw_city
,
cw_country
,
cw_firstName
,
cw_lastName
,
cw_labTeamDepts
,
cw_office
,
cw_organization
,
cw_role
,
cw_touch
,
ct_mail
,
ct_phone
,
hc_who
,
hc_where
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Table.User
(
getUsersWithHyperdata
)
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Prelude
import
GHC.Generics
(
Generic
)
data
UserInfo
=
UserInfo
{
ui_id
::
Int
,
ui_username
::
Text
,
ui_email
::
Text
,
ui_title
::
Maybe
Text
,
ui_source
::
Maybe
Text
,
ui_cwFirstName
::
Maybe
Text
,
ui_cwLastName
::
Maybe
Text
,
ui_cwCity
::
Maybe
Text
,
ui_cwCountry
::
Maybe
Text
,
ui_cwOrganization
::
[
Text
]
,
ui_cwLabTeamDepts
::
[
Text
]
,
ui_cwOffice
::
Maybe
Text
,
ui_cwRole
::
Maybe
Text
,
ui_cwTouchPhone
::
Maybe
Text
,
ui_cwTouchMail
::
Maybe
Text
}
deriving
(
Generic
,
GQLType
,
Show
)
-- | Arguments to the "user info" query.
data
UserInfoArgs
=
UserInfoArgs
{
user_id
::
Int
}
deriving
(
Generic
,
GQLType
)
-- | Arguments to the "user info" mutation,
data
UserInfoMArgs
=
UserInfoMArgs
{
ui_id
::
Int
,
ui_username
::
Maybe
Text
,
ui_email
::
Maybe
Text
,
ui_title
::
Maybe
Text
,
ui_source
::
Maybe
Text
,
ui_cwFirstName
::
Maybe
Text
,
ui_cwLastName
::
Maybe
Text
,
ui_cwCity
::
Maybe
Text
,
ui_cwCountry
::
Maybe
Text
,
ui_cwOrganization
::
Maybe
[
Text
]
,
ui_cwLabTeamDepts
::
Maybe
[
Text
]
,
ui_cwOffice
::
Maybe
Text
,
ui_cwRole
::
Maybe
Text
,
ui_cwTouchPhone
::
Maybe
Text
,
ui_cwTouchMail
::
Maybe
Text
}
deriving
(
Generic
,
GQLType
)
type
GqlM
e
env
=
Resolver
QUERY
e
(
GargM
env
GargError
)
-- | Function to resolve user from a query.
resolveUserInfos
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
UserInfoArgs
->
GqlM
e
env
[
UserInfo
]
resolveUserInfos
UserInfoArgs
{
user_id
}
=
dbUsers
user_id
-- | Mutation for user info
updateUserInfo
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
UserInfoMArgs
->
ResolverM
e
(
GargM
env
GargError
)
Int
updateUserInfo
(
UserInfoMArgs
{
ui_id
,
..
})
=
do
lift
$
printDebug
"[updateUserInfo] ui_id"
ui_id
users
<-
lift
(
getUsersWithHyperdata
ui_id
)
case
users
of
[]
->
panic
$
"[updateUserInfo] User with id "
<>
(
T
.
pack
$
show
ui_id
)
<>
" doesn't exist."
((
u
,
u_hyperdata
)
:
_
)
->
do
lift
$
printDebug
"[updateUserInfo] u"
u
let
u_hyperdata'
=
uh
ui_titleL
ui_title
$
uh
ui_sourceL
ui_source
$
uh
ui_cwFirstNameL
ui_cwFirstName
$
uh
ui_cwLastNameL
ui_cwLastName
$
uh
ui_cwCityL
ui_cwCity
$
uh
ui_cwCountryL
ui_cwCountry
$
uh'
ui_cwLabTeamDeptsL
ui_cwLabTeamDepts
$
uh'
ui_cwOrganizationL
ui_cwOrganization
$
uh
ui_cwOfficeL
ui_cwOffice
$
uh
ui_cwRoleL
ui_cwRole
$
uh
ui_cwTouchMailL
ui_cwTouchMail
$
uh
ui_cwTouchPhoneL
ui_cwTouchPhone
$
u_hyperdata
lift
$
printDebug
"[updateUserInfo] with firstName"
u_hyperdata'
_
<-
lift
$
updateHyperdata
(
NodeId
ui_id
)
u_hyperdata'
--let _newUser = toUser (u, u_hyperdata')
pure
1
where
uh
_
Nothing
u_hyperdata
=
u_hyperdata
uh
lens'
(
Just
val
)
u_hyperdata
=
u_hyperdata
&
lens'
.~
Just
val
uh'
_
Nothing
u_hyperdata
=
u_hyperdata
uh'
lens'
(
Just
val
)
u_hyperdata
=
u_hyperdata
&
lens'
.~
val
-- | Inner function to fetch the user from DB.
dbUsers
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
Int
->
GqlM
e
env
[
UserInfo
]
dbUsers
user_id
=
do
-- user <- getUsersWithId user_id
-- hyperdata <- getUserHyperdata user_id
-- lift (map toUser <$> zip user hyperdata)
lift
(
map
toUser
<$>
(
getUsersWithHyperdata
user_id
))
toUser
::
(
UserLight
,
HyperdataUser
)
->
UserInfo
toUser
(
UserLight
{
..
},
u_hyperdata
)
=
UserInfo
{
ui_id
=
userLight_id
,
ui_username
=
userLight_username
,
ui_email
=
userLight_email
,
ui_title
=
u_hyperdata
^.
ui_titleL
,
ui_source
=
u_hyperdata
^.
ui_sourceL
,
ui_cwFirstName
=
u_hyperdata
^.
ui_cwFirstNameL
,
ui_cwLastName
=
u_hyperdata
^.
ui_cwLastNameL
,
ui_cwCity
=
u_hyperdata
^.
ui_cwCityL
,
ui_cwCountry
=
u_hyperdata
^.
ui_cwCountryL
,
ui_cwLabTeamDepts
=
u_hyperdata
^.
ui_cwLabTeamDeptsL
,
ui_cwOrganization
=
u_hyperdata
^.
ui_cwOrganizationL
,
ui_cwOffice
=
u_hyperdata
^.
ui_cwOfficeL
,
ui_cwRole
=
u_hyperdata
^.
ui_cwRoleL
,
ui_cwTouchMail
=
u_hyperdata
^.
ui_cwTouchMailL
,
ui_cwTouchPhone
=
u_hyperdata
^.
ui_cwTouchPhoneL
}
sharedL
::
Traversal'
HyperdataUser
HyperdataContact
sharedL
=
hu_shared
.
_Just
ui_titleL
::
Traversal'
HyperdataUser
(
Maybe
Text
)
ui_titleL
=
sharedL
.
hc_title
ui_sourceL
::
Traversal'
HyperdataUser
(
Maybe
Text
)
ui_sourceL
=
sharedL
.
hc_source
contactWhoL
::
Traversal'
HyperdataUser
ContactWho
contactWhoL
=
sharedL
.
hc_who
.
_Just
ui_cwFirstNameL
::
Traversal'
HyperdataUser
(
Maybe
Text
)
ui_cwFirstNameL
=
contactWhoL
.
cw_firstName
ui_cwLastNameL
::
Traversal'
HyperdataUser
(
Maybe
Text
)
ui_cwLastNameL
=
contactWhoL
.
cw_lastName
contactWhereL
::
Traversal'
HyperdataUser
ContactWhere
contactWhereL
=
sharedL
.
hc_where
.
(
ix
0
)
ui_cwCityL
::
Traversal'
HyperdataUser
(
Maybe
Text
)
ui_cwCityL
=
contactWhereL
.
cw_city
ui_cwCountryL
::
Traversal'
HyperdataUser
(
Maybe
Text
)
ui_cwCountryL
=
contactWhereL
.
cw_country
ui_cwLabTeamDeptsL
::
Traversal'
HyperdataUser
[
Text
]
ui_cwLabTeamDeptsL
=
hu_shared
.
_Just
.
(
hc_where
.
(
ix
0
)
.
cw_labTeamDepts
)
ui_cwOrganizationL
::
Traversal'
HyperdataUser
[
Text
]
ui_cwOrganizationL
=
hu_shared
.
_Just
.
(
hc_where
.
(
ix
0
)
.
cw_organization
)
ui_cwOfficeL
::
Traversal'
HyperdataUser
(
Maybe
Text
)
ui_cwOfficeL
=
contactWhereL
.
cw_office
ui_cwRoleL
::
Traversal'
HyperdataUser
(
Maybe
Text
)
ui_cwRoleL
=
contactWhereL
.
cw_role
ui_cwTouchMailL
::
Traversal'
HyperdataUser
(
Maybe
Text
)
ui_cwTouchMailL
=
hu_shared
.
_Just
.
(
hc_where
.
(
ix
0
)
.
cw_touch
.
_Just
.
ct_mail
)
--ui_cwTouchMailL = contactWhereL . cw_touch . _Just . ct_mail
ui_cwTouchPhoneL
::
Traversal'
HyperdataUser
(
Maybe
Text
)
ui_cwTouchPhoneL
=
hu_shared
.
_Just
.
(
hc_where
.
(
ix
0
)
.
cw_touch
.
_Just
.
ct_phone
)
--ui_cwTouchPhoneL = contactWhereL . cw_touch . _Just . ct_phone
This diff is collapsed.
Click to expand it.
src/Gargantext/API/GraphQL/Utils.hs
0 → 100644
View file @
a4fa6344
module
Gargantext.API.GraphQL.Utils
where
import
Data.Morpheus.Types
(
GQLTypeOptions
,
fieldLabelModifier
)
import
qualified
Data.Text
as
T
import
Gargantext.Core.Utils.Prefix
(
unCapitalize
,
dropPrefix
)
import
Gargantext.Prelude
unPrefix
::
T
.
Text
->
GQLTypeOptions
->
GQLTypeOptions
unPrefix
prefix
options
=
options
{
fieldLabelModifier
=
nflm
}
where
nflm
label
=
unCapitalize
$
dropPrefix
(
T
.
unpack
prefix
)
$
(
fieldLabelModifier
options
)
label
This diff is collapsed.
Click to expand it.
src/Gargantext/API/Prelude.hs
View file @
a4fa6344
...
...
@@ -50,6 +50,8 @@ class HasJoseError e where
joseError
::
(
MonadError
e
m
,
HasJoseError
e
)
=>
Jose
.
Error
->
m
a
joseError
=
throwError
.
(
_JoseError
#
)
type
HasJobEnv'
env
=
HasJobEnv
env
JobLog
JobLog
type
EnvC
env
=
(
HasConnectionPool
env
,
HasSettings
env
-- TODO rename HasDbSettings
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/API/Routes.hs
View file @
a4fa6344
...
...
@@ -44,6 +44,7 @@ import Gargantext.API.Admin.Auth.Types (AuthRequest, AuthResponse, Authenticated
import
Gargantext.API.Admin.Auth
(
withAccess
)
import
Gargantext.API.Admin.FrontEnd
(
FrontEndAPI
)
import
Gargantext.API.Count
(
CountAPI
,
count
,
Query
)
import
qualified
Gargantext.API.GraphQL
as
GraphQL
import
Gargantext.API.Job
(
jobLogInit
)
import
Gargantext.API.Ngrams
(
TableNgramsApi
,
apiNgramsTableDoc
)
import
Gargantext.API.Node
...
...
@@ -167,7 +168,6 @@ type GargPrivateAPI' =
:<|>
List
.
GETAPI
:<|>
List
.
JSONAPI
:<|>
List
.
CSVAPI
{-
:<|> "wait" :> Summary "Wait test"
:> Capture "x" Int
...
...
@@ -184,6 +184,7 @@ type GargPrivateAPI' =
type
API
=
SwaggerAPI
:<|>
GargAPI
:<|>
GraphQL
.
API
:<|>
FrontEndAPI
-- | API for serving @swagger.json@
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/API/Server.hs
View file @
a4fa6344
...
...
@@ -29,6 +29,7 @@ import qualified Gargantext.API.Public as Public
import
Gargantext.API.Admin.Auth.Types
(
AuthContext
)
import
Gargantext.API.Admin.Auth
(
auth
)
import
Gargantext.API.Admin.FrontEnd
(
frontEndServer
)
import
qualified
Gargantext.API.GraphQL
as
GraphQL
import
Gargantext.API.Prelude
import
Gargantext.API.Routes
import
Gargantext.API.Swagger
(
swaggerDoc
)
...
...
@@ -52,7 +53,7 @@ serverGargAPI baseUrl -- orchestrator
gargVersion
=
pure
(
cs
$
showVersion
PG
.
version
)
-- | Server declarations
server
::
forall
env
.
EnvC
env
=>
env
->
IO
(
Server
API
)
server
::
forall
env
.
(
Typeable
env
,
EnvC
env
)
=>
env
->
IO
(
Server
API
)
server
env
=
do
-- orchestrator <- scrapyOrchestrator env
pure
$
swaggerSchemaUIServer
swaggerDoc
...
...
@@ -61,6 +62,11 @@ server env = do
(
Proxy
::
Proxy
AuthContext
)
transform
(
serverGargAPI
(
env
^.
hasConfig
.
gc_url_backend_api
))
:<|>
hoistServerWithContext
(
Proxy
::
Proxy
GraphQL
.
API
)
(
Proxy
::
Proxy
AuthContext
)
transform
GraphQL
.
api
:<|>
frontEndServer
where
transform
::
forall
a
.
GargM
env
GargError
a
->
Handler
a
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/API/ThrowAll.hs
View file @
a4fa6344
...
...
@@ -10,6 +10,7 @@ Portability : POSIX
-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Core.hs
View file @
a4fa6344
...
...
@@ -9,14 +9,17 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveAnyClass #-}
module
Gargantext.Core
where
import
Data.Text
(
Text
)
import
Data.Aeson
import
Data.Either
(
Either
(
Left
))
import
Data.Hashable
(
Hashable
)
import
Data.Morpheus.Types
(
GQLType
)
import
Data.Swagger
import
Data.Text
(
Text
)
import
GHC.Generics
(
Generic
)
import
Gargantext.Prelude
import
Servant.API
...
...
@@ -38,7 +41,7 @@ import Servant.API
-- | All languages supported
-- TODO : DE | SP | CH
data
Lang
=
EN
|
FR
|
All
deriving
(
Show
,
Eq
,
Ord
,
Bounded
,
Enum
,
Generic
)
deriving
(
Show
,
Eq
,
Ord
,
Bounded
,
Enum
,
Generic
,
GQLType
)
instance
ToJSON
Lang
instance
FromJSON
Lang
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs
View file @
a4fa6344
...
...
@@ -9,9 +9,10 @@ Portability : POSIX
-}
{-# LANGUAGE
FunctionalDependencies
#-}
{-# LANGUAGE
DeriveAnyClass
#-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
...
...
@@ -23,72 +24,90 @@ Portability : POSIX
module
Gargantext.Database.Admin.Types.Hyperdata.Contact
where
import
Data.Morpheus.Types
(
GQLType
(
..
))
import
Data.Time.Segment
(
jour
)
import
Data.Time
(
UTCTime
)
import
qualified
Gargantext.API.GraphQL.Utils
as
GAGU
import
Gargantext.Core.Text
(
HasText
(
..
))
import
Gargantext.Database.Admin.Types.Hyperdata.Prelude
import
Gargantext.Prelude
import
Gargantext.Utils.UTCTime
--------------------------------------------------------------------------------
data
HyperdataContact
=
HyperdataContact
{
_hc_bdd
::
Maybe
Text
-- ID of Database source
,
_hc_who
::
Maybe
ContactWho
,
_hc_where
::
[
ContactWhere
]
,
_hc_title
::
Maybe
Text
-- TODO remove (only demo)
,
_hc_source
::
Maybe
Text
-- TODO remove (only demo)
,
_hc_lastValidation
::
Maybe
Text
-- TODO UTCTime
,
_hc_uniqIdBdd
::
Maybe
Text
,
_hc_uniqId
::
Maybe
Text
HyperdataContact
{
_hc_bdd
::
Maybe
Text
-- ID of Database source
,
_hc_who
::
Maybe
ContactWho
,
_hc_where
::
[
ContactWhere
]
,
_hc_title
::
Maybe
Text
-- TODO remove (only demo)
,
_hc_source
::
Maybe
Text
-- TODO remove (only demo)
,
_hc_lastValidation
::
Maybe
Text
-- TODO UTCTime
,
_hc_uniqIdBdd
::
Maybe
Text
,
_hc_uniqId
::
Maybe
Text
}
deriving
(
Eq
,
Show
,
Generic
)
instance
GQLType
HyperdataContact
where
typeOptions
_
=
GAGU
.
unPrefix
"_hc_"
instance
HasText
HyperdataContact
where
hasText
=
undefined
defaultHyperdataContact
::
HyperdataContact
defaultHyperdataContact
=
HyperdataContact
(
Just
"bdd"
)
(
Just
defaultContactWho
)
[
defaultContactWhere
]
(
Just
"Title"
)
(
Just
"Source"
)
(
Just
"TODO lastValidation date"
)
(
Just
"DO NOT expose this"
)
(
Just
"DO NOT expose this"
)
defaultHyperdataContact
=
HyperdataContact
{
_hc_bdd
=
Just
"bdd"
,
_hc_who
=
Just
defaultContactWho
,
_hc_where
=
[
defaultContactWhere
]
,
_hc_title
=
Just
"Title"
,
_hc_source
=
Just
"Source"
,
_hc_lastValidation
=
Just
"TODO lastValidation date"
,
_hc_uniqIdBdd
=
Just
"DO NOT expose this"
,
_hc_uniqId
=
Just
"DO NOT expose this"
}
hyperdataContact
::
FirstName
->
LastName
->
HyperdataContact
hyperdataContact
fn
ln
=
HyperdataContact
Nothing
(
Just
(
contactWho
fn
ln
))
[]
Nothing
Nothing
Nothing
Nothing
Nothing
hyperdataContact
fn
ln
=
HyperdataContact
{
_hc_bdd
=
Nothing
,
_hc_who
=
Just
(
contactWho
fn
ln
)
,
_hc_where
=
[]
,
_hc_title
=
Nothing
,
_hc_source
=
Nothing
,
_hc_lastValidation
=
Nothing
,
_hc_uniqIdBdd
=
Nothing
,
_hc_uniqId
=
Nothing
}
-- TOD0 contact metadata (Type is too flat)
data
ContactMetaData
=
ContactMetaData
{
_cm_bdd
::
Maybe
Text
,
_cm_lastValidation
::
Maybe
Text
-- TODO UTCTIME
ContactMetaData
{
_cm_bdd
::
Maybe
Text
,
_cm_lastValidation
::
Maybe
Text
-- TODO UTCTIME
}
deriving
(
Eq
,
Show
,
Generic
)
defaultContactMetaData
::
ContactMetaData
defaultContactMetaData
=
ContactMetaData
(
Just
"bdd"
)
(
Just
"TODO UTCTime"
)
arbitraryHyperdataContact
::
HyperdataContact
arbitraryHyperdataContact
=
HyperdataContact
Nothing
Nothing
[]
Nothing
Nothing
Nothing
Nothing
Nothing
arbitraryHyperdataContact
=
HyperdataContact
{
_hc_bdd
=
Nothing
,
_hc_who
=
Nothing
,
_hc_where
=
[]
,
_hc_title
=
Nothing
,
_hc_source
=
Nothing
,
_hc_lastValidation
=
Nothing
,
_hc_uniqIdBdd
=
Nothing
,
_hc_uniqId
=
Nothing
}
data
ContactWho
=
ContactWho
{
_cw_id
::
Maybe
Text
,
_cw_firstName
::
Maybe
Text
,
_cw_lastName
::
Maybe
Text
,
_cw_keywords
::
[
Text
]
,
_cw_freetags
::
[
Text
]
ContactWho
{
_cw_id
::
Maybe
Text
,
_cw_firstName
::
Maybe
Text
,
_cw_lastName
::
Maybe
Text
,
_cw_keywords
::
[
Text
]
,
_cw_freetags
::
[
Text
]
}
deriving
(
Eq
,
Show
,
Generic
)
instance
GQLType
ContactWho
where
typeOptions
_
=
GAGU
.
unPrefix
"_cw_"
type
FirstName
=
Text
type
LastName
=
Text
...
...
@@ -96,40 +115,44 @@ defaultContactWho :: ContactWho
defaultContactWho
=
contactWho
"Pierre"
"Dupont"
contactWho
::
FirstName
->
LastName
->
ContactWho
contactWho
fn
ln
=
ContactWho
Nothing
(
Just
fn
)
(
Just
ln
)
[]
[]
contactWho
fn
ln
=
ContactWho
{
_cw_id
=
Nothing
,
_cw_firstName
=
Just
fn
,
_cw_lastName
=
Just
ln
,
_cw_keywords
=
[]
,
_cw_freetags
=
[]
}
data
ContactWhere
=
ContactWhere
{
_cw_organization
::
[
Text
]
,
_cw_labTeamDepts
::
[
Text
]
,
_cw_role
::
Maybe
Text
,
_cw_office
::
Maybe
Text
,
_cw_country
::
Maybe
Text
,
_cw_city
::
Maybe
Text
,
_cw_touch
::
Maybe
ContactTouch
,
_cw_entry
::
Maybe
UTCTime
,
_cw_exit
::
Maybe
UTCTime
ContactWhere
{
_cw_organization
::
[
Text
]
,
_cw_labTeamDepts
::
[
Text
]
,
_cw_role
::
Maybe
Text
,
_cw_office
::
Maybe
Text
,
_cw_country
::
Maybe
Text
,
_cw_city
::
Maybe
Text
,
_cw_touch
::
Maybe
ContactTouch
,
_cw_entry
::
Maybe
N
UTCTime
,
_cw_exit
::
Maybe
N
UTCTime
}
deriving
(
Eq
,
Show
,
Generic
)
instance
GQLType
ContactWhere
where
typeOptions
_
=
GAGU
.
unPrefix
"_cw_"
defaultContactWhere
::
ContactWhere
defaultContactWhere
=
ContactWhere
[
"Organization X"
]
[
"Lab Z"
]
(
Just
"Role"
)
(
Just
"Office"
)
(
Just
"Country"
)
(
Just
"City"
)
(
Just
defaultContactTouch
)
(
Just
$
jour
01
01
2020
)
(
Just
$
jour
01
01
2029
)
defaultContactWhere
=
ContactWhere
{
_cw_organization
=
[
"Organization X"
]
,
_cw_labTeamDepts
=
[
"Lab Z"
]
,
_cw_role
=
Just
"Role"
,
_cw_office
=
Just
"Office"
,
_cw_country
=
Just
"Country"
,
_cw_city
=
Just
"City"
,
_cw_touch
=
Just
defaultContactTouch
,
_cw_entry
=
Just
$
NUTCTime
$
jour
01
01
2020
,
_cw_exit
=
Just
$
NUTCTime
$
jour
01
01
2029
}
data
ContactTouch
=
ContactTouch
{
_ct_mail
::
Maybe
Text
...
...
@@ -137,10 +160,15 @@ data ContactTouch =
,
_ct_url
::
Maybe
Text
}
deriving
(
Eq
,
Show
,
Generic
)
instance
GQLType
ContactTouch
where
typeOptions
_
=
GAGU
.
unPrefix
"_ct_"
defaultContactTouch
::
ContactTouch
defaultContactTouch
=
ContactTouch
(
Just
"email@data.com"
)
(
Just
"+336 328 283 288"
)
(
Just
"https://url.com"
)
defaultContactTouch
=
ContactTouch
{
_ct_mail
=
Just
"email@data.com"
,
_ct_phone
=
Just
"+336 328 283 288"
,
_ct_url
=
Just
"https://url.com"
}
-- | ToSchema instances
instance
ToSchema
HyperdataContact
where
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Database/Admin/Types/Hyperdata/User.hs
View file @
a4fa6344
...
...
@@ -11,6 +11,7 @@ Portability : POSIX
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
...
...
@@ -23,11 +24,13 @@ Portability : POSIX
module
Gargantext.Database.Admin.Types.Hyperdata.User
where
import
Gargantext.Prelude
import
Data.Morpheus.Types
(
GQLType
(
typeOptions
))
import
qualified
Gargantext.API.GraphQL.Utils
as
GAGU
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Database.Admin.Types.Hyperdata.Prelude
import
Gargantext.Database.Admin.Types.Hyperdata.Contact
import
Gargantext.Database.Admin.Types.Node
(
DocumentId
)
import
Gargantext.Prelude
-- import Gargantext.Database.Schema.Node -- (Node(..))
...
...
@@ -37,23 +40,35 @@ data HyperdataUser =
,
_hu_public
::
!
(
Maybe
HyperdataPublic
)
}
deriving
(
Eq
,
Show
,
Generic
)
instance
GQLType
HyperdataUser
where
typeOptions
_
=
GAGU
.
unPrefix
"_hu_"
data
HyperdataPrivate
=
HyperdataPrivate
{
_hpr_password
::
!
Text
,
_hpr_lang
::
!
Lang
}
deriving
(
Eq
,
Show
,
Generic
)
instance
GQLType
HyperdataPrivate
where
typeOptions
_
=
GAGU
.
unPrefix
"_hpr_"
data
HyperdataPublic
=
HyperdataPublic
{
_hpu_pseudo
::
!
Text
,
_hpu_publications
::
!
[
DocumentId
]
}
deriving
(
Eq
,
Show
,
Generic
)
instance
GQLType
HyperdataPublic
where
typeOptions
_
=
GAGU
.
unPrefix
"_hpu_"
-- | Default
defaultHyperdataUser
::
HyperdataUser
defaultHyperdataUser
=
HyperdataUser
(
Just
defaultHyperdataPrivate
)
(
Just
defaultHyperdataContact
)
(
Just
defaultHyperdataPublic
)
defaultHyperdataUser
=
HyperdataUser
{
_hu_private
=
Just
defaultHyperdataPrivate
,
_hu_shared
=
Just
defaultHyperdataContact
,
_hu_public
=
Just
defaultHyperdataPublic
}
defaultHyperdataPublic
::
HyperdataPublic
defaultHyperdataPublic
=
HyperdataPublic
"pseudo"
[
1
..
10
]
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Database/Admin/Types/Node.hs
View file @
a4fa6344
...
...
@@ -25,6 +25,7 @@ import Data.Aeson
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Either
import
Data.Hashable
(
Hashable
)
import
Data.Morpheus.Types
(
GQLType
)
import
Data.Swagger
import
Data.Text
(
Text
,
unpack
)
import
Data.Time
(
UTCTime
)
...
...
@@ -152,6 +153,7 @@ pgNodeId = O.sqlInt4 . id2int
------------------------------------------------------------------------
newtype
NodeId
=
NodeId
Int
deriving
(
Read
,
Generic
,
Num
,
Eq
,
Ord
,
Enum
,
ToJSONKey
,
FromJSONKey
,
ToJSON
,
FromJSON
,
Hashable
)
instance
GQLType
NodeId
instance
Show
NodeId
where
show
(
NodeId
n
)
=
"nodeId-"
<>
show
n
instance
Serialise
NodeId
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Database/Query/Table/User.hs
View file @
a4fa6344
...
...
@@ -23,6 +23,8 @@ module Gargantext.Database.Query.Table.User
,
deleteUsers
,
updateUserDB
,
queryUserTable
,
getUserHyperdata
,
getUsersWithHyperdata
,
getUser
,
insertNewUsers
,
selectUsersLightWith
...
...
@@ -36,13 +38,16 @@ module Gargantext.Database.Query.Table.User
where
import
Control.Arrow
(
returnA
)
import
Control.Lens
((
^.
))
import
Data.List
(
find
)
import
Data.Text
(
Text
)
import
Data.Time
(
UTCTime
)
import
Gargantext.Core.Types.Individu
import
qualified
Gargantext.Prelude.Crypto.Auth
as
Auth
import
Gargantext.Database.
Schema.User
import
Gargantext.Database.
Admin.Types.Hyperdata
(
HyperdataUser
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Schema.Node
(
node_hyperdata
,
node_id
,
queryNodeTable
)
import
Gargantext.Database.Schema.User
import
Gargantext.Prelude
import
Opaleye
...
...
@@ -107,10 +112,25 @@ getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
returnA
-<
row
queryUserTable
::
Query
UserRead
queryUserTable
=
selectTable
userTable
----------------------------------------------------------------------
getUserHyperdata
::
Int
->
Cmd
err
[
HyperdataUser
]
getUserHyperdata
i
=
do
runOpaQuery
(
selectUserHyperdataWithId
i
)
where
selectUserHyperdataWithId
::
Int
->
Query
(
Column
PGJsonb
)
selectUserHyperdataWithId
i'
=
proc
()
->
do
row
<-
queryNodeTable
-<
()
restrict
-<
row
^.
node_id
.==
(
sqlInt4
i'
)
returnA
-<
row
^.
node_hyperdata
getUsersWithHyperdata
::
Int
->
Cmd
err
[(
UserLight
,
HyperdataUser
)]
getUsersWithHyperdata
i
=
do
u
<-
getUsersWithId
i
h
<-
getUserHyperdata
i
pure
$
zip
u
h
------------------------------------------------------------------
-- | Select User with some parameters
-- Not optimized version
...
...
@@ -129,7 +149,6 @@ userLightWithUsername t xs = userWith userLight_username t xs
userLightWithId
::
Int
->
[
UserLight
]
->
Maybe
UserLight
userLightWithId
t
xs
=
userWith
userLight_id
t
xs
----------------------------------------------------------------------
users
::
Cmd
err
[
UserDB
]
users
=
runOpaQuery
queryUserTable
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Database/Schema/User.hs
View file @
a4fa6344
...
...
@@ -13,20 +13,23 @@ Functions to deal with users, database side.
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell
#-}
module
Gargantext.Database.Schema.User
where
import
Data.Morpheus.Types
(
GQLType
(
typeOptions
))
import
Data.Text
(
Text
)
import
Data.Time
(
UTCTime
)
import
qualified
Gargantext.API.GraphQL.Utils
as
GAGU
import
Gargantext.Core.Utils.Prefix
(
unPrefix
)
import
Gargantext.Database.Prelude
(
fromField'
)
import
Gargantext.Prelude
import
GHC.Generics
(
Generic
)
import
Database.PostgreSQL.Simple.FromField
(
FromField
,
fromField
)
import
Data.Aeson.TH
(
deriveJSON
)
import
Gargantext.Database.Prelude
(
fromField'
)
import
Gargantext.Core.Utils.Prefix
(
unPrefix
)
-- FIXME PLZ : the import below leads to an error, why ?
-- import Gargantext.Database.Schema.Prelude hiding (makeLensesWith, abbreviatedFields, makeAdaptorAndInstance)
...
...
@@ -43,6 +46,9 @@ data UserLight = UserLight { userLight_id :: !Int
,
userLight_password
::
!
Text
}
deriving
(
Show
,
Generic
)
instance
GQLType
UserLight
where
typeOptions
_
=
GAGU
.
unPrefix
"userLight_"
toUserLight
::
UserDB
->
UserLight
toUserLight
(
UserDB
id
p
_
_
u
_
_
e
_
_
_
)
=
UserLight
id
u
e
p
...
...
This diff is collapsed.
Click to expand it.
src/Gargantext/Utils/UTCTime.hs
0 → 100644
View file @
a4fa6344
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module
Gargantext.Utils.UTCTime
where
import
Data.Aeson
(
FromJSON
,
ToJSON
)
import
Data.Either
(
Either
(
..
))
import
Data.Morpheus.Kind
(
SCALAR
)
import
Data.Morpheus.Types
(
GQLType
(
..
),
DecodeScalar
(
..
),
EncodeScalar
(
..
))
import
qualified
Data.Morpheus.Types
as
DMT
import
Data.Swagger
(
ToSchema
)
import
qualified
Data.Text
as
T
import
Data.Time
(
UTCTime
)
import
Gargantext.Prelude
import
GHC.Generics
(
Generic
)
import
Text.Read
(
readEither
)
newtype
NUTCTime
=
NUTCTime
UTCTime
deriving
(
Eq
,
Show
,
Generic
)
instance
DecodeScalar
NUTCTime
where
decodeScalar
(
DMT
.
String
x
)
=
case
(
readEither
$
T
.
unpack
x
)
of
Right
r
->
pure
$
NUTCTime
r
Left
err
->
Left
$
T
.
pack
err
decodeScalar
_
=
Left
"Invalid value for NUTCTime"
instance
EncodeScalar
NUTCTime
where
encodeScalar
(
NUTCTime
x
)
=
DMT
.
String
$
T
.
pack
$
show
x
instance
GQLType
NUTCTime
where
type
KIND
NUTCTime
=
SCALAR
instance
FromJSON
NUTCTime
instance
ToJSON
NUTCTime
instance
ToSchema
NUTCTime
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