Merge remote-tracking branch 'origin/adinapoli/issue-279' into dev

src/Gargantext/API/Auth/PolicyCheck.hs

@@ -15,6 +15,7 @@ module Gargantext.API.Auth.PolicyCheck (
   , nodeSuper
   , nodeUser
   , nodeChecks
+  , userMe
   , alwaysAllow
   , alwaysDeny
   ) where
@@ -72,11 +73,15 @@ data AccessPolicyManager = AccessPolicyManager
 data AccessCheck
   = -- | Grants access if the input 'NodeId' is a descendant of the
     -- 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.
+  | AC_node_shared      !NodeId
     -- | 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.
-  | AC_master_user      NodeId
+  | AC_master_user      !NodeId
     -- | Always grant access, effectively a public route.
   | AC_always_allow
     -- | Always denies access.
@@ -119,13 +124,16 @@ accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
 
 
 check :: HasNodeError err => AuthenticatedUser -> AccessCheck -> DBCmd err AccessResult
-check (AuthenticatedUser loggedUserNodeId _loggedUserUserId) = \case
+check (AuthenticatedUser loggedUserNodeId loggedUserUserId) = \case
   AC_always_deny
     -> pure $ Deny err500
   AC_always_allow
     -> pure Allow
   AC_user_node requestedNodeId
-    -> enforce err403 $ loggedUserNodeId == requestedNodeId
+    -> do ownedByMe <- requestedNodeId `isOwnedBy` loggedUserUserId
+          enforce err403 $ (loggedUserNodeId == requestedNodeId || ownedByMe)
+  AC_user requestedUserId
+    -> enforce err403 $ (loggedUserUserId == requestedUserId)
   AC_master_user _requestedNodeId
     -> do
       masterUsername <- _gc_masteruser <$> view hasConfig
@@ -133,6 +141,8 @@ check (AuthenticatedUser loggedUserNodeId _loggedUserUserId) = \case
       enforce err403 $ masterNodeId == loggedUserNodeId
   AC_node_descendant nodeId
     -> enforce err403 =<< nodeId `isDescendantOf` loggedUserNodeId
+  AC_node_shared nodeId
+    -> enforce err403 =<< nodeId `isSharedWith` loggedUserNodeId
 
 -------------------------------------------------------------------------------
 -- Smart constructors of access checks
@@ -141,17 +151,20 @@ check (AuthenticatedUser loggedUserNodeId _loggedUserUserId) = \case
 nodeUser :: NodeId -> BoolExpr AccessCheck
 nodeUser = BConst . Positive . AC_user_node
 
+userMe :: UserId -> BoolExpr AccessCheck
+userMe = BConst . Positive . AC_user
+
 nodeSuper :: NodeId -> BoolExpr AccessCheck
 nodeSuper = BConst . Positive . AC_master_user
 
 nodeDescendant :: NodeId -> BoolExpr AccessCheck
 nodeDescendant = BConst . Positive . AC_node_descendant
 
--- FIXME(adinapoli) Checks temporarily disabled.
+nodeShared :: NodeId -> BoolExpr AccessCheck
+nodeShared = BConst . Positive . AC_node_shared
+
 nodeChecks :: NodeId -> BoolExpr AccessCheck
-nodeChecks _nid = alwaysAllow
-  where
-    _disabled = nodeUser _nid `BOr` nodeSuper _nid `BOr` nodeDescendant _nid
+nodeChecks nid = nodeUser nid `BOr` nodeSuper nid `BOr` nodeDescendant nid `BOr` nodeShared nid
 
 alwaysAllow :: BoolExpr AccessCheck
 alwaysAllow = BConst . Positive $ AC_always_allow

src/Gargantext/API/GraphQL/Node.hs

@@ -63,9 +63,7 @@ resolveNodes
   -> NodeArgs
   -> GqlM e env [Node]
 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 alwaysAllow $ dbNodes node_id
+  withPolicy autUser mgr (nodeChecks $ NN.UnsafeMkNodeId node_id) $ dbNodes node_id
 
 resolveNodesCorpus
   :: (CmdCommon env)

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

@@ -69,9 +69,7 @@ resolveTree :: (CmdCommon env)
             -> TreeArgs
             -> GqlM e env (TreeFirstLevel (GqlM e env))
 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 alwaysAllow $ dbTree root_id
+  withPolicy autUser mgr (nodeChecks $ UnsafeMkNodeId root_id) $ dbTree root_id
 
 dbTree :: (CmdCommon env) =>
           Int -> GqlM e env (TreeFirstLevel (GqlM e env))

src/Gargantext/API/GraphQL/User.hs

@@ -55,8 +55,8 @@ resolveUsers
   -> UserArgs
   -> GqlM e env [User (GqlM e env)]
 resolveUsers autUser mgr UserArgs { user_id } = do
-  -- FIXME(adn) we should use a proper policy, not 'alwaysAllow'.
-  withPolicy autUser mgr alwaysAllow $ dbUsers user_id
+  -- We are given the /node id/ of the logged-in user.
+  withPolicy autUser mgr (nodeChecks $ UnsafeMkNodeId user_id) $ dbUsers user_id
 
 -- | Inner function to fetch the user from DB.
 dbUsers :: (CmdCommon env)

src/Gargantext/API/GraphQL/UserInfo.hs

@@ -113,7 +113,7 @@ resolveUserInfos
   -> UserInfoArgs -> GqlM e env [UserInfo]
 resolveUserInfos autUser mgr UserInfoArgs { user_id } =
   -- 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
 updateUserInfo

src/Gargantext/Database/Admin/Types/Node.hs

@@ -15,6 +15,7 @@ Portability : POSIX
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE DerivingVia                #-}
 {-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- {-# LANGUAGE DuplicateRecordFields #-}
 
@@ -26,7 +27,8 @@ import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import Data.Csv qualified as Csv
 import Data.Either
-import Data.Morpheus.Types (GQLType)
+import Data.Morpheus.Kind (SCALAR)
+import Data.Morpheus.Types
 import Data.Swagger
 import Data.Text (unpack, pack)
 import Data.Time (UTCTime)
@@ -59,7 +61,15 @@ newtype UserId = UnsafeMkUserId { _UserId :: Int }
   deriving stock (Show, Eq, Ord, Generic)
   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
   isPositive = (> 0) . _UserId

src/Gargantext/Database/Query/Tree.hs

@@ -20,6 +20,8 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
 module Gargantext.Database.Query.Tree
   ( module Gargantext.Database.Query.Tree.Error
   , isDescendantOf
+  , isOwnedBy
+  , isSharedWith
   , isIn
   , tree
   , tree_flat
@@ -377,6 +379,37 @@ isDescendantOf childId rootId = (== [Only True])
   WHERE t.id = ?;
   |] (childId, rootId)
 
+isOwnedBy :: NodeId -> UserId -> DBCmd err Bool
+isOwnedBy nodeId userId = (== [Only True])
+  <$> runPGSQuery [sql| SELECT COUNT(*) = 1 from nodes AS c where c.id = ? AND c.user_id = ? |] (nodeId, userId)
+
+isSharedWith :: NodeId -> NodeId -> DBCmd err Bool
+isSharedWith targetNode targetUserNode = (== [Only True])
+  <$> runPGSQuery [sql|
+      BEGIN;
+      SET TRANSACTION READ ONLY;
+      COMMIT;
+
+      WITH RECURSIVE SharePath AS (
+        SELECT nn.node1_id, nn.node2_id AS shared_node_id
+        FROM nodes_nodes nn
+        WHERE nn.node1_id IN (SELECT id FROM nodes WHERE parent_id = ?)
+        UNION ALL
+        SELECT nn.node1_id, nn.node2_id
+        FROM nodes_nodes nn
+        JOIN SharePath sp ON nn.node1_id = sp.shared_node_id
+      )
+
+      SELECT
+        EXISTS (
+          SELECT 1
+          FROM nodes n
+          JOIN SharePath sp ON n.parent_id = sp.shared_node_id
+          WHERE n.id = ?
+          OR n.parent_id = ?
+        ) AS share_exists;
+  |] (targetUserNode, targetNode, targetNode)
+
 -- TODO should we check the category?
 isIn :: NodeId -> DocId -> DBCmd err Bool
 isIn cId docId = ( == [Only True])

test/Test/API/Private.hs

@@ -111,8 +111,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
       it "forbids 'alice' to see others node private info" $ \((_testEnv, port), app) -> do
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \token -> do
-            let _unused = protected token "GET" (mkUrl port "/node/1") "" `shouldRespondWith` 403
-                in liftIO $ pendingWith "POLICY CHECK DISABLED FOR NOW (ISSUE #279)"
+            protected token "GET" (mkUrl port "/node/1") "" `shouldRespondWith` 403
 
     describe "GET /api/v1.0/tree" $ do
       it "unauthorised users shouldn't see anything" $ \((_testEnv, port), app) -> do
@@ -128,5 +127,4 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
       it "forbids 'alice' to see others node private info" $ \((_testEnv, port), app) -> do
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \token -> do
-            let _unused = protected token "GET" (mkUrl port "/tree/1") "" `shouldRespondWith` 403
-                in liftIO $ pendingWith "POLICY CHECK DISABLED FOR NOW (ISSUE #279)"
+            protected token "GET" (mkUrl port "/tree/1") "" `shouldRespondWith` 403