Improve isNodeReadOnly query

Now this query accounts correctly for recursive children.

It also:

* Adds basic publish/unpublish works
* Add Move API tests scaffolding

gargantext.cabal

@@ -799,11 +799,13 @@ test-suite garg-test-tasty
   other-modules:
       CLI.Phylo.Common
       Paths_gargantext
+      Test.API.Private.Move
       Test.API.Private.Share
       Test.API.Private.Table
       Test.API.Authentication
       Test.API.Routes
       Test.API.Setup
+      Test.API.Prelude
       Test.API.UpdateList
       Test.Core.Notifications
       Test.Core.Similarity
@@ -861,10 +863,12 @@ test-suite garg-test-hspec
       Test.API.GraphQL
       Test.API.Notifications
       Test.API.Private
+      Test.API.Private.Move
       Test.API.Private.Share
       Test.API.Private.Table
       Test.API.Routes
       Test.API.Setup
+      Test.API.Prelude
       Test.API.UpdateList
       Test.Database.Operations
       Test.Database.Operations.DocumentSearch

src/Gargantext/API/Errors.hs

@@ -165,6 +165,8 @@ nodeErrorToFrontendError ne = case ne of
     -> mkFrontendErrShow $ FE_node_needs_configuration
   NodeError err
     -> mkFrontendErrShow $ FE_node_generic_exception (T.pack $ displayException err)
+  NodeIsReadOnly nodeId reason
+    -> mkFrontendErrShow $ FE_node_is_read_only nodeId reason
 
   -- backward-compatibility shims, to remove eventually.
   DoesNotExist nid

src/Gargantext/API/Errors/Types.hs

@@ -247,6 +247,9 @@ data instance ToFrontendErrorData 'EC_400__node_needs_configuration =
   FE_node_needs_configuration
   deriving (Show, Eq, Generic)
 
+data instance ToFrontendErrorData 'EC_403__node_is_read_only =
+  FE_node_is_read_only { niro_node_id :: NodeId, niro_reason :: T.Text }
+  deriving (Show, Eq, Generic)
 
 --
 -- validation errors
@@ -457,6 +460,15 @@ instance ToJSON (ToFrontendErrorData 'EC_400__node_needs_configuration) where
 instance FromJSON (ToFrontendErrorData 'EC_400__node_needs_configuration) where
   parseJSON _ = pure FE_node_needs_configuration
 
+instance ToJSON (ToFrontendErrorData 'EC_403__node_is_read_only) where
+  toJSON FE_node_is_read_only{..} =
+    object [ "node_id" .= toJSON niro_node_id, "reason" .= toJSON niro_reason ]
+instance FromJSON (ToFrontendErrorData 'EC_403__node_is_read_only) where
+  parseJSON = withObject "FE_node_is_read_only" $ \o -> do
+    niro_node_id <- o .: "node_id"
+    niro_reason  <- o .: "reason"
+    pure FE_node_is_read_only{..}
+
 --
 -- validation errors
 --
@@ -655,6 +667,9 @@ instance FromJSON FrontendError where
       EC_400__node_needs_configuration -> do
         (fe_data :: ToFrontendErrorData 'EC_400__node_needs_configuration) <- o .: "data"
         pure FrontendError{..}
+      EC_403__node_is_read_only -> do
+        (fe_data :: ToFrontendErrorData 'EC_403__node_is_read_only) <- o .: "data"
+        pure FrontendError{..}
 
       -- validation error
       EC_400__validation_error -> do

src/Gargantext/API/Errors/Types/Backend.hs

@@ -33,6 +33,7 @@ data BackendErrorCode
   | EC_400__node_creation_failed_user_negative_id
   | EC_500__node_generic_exception
   | EC_400__node_needs_configuration
+  | EC_403__node_is_read_only
   -- validation errors
   | EC_400__validation_error
   -- authentication errors

src/Gargantext/API/Node.hs

@@ -29,7 +29,7 @@ module Gargantext.API.Node
   where
 
 import Gargantext.API.Admin.Auth (withNamedAccess, withNamedPolicyT)
-import Gargantext.API.Admin.Auth.Types (PathId(..), AuthenticatedUser (..), auth_node_id)
+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.Errors.Types (BackendInternalError)
@@ -71,6 +71,7 @@ import Gargantext.Prelude
 import Servant
 import Servant.Server.Generic (AsServerT)
 import Gargantext.API.Routes.Named.Tree qualified as Named
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 
 
 -- | Delete Nodes
@@ -180,8 +181,8 @@ treeFlatAPI authenticatedUser rootId =
 
 ------------------------------------------------------------------------
 -- | TODO Check if the name is less than 255 char
-rename :: NodeId -> RenameNode -> Cmd err [Int]
-rename nId (RenameNode name') = U.update (U.Rename nId name')
+rename :: HasNodeError err => UserId -> NodeId -> RenameNode -> Cmd err [Int]
+rename loggedInUserId nId (RenameNode name') = U.update loggedInUserId (U.Rename nId name')
 
 putNode :: forall err a. (HyperdataC a)
         => NodeId
@@ -189,11 +190,12 @@ putNode :: forall err a. (HyperdataC a)
         -> Cmd err Int
 putNode n h = fromIntegral <$> updateHyperdata n h
 
-moveNode :: User
+moveNode :: HasNodeError err
+         => UserId
          -> NodeId
          -> ParentId
          -> Cmd err [Int]
-moveNode _u n p = update (Move n p)
+moveNode loggedInUserId n p = update loggedInUserId (Move n p)
 -------------------------------------------------------------
 
 annuaireNodeAPI :: AuthenticatedUser
@@ -227,7 +229,7 @@ genericNodeAPI' :: forall a proxy. ( HyperdataC a )
 genericNodeAPI' _ authenticatedUser targetNode =  Named.NodeAPI
   { nodeNodeAPI        = withNamedPolicyT authenticatedUser (nodeChecks targetNode) $
                            Named.NodeNodeAPI $ getNodeWith targetNode (Proxy :: Proxy a)
-  , renameAPI          = Named.RenameAPI   $ rename targetNode
+  , renameAPI          = Named.RenameAPI   $ rename loggedInUserId targetNode
   , postNodeAPI        = Named.PostNodeAPI $ postNode authenticatedUser targetNode
   , postNodeAsyncAPI   = postNodeAsyncAPI authenticatedUser targetNode
   , frameCalcUploadAPI = FrameCalcUpload.api authenticatedUser targetNode
@@ -251,7 +253,7 @@ genericNodeAPI' _ authenticatedUser targetNode =  Named.NodeAPI
   , pieAPI             = pieApi targetNode
   , treeAPI            = treeApi targetNode
   , phyloAPI           = phyloAPI targetNode
-  , moveAPI            = Named.MoveAPI $ moveNode userRootId targetNode
+  , moveAPI            = Named.MoveAPI $ moveNode loggedInUserId targetNode
   , unpublishEp        = Share.unPublish targetNode
   , fileAPI            = Named.FileAPI $ fileApi targetNode
   , fileAsyncAPI       = fileAsyncApi authenticatedUser targetNode
@@ -259,4 +261,5 @@ genericNodeAPI' _ authenticatedUser targetNode =  Named.NodeAPI
   , documentUploadAPI  = DocumentUpload.api targetNode
   }
   where
-    userRootId = RootId $ authenticatedUser ^. auth_node_id
+    userRootId     = RootId $ authenticatedUser ^. auth_node_id
+    loggedInUserId = authenticatedUser ^. auth_user_id

src/Gargantext/Database/Query/Table/Node/Error.hs

@@ -83,6 +83,7 @@ data NodeError = NoListFound ListId
                | NodeError SomeException
                -- Left for backward compatibility, but we should remove them.
                | DoesNotExist NodeId
+               | NodeIsReadOnly NodeId T.Text
 
 instance Prelude.Show NodeError
   where
@@ -97,6 +98,7 @@ instance Prelude.Show NodeError
     show NeedsConfiguration = "Needs configuration"
     show (NodeError e)      = "NodeError: " <> displayException e
     show (DoesNotExist n)   = "Node does not exist (" <> show n <> ")"
+    show (NodeIsReadOnly n reason) = "Node " <> show n <> " is read only, edits not allowed. Reason: " <> T.unpack reason
 
 instance ToJSON NodeError where
   toJSON (DoesNotExist n) =
@@ -117,6 +119,10 @@ instance ToJSON NodeError where
   toJSON (NoContextFound n) =
     object [ ( "error", "No context found" )
            , ( "node", toJSON n ) ]
+  toJSON (NodeIsReadOnly n reason) =
+    object [ ( "error", "Node is read only" )
+           , ( "reason", toJSON reason)
+           , ( "node", toJSON n ) ]
   toJSON err =
     object [ ( "error", toJSON $ T.pack $ show err ) ]
 

src/Gargantext/Database/Query/Table/Node/Update.hs

@@ -16,10 +16,15 @@ import Data.Text qualified as DT
 import Database.PostgreSQL.Simple ( Only(Only) )
 import Gargantext.Core.Notifications.CentralExchange.Types qualified as CE
 import Gargantext.Core.Types (Name)
-import Gargantext.Database.Admin.Types.Node (NodeId, ParentId)
-import Gargantext.Database.Query.Table.Node (getParentId)
+import Gargantext.Database.Admin.Config ()
+import Gargantext.Database.Query.Table.Node (getParentId, getNode, getUserRootPublicNode)
 import Gargantext.Database.Prelude (Cmd, DBCmd, runPGSQuery)
+import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
+import Gargantext.Core (fromDBid)
+import Gargantext.Database.Query.Table.NodeNode (isNodeReadOnly, SourceId (..), TargetId(..), publishNode, unpublishNode)
+import Gargantext.Database.Query.Table.Node.Error
+import Gargantext.Database.Admin.Types.Node
 
 -- import Data.ByteString
 --rename :: NodeId -> Text -> IO ByteString
@@ -38,22 +43,63 @@ unOnly :: Only a -> a
 unOnly (Only a) = a
 
 -- | Prefer this, because it notifies parents of the node change
-update :: Update -> Cmd err [Int]
-update u@(Rename nId _name) = do
+update :: HasNodeError err => UserId -> Update -> Cmd err [Int]
+update _loggedInUserId u@(Rename nId _name) = do
   ret <- update' u
   mpId <- getParentId nId
   case mpId of
     Nothing -> pure ()
     Just pId -> CE.ce_notify $ CE.UpdateTreeFirstLevel pId
   return ret
-update u@(Move nId pId) = do
-  mpId <- getParentId nId
-  ret <- update' u
-  case mpId of
-    Nothing -> pure ()
-    Just pId' -> CE.ce_notify $ CE.UpdateTreeFirstLevel pId'
-  CE.ce_notify $ CE.UpdateTreeFirstLevel pId
-  return ret
+update loggedInUserId u@(Move sourceId targetId) = do
+  mbParentId <- getParentId sourceId
+
+  -- if the source and the target are the same, this is identity.
+  case sourceId == targetId of
+    True  -> pure [ _NodeId sourceId ]
+    False -> do
+      -- Check if the source and the target are read only (i.e. published) and
+      -- act accordingly.
+      sourceNode <- getNode sourceId
+      targetNode <- getNode targetId
+
+      isSourceRO <- isNodeReadOnly sourceId
+      isTargetRO <- isNodeReadOnly targetId
+
+      ids <- case (isSourceRO, isTargetRO) of
+        (False, False)
+          -> -- both are not read-only, normal move
+             update' u
+        (False, True)
+          -> -- the target is read only
+             -- First of all, we need to understand if the target node
+             -- is a public folder, as we don't allow (at the moment)
+             -- publishing into sub (public) directories.
+             do case fromDBid $ _node_typename targetNode of
+                 NodeFolderPublic
+                   -> do
+                   publishNode (SourceId sourceId) (TargetId targetId)
+                   pure [ _NodeId $ sourceId]
+                 _ -> nodeError (NodeIsReadOnly targetId "Target is read only, but not a public folder.")
+        (True, False)
+          -> -- the source is read only. If we are the owner we allow unpublishing.
+             -- FIXME(adn) is this check enough?
+             do
+               case _node_user_id sourceNode == loggedInUserId of
+                 True -> do
+                   userPublicFolderNode <- getUserRootPublicNode loggedInUserId
+                   unpublishNode (SourceId $ _node_id userPublicFolderNode) (TargetId sourceId)
+                   -- Now we can perform the move
+                   update' u
+                 False -> nodeError (NodeIsReadOnly targetId "logged user is not allowed to move/unpublish a read-only node")
+        (True, True)
+          -> -- this case is not allowed.
+            nodeError (NodeIsReadOnly targetId "Both the source and the target are read-only.")
+
+      for_ mbParentId $ CE.ce_notify . CE.UpdateTreeFirstLevel
+      CE.ce_notify $ CE.UpdateTreeFirstLevel targetId
+
+      pure ids
 
 -- TODO-ACCESS
 update' :: Update -> DBCmd err [Int]

src/Gargantext/Database/Query/Table/NodeNode.hs

@@ -49,7 +49,7 @@ import Control.Arrow (returnA)
 import Control.Lens (view)
 import Database.PostgreSQL.Simple qualified as PGS
 import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
+import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..), Only (..))
 import Data.Text (splitOn)
 import Gargantext.Core ( HasDBid(toDBid) )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument, hd_publication_date )
@@ -62,8 +62,8 @@ import Gargantext.Database.Schema.NodeNode
 import Gargantext.Prelude
 import Opaleye
 import Opaleye qualified as O
-import qualified Data.List as L
-import qualified Prelude
+--import qualified Data.List as L
+--import qualified Prelude
 
 queryNodeNodeTable :: Select NodeNodeRead
 queryNodeNodeTable = selectTable nodeNodeTable
@@ -260,23 +260,47 @@ selectPublicNodes = runOpaQuery (queryWithType NodeFolderPublic)
 -- | A 'Node' is read-only if there exist a match in the node_nodes directory
 -- where the source is a public folder. Certain category of nodes (like private/shared folders, etc)
 -- are automatically read-only.
--- NOTE(adn) This query could probably be simplified to just account for the category, which should
--- be enough to understand if a node is read-only or not.
 isNodeReadOnly :: HasDBid NodeType => NodeId -> DBCmd err Bool
-isNodeReadOnly nodeId = do
-  ( result :: [NodeId] ) <- runOpaQuery $ do
-    node <- queryNodeTable
-    nn   <- queryNodeNodeTable
-    where_ $ node ^. node_typename .== sqlInt4 (toDBid NodeFolderPublic)
-
-    let isLinked = (nn ^. nn_node1_id .== pgNodeId nodeId) .|| (nn ^. nn_node2_id .== pgNodeId nodeId)
-    where_ isLinked
-    where_ ((nn ^. nn_category) .== sqlInt4 (toDBid NNC_read_only_publish))
-    pure $ nn ^. nn_node1_id
-
-  return $ Prelude.not (L.null result)  -- Return True if any rows are found
+isNodeReadOnly targetNode = (== [Only True])
+  <$> runPGSQuery [sql|
+      BEGIN;
+      SET TRANSACTION READ ONLY;
+      COMMIT;
+
+      WITH RECURSIVE ParentNodes AS (
+        -- Base case: Start from the given node ID
+        SELECT id, parent_id
+        FROM nodes
+        WHERE id = ?
+
+        UNION ALL
+
+        -- Recursive case: Traverse to parent nodes
+        SELECT n.id, n.parent_id
+        FROM nodes n
+        JOIN ParentNodes pn ON n.id = pn.parent_id
+    )
+    SELECT EXISTS (
+        SELECT 1
+        FROM ParentNodes pn
+        JOIN nodes_nodes nn ON pn.id = nn.node1_id OR pn.id = nn.node2_id
+        JOIN nodes n ON (nn.node1_id = n.id OR nn.node2_id = n.id)
+        WHERE n.typename = ? AND nn.category = ?
+    ) OR EXISTS (
+           SELECT 1
+           FROM nodes
+           WHERE id = ? AND typename = ? -- if the target is a public folder, it's automatically considered read-only
+    ) AS is_read_only;
+
+  |] ( targetNode
+     , toDBid NodeFolderPublic
+     , toDBid NNC_read_only_publish
+     , targetNode
+     , toDBid NNC_read_only_publish
+     )
+
   where
-    -- FIXME(and) whitelisting.
+    -- NOTE(and) whitelisting?
     _typesWhiteList :: [ NodeType ]
     _typesWhiteList = [
         NodeFolder
@@ -329,8 +353,6 @@ publishNode :: SourceId -> TargetId -> DBCmd err ()
 publishNode (SourceId sourceId) (TargetId targetId) =
   void $ insertNodeNode [ NodeNode sourceId targetId Nothing (Just NNC_read_only_publish) ]
 
--- | FIXME(adn) This needs to delete all the children relationships,
--- recursively.
 unpublishNode :: SourceId -> TargetId -> DBCmd err ()
 unpublishNode (SourceId sourceId) (TargetId targetId) =
   void $ deleteNodeNode sourceId targetId

test/Test/API/Prelude.hs

+{--| Prelude module for our API specs, with utility functions to get us started quickly. -}
+
+module Test.API.Prelude
+  ( newCorpusForUser
+  , newPrivateFolderForUser
+  , newPublicFolderForUser
+  , getRootPublicFolderIdForUser
+  , checkEither
+  ) where
+
+import Data.Text qualified as T
+import Gargantext.Core.Types.Individu
+import Gargantext.Core.Types ( NodeId)
+import Gargantext.Core.Types (NodeType(..))
+import Gargantext.Database.Action.User
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus
+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 Test.Database.Types
+
+checkEither :: (Show a, Monad m) => m (Either a b) -> m b
+checkEither = fmap (either (\x -> panicTrace $ "checkEither:" <> T.pack (show x)) identity)
+
+newCorpusForUser :: TestEnv -> T.Text -> IO NodeId
+newCorpusForUser env uname = flip runReaderT env $ runTestMonad $ do
+  uid      <- getUserId (UserName uname)
+  parentId <- getRootId (UserName uname)
+  let corpusName = "Test_Corpus"
+  (corpusId:_) <- mk (Just corpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
+  pure corpusId
+
+-- | Generate a 'Node' where we can append more data into, a bit reminiscent to the
+-- \"Private\" root node we use in the real Gargantext.
+newPrivateFolderForUser :: TestEnv -> T.Text -> IO NodeId
+newPrivateFolderForUser env uname = flip runReaderT env $ runTestMonad $ do
+  uid      <- getUserId (UserName uname)
+  parentId <- getRootId (UserName uname)
+  let nodeName = "NodeFolderPrivate"
+  insertNode NodeFolderPrivate (Just nodeName) Nothing parentId uid
+
+newPublicFolderForUser :: TestEnv -> T.Text -> IO NodeId
+newPublicFolderForUser env uname = flip runReaderT env $ runTestMonad $ do
+  uid      <- getUserId (UserName uname)
+  parentId <- getRootId (UserName uname)
+  let nodeName = "NodeFolderPublic"
+  insertNode NodeFolderPublic (Just nodeName) Nothing parentId uid
+
+getRootPublicFolderIdForUser :: TestEnv -> User -> IO NodeId
+getRootPublicFolderIdForUser env uname = flip runReaderT env $ runTestMonad $ do
+  _node_id <$> (getUserId uname >>= getUserRootPublicNode)

test/Test/API/Private.hs

@@ -17,6 +17,7 @@ import Network.HTTP.Client hiding (Proxy)
 import Servant.Auth.Client ()
 import Servant.Client
 import Servant.Client.Generic (genericClient)
+import Test.API.Private.Move  qualified as Move
 import Test.API.Private.Share qualified as Share
 import Test.API.Private.Table qualified as Table
 import Test.API.Routes (mkUrl)
@@ -101,3 +102,5 @@ tests = do
     Share.tests
   describe "Table API" $ do
     Table.tests
+  describe "Move API" $ do
+    Move.tests

test/Test/API/Private/Move.hs

+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Test.API.Private.Move (
+    tests
+  ) where
+
+import Control.Lens
+import Gargantext.API.Errors
+import Gargantext.API.Routes.Named
+import Gargantext.API.Routes.Named.Node (moveAPI, moveNodeEp)
+import Gargantext.API.Routes.Named.Private
+import Gargantext.Core.Types
+import Gargantext.Core.Types.Individu
+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.Routes
+import Test.API.Setup
+import Test.Hspec
+import Test.Hspec.Wai.Internal (withApplication)
+import Test.Utils
+
+moveNodeFromTo :: SC.Token -> SourceId -> TargetId -> ClientM [NodeId]
+moveNodeFromTo token (SourceId sourceId) (TargetId targetId) = fmap (map UnsafeMkNodeId) $
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & nodeEp
+               & nodeEndpointAPI
+               & ($ sourceId)
+               & moveAPI
+               & moveNodeEp
+               & ($ targetId)
+
+tests :: Spec
+tests = sequential $ aroundAll withTestDBAndPort $ do
+  describe "Prelude" $ do
+    it "setup DB triggers" $ \SpecContext{..} -> do
+      setupEnvironment _sctx_env
+      -- Let's create the Alice user.
+      void $ createAliceAndBob _sctx_env
+
+    describe "Publishing a Corpus" $ 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
+              cId <- newCorpusForUser testEnv "alice"
+              bobPublicFolderId <- getRootPublicFolderIdForUser testEnv (UserName "bob")
+              checkEither $ runClientM (moveNodeFromTo (toServantToken token) (SourceId bobPublicFolderId) (TargetId cId)) clientEnv
+            liftIO $ length nodes `shouldBe` 1
+
+      it "should allow moving a corpus node into Alice Public folder" $ \(SpecContext testEnv serverPort app _) -> do
+        withApplication app $ do
+          withValidLogin serverPort "alice" (GargPassword "alice") $ \clientEnv token -> do
+            nodes <- liftIO $ do
+              cId <- newCorpusForUser testEnv "alice"
+              alicePublicFolderId <- getRootPublicFolderIdForUser testEnv (UserName "alice")
+              checkEither $ runClientM (moveNodeFromTo (toServantToken token) (SourceId alicePublicFolderId) (TargetId cId)) clientEnv
+            liftIO $ length nodes `shouldBe` 1

test/Test/API/Private/Share.hs

@@ -19,9 +19,9 @@ import Gargantext.Prelude
 import Prelude (fail)
 import Servant.Auth.Client qualified as SC
 import Servant.Client
+import Test.API.Prelude (newCorpusForUser)
 import Test.API.Routes
 import Test.API.Setup
-import Test.API.UpdateList (newCorpusForUser)
 import Test.Hspec
 import Test.Hspec.Wai.Internal (withApplication)
 import Test.Utils

test/Test/API/Private/Table.hs

@@ -14,9 +14,10 @@ import Gargantext.Prelude
 import qualified Gargantext.API.Ngrams.Types as APINgrams
 import qualified Gargantext.Database.Query.Facet as Facet
 import Servant.Client
+import Test.API.Prelude (checkEither)
 import Test.API.Routes
 import Test.API.Setup
-import Test.API.UpdateList (createDocsList, checkEither)
+import Test.API.UpdateList (createDocsList)
 import Test.Hspec
 import Test.Hspec.Wai.Internal (withApplication)
 import Test.Utils

test/Test/API/UpdateList.hs

@@ -9,14 +9,8 @@ module Test.API.UpdateList (
     tests
   -- * Useful helpers
   , JobPollHandle(..)
-  , newCorpusForUser
-  , pollUntilFinished
   , updateNode
   , createDocsList
-  , checkEither
-
-  , newPrivateFolderForUser
-  , newPublicFolderForUser
   ) where
 
 import Control.Lens (mapped, over)
@@ -50,21 +44,17 @@ import Gargantext.Core.Text.Ngrams
 import Gargantext.Core.Types ( CorpusId, ListId, NodeId, _NodeId)
 import Gargantext.Core.Types.Individu
 import Gargantext.Core.Types.Main (ListType(..))
-import Gargantext.Core.Types (NodeType(..))
 import Gargantext.Core.Types (TableResult(..))
-import Gargantext.Database.Action.User
-import Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Database.Query.Facet qualified as Facet
-import Gargantext.Database.Query.Table.Node
-import Gargantext.Database.Query.Tree.Root
 import Gargantext.Prelude hiding (get)
 import Network.Wai.Handler.Warp qualified as Wai
 import Paths_gargantext (getDataFileName)
 import qualified Prelude
-import System.FilePath
 import Servant
 import Servant.Client
 import Servant.Job.Async
+import System.FilePath
+import Test.API.Prelude (newCorpusForUser, newPrivateFolderForUser, checkEither)
 import Test.API.Routes (mkUrl, gqlUrl, get_table_ngrams, put_table_ngrams, toServantToken, clientRoutes, get_table, update_node)
 import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob, SpecContext (..))
 import Test.Database.Types
@@ -77,30 +67,6 @@ import Test.Utils (getJSON, pollUntilFinished, postJSONUrlEncoded, protectedJSON
 import Text.Printf (printf)
 import Web.FormUrlEncoded
 
-newCorpusForUser :: TestEnv -> T.Text -> IO NodeId
-newCorpusForUser env uname = flip runReaderT env $ runTestMonad $ do
-  uid      <- getUserId (UserName uname)
-  parentId <- getRootId (UserName uname)
-  let corpusName = "Test_Corpus"
-  (corpusId:_) <- mk (Just corpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
-  pure corpusId
-
--- | Generate a 'Node' where we can append more data into, a bit reminiscent to the
--- \"Private\" root node we use in the real Gargantext.
-newPrivateFolderForUser :: TestEnv -> T.Text -> IO NodeId
-newPrivateFolderForUser env uname = flip runReaderT env $ runTestMonad $ do
-  uid      <- getUserId (UserName uname)
-  parentId <- getRootId (UserName uname)
-  let nodeName = "NodeFolderPrivate"
-  insertNode NodeFolderPrivate (Just nodeName) Nothing parentId uid
-
-newPublicFolderForUser :: TestEnv -> T.Text -> IO NodeId
-newPublicFolderForUser env uname = flip runReaderT env $ runTestMonad $ do
-  uid      <- getUserId (UserName uname)
-  parentId <- getRootId (UserName uname)
-  let nodeName = "NodeFolderPublic"
-  insertNode NodeFolderPublic (Just nodeName) Nothing parentId uid
-
 uploadJSONList :: Wai.Port
                -> Token
                -> CorpusId
@@ -380,9 +346,6 @@ updateNode port clientEnv token nodeId = do
 toJobPollHandle :: JobStatus 'Safe JobLog -> JobPollHandle
 toJobPollHandle = either (\x -> panicTrace $ "toJobPollHandle:" <> T.pack x) identity . JSON.eitherDecode . JSON.encode
 
-checkEither :: (Show a, Monad m) => m (Either a b) -> m b
-checkEither = fmap (either (\x -> panicTrace $ "checkEither:" <> T.pack (show x)) identity)
-
 mkNewWithForm :: T.Text -> T.Text -> NewWithForm
 mkNewWithForm content name = NewWithForm
   { _wf_filetype   = FType.JSON

test/Test/Database/Operations.hs

@@ -72,7 +72,8 @@ tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
     describe "Publishing a node" $ do
       it "Returns the root public folder for a user" testGetUserRootPublicNode
       it "Correctly detects if a node is read only"  testIsReadOnlyWorks
-      it "Publish the root and its first level children"  testPublishRecursiveFirstLevel
+      it "Publishes the root and its first level children"  testPublishRecursiveFirstLevel
+      it "Publishes the root and its recursive children"  testPublishRecursiveNLevel
 
 nodeStoryTests :: Spec
 nodeStoryTests = sequential $

test/Test/Database/Operations/PublishNode.hs

@@ -21,13 +21,12 @@ import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.User (getUserId)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Table.NodeNode
 import Gargantext.Database.Schema.Node (NodePoly(..))
-
+import Test.API.Prelude (newPrivateFolderForUser, newPublicFolderForUser)
 import Test.API.Setup (createAliceAndBob)
-import Test.API.UpdateList (newPrivateFolderForUser, newPublicFolderForUser)
 import Test.Database.Types
 import Test.Tasty.HUnit
-import Gargantext.Database.Query.Table.NodeNode
 
 testGetUserRootPublicNode :: TestEnv -> Assertion
 testGetUserRootPublicNode testEnv = do
@@ -71,3 +70,22 @@ testPublishRecursiveFirstLevel testEnv = do
 
     isNodeReadOnly aliceFolderId >>= liftIO . (@?= True)
     isNodeReadOnly corpusId      >>= liftIO . (@?= True)
+
+-- | In this test, we check that if we publish the root of a subtree,
+-- then all the children of the children are also marked read-only.
+testPublishRecursiveNLevel :: TestEnv -> Assertion
+testPublishRecursiveNLevel testEnv = do
+  alicePrivateFolderId <- newPrivateFolderForUser testEnv "alice"
+  alicePublicFolderId  <- newPublicFolderForUser testEnv "alice"
+  flip runReaderT testEnv $ runTestMonad $ do
+    -- Create a corpus, by default is not read only
+    aliceUserId    <- getUserId (UserName "alice")
+    aliceFolderId  <- insertDefaultNode NodeFolder alicePrivateFolderId aliceUserId
+    aliceSubFolderId <- insertDefaultNode NodeFolder aliceFolderId aliceUserId
+    corpusId       <- insertDefaultNode NodeCorpus aliceSubFolderId aliceUserId
+
+    publishNode (SourceId aliceFolderId) (TargetId alicePublicFolderId)
+
+    isNodeReadOnly aliceFolderId    >>= liftIO . (@?= True)
+    isNodeReadOnly aliceSubFolderId >>= liftIO . (@?= True)
+    isNodeReadOnly corpusId         >>= liftIO . (@?= True)

test/Test/Instances.hs

@@ -290,6 +290,9 @@ genFrontendErr be = do
             pure $ Errors.mkFrontendErr' txt $ Errors.FE_node_generic_exception err
     Errors.EC_400__node_needs_configuration
       ->    pure $ Errors.mkFrontendErr' txt $ Errors.FE_node_needs_configuration
+    Errors.EC_403__node_is_read_only
+      -> do nId <- arbitrary
+            pure $ Errors.mkFrontendErr' txt $ Errors.FE_node_is_read_only nId "generic reason"
 
     -- validation error
     Errors.EC_400__validation_error

test/Test/Utils.hs

@@ -3,7 +3,29 @@
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeApplications    #-}
 
-module Test.Utils where
+module Test.Utils (
+  -- * Helper types
+    JsonFragmentResponseMatcher(..)
+
+  -- * Utility functions
+  , (@??=)
+  , containsJSON
+  , gargMkRequest
+  , getJSON
+  , pending
+  , pollUntilFinished
+  , postJSONUrlEncoded
+  , protected
+  , protectedJSON
+  , protectedJSONWith
+  , protectedNewError
+  , protectedWith
+  , shouldRespondWithFragment
+  , shouldRespondWithFragmentCustomStatus
+  , shouldRespondWithJSON
+  , waitUntil
+  , withValidLogin
+  ) where
 
 import Control.Exception.Safe ()
 import Control.Monad ()