Merge dev

CHANGELOG.md

+## Version 0.0.7.3.7
+
+* [BACK][FEAT][Automatically import useful modules in the REPL (#422)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/422)
+* [BACK][FEAT][Publishing a Corpus (#400)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/400)
+
 ## Version 0.0.7.3.6
 
 * [BACK][FIX][Store execution time of Phylomemy graph (#409)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/409)

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.7.3.6
+version: 0.0.7.3.7
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -273,7 +273,9 @@ library
       Gargantext.Database.Query.Table.NgramsPostag
       Gargantext.Database.Query.Table.Node
       Gargantext.Database.Query.Table.Node.Error
+      Gargantext.Database.Query.Table.NodeNode
       Gargantext.Database.Query.Table.Node.UpdateOpaleye
+      Gargantext.Database.Query.Table.Node.User
       Gargantext.Database.Query.Table.User
       Gargantext.Database.Query.Tree.Root
       Gargantext.Database.Schema.Ngrams
@@ -447,11 +449,9 @@ library
       Gargantext.Database.Query.Table.Node.Document.Insert
       Gargantext.Database.Query.Table.Node.Select
       Gargantext.Database.Query.Table.Node.Update
-      Gargantext.Database.Query.Table.Node.User
       Gargantext.Database.Query.Table.NodeContext
       Gargantext.Database.Query.Table.NodeContext_NodeContext
       Gargantext.Database.Query.Table.NodeNgrams
-      Gargantext.Database.Query.Table.NodeNode
       Gargantext.Database.Query.Tree
       Gargantext.Database.Query.Tree.Error
       Gargantext.Database.Schema.Context
@@ -548,6 +548,7 @@ library
     , monad-control ^>= 1.0.3.1
     , monad-logger ^>= 0.3.36
     , morpheus-graphql >= 0.24.3 && < 0.25
+    , morpheus-graphql-app >= 0.24.3 && < 0.25
     , morpheus-graphql-server >= 0.24.3 && < 0.25
     , morpheus-graphql-subscriptions >= 0.24.3 && < 0.25
     , mtl ^>= 2.2.2
@@ -742,6 +743,7 @@ common testDependencies
     , hspec ^>= 2.11.1
     , hspec-core
     , hspec-expectations >= 0.8 && < 0.9
+    , hspec-expectations-lifted < 0.11
     , hspec-wai
     , hspec-wai-json
     , http-api-data >= 0.5 && < 0.6
@@ -809,11 +811,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
@@ -827,6 +831,7 @@ test-suite garg-test-tasty
       Test.Database.Operations
       Test.Database.Operations.DocumentSearch
       Test.Database.Operations.NodeStory
+      Test.Database.Operations.PublishNode
       Test.Database.Setup
       Test.Database.Types
       Test.Graph.Clustering
@@ -873,15 +878,18 @@ 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.API.Worker
       Test.Database.Operations
       Test.Database.Operations.DocumentSearch
       Test.Database.Operations.NodeStory
+      Test.Database.Operations.PublishNode
       Test.Database.Setup
       Test.Database.Types
       Test.Instances

src/Gargantext/API/Admin/Auth.hs

@@ -191,7 +191,7 @@ withPolicy ur checks m mgr = case mgr of
     res <- runAccessPolicy ur checks
     case res of
       Allow     -> m
-      Deny err  -> throwError $ InternalServerError $ err
+      Deny err  -> throwError $ AccessPolicyError err
 
 -- FIXME(adn) the types are wrong.
 withNamedPolicyT :: forall env m routes.

src/Gargantext/API/Auth/PolicyCheck.hs

@@ -15,7 +15,11 @@ module Gargantext.API.Auth.PolicyCheck (
   , nodeDescendant
   , nodeSuper
   , nodeUser
-  , nodeChecks
+  , nodeReadChecks
+  , nodeWriteChecks
+  , nodePublishedRead
+  , nodePublishedEdit
+  , moveChecks
   , userMe
   , alwaysAllow
   , alwaysDeny
@@ -23,22 +27,27 @@ module Gargantext.API.Auth.PolicyCheck (
 
 import Control.Lens (view)
 import Data.BoolExpr (BoolExpr(..), Signed(..))
+import Data.Text qualified as T
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..))
-import Gargantext.API.Errors.Types (BackendInternalError)
+import Gargantext.API.Errors (BackendInternalError)
+import Gargantext.API.Errors.Types (AccessPolicyErrorReason(..))
 import Gargantext.Core.Config (GargConfig(..), HasConfig(hasConfig))
 import Gargantext.Core.Config.Types (SecretsConfig(..))
-import Gargantext.Core.Types (NodeId, UserId)
 import Gargantext.Core.Types.Individu (User(UserName))
+import Gargantext.Core.Types (NodeId, UserId)
 import Gargantext.Database.Prelude (DBCmd)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
-import Gargantext.Database.Query.Tree (isDescendantOf, isOwnedBy, isSharedWith)
+import Gargantext.Database.Query.Table.Node (getNode)
+import Gargantext.Database.Query.Table.NodeNode
+import Gargantext.Database.Query.Tree (isDescendantOf, isOwnedBy, isSharedWith, lookupPublishPolicy)
 import Gargantext.Database.Query.Tree.Root (getRootId)
+import Gargantext.Database.Schema.Node (node_user_id)
 import Gargantext.Prelude
-import Servant (HasServer(..), ServerError, ServerT, err403, err500)
 import Servant.API.Routes (HasRoutes(getRoutes))
 import Servant.Auth.Server.Internal.AddSetCookie (AddSetCookieApi, AddSetCookies(..), Nat(S))
 import Servant.Client.Core (HasClient(..), Client)
 import Servant.Ekg (HasEndpoint(..))
+import Servant (HasServer(..), ServerT)
 import Servant.Server.Internal.Delayed (addParameterCheck)
 import Servant.Server.Internal.DelayedIO (DelayedIO(..))
 import Servant.Swagger qualified as Swagger
@@ -55,7 +64,8 @@ data AccessResult
   = -- | Grants access.
     Allow
     -- | Denies access with the given 'ServerError'.
-  | Deny ServerError
+  | Deny AccessPolicyErrorReason
+  deriving Show
 
 instance Semigroup AccessResult where
   Allow <> Allow        = Allow
@@ -79,6 +89,10 @@ data AccessCheck
     AC_node_descendant  !NodeId
     -- | Grants access if the input 'NodeId' is shared with the logged-in user.
   | AC_node_shared      !NodeId
+    -- | Grants read access if the input 'NodeId' is published.
+  | AC_node_published_read   !NodeId
+    -- | Grants edit access if the input 'NodeId' is published.
+  | AC_node_published_edit   !NodeId
     -- | Grants access if the input 'NodeId' /is/ the logged-in user.
   | AC_user_node        !NodeId
     -- | Grants access if the logged-in user is the user.
@@ -114,12 +128,12 @@ accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
         -> do
           res <- interpretPolicy ur b1
           case res of
-            Allow  -> pure $ Deny err403
+            Allow  -> pure $ Deny invalidUserPermissions
             Deny _ -> pure Allow
       BTrue
         -> pure Allow
       BFalse
-        -> pure $ Deny err403
+        -> pure $ Deny invalidUserPermissions
       BConst (Positive b)
         -> check' ur b
       BConst (Negative b)
@@ -129,23 +143,61 @@ accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
 check' :: HasNodeError err => AuthenticatedUser -> AccessCheck -> DBCmd err AccessResult
 check' (AuthenticatedUser loggedUserNodeId loggedUserUserId) = \case
   AC_always_deny
-    -> pure $ Deny err500
+    -> pure $ Deny invalidUserPermissions
   AC_always_allow
     -> pure Allow
   AC_user_node requestedNodeId
     -> do ownedByMe <- requestedNodeId `isOwnedBy` loggedUserUserId
-          enforce err403 $ (loggedUserNodeId == requestedNodeId || ownedByMe)
+          enforce invalidUserPermissions $ (loggedUserNodeId == requestedNodeId || ownedByMe)
   AC_user requestedUserId
-    -> enforce err403 $ (loggedUserUserId == requestedUserId)
+    -> enforce invalidUserPermissions $ (loggedUserUserId == requestedUserId)
   AC_master_user _requestedNodeId
     -> do
       masterUsername <- _s_master_user . _gc_secrets <$> view hasConfig
       masterNodeId   <- getRootId (UserName masterUsername)
-      enforce err403 $ masterNodeId == loggedUserNodeId
+      enforce invalidUserPermissions $ masterNodeId == loggedUserNodeId
   AC_node_descendant nodeId
-    -> enforce err403 =<< nodeId `isDescendantOf` loggedUserNodeId
+    -> enforce nodeNotDescendant =<< nodeId `isDescendantOf` loggedUserNodeId
   AC_node_shared nodeId
-    -> enforce err403 =<< nodeId `isSharedWith` loggedUserNodeId
+    -> enforce nodeNotShared =<< nodeId `isSharedWith` loggedUserNodeId
+  AC_node_published_read nodeId
+    -> enforce nodeNotShared =<< isNodeReadOnly nodeId
+  AC_node_published_edit nodeId
+    -> do
+      mb_pp <- lookupPublishPolicy nodeId
+      targetNode <- getNode nodeId
+      let allowedOrNot = do
+            case mb_pp of
+              Nothing -> pure Allow
+              Just NPP_publish_no_edits_allowed
+                -> throwError not_editable
+              Just NPP_publish_edits_only_owner_or_super
+                -> enforce (nodeNotShared' not_editable) (targetNode ^. node_user_id == loggedUserUserId)
+      case allowedOrNot of
+        Left err -> enforce (nodeNotShared' err) False
+        Right _  -> pure Allow
+
+-------------------------------------------------------------------------------
+-- Errors
+-------------------------------------------------------------------------------
+
+nodeNotShared :: AccessPolicyErrorReason
+nodeNotShared = nodeNotShared' not_shared_with_user
+
+not_shared_with_user :: T.Text
+not_shared_with_user = "Node is not published or shared with user."
+
+not_editable :: T.Text
+not_editable = "Node is published and not editable by anyone."
+
+nodeNotShared' :: T.Text -> AccessPolicyErrorReason
+nodeNotShared' = AccessPolicyErrorReason
+
+nodeNotDescendant :: AccessPolicyErrorReason
+nodeNotDescendant = AccessPolicyErrorReason "Node is not a direct descendant."
+
+invalidUserPermissions :: AccessPolicyErrorReason
+invalidUserPermissions = AccessPolicyErrorReason "User not authorized to perform the operation."
 
 -------------------------------------------------------------------------------
 -- Smart constructors of access checks
@@ -166,8 +218,43 @@ nodeDescendant = BConst . Positive . AC_node_descendant
 nodeShared :: NodeId -> BoolExpr AccessCheck
 nodeShared = BConst . Positive . AC_node_shared
 
-nodeChecks :: NodeId -> BoolExpr AccessCheck
-nodeChecks nid = nodeUser nid `BOr` nodeSuper nid `BOr` nodeDescendant nid `BOr` nodeShared nid
+nodePublishedRead :: NodeId -> BoolExpr AccessCheck
+nodePublishedRead = BConst . Positive . AC_node_published_read
+
+nodePublishedEdit :: NodeId -> BoolExpr AccessCheck
+nodePublishedEdit = BConst . Positive . AC_node_published_edit
+
+nodeReadChecks :: NodeId -> BoolExpr AccessCheck
+nodeReadChecks nid =
+  nodeUser nid  `BOr`
+  nodeSuper nid `BOr`
+  nodeDescendant nid `BOr`
+  nodeShared nid `BOr`
+  nodePublishedRead nid
+
+-- | A user can edit a node iff:
+-- * The node is not published or Is published, but using a policy that allows modifications
+-- /OR/
+-- * The user is the owner
+-- * The user is a super
+-- * The node has been shared with the user
+-- * The node is a discendant (adn: really needed?)
+nodeWriteChecks :: NodeId -> BoolExpr AccessCheck
+nodeWriteChecks nid =
+  (nodeUser nid  `BOr`
+   nodeSuper nid `BOr`
+   nodeDescendant nid `BOr`
+   nodeShared nid
+  ) `BAnd` nodePublishedEdit 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 +287,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 =
@@ -216,5 +304,5 @@ instance (HasRoutes subApi) => HasRoutes (PolicyChecked subApi) where
 
 -- | If the given predicate holds then grant access, otherwise denies access
 -- with the given 'ServerError'.
-enforce :: Applicative m => ServerError -> Bool -> m AccessResult
+enforce :: Applicative m => AccessPolicyErrorReason -> Bool -> m AccessResult
 enforce errStatus p = pure $ if p then Allow else Deny errStatus

src/Gargantext/API/Errors.hs

@@ -79,6 +79,13 @@ backendErrorToFrontendError = \case
          $ FE_validation_error $ case prettyValidation validationError of
              Nothing -> "unknown_validation_error"
              Just v  -> T.pack v
+  AccessPolicyError accessPolicyError
+    -> case accessPolicyError of
+         AccessPolicyNodeError nodeError
+           -> nodeErrorToFrontendError nodeError
+         AccessPolicyErrorReason reason
+           -> mkFrontendErr' "A policy check failed"
+                $ FE_policy_check_error reason
 
 frontendErrorToGQLServerError :: FrontendError -> ServerError
 frontendErrorToGQLServerError fe@(FrontendError diag ty _) =
@@ -155,6 +162,8 @@ nodeErrorToFrontendError ne = case ne of
            -> mkFrontendErrShow $ FE_node_lookup_failed_username_not_found uname
          UserHasTooManyRoots uid roots
            -> mkFrontendErrShow $ FE_node_lookup_failed_user_too_many_roots uid roots
+         UserFolderDoesNotExist uid
+           -> mkFrontendErrShow $ FE_node_lookup_failed_user_no_folder uid
   NotImplYet
     -> mkFrontendErrShow FE_node_not_implemented_yet
   NoContextFound contextId
@@ -163,6 +172,10 @@ 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
+  MoveError sourceId targetId reason
+    -> mkFrontendErrShow $ FE_node_move_error sourceId targetId reason
 
   -- backward-compatibility shims, to remove eventually.
   DoesNotExist nid

src/Gargantext/API/Errors/Types.hs

@@ -31,6 +31,7 @@ module Gargantext.API.Errors.Types (
   , BackendInternalError(..)
   , GraphQLError(..)
   , ToFrontendErrorData(..)
+  , AccessPolicyErrorReason(..)
 
   -- * Constructing frontend errors
   , mkFrontendErrNoDiagnostic
@@ -83,8 +84,15 @@ instance Exception e => Exception (WithStacktrace e) where
 -- | An internal error which can be emitted from the backend and later
 -- converted into a 'FrontendError', for later consumption.
 
+data AccessPolicyErrorReason
+  = AccessPolicyErrorReason !T.Text
+  | AccessPolicyNodeError !NodeError
+  deriving Show
 
+makePrisms ''AccessPolicyErrorReason
 
+instance HasNodeError AccessPolicyErrorReason where
+  _NodeError = _AccessPolicyNodeError
 
 data BackendInternalError
   = InternalAuthenticationError !AuthenticationError
@@ -94,6 +102,7 @@ data BackendInternalError
   | InternalTreeError           !TreeError
   | InternalUnexpectedError     !SomeException
   | InternalValidationError     !Validation
+  | AccessPolicyError           !AccessPolicyErrorReason
   deriving (Show, Typeable)
 
 makePrisms ''BackendInternalError
@@ -215,6 +224,10 @@ data instance ToFrontendErrorData 'EC_400__node_lookup_failed_user_too_many_root
                                             }
   deriving (Show, Eq, Generic)
 
+data instance ToFrontendErrorData 'EC_404__node_lookup_failed_user_no_folder =
+  FE_node_lookup_failed_user_no_folder { nenpf_user_id :: UserId }
+  deriving (Show, Eq, Generic)
+
 newtype instance ToFrontendErrorData 'EC_404__node_context_not_found =
   FE_node_context_not_found { necnf_context_id :: ContextId }
   deriving (Show, Eq, Generic)
@@ -243,6 +256,13 @@ 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)
+
+data instance ToFrontendErrorData 'EC_403__node_move_error =
+  FE_node_move_error { nme_source_id :: !NodeId, nme_target_id :: !NodeId, nme_reason :: !T.Text }
+  deriving (Show, Eq, Generic)
 
 --
 -- validation errors
@@ -252,6 +272,14 @@ data instance ToFrontendErrorData 'EC_400__validation_error =
   FE_validation_error { validation_error :: T.Text }
   deriving (Show, Eq, Generic)
 
+--
+-- policy check errors
+--
+
+data instance ToFrontendErrorData 'EC_403__policy_check_error =
+  FE_policy_check_error { policy_check_error :: T.Text }
+  deriving (Show, Eq, Generic)
+
 --
 -- authentication errors
 --
@@ -400,6 +428,14 @@ instance FromJSON (ToFrontendErrorData 'EC_400__node_lookup_failed_user_too_many
     netmr_roots   <- o .: "roots"
     pure FE_node_lookup_failed_user_too_many_roots{..}
 
+instance ToJSON (ToFrontendErrorData 'EC_404__node_lookup_failed_user_no_folder) where
+  toJSON (FE_node_lookup_failed_user_no_folder userId) =
+    object [ "user_id" .= toJSON userId ]
+instance FromJSON (ToFrontendErrorData 'EC_404__node_lookup_failed_user_no_folder) where
+  parseJSON = withObject "FE_node_lookup_failed_user_no_folder" $ \o -> do
+    nenpf_user_id <- o .: "user_id"
+    pure FE_node_lookup_failed_user_no_folder{..}
+
 instance ToJSON (ToFrontendErrorData 'EC_404__node_context_not_found) where
   toJSON (FE_node_context_not_found cId) = object [ "context_id" .= toJSON cId ]
 instance FromJSON (ToFrontendErrorData 'EC_404__node_context_not_found) where
@@ -445,6 +481,25 @@ 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{..}
+
+instance ToJSON (ToFrontendErrorData 'EC_403__node_move_error) where
+  toJSON FE_node_move_error{..} =
+    object [ "source_id" .= toJSON nme_source_id, "target_id" .= toJSON nme_target_id, "reason" .= toJSON nme_reason ]
+instance FromJSON (ToFrontendErrorData 'EC_403__node_move_error) where
+  parseJSON = withObject "FE_node_move_error" $ \o -> do
+    nme_source_id <- o .: "source_id"
+    nme_target_id <- o .: "target_id"
+    nme_reason  <- o .: "reason"
+    pure FE_node_move_error{..}
+
 --
 -- validation errors
 --
@@ -455,6 +510,16 @@ instance FromJSON (ToFrontendErrorData 'EC_400__validation_error) where
   parseJSON (String txt) = pure $ FE_validation_error txt
   parseJSON ty           = typeMismatch "FE_validation_error" ty
 
+--
+-- policy check errors
+--
+
+instance ToJSON (ToFrontendErrorData 'EC_403__policy_check_error) where
+  toJSON (FE_policy_check_error val) = toJSON val
+instance FromJSON (ToFrontendErrorData 'EC_403__policy_check_error) where
+  parseJSON (String txt) = pure $ FE_policy_check_error txt
+  parseJSON ty           = typeMismatch "FE_policy_check_error" ty
+
 --
 -- authentication errors
 --
@@ -616,6 +681,9 @@ instance FromJSON FrontendError where
       EC_400__node_lookup_failed_user_too_many_roots -> do
         (fe_data :: ToFrontendErrorData 'EC_400__node_lookup_failed_user_too_many_roots) <- o .: "data"
         pure FrontendError{..}
+      EC_404__node_lookup_failed_user_no_folder -> do
+        (fe_data :: ToFrontendErrorData 'EC_404__node_lookup_failed_user_no_folder) <- o .: "data"
+        pure FrontendError{..}
       EC_500__node_not_implemented_yet -> do
         (fe_data :: ToFrontendErrorData 'EC_500__node_not_implemented_yet) <- o .: "data"
         pure FrontendError{..}
@@ -640,12 +708,23 @@ 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{..}
+      EC_403__node_move_error -> do
+        (fe_data :: ToFrontendErrorData 'EC_403__node_move_error) <- o .: "data"
+        pure FrontendError{..}
 
       -- validation error
       EC_400__validation_error -> do
         (fe_data :: ToFrontendErrorData 'EC_400__validation_error) <- o .: "data"
         pure FrontendError{..}
 
+      -- policy check error
+      EC_403__policy_check_error -> do
+        (fe_data :: ToFrontendErrorData 'EC_403__policy_check_error) <- o .: "data"
+        pure FrontendError{..}
+
       -- authentication errors
       EC_403__login_failed_error -> do
         (fe_data :: ToFrontendErrorData 'EC_403__login_failed_error) <- o .: "data"

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

@@ -23,6 +23,7 @@ data BackendErrorCode
   | EC_400__node_lookup_failed_user_too_many_roots
   | EC_404__node_lookup_failed_user_not_found
   | EC_404__node_lookup_failed_username_not_found
+  | EC_404__node_lookup_failed_user_no_folder
   | EC_404__node_corpus_not_found
   | EC_500__node_not_implemented_yet
   | EC_404__node_context_not_found
@@ -32,8 +33,12 @@ 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
+  | EC_403__node_move_error
   -- validation errors
   | EC_400__validation_error
+  -- policy check errors
+  | EC_403__policy_check_error
   -- authentication errors
   | EC_403__login_failed_error
   | EC_403__login_failed_invalid_username_or_password

src/Gargantext/API/GraphQL.hs

@@ -124,7 +124,7 @@ rootResolver authenticatedUser policyManager =
                                   , update_user_epo_api_user = GQLUser.updateUserEPOAPIUser
                                   , update_user_epo_api_token = GQLUser.updateUserEPOAPIToken
                                   , delete_team_membership = GQLTeam.deleteTeamMembership
-                                  , update_node_context_category = GQLCTX.updateNodeContextCategory }
+                                  , update_node_context_category = GQLCTX.updateNodeContextCategory authenticatedUser policyManager }
     }
 
 -- | Main GraphQL "app".

src/Gargantext/API/GraphQL/Context.hs

@@ -23,9 +23,12 @@ import Data.Morpheus.Types
   , QUERY
   )
 import Data.Text (pack, unpack)
-import qualified Data.Text as Text
+import Data.Text qualified as Text
 import Data.Time.Format.ISO8601 (iso8601Show)
+import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
+import Gargantext.API.Auth.PolicyCheck ( nodeWriteChecks, AccessPolicyManager )
 import Gargantext.API.Errors.Types ( BackendInternalError )
+import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
 import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument )
@@ -219,8 +222,11 @@ toHyperdataRowDocumentGQL hyperdata =
     HyperdataRowContact { } -> Nothing
 
 updateNodeContextCategory :: (CmdCommon env)
-                          => NodeContextCategoryMArgs -> GqlM' e env [Int]
-updateNodeContextCategory NodeContextCategoryMArgs { context_id, node_id, category } = do
-  _ <- lift $ DNC.updateNodeContextCategory (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id) category
-
+                          => AuthenticatedUser
+                          -> AccessPolicyManager
+                          -> NodeContextCategoryMArgs
+                          -> GqlM' e env [Int]
+updateNodeContextCategory autUser mgr NodeContextCategoryMArgs { context_id, node_id, category } =
+  withPolicy autUser mgr (nodeWriteChecks $ UnsafeMkNodeId node_id) $ do
+    void $ lift $ DNC.updateNodeContextCategory (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id) category
     pure [1]

src/Gargantext/API/GraphQL/Node.hs

@@ -18,7 +18,7 @@ import Data.Aeson ( Result(..), Value(..) )
 import Data.Aeson.KeyMap qualified as KM
 import Data.Morpheus.Types ( GQLType )
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
-import Gargantext.API.Auth.PolicyCheck ( nodeChecks, AccessPolicyManager )
+import Gargantext.API.Auth.PolicyCheck ( nodeReadChecks, AccessPolicyManager )
 import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
 import Gargantext.API.GraphQL.Types ( GqlM )
 import Gargantext.Core ( HasDBid(lookupDBid) )
@@ -63,7 +63,7 @@ resolveNodes
   -> NodeArgs
   -> GqlM e env [Node]
 resolveNodes autUser mgr NodeArgs { node_id } =
-  withPolicy autUser mgr (nodeChecks $ NN.UnsafeMkNodeId node_id) $ dbNodes node_id
+  withPolicy autUser mgr (nodeReadChecks $ NN.UnsafeMkNodeId node_id) $ dbNodes node_id
 
 resolveNodesCorpus
   :: (CmdCommon env)

src/Gargantext/API/GraphQL/PolicyCheck.hs

@@ -7,20 +7,22 @@ import Control.Monad.Except (MonadError(..), MonadTrans(..))
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
 import Gargantext.API.Auth.PolicyCheck ( BoolExpr, AccessCheck, AccessPolicyManager(..), AccessResult(..))
 import Gargantext.API.Errors.Types ( BackendInternalError(..) )
-import Gargantext.API.GraphQL.Types (GqlM)
 import Gargantext.Core.Config (HasConfig)
 import Gargantext.Database.Prelude (HasConnectionPool)
+import Data.Morpheus.Types (ResolverO)
+import Data.Morpheus.App.Internal.Resolving (LiftOperation)
+import Gargantext.API.Prelude (GargM)
 
-withPolicy :: (HasConnectionPool env, HasConfig env)
+withPolicy :: (HasConnectionPool env, HasConfig env, LiftOperation op)
            => AuthenticatedUser
            -> AccessPolicyManager
            -> BoolExpr AccessCheck
-           -> GqlM e env a
-           -> GqlM e env a
+           -> ResolverO op e (GargM env BackendInternalError) a
+           -> ResolverO op e (GargM env BackendInternalError) a
 withPolicy ur mgr checks m = case mgr of
   AccessPolicyManager{runAccessPolicy} -> do
     res <- lift $ runAccessPolicy ur checks
     case res of
       Allow     -> m
-      Deny err  -> lift $ throwError $ InternalServerError $ err
+      Deny err  -> lift $ throwError $ AccessPolicyError err
 

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

@@ -15,8 +15,8 @@ Portability : POSIX
 module Gargantext.API.GraphQL.TreeFirstLevel where
 
 import Data.Morpheus.Types (GQLType)
-import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
-import Gargantext.API.Auth.PolicyCheck (AccessPolicyManager, nodeChecks)
+import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(..) )
+import Gargantext.API.Auth.PolicyCheck (AccessPolicyManager, nodeReadChecks)
 import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
 import Gargantext.API.GraphQL.Types ( GqlM )
 import Gargantext.Core (fromDBid)
@@ -71,13 +71,13 @@ resolveTree :: (CmdCommon env)
             -> TreeArgs
             -> GqlM e env (TreeFirstLevel (GqlM e env))
 resolveTree autUser mgr TreeArgs { root_id } =
-  withPolicy autUser mgr (nodeChecks $ UnsafeMkNodeId root_id) $ dbTree root_id
+  withPolicy autUser mgr (nodeReadChecks $ UnsafeMkNodeId root_id) $ dbTree (_auth_user_id autUser) root_id
 
 dbTree :: (CmdCommon env) =>
-          Int -> GqlM e env (TreeFirstLevel (GqlM e env))
-dbTree root_id = do
+          NN.UserId -> Int -> GqlM e env (TreeFirstLevel (GqlM e env))
+dbTree loggedInUserId root_id = do
   let rId = UnsafeMkNodeId root_id
-  t <- lift $ T.tree T.TreeFirstLevel rId allNodeTypes
+  t <- lift $ T.tree loggedInUserId T.TreeFirstLevel rId allNodeTypes
   n <- lift $ getNode $ UnsafeMkNodeId root_id
   let pId = toParentId n
   pure $ toTree rId pId t

src/Gargantext/API/GraphQL/User.hs

@@ -67,7 +67,7 @@ resolveUsers
   -> GqlM e env [User (GqlM e env)]
 resolveUsers autUser mgr UserArgs { user_id } = do
   -- We are given the /node id/ of the logged-in user.
-  withPolicy autUser mgr (nodeChecks $ UnsafeMkNodeId user_id) $ dbUsers user_id
+  withPolicy autUser mgr (nodeReadChecks $ UnsafeMkNodeId user_id) $ dbUsers user_id
 
 -- | Inner function to fetch the user from DB.
 dbUsers :: (CmdCommon env)

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.Types (PathId(..), AuthenticatedUser (..), auth_node_id)
+import Gargantext.API.Admin.Auth (withNamedAccess, withNamedPolicyT, withPolicy, 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 ( nodeReadChecks, nodeWriteChecks, moveChecks, AccessPolicyManager )
 import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Metrics
 import Gargantext.API.Ngrams.Types (TabType(..))
@@ -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
@@ -155,10 +156,7 @@ pairs cId = Named.Pairs $ do
 pairWith :: IsGargServer err env m => CorpusId -> Named.PairWith (AsServerT m)
 pairWith cId = Named.PairWith $ \ aId lId -> do
   r <- pairing cId aId lId
-  _ <- insertNodeNode [ NodeNode { _nn_node1_id = cId
-                                 , _nn_node2_id = aId
-                                 , _nn_score = Nothing
-                                 , _nn_category = Nothing }]
+  pairCorpusWithAnnuaire (SourceId cId) (TargetId aId)
   pure r
 
 
@@ -168,9 +166,9 @@ treeAPI :: IsGargServer env BackendInternalError m
         -> AccessPolicyManager
         -> Named.NodeTreeAPI (AsServerT m)
 treeAPI authenticatedUser nodeId mgr =
-  withNamedPolicyT authenticatedUser (nodeChecks nodeId) (Named.NodeTreeAPI
-    { nodeTreeEp   = tree TreeAdvanced nodeId
-    , firstLevelEp = tree TreeFirstLevel nodeId
+  withNamedPolicyT authenticatedUser (nodeReadChecks nodeId) (Named.NodeTreeAPI
+    { nodeTreeEp   = tree (_auth_user_id authenticatedUser) TreeAdvanced nodeId
+    , firstLevelEp = tree (_auth_user_id authenticatedUser) TreeFirstLevel nodeId
     }) mgr
 
 treeFlatAPI :: IsGargServer env err m
@@ -179,12 +177,12 @@ treeFlatAPI :: IsGargServer env err m
             -> Named.TreeFlatAPI (AsServerT m)
 treeFlatAPI authenticatedUser rootId =
   withNamedAccess authenticatedUser (PathNode rootId) $
-    Named.TreeFlatAPI { getNodesEp = tree_flat rootId }
+    Named.TreeFlatAPI { getNodesEp = tree_flat (_auth_user_id 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
@@ -192,30 +190,31 @@ 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
-                -> Named.NodeAPIEndpoint HyperdataAnnuaire (AsServerT (GargM Env BackendInternalError))
-annuaireNodeAPI authenticatedUser = Named.NodeAPIEndpoint $ \targetNode ->
+                -> Named.AnnuaireAPIEndpoint (AsServerT (GargM Env BackendInternalError))
+annuaireNodeAPI authenticatedUser = Named.AnnuaireAPIEndpoint $ \targetNode ->
   withNamedAccess authenticatedUser (PathNode targetNode) (concreteAPI targetNode)
   where
     concreteAPI = genericNodeAPI' (Proxy :: Proxy HyperdataAnnuaire) authenticatedUser
 
 corpusNodeAPI :: AuthenticatedUser
-              -> Named.NodeAPIEndpoint HyperdataCorpus (AsServerT (GargM Env BackendInternalError))
-corpusNodeAPI authenticatedUser = Named.NodeAPIEndpoint $ \targetNode ->
+              -> Named.CorpusAPIEndpoint (AsServerT (GargM Env BackendInternalError))
+corpusNodeAPI authenticatedUser = Named.CorpusAPIEndpoint $ \targetNode ->
   withNamedAccess authenticatedUser (PathNode targetNode) (concreteAPI targetNode)
   where
     concreteAPI = genericNodeAPI' (Proxy :: Proxy HyperdataCorpus) authenticatedUser
 
 ------------------------------------------------------------------------
 nodeAPI :: AuthenticatedUser
-        -> Named.NodeAPIEndpoint HyperdataAny (AsServerT (GargM Env BackendInternalError))
+        -> Named.NodeAPIEndpoint (AsServerT (GargM Env BackendInternalError))
 nodeAPI authenticatedUser = Named.NodeAPIEndpoint $ \targetNode ->
   withNamedAccess authenticatedUser (PathNode targetNode) (concreteAPI targetNode)
   where
@@ -228,15 +227,20 @@ genericNodeAPI' :: forall a proxy. ( HyperdataC a )
                 -> NodeId
                 -> Named.NodeAPI a (AsServerT (GargM Env BackendInternalError))
 genericNodeAPI' _ authenticatedUser targetNode =  Named.NodeAPI
-  { nodeNodeAPI        = withNamedPolicyT authenticatedUser (nodeChecks targetNode) $
+  { nodeNodeAPI        = withNamedPolicyT authenticatedUser (nodeReadChecks targetNode) $
                            Named.NodeNodeAPI $ getNodeWith targetNode (Proxy :: Proxy a)
-  , renameAPI          = Named.RenameAPI   $ rename targetNode
-  , postNodeAPI        = Named.PostNodeAPI $ postNode authenticatedUser targetNode
-  , postNodeAsyncAPI   = postNodeAsyncAPI authenticatedUser targetNode
+  , renameAPI          = withNamedPolicyT authenticatedUser (nodeWriteChecks targetNode) $
+                           Named.RenameAPI   $ rename loggedInUserId targetNode
+  , postNodeAPI        = withNamedPolicyT authenticatedUser (nodeWriteChecks targetNode) $
+                           Named.PostNodeAPI $ postNode authenticatedUser targetNode
+  , postNodeAsyncAPI   = withNamedPolicyT authenticatedUser (nodeWriteChecks targetNode) $
+                           postNodeAsyncAPI authenticatedUser targetNode
   , frameCalcUploadAPI = FrameCalcUpload.api authenticatedUser targetNode
   , putEp              = putNode targetNode
-  , updateAPI          = Update.api targetNode
-  , deleteEp           = Action.deleteNode userRootId targetNode
+  , updateAPI          = withNamedPolicyT authenticatedUser (nodeWriteChecks targetNode) $
+                           Update.api targetNode
+  , deleteEp           = withPolicy authenticatedUser (nodeWriteChecks targetNode) $
+                           Action.deleteNode userRootId targetNode
   , childrenAPI        = Named.ChildrenAPI $ getChildren targetNode (Proxy :: Proxy a)
   , tableAPI           = tableApi targetNode
   , tableNgramsAPI     = apiNgramsTableCorpus targetNode
@@ -254,7 +258,9 @@ genericNodeAPI' _ authenticatedUser targetNode =  Named.NodeAPI
   , pieAPI             = pieApi targetNode
   , treeAPI            = treeApi targetNode
   , phyloAPI           = phyloAPI targetNode
-  , moveAPI            = Named.MoveAPI $ moveNode userRootId 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
@@ -263,3 +269,4 @@ genericNodeAPI' _ authenticatedUser targetNode =  Named.NodeAPI
   }
   where
     userRootId     = RootId $ authenticatedUser ^. auth_node_id
+    loggedInUserId = authenticatedUser ^. auth_user_id

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

@@ -67,13 +67,13 @@ import Servant
 
 data NodeAPI a mode = NodeAPI
   { nodeNodeAPI        :: mode :- PolicyChecked (NamedRoutes (NodeNodeAPI a))
-  , renameAPI          :: mode :- "rename" :> NamedRoutes RenameAPI
-  , postNodeAPI        :: mode :- NamedRoutes PostNodeAPI -- TODO move to children POST
-  , postNodeAsyncAPI   :: mode :- NamedRoutes PostNodeAsyncAPI
+  , renameAPI          :: mode :- "rename" :> PolicyChecked (NamedRoutes RenameAPI)
+  , postNodeAPI        :: mode :- PolicyChecked (NamedRoutes PostNodeAPI) -- TODO move to children POST
+  , postNodeAsyncAPI   :: mode :- PolicyChecked (NamedRoutes PostNodeAsyncAPI)
   , frameCalcUploadAPI :: mode :- NamedRoutes FrameCalcAPI
   , putEp              :: mode :- ReqBody '[JSON] a :> Put '[JSON] Int
-  , updateAPI          :: mode :- "update" :> NamedRoutes UpdateAPI
-  , deleteEp           :: mode :- Delete '[JSON] Int
+  , updateAPI          :: mode :- "update" :> PolicyChecked (NamedRoutes UpdateAPI)
+  , deleteEp           :: mode :- PolicyChecked (Delete '[JSON] Int)
   , childrenAPI        :: mode :- "children"  :> NamedRoutes (ChildrenAPI a)
   , tableAPI           :: mode :- "table" :> NamedRoutes TableAPI
   , tableNgramsAPI     :: mode :- "ngrams" :> NamedRoutes TableNgramsAPI
@@ -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
 
 

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

@@ -20,14 +20,13 @@ module Gargantext.API.Routes.Named.Private (
   , GargAdminAPI(..)
   , NodeAPIEndpoint(..)
   , MembersAPI(..)
-  , IsGenericNodeRoute(..)
+  , AnnuaireAPIEndpoint(..)
+  , CorpusAPIEndpoint(..)
   ) where
 
 
-import Data.Kind
 import Data.Text (Text)
 import GHC.Generics
-import GHC.TypeLits
 import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Auth.PolicyCheck
 import Gargantext.API.Routes.Named.Contact
@@ -58,11 +57,11 @@ newtype GargPrivateAPI mode = GargPrivateAPI
 
 data GargPrivateAPI' mode = GargPrivateAPI'
   { gargAdminAPI :: mode :- NamedRoutes GargAdminAPI
-  , nodeEp       :: mode :- NamedRoutes (NodeAPIEndpoint HyperdataAny)
+  , nodeEp       :: mode :- NamedRoutes NodeAPIEndpoint
   , contextEp    :: mode :- "context"  :> Summary "Context endpoint"
                                        :> Capture "node_id" ContextId
                                        :> NamedRoutes (ContextAPI HyperdataAny)
-  , corpusNodeAPI :: mode :- NamedRoutes (NodeAPIEndpoint HyperdataCorpus)
+  , corpusNodeAPI :: mode :- NamedRoutes CorpusAPIEndpoint
   , corpusNodeNodeAPI :: mode :- "corpus" :> Summary "Corpus endpoint"
                                           :> Capture "node1_id" NodeId
                                           :> "document"
@@ -70,7 +69,7 @@ data GargPrivateAPI' mode = GargPrivateAPI'
                                           :> NamedRoutes (NodeNodeAPI HyperdataAny)
   , corpusExportAPI :: mode :- "corpus" :> Capture "node_id" CorpusId
                                         :> NamedRoutes CorpusExportAPI
-  , annuaireEp :: mode :- NamedRoutes (NodeAPIEndpoint HyperdataAnnuaire)
+  , annuaireEp :: mode :- NamedRoutes AnnuaireAPIEndpoint
   , contactAPI :: mode :- "annuaire" :> Summary "Contact endpoint"
                                      :> Capture "annuaire_id" NodeId
                                      :> NamedRoutes ContactAPI
@@ -111,31 +110,29 @@ data GargAdminAPI mode = GargAdminAPI
                                      :> NamedRoutes NodesAPI
   } deriving Generic
 
-class IsGenericNodeRoute a where
-  type family TyToSubPath (a :: Type) :: Symbol
-  type family TyToCapture (a :: Type) :: Symbol
-  type family TyToSummary (a :: Type) :: Type
-
-instance IsGenericNodeRoute HyperdataAny where
-  type instance TyToSubPath HyperdataAny = "node"
-  type instance TyToCapture HyperdataAny = "node_id"
-  type instance TyToSummary HyperdataAny = Summary "Node endpoint"
-
-instance IsGenericNodeRoute HyperdataCorpus where
-  type instance TyToSubPath HyperdataCorpus = "corpus"
-  type instance TyToCapture HyperdataCorpus = "corpus_id"
-  type instance TyToSummary HyperdataCorpus = Summary "Corpus endpoint"
-
-instance IsGenericNodeRoute HyperdataAnnuaire where
-  type instance TyToSubPath HyperdataAnnuaire = "annuaire"
-  type instance TyToCapture HyperdataAnnuaire = "annuaire_id"
-  type instance TyToSummary HyperdataAnnuaire = Summary "Annuaire endpoint"
-
-newtype NodeAPIEndpoint a mode = NodeAPIEndpoint
-  { nodeEndpointAPI :: mode :- TyToSubPath a
-                            :> TyToSummary a
-                            :> Capture (TyToCapture a) NodeId
-                            :> NamedRoutes (NodeAPI a)
+-- | The 'Node' API, unlike the ones for annuaire and corpus,
+-- have other endpoints which should not be shared in the hierarchy,
+-- like the /freeze/ one. Similarly, a 'Corpus' API will have a
+-- '/publish' endpoint that doesn't generalise to everything.
+data NodeAPIEndpoint mode = NodeAPIEndpoint
+  { nodeEndpointAPI :: mode :- "node"
+                            :> Summary "Node endpoint"
+                            :> Capture "node_id" NodeId
+                            :> NamedRoutes (NodeAPI HyperdataAny)
+  } deriving Generic
+
+newtype AnnuaireAPIEndpoint mode = AnnuaireAPIEndpoint
+  { annuaireEndpointAPI :: mode :- "annuaire"
+                        :> Summary "Annuaire endpoint"
+                        :> Capture "annuaire_id" NodeId
+                        :> NamedRoutes (NodeAPI HyperdataAnnuaire)
+  } deriving Generic
+
+newtype CorpusAPIEndpoint mode = CorpusAPIEndpoint
+  { corpusEndpointAPI :: mode :- "corpus"
+                      :> Summary "Corpus endpoint"
+                      :> Capture "corpus_id" NodeId
+                      :> NamedRoutes (NodeAPI HyperdataCorpus)
   } deriving Generic
 
 newtype MembersAPI mode = MembersAPI

src/Gargantext/Core/Text/List/Social/Find.hs

@@ -23,14 +23,17 @@ import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Tree
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Prelude
+import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Schema.Node
 
 ------------------------------------------------------------------------
 findListsId :: (HasNodeError err, HasTreeError err)
             => User -> NodeMode -> DBCmd err [NodeId]
 findListsId u mode = do
   rootId <- getRootId u
+  userNode <- getNode rootId
   ns <- map (view dt_nodeId) <$> filter ((== toDBid NodeList) . (view dt_typeId))
-                             <$> findNodes' rootId mode
+                             <$> findNodes' (_node_user_id userNode) rootId mode
   pure ns
 
 
@@ -39,17 +42,19 @@ findListsId u mode = do
 -- | Shared is for Shared with me but I am not the owner of it
 -- | Private is for all Lists I have created
 findNodes' :: (HasTreeError err, HasNodeError err)
-          => RootId
+          => UserId
+          -> RootId
           -> NodeMode
           -> DBCmd err [DbTreeNode]
-findNodes' r Private = do
-  pv <- (findNodes r Private $ [NodeFolderPrivate]          <> commonNodes)
-  sh <- (findNodes' r Shared)
+findNodes' loggedInUserId r Private = do
+  pv <- (findNodes loggedInUserId r Private $ [NodeFolderPrivate]          <> commonNodes)
+  sh <- (findNodes' loggedInUserId r Shared)
   pure $ pv <> sh
-findNodes' r Shared       = findNodes r Shared  $ [NodeFolderShared, NodeTeam] <> commonNodes
-findNodes' r SharedDirect = findNodes r Shared  $ [NodeFolderShared, NodeTeam] <> commonNodes
-findNodes' r Public       = findNodes r Public  $ [NodeFolderPublic ]          <> commonNodes
-findNodes' r PublicDirect = findNodes r Public  $ [NodeFolderPublic ]          <> commonNodes
+findNodes' loggedInUserId r Shared       = findNodes loggedInUserId r Shared  $ [NodeFolderShared, NodeTeam] <> commonNodes
+findNodes' loggedInUserId r SharedDirect = findNodes loggedInUserId r Shared  $ [NodeFolderShared, NodeTeam] <> commonNodes
+findNodes' loggedInUserId r Public       = findNodes loggedInUserId r Public  $ [NodeFolderPublic ]          <> commonNodes
+findNodes' loggedInUserId r PublicDirect = findNodes loggedInUserId r Public  $ [NodeFolderPublic ]          <> commonNodes
+findNodes' _loggedInUserId _ Published    = pure [] -- FIXME(adn) What's the right behaviour here?
 
 commonNodes:: [NodeType]
 commonNodes = [NodeFolder, NodeCorpus, NodeList, NodeFolderShared, NodeTeam]

src/Gargantext/Core/Types/Main.hs

@@ -38,6 +38,9 @@ data NodeTree = NodeTree { _nt_name      :: Text
                          , _nt_id        :: NodeId
                          } deriving (Show, Read, Generic)
 
+instance Eq NodeTree where
+  (==) d1 d2 = _nt_id d1 == _nt_id d2
+
 $(deriveJSON (unPrefix "_nt_") ''NodeTree)
 instance ToSchema NodeTree where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nt_")

src/Gargantext/Database.hs

@@ -18,41 +18,10 @@ https://dl.gargantext.org/2023-06-09-gargantext-db-graph.svg
 -}
 
 
-module Gargantext.Database ( module Gargantext.Database.Prelude
-                           , module Gargantext.Database.Schema.NodeNode
-                           , insertDB
-                        -- , module Gargantext.Database.Bashql
-                           )
-    where
+module Gargantext.Database
+  ( module Gargantext.Database.Prelude
+  , module Gargantext.Database.Query.Table.NodeNode
+  ) where
 
-import Gargantext.Prelude
-import Gargantext.Database.Prelude (DBCmd) -- (connectGargandb)
-
--- import Gargantext.Database.Schema.Node
--- import Gargantext.Database.Query.Table.Node
-
-import Gargantext.Database.Schema.NodeNode -- (NodeNode(..))
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.NodeNode
-
-
-class InsertDB a where
-  insertDB :: a -> DBCmd err Int
-
-{-
-class DeleteDB a where
-  deleteDB :: a -> DBCmd err Int
--}
-
-instance InsertDB [NodeNode] where
-  insertDB = insertNodeNode
-
-
-{-
-instance InsertDB [Node a] where
-  insertDB = insertNodes'
-
-instance InsertDB [NodeNodeNgram] where
-  insertDB = ...
-
-
--}

src/Gargantext/Database/Action/Flow/Pairing.hs

@@ -71,7 +71,7 @@ pairing a c l' = do
     Nothing -> defaultList c
     Just l'' -> pure l''
   dataPaired <- dataPairing a (c,l,Authors)
-  _ <- insertNodeNode [ NodeNode c a Nothing Nothing]
+  pairCorpusWithAnnuaire (SourceId c) (TargetId a)
   insertNodeContext_NodeContext $ prepareInsert c a dataPaired
 
 

src/Gargantext/Database/Action/Share.hs

@@ -27,10 +27,8 @@ import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny(..))
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Query.Table.Node (getNode, getNodesWith)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError, errorWith)
-import Gargantext.Database.Query.Table.NodeNode (deleteNodeNode, queryNodeNodeTable)
 import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Query.Tree.Root (getRootId)
-import Gargantext.Database.Prelude (Cmd, runOpaQuery)
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
 import Gargantext.Utils.Tuple (uncurryMaybe)
@@ -42,12 +40,9 @@ publicNodeTypes :: [NodeType]
 publicNodeTypes = [NodeDashboard, NodeGraph, NodePhylo, NodeFile]
 
 ------------------------------------------------------------------------
-data ShareNodeWith = ShareNodeWith_User { snwu_nodetype :: NodeType
-                                        , snwu_user     :: User
-                                        }
-                   | ShareNodeWith_Node { snwn_nodetype :: NodeType
-                                        , snwn_node_id  :: NodeId
-                                        }
+data ShareNodeWith = ShareNodeWith_User !NodeType !User
+                   | ShareNodeWith_Node !NodeType !NodeId
+
 ------------------------------------------------------------------------
 deleteMemberShip :: HasNodeError err => [(SharedFolderId, TeamNodeId)] -> Cmd err [Int]
 deleteMemberShip xs = mapM (\(s,t) -> deleteNodeNode s t) xs
@@ -94,6 +89,8 @@ nodeNode_node_User = proc () -> do
 shareNodeWith :: HasNodeError err
               => ShareNodeWith
               -> NodeId
+              -- ^ The target node we would like to share, it has
+              -- to be a 'NodeFolderShared'.
               -> Cmd err Int
 shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
   nodeToCheck <- getNode   n
@@ -105,14 +102,10 @@ shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
         then errorWith "[G.D.A.S.shareNodeWith] Can share to others only"
         else do
           folderSharedId  <- getFolderId u NodeFolderShared
-          ret <- insertDB ([NodeNode { _nn_node1_id = folderSharedId
-                                     , _nn_node2_id = n
-                                     , _nn_score = Nothing
-                                     , _nn_category = Nothing }]:: [NodeNode])
+          ret <- shareNode (SourceId folderSharedId) (TargetId n)
           void $ CE.ce_notify $ CE.UpdateTreeFirstLevel folderSharedId
           void $ CE.ce_notify $ CE.UpdateTreeFirstLevel n
-
-          return ret
+          pure ret
 
 shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
   nodeToCheck <- getNode n
@@ -123,14 +116,10 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
       folderToCheck <- getNode nId
       if hasNodeType folderToCheck NodeFolderPublic
         then do
-          ret <- insertDB ([NodeNode { _nn_node1_id = nId
-                                     , _nn_node2_id = n
-                                     , _nn_score = Nothing
-                                     , _nn_category = Nothing }] :: [NodeNode])
+          ret <- shareNode (SourceId nId) (TargetId n)
           void $ CE.ce_notify $ CE.UpdateTreeFirstLevel nId
           void $ CE.ce_notify $ CE.UpdateTreeFirstLevel n
-
-          return ret
+          pure ret
         else errorWith "[G.D.A.S.shareNodeWith] Can share NodeWith NodeFolderPublic only"
 
 shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType"

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

@@ -57,6 +57,7 @@ data NodeLookupError
   | UserDoesNotExist     UserId
   | UserNameDoesNotExist Username
   | UserHasTooManyRoots UserId [NodeId]
+  | UserFolderDoesNotExist UserId
   deriving (Show, Eq, Generic)
 
 instance ToJSON NodeLookupError
@@ -68,6 +69,7 @@ renderNodeLookupFailed = \case
   UserDoesNotExist uid -> "user with id " <> T.pack (show uid) <> " couldn't be found."
   UserNameDoesNotExist uname -> "user with username '" <> uname <> "' couldn't be found."
   UserHasTooManyRoots uid roots -> "user with id " <> T.pack (show uid) <> " has too many roots: [" <> T.intercalate "," (map (T.pack . show) roots)
+  UserFolderDoesNotExist uid -> "no requested folder was found for user with id " <> T.pack (show uid)
 
 ------------------------------------------------------------------------
 data NodeError = NoListFound ListId
@@ -81,6 +83,8 @@ data NodeError = NoListFound ListId
                | NodeError SomeException
                -- Left for backward compatibility, but we should remove them.
                | DoesNotExist NodeId
+               | NodeIsReadOnly NodeId T.Text
+               | MoveError NodeId NodeId T.Text
 
 instance Prelude.Show NodeError
   where
@@ -95,6 +99,8 @@ 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
+    show (MoveError s t reason) = "Moving " <> show s <> " to " <> show t <> " failed: " <> T.unpack reason
 
 instance ToJSON NodeError where
   toJSON (DoesNotExist n) =
@@ -115,6 +121,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

+{-# LANGUAGE LambdaCase #-}
 {-|
 Module      : Gargantext.Database.Node.Update
 Description : Update Node in Database (Postgres)
@@ -12,13 +13,18 @@ Portability : POSIX
 module Gargantext.Database.Query.Table.Node.Update (Update(..), update)
   where
 
-import Data.Text qualified as DT
 import Database.PostgreSQL.Simple ( Only(Only) )
+import Data.Text qualified as DT
+import Gargantext.Core (fromDBid)
 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.Admin.Types.Node
 import Gargantext.Database.Prelude (Cmd, DBCmd, runPGSQuery)
+import Gargantext.Database.Query.Table.Node.Error
+import Gargantext.Database.Query.Table.Node (getParentId, getNode, getUserRootPublicNode)
+import Gargantext.Database.Query.Table.NodeNode (NodePublishPolicy(..), isNodeReadOnly, SourceId (..), TargetId(..), publishNode, unpublishNode)
+import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
 
 -- import Data.ByteString
@@ -38,22 +44,74 @@ 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
+                   check_publish_source_type_allowed (SourceId sourceId) (TargetId targetId) (fromDBid $ _node_typename sourceNode)
+                   -- See issue #400, by default we publish in a \"strict\"
+                   -- way by disallowing further edits on the original node,
+                   -- including edits from the owner itself!
+                   publishNode NPP_publish_no_edits_allowed (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
+
+-- Issue #400, for now we support only publishing corpus nodes
+check_publish_source_type_allowed :: HasNodeError err => SourceId -> TargetId -> NodeType -> Cmd err ()
+check_publish_source_type_allowed (SourceId nId) (TargetId tId) = \case
+  NodeCorpus   -> pure ()
+  NodeCorpusV3 -> pure ()
+  _            -> nodeError (MoveError nId tId "At the moment only corpus nodes can be published.")
 
 -- TODO-ACCESS
 update' :: Update -> DBCmd err [Int]

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

@@ -10,17 +10,22 @@ Portability : POSIX
 -}
 
 module Gargantext.Database.Query.Table.Node.User
+  ( getNodeUser
+  , getUserByName
+  )
   where
 
-import Gargantext.Core ( HasDBid )
-import Gargantext.Core.Types (Name)
-import Gargantext.Database.Admin.Types.Hyperdata.User ( HyperdataUser(..), defaultHyperdataUser )
-import Gargantext.Database.Admin.Types.Node (Node, NodeId(..), UserId, NodeType(..), pgNodeId)
+import Data.Text qualified as T
+import Gargantext.Database.Admin.Types.Hyperdata.User ( HyperdataUser(..) )
+import Gargantext.Database.Admin.Types.Node (Node, NodeId(..), pgNodeId)
 import Gargantext.Database.Prelude (DBCmd, runOpaQuery)
-import Gargantext.Database.Query.Table.Node ( node, selectNode )
-import Gargantext.Database.Schema.Node ( NodeWrite ) -- (Node(..))
+import Gargantext.Database.Query.Table.Node ( selectNode )
 import Gargantext.Prelude
 import Opaleye (limit)
+import Gargantext.Database.Schema.Node (queryNodeTable, node_name)
+import Opaleye.Operators
+import Opaleye.SqlTypes
+import Gargantext.Database.Query.Table.Node.Error
 
 
 getNodeUser :: NodeId -> DBCmd err (Node HyperdataUser)
@@ -28,9 +33,12 @@ getNodeUser nId = do
     fromMaybe (panicTrace $ "Node does not exist: " <> (show nId)) . headMay
              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 
-nodeUserW :: HasDBid NodeType => Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
-nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
-  where
-    name = maybe "User" identity maybeName
-    user = maybe defaultHyperdataUser identity maybeHyperdata
-
+getUserByName :: HasNodeError err => T.Text -> DBCmd err (Node HyperdataUser)
+getUserByName username = do
+  result <- runOpaQuery $ do
+    n <- queryNodeTable
+    where_ $ (n ^. node_name .== sqlStrictText username)
+    pure n
+  case result of
+    [n]  -> pure n
+    _    -> nodeError $ NodeLookupFailed $ UserNameDoesNotExist username

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

@@ -14,33 +14,53 @@ commentary with @some markup@.
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE LambdaCase             #-}
 {-# LANGUAGE QuasiQuotes            #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
 
 module Gargantext.Database.Query.Table.NodeNode
   ( module Gargantext.Database.Schema.NodeNode
-  , deleteNodeNode
+
+  -- * Types
+  , SourceId(..)
+  , TargetId(..)
+  , OwnerId(..)
+
+  -- * Queries
   , getNodeNode
-  , insertNodeNode
-  , nodeNodesCategory
-  , nodeNodesScore
-  , queryNodeNodeTable
+  , getNodeNode2
+  , isNodeReadOnly
   , selectDocNodes
   , selectDocs
   , selectDocsDates
   , selectPublicNodes
+  , publishedNodeIds
+
+  -- * Destructive operations
+  , deleteNodeNode
+  , nodeNodesCategory
+  , nodeNodesScore
+  , pairCorpusWithAnnuaire
+  , publishNode
+  , queryNodeNodeTable
+  , shareNode
+  , unpublishNode
+
   )
   where
 
 import Control.Arrow (returnA)
 import Control.Lens (view)
-import Data.Text (splitOn)
 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.Node
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument, hd_publication_date )
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude ( Hyperdata )
+import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (DBCmd, mkCmd, runPGSQuery, runCountOpaQuery, runOpaQuery)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Schema.Ngrams ()
 import Gargantext.Database.Schema.Node
 import Gargantext.Database.Schema.NodeNode
@@ -66,6 +86,15 @@ getNodeNode n = runOpaQuery (selectNodeNode $ pgNodeId n)
       restrict -< _nn_node1_id ns .== n'
       returnA -< ns
 
+getNodeNode2 :: NodeId -> DBCmd err (Maybe NodeNode)
+getNodeNode2 n = listToMaybe <$> runOpaQuery (selectNodeNode $ pgNodeId n)
+  where
+    selectNodeNode :: Column SqlInt4 -> Select NodeNodeRead
+    selectNodeNode n' = proc () -> do
+      ns <- queryNodeNodeTable -< ()
+      restrict -< _nn_node2_id ns .== n'
+      returnA -< ns
+
 ------------------------------------------------------------------------
 -- TODO (refactor with Children)
 {-
@@ -91,6 +120,11 @@ getNodeNodeWith pId _ maybeNodeType = runOpaQuery query
 -}
 
 ------------------------------------------------------------------------
+-- | Inserts a list of 'NodeNode', creating relationship between nodes
+-- in the database. This function is deliberately not exposed, because
+-- it's low-level and it doesn't do any business-logic check to ensure
+-- the share being created is valid. Use the other functions like
+-- 'shareNode', 'publishNode', or roll your own.
 insertNodeNode :: [NodeNode] -> DBCmd err Int
 insertNodeNode ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
                           $ Insert nodeNodeTable ns' rCount (Just DoNothing))
@@ -100,7 +134,7 @@ insertNodeNode ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
                 -> NodeNode (pgNodeId n1)
                             (pgNodeId n2)
                             (sqlDouble <$> x)
-                            (sqlInt4   <$> y)
+                            (sqlInt4 . toDBid <$> y)
               ) ns
 
 
@@ -227,10 +261,88 @@ joinInCorpus = proc () -> do
 
 
 ------------------------------------------------------------------------
+-- | Returns /all/ the public nodes, i.e. nodes which 'NodeType' is
+-- 'NodeFolderPublic'. Each user, upon creation, receives his/her personal
+-- public folder. Nodes placed inside /any/ public folder is visible into
+-- /any other/ public folder.
 selectPublicNodes :: HasDBid NodeType => (Hyperdata a, DefaultFromField SqlJsonb a)
                   => DBCmd err [(Node a, Maybe Int)]
 selectPublicNodes = runOpaQuery (queryWithType NodeFolderPublic)
 
+publishedNodeIds :: DBCmd err [(SourceId, TargetId, OwnerId)]
+publishedNodeIds =
+  map (\(owner, nn) -> (SourceId $ _nn_node2_id nn, TargetId $ _nn_node1_id nn, OwnerId owner)) <$> published_node_ids []
+
+published_node_ids :: [ NodeNodeRead -> Field SqlBool ] -> DBCmd err [(NodeId, NodeNode)]
+published_node_ids extraPreds = runOpaQuery $ do
+  n  <- queryNodeTable
+  nn <- queryNodeNodeTable
+  let isRO = ors [ (nn ^. nn_category .== sqlInt4 (toDBid $ NNC_publish ro))
+                 | ro <- [minBound .. maxBound]
+                 ]
+  where_ isRO
+  where_ $ (n ^. node_id .== nn ^. nn_node1_id)
+  where_ $ ands (map ($ nn) extraPreds)
+  pure (n ^. node_parent_id, nn)
+  where
+
+ands :: Foldable f => f (Field SqlBool) -> Field SqlBool
+ands = foldl' (.&&) (sqlBool True)
+
+-- | 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.
+isNodeReadOnly :: (HasNodeError err, HasDBid NodeType) => NodeId -> DBCmd err Bool
+isNodeReadOnly targetNodeId = do
+  targetNode <- getNode targetNodeId
+  case targetNode ^. node_typename `elem` map toDBid typesWhiteList of
+    True  -> pure True
+    False -> is_read_only_query
+  where
+    -- Certain kind of nodes are by default read-only and can in principle be visualised by other users
+    -- without harm. This would be the case for a user node which might contained published corpuses.
+    typesWhiteList :: [ NodeType ]
+    typesWhiteList = [ NodeFolderPublic ]
+
+    is_read_only_query = (== [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;
+
+      |] ( targetNodeId
+         , toDBid NodeFolderPublic
+         , toDBid (maxBound @NodePublishPolicy)
+         , targetNodeId
+         , toDBid NodeFolderPublic
+         )
+
+
 queryWithType :: HasDBid NodeType
               => NodeType
               -> O.Select (NodeRead, MaybeFields (Column SqlInt4))
@@ -245,3 +357,40 @@ node_NodeNode = proc () -> do
   nn <- optionalRestrict queryNodeNodeTable -<
     (\nn' -> (nn' ^. nn_node1_id) .== (n ^. node_id))
   returnA -< (n, view nn_node2_id <$> nn)
+
+newtype SourceId = SourceId NodeId
+  deriving (Show, Eq, Ord)
+newtype TargetId = TargetId NodeId
+  deriving (Show, Eq, Ord)
+newtype OwnerId = OwnerId NodeId
+  deriving (Show, Eq, Ord)
+
+shareNode :: SourceId -> TargetId -> DBCmd err Int
+shareNode (SourceId sourceId) (TargetId targetId) =
+  insertNodeNode [ NodeNode sourceId targetId Nothing Nothing ]
+
+-- | Publishes a node, i.e. it creates a relationship between
+-- the input node and the target public folder.
+-- /NOTE/: Even though the semantic of the relationships it
+-- source -> target, by historical reason we store this in the
+-- node_node table backwards, i.e. the public folder first as
+-- the 'node1_id', and the shared node as the target, so we
+-- honour this.
+publishNode :: NodePublishPolicy -> SourceId -> TargetId -> DBCmd err ()
+publishNode publishPolicy (SourceId sourceId) (TargetId targetId) =
+  void $ insertNodeNode [ NodeNode targetId sourceId Nothing (Just $ NNC_publish publishPolicy) ]
+
+-- /NOTE/: Even though the semantic of the relationships it
+-- source -> target, by historical reason we store this in the
+-- node_node table backwards, i.e. the public folder first as
+-- the 'node1_id', and the shared node as the target, so we
+-- honour this.
+unpublishNode :: SourceId -> TargetId -> DBCmd err ()
+unpublishNode (SourceId sourceId) (TargetId targetId) =
+  void $ deleteNodeNode targetId sourceId
+
+-- | Pair two nodes together. Typically used to pair
+-- together
+pairCorpusWithAnnuaire :: SourceId -> TargetId -> DBCmd err ()
+pairCorpusWithAnnuaire (SourceId sourceId) (TargetId targetId) =
+  void $ insertNodeNode [ NodeNode sourceId targetId Nothing Nothing ]

src/Gargantext/Database/Schema/NodeNode.hs

@@ -13,11 +13,35 @@ commentary with @some markup@.
 
 {-# LANGUAGE Arrows                 #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE LambdaCase             #-}
 {-# LANGUAGE QuasiQuotes            #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
-module Gargantext.Database.Schema.NodeNode where
+module Gargantext.Database.Schema.NodeNode (
+  -- * Opaque type synonims
+    NodeNodeRead
+  , NodeNodeWrite
+  , NodeNode
 
+  -- * Types
+  , NodeNodePoly(..)
+  , NodeNodeCategory(..)
+  , NodePublishPolicy(..)
+
+  -- * Lenses
+  , nn_node1_id
+  , nn_node2_id
+  , nn_score
+  , nn_category
+
+  -- * Prisms
+  , _NNC_publish
+
+  , nodeNodeTable
+  ) where
+
+import Control.Lens.TH
+import Gargantext.Core (HasDBid(..))
 import Gargantext.Core.Types
 import Gargantext.Database.Schema.Prelude
 import Gargantext.Prelude
@@ -40,10 +64,43 @@ type NodeNodeRead      = NodeNodePoly (Field SqlInt4)
                                       (Field SqlFloat8)
                                       (Field SqlInt4)
 
-type NodeNode = NodeNodePoly NodeId NodeId (Maybe Double) (Maybe Int)
+data NodeNodeCategory
+  = -- | Read-only/publishing relationship between nodes.
+    NNC_publish !NodePublishPolicy
+    deriving (Show, Eq, Ord)
+
+data NodePublishPolicy
+  = -- | No edits are allowed (not even the ones from the owner)
+    NPP_publish_no_edits_allowed
+    -- | Edits after publishing are allowed only from the owner or the super user
+  | NPP_publish_edits_only_owner_or_super
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+instance HasDBid NodeNodeCategory where
+  toDBid = \case
+    NNC_publish roCats -> toDBid roCats
+  lookupDBid x =
+    NNC_publish <$> lookupDBid x
+
+instance HasDBid NodePublishPolicy where
+  toDBid = \case
+    NPP_publish_no_edits_allowed
+      -> 0
+    NPP_publish_edits_only_owner_or_super
+      -> 1
+  lookupDBid = \case
+    0 -> Just NPP_publish_no_edits_allowed
+    1 -> Just NPP_publish_edits_only_owner_or_super
+    _ -> Nothing
+
+instance DefaultFromField SqlInt4 (Maybe NodeNodeCategory) where
+    defaultFromField = lookupDBid <$> fromPGSFromField
+
+type NodeNode = NodeNodePoly NodeId NodeId (Maybe Double) (Maybe NodeNodeCategory)
 
 $(makeAdaptorAndInstance "pNodeNode" ''NodeNodePoly)
 makeLenses ''NodeNodePoly
+makePrisms ''NodeNodeCategory
 
 nodeNodeTable :: Table NodeNodeWrite NodeNodeRead
 nodeNodeTable  =

test/Test/API.hs

@@ -12,7 +12,7 @@ import qualified Test.API.UpdateList as UpdateList
 import qualified Test.API.Worker as Worker
 
 tests :: Spec
-tests = describe "API" $ do
+tests = describe "Gargantext API" $ do
   Auth.tests
   Private.tests
   GraphQL.tests

test/Test/API/GraphQL.hs

@@ -7,6 +7,7 @@ module Test.API.GraphQL (
     tests
   ) where
 
+import Control.Monad (void)
 import Gargantext.Core.Types.Individu
 import Prelude
 import Servant.Auth.Client ()
@@ -21,9 +22,9 @@ tests :: Spec
 tests = parallel $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
   describe "GraphQL" $ do
     describe "get_user_infos" $ do
-      it "allows 'alice' to see her own info" $ \(SpecContext _testEnv port app _) -> do
-        withApplication app $ do
-          withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
+      it "allows 'alice' to see her own info" $ \SpecContext{..} -> do
+        withApplication _sctx_app $ do
+          withValidLogin _sctx_port "alice" (GargPassword "alice") $ \_clientEnv token -> do
             let query = [r| { "query": "{ user_infos(user_id: 2) { ui_id, ui_email } }" } |]
             let expected = [json| {"data":{"user_infos":[{"ui_id":2,"ui_email":"alice@gargan.text"}]}} |]
             protected token "POST" "/gql" query `shouldRespondWithFragment` expected

test/Test/API/Notifications.hs

@@ -20,7 +20,7 @@ module Test.API.Notifications (
 
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM.TChan
-import Control.Concurrent.STM.TSem (newTSem, signalTSem, waitTSem)
+import Control.Concurrent.STM.TSem (newTSem, signalTSem)
 import Control.Lens ((^.))
 import Control.Monad.STM (atomically)
 import Data.Aeson qualified as Aeson

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
+  , newFolderForUser
+  , getRootPublicFolderIdForUser
+  , getRootPrivateFolderIdForUser
+  , myUserNodeId
+  , checkEither
+  , shouldFailWith
+  ) where
+
+import Data.Aeson qualified as JSON
+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(..))
+import Gargantext.Core.Worker.Env ()  -- instance HasNodeError
+import Gargantext.Database.Action.User
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus
+import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Table.Node.User (getUserByName)
+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, (@?=))
+
+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
+
+newFolderForUser :: TestEnv -> T.Text -> T.Text -> IO NodeId
+newFolderForUser env uname folderName = flip runReaderT env $ runTestMonad $ do
+  uid      <- getUserId (UserName uname)
+  parentId <- getRootId (UserName uname)
+  insertNode NodeFolder (Just folderName) Nothing parentId uid
+
+-- | 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)
+
+getRootPrivateFolderIdForUser :: TestEnv -> User -> IO NodeId
+getRootPrivateFolderIdForUser env uname = flip runReaderT env $ runTestMonad $ do
+  _node_id <$> (getUserId uname >>= getUserRootPrivateNode)
+
+myUserNodeId :: TestEnv -> T.Text -> IO NodeId
+myUserNodeId env uname = flip runReaderT env $ runTestMonad $ do
+  _node_id <$> getUserByName uname
+
+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.hs

@@ -7,19 +7,22 @@ module Test.API.Private (
     tests
   ) where
 
+import Gargantext.API.Errors
 import Gargantext.API.Routes.Named.Node
 import Gargantext.API.Routes.Named.Private
+import Gargantext.Core.Types
 import Gargantext.Core.Types.Individu
-import Gargantext.Core.Types (Node)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
 import Gargantext.Prelude hiding (get)
 import Network.HTTP.Client hiding (Proxy)
 import Servant.Auth.Client ()
 import Servant.Client
 import Servant.Client.Generic (genericClient)
+import Test.API.Prelude
+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)
+import Test.API.Routes (mkUrl, get_node, get_tree)
 import Test.API.Setup (withTestDBAndPort, dbEnvSetup, SpecContext (..))
 import Test.Hspec
 import Test.Hspec.Wai hiding (pendingWith)
@@ -28,9 +31,9 @@ import Test.Hspec.Wai.JSON (json)
 import Test.Utils (protected, shouldRespondWithFragment, withValidLogin)
 
 
-privateTests :: SpecWith (SpecContext a)
-privateTests =
-  describe "Private API" $ do
+nodeTests :: Spec
+nodeTests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
+  describe "Prelude" $ do
     baseUrl <- runIO $ parseBaseUrl "http://localhost"
     manager <- runIO $ newManager defaultManagerSettings
     let unauthenticatedClientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port })
@@ -72,8 +75,10 @@ privateTests =
       it "forbids 'alice' to see others node private info" $ \ctx -> do
         let port = _sctx_port ctx
         withApplication (_sctx_app ctx) $ do
-          withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
-            protected token "GET" (mkUrl port "/node/1") "" `shouldRespondWith` 403
+          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
+            liftIO $ do
+              res <- runClientM (get_node token (UnsafeMkNodeId 1)) clientEnv
+              res `shouldFailWith` EC_403__policy_check_error
 
     describe "GET /api/v1.0/tree" $ do
       it "unauthorised users shouldn't see anything" $ \ctx -> do
@@ -90,15 +95,19 @@ privateTests =
       it "forbids 'alice' to see others node private info" $ \ctx -> do
         let port = _sctx_port ctx
         withApplication (_sctx_app ctx) $ do
-          withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
-            protected token "GET" (mkUrl port "/tree/1") "" `shouldRespondWith` 403
+          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
+            liftIO $ do
+              res <- runClientM (get_tree token (UnsafeMkNodeId 1)) clientEnv
+              res `shouldFailWith` EC_403__policy_check_error
 
 
 tests :: Spec
 tests = do
-  sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
-    privateTests
+  describe "Private API" $ do
+    nodeTests
   describe "Share API" $ 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 Gargantext.API.Errors
+import Gargantext.Core.Types
+import Gargantext.Core.Types.Individu
+import Gargantext.Database.Query.Table.NodeNode (SourceId(..), TargetId(..))
+import Gargantext.Prelude
+import Servant.Client
+import Test.API.Prelude
+import Test.API.Routes
+import Test.API.Setup
+import Test.Hspec (Spec, it, aroundAll, describe, sequential)
+import Test.Hspec.Wai.Internal (withApplication)
+import Test.Hspec.Expectations.Lifted
+import Test.Tasty.HUnit (assertBool)
+import Test.Utils
+
+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
+            liftIO $ do
+              cId <- newCorpusForUser testEnv "alice"
+              bobPublicFolderId <- getRootPublicFolderIdForUser testEnv (UserName "bob")
+              res <- runClientM (move_node token (SourceId cId) (TargetId bobPublicFolderId)) clientEnv
+              res `shouldFailWith` EC_403__policy_check_error
+
+      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 (move_node token (SourceId cId) (TargetId alicePublicFolderId)) clientEnv
+            liftIO $ length nodes `shouldBe` 1
+
+      it "should allow Alice to unpublish a corpus" $ \(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")
+              alicePrivateFolderId <- getRootPrivateFolderIdForUser testEnv (UserName "alice")
+              _     <- checkEither $ runClientM (move_node token (SourceId cId) (TargetId alicePublicFolderId)) clientEnv
+              checkEither $ runClientM (move_node token (SourceId cId) (TargetId alicePrivateFolderId)) clientEnv
+            length nodes `shouldBe` 1
+
+      it "should allow Bob to see Alice's published corpuses" $ \(SpecContext testEnv serverPort app _) -> do
+        withApplication app $ do
+          aliceCorpusId <- withValidLogin serverPort "alice" (GargPassword "alice") $ \clientEnv token -> do
+            liftIO $ do
+              cId <- newCorpusForUser testEnv "alice"
+              alicePublicFolderId <- getRootPublicFolderIdForUser testEnv (UserName "alice")
+              _ <- checkEither $ runClientM (move_node token (SourceId cId) (TargetId alicePublicFolderId)) clientEnv
+
+              -- Check that we can see the folder
+              aliceNodeId <- myUserNodeId testEnv "alice"
+              tree <- checkEither $ runClientM (get_tree token aliceNodeId) clientEnv
+              assertBool "alice can't see her own corpus" (containsNode cId tree)
+              pure cId
+
+          withValidLogin serverPort "bob" (GargPassword "bob") $ \clientEnv token -> do
+            tree <- liftIO $ do
+              bobNodeId <- myUserNodeId testEnv "bob"
+              checkEither $ runClientM (get_tree token bobNodeId) clientEnv
+            containsNode aliceCorpusId tree `shouldBe` True
+
+      it "shouldn't allow Alice to modify a (strictly) published node even if owner" $ \(SpecContext testEnv serverPort app _) -> do
+        withApplication app $ do
+          withValidLogin serverPort "alice" (GargPassword "alice") $ \clientEnv token -> do
+            liftIO $ do
+              cId <- newCorpusForUser testEnv "alice"
+              alicePublicFolderId  <- getRootPublicFolderIdForUser testEnv (UserName "alice")
+              _     <- checkEither $ runClientM (move_node token (SourceId cId) (TargetId alicePublicFolderId)) clientEnv
+
+              -- Trying to delete a strictly published node should fail
+              res <- runClientM (delete_node token cId) clientEnv
+              res `shouldFailWith` EC_403__policy_check_error
+
+      it "shouldn't allow publishing things which are not a node corpus" $ \(SpecContext testEnv serverPort app _) -> do
+        withApplication app $ do
+          withValidLogin serverPort "alice" (GargPassword "alice") $ \clientEnv token -> do
+            liftIO $ do
+              fId   <- newFolderForUser testEnv "alice" "my-test-folder"
+              fId'' <- newPrivateFolderForUser testEnv "alice"
+              alicePublicFolderId  <- getRootPublicFolderIdForUser testEnv (UserName "alice")
+
+              res <- runClientM (move_node token (SourceId fId) (TargetId alicePublicFolderId)) clientEnv
+              res `shouldFailWith` EC_403__node_move_error
+
+              res' <- runClientM (move_node token (SourceId fId'') (TargetId alicePublicFolderId)) clientEnv
+              res' `shouldFailWith` EC_403__node_move_error
+
+containsNode :: NodeId -> Tree NodeTree -> Bool
+containsNode target (TreeN r c) = _nt_id r == target || any (containsNode target) c

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 (SpecContext(..), dbEnvSetup, withTestDBAndPort)
-import Test.API.UpdateList (newCorpusForUser)
 import Test.Hspec
 import Test.Hspec.Wai.Internal (withApplication)
 import Test.Utils

test/Test/API/Private/Table.hs

@@ -12,9 +12,10 @@ import Gargantext.Core.Types.Individu
 import Gargantext.Database.Query.Facet qualified as Facet
 import Gargantext.Prelude
 import Servant.Client
+import Test.API.Prelude (checkEither)
 import Test.API.Routes
 import Test.API.Setup (SpecContext(..), dbEnvSetup, withTestDBAndPort)
-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/Routes.hs

 {-# LANGUAGE InstanceSigs         #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE ViewPatterns         #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
+{--| Collection of ready-to-use servant-client functions to use in all our specs. -}
 
-module Test.API.Routes where
+module Test.API.Routes (
+
+  -- * Constants and helpers
+    curApi
+  , mkUrl
+  , gqlUrl
+  , toServantToken
+  , clientRoutes
+
+  -- * Servant client functions
+  , auth_api
+  , get_children
+  , get_node
+  , get_table
+  , get_table_ngrams
+  , get_tree
+  , move_node
+  , put_table_ngrams
+  , update_node
+  , delete_node
+  , add_form_to_list
+  , add_tsv_to_list
+  ) where
 
 import Data.Text.Encoding qualified as TE
 import Fmt (Builder, (+|), (|+))
@@ -14,18 +38,19 @@ import Gargantext.API.Ngrams.List.Types (WithJsonFile, WithTextFile)
 import Gargantext.API.Ngrams.Types ( NgramsTable, NgramsTablePatch, OrderBy, TabType, Versioned, VersionedWithCount )
 import Gargantext.API.Routes.Named
 import Gargantext.API.Routes.Named.List (updateListJSONEp, updateListTSVEp)
-import Gargantext.API.Routes.Named.Node
+import Gargantext.API.Routes.Named.Node hiding (treeAPI)
 import Gargantext.API.Routes.Named.Private hiding (tableNgramsAPI)
 import Gargantext.API.Routes.Named.Table
+import Gargantext.API.Routes.Named.Tree (nodeTreeEp)
 import Gargantext.API.Types () -- MimeUnrender instances
 import Gargantext.API.Worker (workerAPIPost)
 import Gargantext.Core.Text.Corpus.Query (RawQuery)
-import Gargantext.Core.Types (ListId, NodeId, NodeType, NodeTableResult)
-import Gargantext.Core.Types.Main (ListType)
+import Gargantext.Core.Types
 import Gargantext.Core.Types.Query (Limit, MaxSize, MinSize, Offset)
 import Gargantext.Core.Worker.Types (JobInfo)
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Query.Facet qualified as Facet
+import Gargantext.Database.Query.Table.NodeNode (SourceId(..), TargetId(..))
 import Gargantext.Prelude
 import Network.HTTP.Types qualified as H
 import Network.Wai.Handler.Warp (Port)
@@ -42,12 +67,11 @@ instance RunClient m => HasClient m WS.WebSocketPending where
   clientWithRoute :: Proxy m -> Proxy WS.WebSocketPending -> Request -> Client m WS.WebSocketPending
   clientWithRoute _pm Proxy _req _httpMethod = do
     panicTrace "[WebSocket client] this is not implemented!"
-    return ()
 
   hoistClientMonad _ _ f cl = \meth -> f (cl meth)
 
 
--- This is for requests made by http.client directly to hand-crafted URLs    
+-- This is for requests made by http.client directly to hand-crafted URLs.
 curApi :: Builder
 curApi = "v1.0"
 
@@ -78,6 +102,25 @@ auth_api = clientRoutes & apiWithCustomErrorScheme
 toServantToken :: Token -> S.Token
 toServantToken = S.Token . TE.encodeUtf8
 
+get_node :: Token
+         -> NodeId
+         -> ClientM (Node HyperdataAny)
+get_node (toServantToken -> token) nodeId =
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & nodeEp
+               & nodeEndpointAPI
+               & ($ nodeId)
+               & nodeNodeAPI
+               & getNodeEp
+
 update_node :: Token
             -> NodeId
             -> UpdateNodeParams
@@ -240,3 +283,54 @@ get_children (toServantToken -> token) nodeId =
                & childrenAPI
                & summaryChildrenEp
 
+get_tree :: Token -> NodeId -> ClientM (Tree NodeTree)
+get_tree (toServantToken -> token) nId = do
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & treeAPI
+               & ($ nId)
+               & nodeTreeEp
+               & ($ [])
+
+move_node :: Token -> SourceId -> TargetId -> ClientM [NodeId]
+move_node (toServantToken -> 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)
+
+delete_node :: Token
+            -> NodeId
+            -> ClientM Int
+delete_node (toServantToken -> token) nodeId =
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & nodeEp
+               & nodeEndpointAPI
+               & ($ nodeId)
+               & deleteEp

test/Test/API/Setup.hs

@@ -5,6 +5,7 @@ module Test.API.Setup (
     SpecContext(..)
   , withTestDBAndPort
   , withBackendServerAndProxy
+  , testWithApplicationOnPort
   , setupEnvironment
   , createAliceAndBob
   , dbEnvSetup
@@ -31,6 +32,7 @@ import Gargantext.Database.Action.User.New
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Trigger.Init
 import Gargantext.Database.Admin.Types.Hyperdata
+import Gargantext.Database.Admin.Types.Node (UserId)
 import Gargantext.Database.Prelude ()
 import Gargantext.Database.Query.Table.Node (getOrMkList)
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))
@@ -40,11 +42,12 @@ import Gargantext.System.Logging
 import Network.HTTP.Client.TLS (newTlsManager)
 import Network.HTTP.Types
 import Network.Wai (Application, responseLBS)
-import Network.Wai qualified as Wai
-import Network.Wai.Handler.Warp (runSettingsSocket)
-import Network.Wai.Handler.Warp qualified as Warp
 import Network.Wai.Handler.Warp.Internal
 import Network.WebSockets qualified as WS
+import Network.Wai.Handler.Warp qualified as Warp
+import Network.Wai.Handler.Warp (runSettingsSocket)
+import Network.Wai qualified as Wai
+import Prelude hiding (show)
 import Servant.Auth.Client ()
 import Test.Database.Setup (withTestDB)
 import Test.Database.Types
@@ -165,14 +168,15 @@ setupEnvironment env = flip runReaderT env $ runTestMonad $ do
 
 -- | Creates two users, Alice & Bob. Alice shouldn't be able to see
 -- Bob's private data and vice-versa.
-createAliceAndBob :: TestEnv -> IO ()
+createAliceAndBob :: TestEnv -> IO [UserId]
 createAliceAndBob testEnv = do
-  void $ flip runReaderT testEnv $ runTestMonad $ do
+  flip runReaderT testEnv $ runTestMonad $ do
     let nur1 = mkNewUser "alice@gargan.text" (GargPassword "alice")
     let nur2 = mkNewUser "bob@gargan.text" (GargPassword "bob")
 
-    void $ new_user nur1
-    void $ new_user nur2
+    aliceId <- new_user nur1
+    bobId   <- new_user nur2
+    pure [aliceId, bobId]
 
 dbEnvSetup :: SpecContext a -> IO (SpecContext a)
 dbEnvSetup ctx = do

test/Test/API/UpdateList.hs

@@ -19,12 +19,8 @@ module Test.API.UpdateList (
     tests
   -- * Useful helpers
   , JobPollHandle(..)
-  , newCorpusForUser
-  , pollUntilFinished
   , updateNode
   , createDocsList
-  , checkEither
-
   ) where
 
 import Control.Lens (mapped, over)
@@ -56,7 +52,7 @@ import Gargantext.Core qualified as Lang
 import Gargantext.Core.Text.Corpus.Query (RawQuery(..))
 import Gargantext.Core.Text.List.Social
 import Gargantext.Core.Text.Ngrams
-import Gargantext.Core.Types ( CorpusId, ListId, NodeId, _NodeId)
+import Gargantext.Core.Types ( CorpusId, ListId, NodeId, _NodeId, TableResult(..))
 import Gargantext.Core.Types (TableResult(..))
 import Gargantext.Core.Types.Individu
 import Gargantext.Core.Types.Main (ListType(..))
@@ -65,13 +61,12 @@ import Gargantext.Database.Action.User
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Database.Admin.Types.Hyperdata.Folder (defaultHyperdataFolderPrivate)
 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 Servant.Client
 import System.FilePath
+import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser)
 import Test.API.Routes (mkUrl, gqlUrl, get_table_ngrams, put_table_ngrams, toServantToken, clientRoutes, get_table, update_node, add_form_to_list, add_tsv_to_list)
 import Test.API.Setup (withTestDBAndPort, dbEnvSetup, SpecContext (..))
 import Test.Database.Types
@@ -79,29 +74,11 @@ import Test.Hspec
 import Test.Hspec.Wai.Internal (withApplication, WaiSession)
 import Test.Hspec.Wai.JSON (json)
 import Test.Types (JobPollHandle(..))
-import Test.Utils (pollUntilFinished, pollUntilWorkFinished, protectedJSON, withValidLogin)
+import Test.Utils (pollUntilWorkFinished, protectedJSON, withValidLogin)
 import Text.Printf (printf)
 import qualified Prelude
 
 
-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"
-  (nodeId:_) <- mk (Just nodeName) (Just defaultHyperdataFolderPrivate) parentId uid
-  pure nodeId
-
 uploadJSONList :: Wai.Port
                -> Token
                -> CorpusId
@@ -384,9 +361,6 @@ updateNode port clientEnv token nodeId = do
   ji' <- pollUntilWorkFinished token port ji
   liftIO $ ji' `shouldBe` ji
 
-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

@@ -29,9 +29,10 @@ import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Prelude
-import Test.API.Setup (setupEnvironment)
+import Test.API.Setup (createAliceAndBob, setupEnvironment)
 import Test.Database.Operations.DocumentSearch
 import Test.Database.Operations.NodeStory
+import Test.Database.Operations.PublishNode
 import Test.Database.Setup (withTestDB)
 import Test.Database.Types
 import Test.Hspec
@@ -73,6 +74,13 @@ tests = parallel $ around withTestDB $ beforeWith (\ctx -> setupEnvironment ctx
             it "Can perform more complex searches using the boolean API" corpusSearch03
             it "Can correctly count doc score" corpusScore01
             it "Can perform search with spaces for doc in db" corpusSearchDB01
+    beforeWith (\env -> createAliceAndBob env >>= (const $ pure env)) $
+      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 "Publishes the root and its first level children"  testPublishRecursiveFirstLevel
+        it "Publishes the root and its recursive children"  testPublishRecursiveNLevel
+        it "Publishes in a lenient way but it's still considered read-only"  testPublishLenientWorks
         
 nodeStoryTests :: Spec
 nodeStoryTests = sequential $

test/Test/Database/Operations/PublishNode.hs

+{-|
+Module      : Test.Database.Operations.PublishNode
+Description : GarganText database tests
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# LANGUAGE QuasiQuotes   #-}
+{-# LANGUAGE TupleSections #-}
+
+module Test.Database.Operations.PublishNode where
+
+import Prelude
+
+import Control.Monad.Reader
+import Gargantext.Core
+import Gargantext.Core.Types.Individu
+import Gargantext.Database.Action.User (getUserId)
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude (DBCmd)
+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.Database.Types
+import Test.Tasty.HUnit
+
+publishStrict :: SourceId -> TargetId -> DBCmd err ()
+publishStrict = publishNode NPP_publish_no_edits_allowed
+
+publishLenient :: SourceId -> TargetId -> DBCmd err ()
+publishLenient = publishNode NPP_publish_edits_only_owner_or_super
+
+testGetUserRootPublicNode :: TestEnv -> Assertion
+testGetUserRootPublicNode testEnv = do
+  alicePublicFolder <- flip runReaderT testEnv $ runTestMonad $ do
+    aliceId <- getUserId (UserName "alice")
+    getUserRootPublicNode aliceId
+  _node_typename alicePublicFolder @?= (toDBid NodeFolderPublic)
+
+testIsReadOnlyWorks :: TestEnv -> Assertion
+testIsReadOnlyWorks 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")
+    corpusId    <- insertDefaultNode NodeCorpus alicePrivateFolderId aliceUserId
+
+    isNodeReadOnly corpusId >>= liftIO . (@?= False)
+
+    -- Publish the node, then check that's now public.
+    publishStrict (SourceId corpusId) (TargetId alicePublicFolderId)
+    isNodeReadOnly corpusId >>= liftIO . (@?= True)
+
+    -- Finally check that if we unpublish, the node is back to normal
+    unpublishNode (SourceId corpusId) (TargetId alicePublicFolderId)
+    isNodeReadOnly corpusId >>= liftIO . (@?= False)
+
+-- | In this test, we check that if we publish the root of a subtree,
+-- then all the children (up to the first level) are also marked read-only.
+testPublishRecursiveFirstLevel :: TestEnv -> Assertion
+testPublishRecursiveFirstLevel 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
+    corpusId       <- insertDefaultNode NodeCorpus aliceFolderId aliceUserId
+
+    publishStrict (SourceId aliceFolderId) (TargetId alicePublicFolderId)
+
+    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
+
+    publishStrict (SourceId aliceFolderId) (TargetId alicePublicFolderId)
+
+    isNodeReadOnly aliceFolderId    >>= liftIO . (@?= True)
+    isNodeReadOnly aliceSubFolderId >>= liftIO . (@?= True)
+    isNodeReadOnly corpusId         >>= liftIO . (@?= True)
+
+testPublishLenientWorks :: TestEnv -> Assertion
+testPublishLenientWorks testEnv = do
+  alicePrivateFolderId <- newPrivateFolderForUser testEnv "alice"
+  alicePublicFolderId  <- newPublicFolderForUser testEnv "alice"
+  flip runReaderT testEnv $ runTestMonad $ do
+    aliceUserId <- getUserId (UserName "alice")
+    corpusId    <- insertDefaultNode NodeCorpus alicePrivateFolderId aliceUserId
+    publishLenient (SourceId corpusId) (TargetId alicePublicFolderId)
+    isNodeReadOnly corpusId >>= liftIO . (@?= True)

test/Test/Instances.hs

@@ -37,6 +37,7 @@ import Gargantext.Core.Types.Main (ListType(CandidateTerm, StopTerm, MapTerm))
 import Gargantext.Core.Worker.Jobs.Types (Job(..))
 import Gargantext.Database.Admin.Types.Node (UserId(UnsafeMkUserId))
 import Gargantext.Database.Admin.Types.Hyperdata qualified as Hyperdata
+import Gargantext.Database.Admin.Types.Node (UserId(UnsafeMkUserId), NodeType(..))
 import Gargantext.Prelude hiding (replace, Location)
 import Servant.Job.Core qualified as SJ
 import Servant.Job.Types qualified as SJ
@@ -352,6 +353,9 @@ genFrontendErr be = do
       -> do userId <- arbitrary
             roots  <- arbitrary
             pure $ Errors.mkFrontendErr' txt (Errors.FE_node_lookup_failed_user_too_many_roots userId roots)
+    Errors.EC_404__node_lookup_failed_user_no_folder
+      -> do userId <- arbitrary
+            pure $ Errors.mkFrontendErr' txt (Errors.FE_node_lookup_failed_user_no_folder userId)
     Errors.EC_404__node_context_not_found
       -> do contextId <- arbitrary
             pure $ Errors.mkFrontendErr' txt (Errors.FE_node_context_not_found contextId)
@@ -373,6 +377,13 @@ 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"
+    Errors.EC_403__node_move_error
+      -> do sId <- arbitrary
+            tId <- arbitrary
+            pure $ Errors.mkFrontendErr' txt $ Errors.FE_node_move_error sId tId "generic reason"
 
     -- validation error
     Errors.EC_400__validation_error
@@ -380,6 +391,10 @@ genFrontendErr be = do
             chain <- listOf1 genValChain
             pure $ Errors.mkFrontendErr' txt $ Errors.FE_validation_error (T.pack $ fromMaybe "unknown_validation_error" $ prettyValidation $ Validation chain)
 
+    -- policy check error
+    Errors.EC_403__policy_check_error
+      -> pure $ Errors.mkFrontendErr' txt $ Errors.FE_policy_check_error (T.pack "failed policy check.")
+
     -- authentication error
     Errors.EC_403__login_failed_error
       -> do nid <- arbitrary

test/Test/Offline/JSON.hs

@@ -6,8 +6,8 @@
 module Test.Offline.JSON (tests) where
 
 import Data.Aeson
-import Data.ByteString.Lazy.Char8 qualified as C8
 import Data.ByteString qualified as B
+import Data.ByteString.Lazy.Char8 qualified as C8
 import Data.Either
 import Gargantext.API.Errors
 import Gargantext.API.Node.Corpus.Types
@@ -15,6 +15,7 @@ import Gargantext.API.Node.Types
 import Gargantext.API.Viz.Types
 import Gargantext.Core.Types.Phylo
 import qualified Gargantext.Core.Viz.Phylo as VizPhylo
+import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node
 import Paths_gargantext
 import Prelude

test/Test/Server/ReverseProxy.hs

 
 module Test.Server.ReverseProxy where
 
+import Control.Monad (void)
 import Data.Function ((&))
 import Gargantext.MicroServices.ReverseProxy
 import Network.HTTP.Client
@@ -50,7 +51,7 @@ writeFrameTests = parallel $ aroundAll withBackendServerAndProxy $ beforeAllWith
 
     it "should allow authenticated requests" $ \(testEnv, serverPort, proxyPort) -> do
       -- Let's create the Alice user.
-      createAliceAndBob testEnv
+      void $ createAliceAndBob testEnv
       baseUrl <- parseBaseUrl "http://localhost"
       manager <- newManager defaultManagerSettings
       let clientEnv prt = mkClientEnv manager (baseUrl { baseUrlPort = prt })

test/Test/Utils.hs

 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 
-module Test.Utils where
+module Test.Utils (
+  -- * Helper types
+    JsonFragmentResponseMatcher(..)
+
+  -- * Utility functions
+  , (@??=)
+  , containsJSON
+  , gargMkRequest
+  , getJSON
+  , pending
+  , pollUntilWorkFinished
+  , postJSONUrlEncoded
+  , protected
+  , protectedJSON
+  , protectedJSONWith
+  , protectedNewError
+  , protectedWith
+  , shouldRespondWithFragment
+  , shouldRespondWithFragmentCustomStatus
+  , shouldRespondWithJSON
+  , waitForTChanValue
+  , waitForTSem
+  , waitUntil
+  , withValidLogin
+  ) where
 
 import Control.Concurrent.STM.TChan (TChan, readTChan)
 import Control.Concurrent.STM.TSem (TSem, waitTSem)
@@ -211,39 +235,6 @@ gargMkRequest traceEnabled bu clientRq =
        False -> httpReq
 
 
--- | Poll the given job URL every second until it finishes.
--- Retries up to 60 times (i.e. for 1 minute, before giving up)
--- /NOTE(adn)/: Check the content of the \"events\" logs as a stopgap
--- measure for #390.
-pollUntilFinished :: HasCallStack
-                  => Token
-                  -> Port
-                  -> (JobPollHandle -> Builder)
-                  -> JobPollHandle
-                  -> WaiSession () JobPollHandle
-pollUntilFinished tkn port mkUrlPiece = go 60
-  where
-   go :: Int -> JobPollHandle -> WaiSession () JobPollHandle
-   go 0 h  = panicTrace $ "pollUntilFinished exhausted attempts. Last found JobPollHandle: " <> TE.decodeUtf8 (L.toStrict $ JSON.encode h)
-   go n h = case _jph_status h == "IsPending" || _jph_status h == "IsRunning" of
-    True -> do
-      liftIO $ threadDelay 1_000_000
-      h' <- protectedJSON tkn "GET" (mkUrl port $ mkUrlPiece h) ""
-      go (n-1) h'
-    False
-     | _jph_status h == "IsFailure"
-     -> panicTrace $ "JobPollHandle contains a failure: " <> TE.decodeUtf8 (L.toStrict $ JSON.encode h)
-     | otherwise
-     -> case any hasError (_jph_log h) of
-          True  -> panicTrace $ "JobPollHandle contains a failure: " <> TE.decodeUtf8 (L.toStrict $ JSON.encode h)
-          False -> pure h
-
-   -- FIXME(adn) This is wrong, errs should be >= 1.
-   hasError :: JobLog -> Bool
-   hasError JobLog{..} = case _scst_failed of
-     Nothing   -> False
-     Just errs -> errs > 1
-
 pollUntilWorkFinished :: HasCallStack
                       => Token
                       -> Port

test/drivers/hspec/Main.hs

@@ -63,4 +63,3 @@ main = do
       DB.tests
       DB.nodeStoryTests
       runIO $ putText "tests finished"
-