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
118
Issues
118
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
2cc2359d
Commit
2cc2359d
authored
Oct 23, 2023
by
Alfredo Di Napoli
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Add userMe policy and isomorphic GQLType UserId instance
parent
4046bc84
Pipeline
#5293
passed with stages
in 70 minutes and 22 seconds
Changes
6
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
27 additions
and
13 deletions
+27
-13
PolicyCheck.hs
src/Gargantext/API/Auth/PolicyCheck.hs
+12
-4
Node.hs
src/Gargantext/API/GraphQL/Node.hs
+0
-2
TreeFirstLevel.hs
src/Gargantext/API/GraphQL/TreeFirstLevel.hs
+0
-2
User.hs
src/Gargantext/API/GraphQL/User.hs
+2
-2
UserInfo.hs
src/Gargantext/API/GraphQL/UserInfo.hs
+1
-1
Node.hs
src/Gargantext/Database/Admin/Types/Node.hs
+12
-2
No files found.
src/Gargantext/API/Auth/PolicyCheck.hs
View file @
2cc2359d
...
@@ -15,6 +15,7 @@ module Gargantext.API.Auth.PolicyCheck (
...
@@ -15,6 +15,7 @@ module Gargantext.API.Auth.PolicyCheck (
,
nodeSuper
,
nodeSuper
,
nodeUser
,
nodeUser
,
nodeChecks
,
nodeChecks
,
userMe
,
alwaysAllow
,
alwaysAllow
,
alwaysDeny
,
alwaysDeny
)
where
)
where
...
@@ -72,13 +73,15 @@ data AccessPolicyManager = AccessPolicyManager
...
@@ -72,13 +73,15 @@ data AccessPolicyManager = AccessPolicyManager
data
AccessCheck
data
AccessCheck
=
-- | Grants access if the input 'NodeId' is a descendant of the
=
-- | Grants access if the input 'NodeId' is a descendant of the
-- one for the logged-in user.
-- one for the logged-in user.
AC_node_descendant
NodeId
AC_node_descendant
!
NodeId
-- | Grants access if the input 'NodeId' is shared with the logged-in user.
-- | Grants access if the input 'NodeId' is shared with the logged-in user.
|
AC_node_shared
NodeId
|
AC_node_shared
!
NodeId
-- | Grants access if the input 'NodeId' /is/ the logged-in user.
-- | Grants access if the input 'NodeId' /is/ the logged-in user.
|
AC_user_node
NodeId
|
AC_user_node
!
NodeId
-- | Grants access if the logged-in user is the user.
|
AC_user
!
UserId
-- | Grants access if the logged-in user is the master user.
-- | Grants access if the logged-in user is the master user.
|
AC_master_user
NodeId
|
AC_master_user
!
NodeId
-- | Always grant access, effectively a public route.
-- | Always grant access, effectively a public route.
|
AC_always_allow
|
AC_always_allow
-- | Always denies access.
-- | Always denies access.
...
@@ -129,6 +132,8 @@ check (AuthenticatedUser loggedUserNodeId loggedUserUserId) = \case
...
@@ -129,6 +132,8 @@ check (AuthenticatedUser loggedUserNodeId loggedUserUserId) = \case
AC_user_node
requestedNodeId
AC_user_node
requestedNodeId
->
do
ownedByMe
<-
requestedNodeId
`
isOwnedBy
`
loggedUserUserId
->
do
ownedByMe
<-
requestedNodeId
`
isOwnedBy
`
loggedUserUserId
enforce
err403
$
(
loggedUserNodeId
==
requestedNodeId
||
ownedByMe
)
enforce
err403
$
(
loggedUserNodeId
==
requestedNodeId
||
ownedByMe
)
AC_user
requestedUserId
->
enforce
err403
$
(
loggedUserUserId
==
requestedUserId
)
AC_master_user
_requestedNodeId
AC_master_user
_requestedNodeId
->
do
->
do
masterUsername
<-
_gc_masteruser
<$>
view
hasConfig
masterUsername
<-
_gc_masteruser
<$>
view
hasConfig
...
@@ -146,6 +151,9 @@ check (AuthenticatedUser loggedUserNodeId loggedUserUserId) = \case
...
@@ -146,6 +151,9 @@ check (AuthenticatedUser loggedUserNodeId loggedUserUserId) = \case
nodeUser
::
NodeId
->
BoolExpr
AccessCheck
nodeUser
::
NodeId
->
BoolExpr
AccessCheck
nodeUser
=
BConst
.
Positive
.
AC_user_node
nodeUser
=
BConst
.
Positive
.
AC_user_node
userMe
::
UserId
->
BoolExpr
AccessCheck
userMe
=
BConst
.
Positive
.
AC_user
nodeSuper
::
NodeId
->
BoolExpr
AccessCheck
nodeSuper
::
NodeId
->
BoolExpr
AccessCheck
nodeSuper
=
BConst
.
Positive
.
AC_master_user
nodeSuper
=
BConst
.
Positive
.
AC_master_user
...
...
src/Gargantext/API/GraphQL/Node.hs
View file @
2cc2359d
...
@@ -63,8 +63,6 @@ resolveNodes
...
@@ -63,8 +63,6 @@ resolveNodes
->
NodeArgs
->
NodeArgs
->
GqlM
e
env
[
Node
]
->
GqlM
e
env
[
Node
]
resolveNodes
autUser
mgr
NodeArgs
{
node_id
}
=
resolveNodes
autUser
mgr
NodeArgs
{
node_id
}
=
-- FIXME(adn) We should have a way to enforce the access policy on
-- the public or public folders, instead of using 'alwaysAllow'.
withPolicy
autUser
mgr
(
nodeChecks
$
NN
.
UnsafeMkNodeId
node_id
)
$
dbNodes
node_id
withPolicy
autUser
mgr
(
nodeChecks
$
NN
.
UnsafeMkNodeId
node_id
)
$
dbNodes
node_id
resolveNodesCorpus
resolveNodesCorpus
...
...
src/Gargantext/API/GraphQL/TreeFirstLevel.hs
View file @
2cc2359d
...
@@ -69,8 +69,6 @@ resolveTree :: (CmdCommon env)
...
@@ -69,8 +69,6 @@ resolveTree :: (CmdCommon env)
->
TreeArgs
->
TreeArgs
->
GqlM
e
env
(
TreeFirstLevel
(
GqlM
e
env
))
->
GqlM
e
env
(
TreeFirstLevel
(
GqlM
e
env
))
resolveTree
autUser
mgr
TreeArgs
{
root_id
}
=
resolveTree
autUser
mgr
TreeArgs
{
root_id
}
=
-- FIXME(adn) We should have a way to enforce the access policy on
-- the public or public folders, instead of using 'alwaysAllow'.
withPolicy
autUser
mgr
(
nodeChecks
$
UnsafeMkNodeId
root_id
)
$
dbTree
root_id
withPolicy
autUser
mgr
(
nodeChecks
$
UnsafeMkNodeId
root_id
)
$
dbTree
root_id
dbTree
::
(
CmdCommon
env
)
=>
dbTree
::
(
CmdCommon
env
)
=>
...
...
src/Gargantext/API/GraphQL/User.hs
View file @
2cc2359d
...
@@ -55,8 +55,8 @@ resolveUsers
...
@@ -55,8 +55,8 @@ resolveUsers
->
UserArgs
->
UserArgs
->
GqlM
e
env
[
User
(
GqlM
e
env
)]
->
GqlM
e
env
[
User
(
GqlM
e
env
)]
resolveUsers
autUser
mgr
UserArgs
{
user_id
}
=
do
resolveUsers
autUser
mgr
UserArgs
{
user_id
}
=
do
--
FIXME(adn) we should use a proper policy, not 'alwaysAllow'
.
--
We are given the /node id/ of the logged-in user
.
withPolicy
autUser
mgr
alwaysAllow
$
dbUsers
user_id
withPolicy
autUser
mgr
(
nodeChecks
$
UnsafeMkNodeId
user_id
)
$
dbUsers
user_id
-- | Inner function to fetch the user from DB.
-- | Inner function to fetch the user from DB.
dbUsers
::
(
CmdCommon
env
)
dbUsers
::
(
CmdCommon
env
)
...
...
src/Gargantext/API/GraphQL/UserInfo.hs
View file @
2cc2359d
...
@@ -113,7 +113,7 @@ resolveUserInfos
...
@@ -113,7 +113,7 @@ resolveUserInfos
->
UserInfoArgs
->
GqlM
e
env
[
UserInfo
]
->
UserInfoArgs
->
GqlM
e
env
[
UserInfo
]
resolveUserInfos
autUser
mgr
UserInfoArgs
{
user_id
}
=
resolveUserInfos
autUser
mgr
UserInfoArgs
{
user_id
}
=
-- FIXME(adn) we should use a proper policy, not 'alwaysAllow'.
-- FIXME(adn) we should use a proper policy, not 'alwaysAllow'.
withPolicy
autUser
mgr
alwaysAllow
$
dbUsers
(
UnsafeMkUserId
user_id
)
withPolicy
autUser
mgr
(
userMe
$
UnsafeMkUserId
user_id
)
$
dbUsers
(
UnsafeMkUserId
user_id
)
-- | Mutation for user info
-- | Mutation for user info
updateUserInfo
updateUserInfo
...
...
src/Gargantext/Database/Admin/Types/Node.hs
View file @
2cc2359d
...
@@ -15,6 +15,7 @@ Portability : POSIX
...
@@ -15,6 +15,7 @@ Portability : POSIX
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- {-# LANGUAGE DuplicateRecordFields #-}
-- {-# LANGUAGE DuplicateRecordFields #-}
...
@@ -26,7 +27,8 @@ import Data.Aeson
...
@@ -26,7 +27,8 @@ import Data.Aeson
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Csv
qualified
as
Csv
import
Data.Csv
qualified
as
Csv
import
Data.Either
import
Data.Either
import
Data.Morpheus.Types
(
GQLType
)
import
Data.Morpheus.Kind
(
SCALAR
)
import
Data.Morpheus.Types
import
Data.Swagger
import
Data.Swagger
import
Data.Text
(
unpack
,
pack
)
import
Data.Text
(
unpack
,
pack
)
import
Data.Time
(
UTCTime
)
import
Data.Time
(
UTCTime
)
...
@@ -59,7 +61,15 @@ newtype UserId = UnsafeMkUserId { _UserId :: Int }
...
@@ -59,7 +61,15 @@ newtype UserId = UnsafeMkUserId { _UserId :: Int }
deriving
stock
(
Show
,
Eq
,
Ord
,
Generic
)
deriving
stock
(
Show
,
Eq
,
Ord
,
Generic
)
deriving
newtype
(
ToSchema
,
ToJSON
,
FromJSON
,
FromField
,
ToField
)
deriving
newtype
(
ToSchema
,
ToJSON
,
FromJSON
,
FromField
,
ToField
)
instance
GQLType
UserId
-- The 'UserId' is isomprohic to an 'Int'.
instance
GQLType
UserId
where
type
KIND
UserId
=
SCALAR
instance
EncodeScalar
UserId
where
encodeScalar
=
encodeScalar
.
_UserId
instance
DecodeScalar
UserId
where
decodeScalar
=
fmap
UnsafeMkUserId
.
decodeScalar
instance
ResourceId
UserId
where
instance
ResourceId
UserId
where
isPositive
=
(
>
0
)
.
_UserId
isPositive
=
(
>
0
)
.
_UserId
...
...
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