Introduce correct policy check for the Move API

src/Gargantext/API/Auth/PolicyCheck.hs

@@ -16,6 +16,7 @@ module Gargantext.API.Auth.PolicyCheck (
   , nodeSuper
   , nodeUser
   , nodeChecks
+  , moveChecks
   , userMe
   , alwaysAllow
   , alwaysDeny
@@ -42,6 +43,7 @@ import Servant.Ekg (HasEndpoint(..))
 import Servant.Server.Internal.Delayed (addParameterCheck)
 import Servant.Server.Internal.DelayedIO (DelayedIO(..))
 import Servant.Swagger qualified as Swagger
+import Gargantext.Database.Query.Table.NodeNode
 
 -------------------------------------------------------------------------------
 -- Types
@@ -169,6 +171,15 @@ nodeShared = BConst . Positive . AC_node_shared
 nodeChecks :: NodeId -> BoolExpr AccessCheck
 nodeChecks nid = nodeUser nid `BOr` nodeSuper nid `BOr` nodeDescendant nid `BOr` nodeShared nid
 
+-- | A user can move a node from source to target only
+-- if:
+-- * He/she is a super user
+-- * He/she owns the target or the source
+moveChecks :: SourceId -> TargetId -> BoolExpr AccessCheck
+moveChecks (SourceId sourceId) (TargetId targetId) =
+  BAnd (nodeUser sourceId `BOr` nodeSuper sourceId)
+       (nodeUser targetId `BOr` nodeUser targetId)
+
 alwaysAllow :: BoolExpr AccessCheck
 alwaysAllow = BConst . Positive $ AC_always_allow
 
@@ -200,10 +211,11 @@ instance HasEndpoint sub => HasEndpoint (PolicyChecked sub) where
   enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
 
 instance HasClient m sub => HasClient m (PolicyChecked sub) where
-  type Client m (PolicyChecked sub) = AccessPolicyManager -> Client m sub
-  clientWithRoute m _ req _mgr = clientWithRoute m (Proxy :: Proxy sub) req
+  -- Clients don't need to be aware of the AccessPolicyManager
+  type Client m (PolicyChecked sub) = Client m sub
+  clientWithRoute m _ req = clientWithRoute m (Proxy :: Proxy sub) req
 
-  hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl
+  hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt $ cl
 
 instance (HasRoutes subApi) => HasRoutes (PolicyChecked subApi) where
   getRoutes =

src/Gargantext/API/Node.hs

@@ -28,10 +28,10 @@ Node API
 module Gargantext.API.Node
   where
 
-import Gargantext.API.Admin.Auth (withNamedAccess, withNamedPolicyT)
+import Gargantext.API.Admin.Auth (withNamedAccess, withNamedPolicyT, withPolicy)
 import Gargantext.API.Admin.Auth.Types (PathId(..), AuthenticatedUser (..), auth_node_id, auth_user_id)
 import Gargantext.API.Admin.EnvTypes (Env)
-import Gargantext.API.Auth.PolicyCheck ( nodeChecks, AccessPolicyManager )
+import Gargantext.API.Auth.PolicyCheck ( nodeChecks, moveChecks, AccessPolicyManager )
 import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Metrics
 import Gargantext.API.Ngrams.Types (TabType(..))
@@ -253,7 +253,9 @@ genericNodeAPI' _ authenticatedUser targetNode =  Named.NodeAPI
   , pieAPI             = pieApi targetNode
   , treeAPI            = treeApi targetNode
   , phyloAPI           = phyloAPI targetNode
-  , moveAPI            = Named.MoveAPI $ moveNode loggedInUserId targetNode
+  , moveAPI            = Named.MoveAPI $ \parentId ->
+                           withPolicy authenticatedUser (moveChecks (SourceId targetNode) (TargetId parentId)) $
+                             moveNode loggedInUserId targetNode parentId
   , unpublishEp        = Share.unPublish targetNode
   , fileAPI            = Named.FileAPI $ fileApi targetNode
   , fileAsyncAPI       = fileAsyncApi authenticatedUser targetNode

src/Gargantext/API/Routes/Named/Node.hs

@@ -91,7 +91,7 @@ data NodeAPI a mode = NodeAPI
   , pieAPI             :: mode :- "pie"      :> NamedRoutes PieAPI
   , treeAPI            :: mode :- "tree"     :> NamedRoutes TreeAPI
   , phyloAPI           :: mode :- "phylo"    :> NamedRoutes PhyloAPI
-  , moveAPI            :: mode :- "move"     :> NamedRoutes MoveAPI
+  , moveAPI            :: mode :- "move"      :> NamedRoutes MoveAPI
   , unpublishEp        :: mode :- "unpublish" :> NamedRoutes Share.Unpublish
   , fileAPI            :: mode :- "file"      :> NamedRoutes FileAPI
   , fileAsyncAPI       :: mode :- "async"     :> NamedRoutes FileAsyncAPI
@@ -151,7 +151,9 @@ newtype UpdateAPI mode = UpdateAPI
 
 
 newtype MoveAPI mode = MoveAPI
-  { moveNodeEp :: mode :- Summary "Move Node endpoint" :> Capture "parent_id" ParentId :> Put '[JSON] [Int]
+  { moveNodeEp :: mode :- Summary "Move Node endpoint"
+                       :> Capture "parent_id" ParentId
+                       :> PolicyChecked (Put '[JSON] [Int])
   } deriving Generic
 
 

test/Test/API/Prelude.hs

@@ -6,9 +6,11 @@ module Test.API.Prelude
   , newPublicFolderForUser
   , getRootPublicFolderIdForUser
   , checkEither
+  , shouldFailWith
   ) where
 
 import Data.Text qualified as T
+import Gargantext.API.Errors
 import Gargantext.Core.Types.Individu
 import Gargantext.Core.Types ( NodeId)
 import Gargantext.Core.Types (NodeType(..))
@@ -18,7 +20,11 @@ import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Tree.Root
 import Gargantext.Database.Schema.Node (_node_id)
 import Gargantext.Prelude hiding (get)
+import Prelude (fail)
+import Servant.Client.Core
 import Test.Database.Types
+import Test.Tasty.HUnit (Assertion, (@?=))
+import qualified Data.Aeson as JSON
 
 checkEither :: (Show a, Monad m) => m (Either a b) -> m b
 checkEither = fmap (either (\x -> panicTrace $ "checkEither:" <> T.pack (show x)) identity)
@@ -50,3 +56,13 @@ newPublicFolderForUser env uname = flip runReaderT env $ runTestMonad $ do
 getRootPublicFolderIdForUser :: TestEnv -> User -> IO NodeId
 getRootPublicFolderIdForUser env uname = flip runReaderT env $ runTestMonad $ do
   _node_id <$> (getUserId uname >>= getUserRootPublicNode)
+
+shouldFailWith :: Show a => Either ClientError a -> BackendErrorCode -> Assertion
+action `shouldFailWith` backendError = case action of
+  Right{} -> fail "Expected action to fail, but it didn't."
+  Left fr@(FailureResponse _req res)
+    | Right FrontendError{..} <- JSON.eitherDecode (responseBody res)
+    -> fe_type @?= backendError
+    | otherwise
+    -> fail $ "FailureResponse didn't have FrontendError: " <> show fr
+  _xs -> fail $ "Unexpected ClientError: " <> show _xs

test/Test/API/Private/Move.hs

@@ -17,7 +17,7 @@ import Gargantext.Database.Query.Table.NodeNode (SourceId(..), TargetId(..))
 import Gargantext.Prelude
 import Servant.Auth.Client qualified as SC
 import Servant.Client
-import Test.API.Prelude (newCorpusForUser, getRootPublicFolderIdForUser, checkEither)
+import Test.API.Prelude (newCorpusForUser, getRootPublicFolderIdForUser, checkEither, shouldFailWith)
 import Test.API.Routes
 import Test.API.Setup
 import Test.Hspec
@@ -55,11 +55,11 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
       it "should forbid moving a corpus node into another user Public folder" $ \(SpecContext testEnv serverPort app _) -> do
         withApplication app $ do
           withValidLogin serverPort "alice" (GargPassword "alice") $ \clientEnv token -> do
-            nodes <- liftIO $ do
+            liftIO $ do
               cId <- newCorpusForUser testEnv "alice"
               bobPublicFolderId <- getRootPublicFolderIdForUser testEnv (UserName "bob")
-              checkEither $ runClientM (moveNodeFromTo (toServantToken token) (SourceId bobPublicFolderId) (TargetId cId)) clientEnv
-            liftIO $ length nodes `shouldBe` 1
+              res <- runClientM (moveNodeFromTo (toServantToken token) (SourceId bobPublicFolderId) (TargetId cId)) clientEnv
+              res `shouldFailWith` EC_500__internal_server_error
 
       it "should allow moving a corpus node into Alice Public folder" $ \(SpecContext testEnv serverPort app _) -> do
         withApplication app $ do