Correct FrontendError for policy check failures

It also:

* Amends tests for policy checks status code changes
* Fix a bug in isNodeReadOnly
* Adds a function to return all the nodes ids for the published
  nodes. Next we need to modify `findShared` & co to make sure that
  published notes will show somewhere in the users' tree.

gargantext.cabal

@@ -261,6 +261,7 @@ library
       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
@@ -446,7 +447,6 @@ 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
@@ -732,6 +732,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

src/Gargantext/API/Admin/Auth.hs

@@ -193,7 +193,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

@@ -16,6 +16,7 @@ module Gargantext.API.Auth.PolicyCheck (
   , nodeSuper
   , nodeUser
   , nodeChecks
+  , nodePublished
   , moveChecks
   , userMe
   , alwaysAllow
@@ -25,25 +26,26 @@ module Gargantext.API.Auth.PolicyCheck (
 import Control.Lens (view)
 import Data.BoolExpr (BoolExpr(..), Signed(..))
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..))
-import Gargantext.API.Errors.Types (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.Table.NodeNode
 import Gargantext.Database.Query.Tree (isDescendantOf, isOwnedBy, isSharedWith)
 import Gargantext.Database.Query.Tree.Root (getRootId)
 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
-import Gargantext.Database.Query.Table.NodeNode
+import Gargantext.API.Errors (BackendInternalError)
 
 -------------------------------------------------------------------------------
 -- Types
@@ -57,7 +59,7 @@ data AccessResult
   = -- | Grants access.
     Allow
     -- | Denies access with the given 'ServerError'.
-  | Deny ServerError
+  | Deny AccessPolicyErrorReason
 
 instance Semigroup AccessResult where
   Allow <> Allow        = Allow
@@ -81,6 +83,8 @@ data AccessCheck
     AC_node_descendant  !NodeId
     -- | Grants access if the input 'NodeId' is shared with the logged-in user.
   | AC_node_shared      !NodeId
+    -- | Grants access if the input 'NodeId' is shared with the logged-in user.
+  | AC_node_published   !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.
@@ -116,12 +120,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)
@@ -131,23 +135,38 @@ 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 nodeId
+    -> enforce nodeNotShared =<< isNodeReadOnly nodeId
+
+-------------------------------------------------------------------------------
+-- Errors
+-------------------------------------------------------------------------------
+
+nodeNotShared :: AccessPolicyErrorReason
+nodeNotShared = AccessPolicyErrorReason "Node is not shared with user."
+
+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
@@ -168,8 +187,15 @@ nodeDescendant = BConst . Positive . AC_node_descendant
 nodeShared :: NodeId -> BoolExpr AccessCheck
 nodeShared = BConst . Positive . AC_node_shared
 
+nodePublished :: NodeId -> BoolExpr AccessCheck
+nodePublished = BConst . Positive . AC_node_published
+
 nodeChecks :: NodeId -> BoolExpr AccessCheck
-nodeChecks nid = nodeUser nid `BOr` nodeSuper nid `BOr` nodeDescendant nid `BOr` nodeShared nid
+nodeChecks nid =
+  nodeUser nid  `BOr`
+  nodeSuper nid `BOr`
+  nodeDescendant nid `BOr`
+  nodeShared nid
 
 -- | A user can move a node from source to target only
 -- if:
@@ -228,5 +254,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,8 +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
-         UserPublicFolderDoesNotExist uid
-           -> mkFrontendErrShow $ FE_node_lookup_failed_user_no_public_folder uid
+         UserFolderDoesNotExist uid
+           -> mkFrontendErrShow $ FE_node_lookup_failed_user_no_folder uid
   NotImplYet
     -> mkFrontendErrShow FE_node_not_implemented_yet
   NoContextFound contextId

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,8 +224,8 @@ 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_public_folder =
-  FE_node_lookup_failed_user_no_public_folder { nenpf_user_id :: UserId }
+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 =
@@ -259,6 +268,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
 --
@@ -407,13 +424,13 @@ 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_public_folder) where
-  toJSON (FE_node_lookup_failed_user_no_public_folder userId) =
+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_public_folder) where
-  parseJSON = withObject "FE_node_lookup_failed_user_no_public_folder" $ \o -> do
+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_public_folder{..}
+    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 ]
@@ -479,6 +496,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
 --
@@ -640,8 +667,8 @@ 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_public_folder -> do
-        (fe_data :: ToFrontendErrorData 'EC_404__node_lookup_failed_user_no_public_folder) <- o .: "data"
+      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"
@@ -676,6 +703,11 @@ instance FromJSON FrontendError where
         (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,7 +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_public_folder
+  | 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
@@ -36,6 +36,8 @@ data BackendErrorCode
   | EC_403__node_is_read_only
   -- 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/PolicyCheck.hs

@@ -22,5 +22,5 @@ withPolicy ur mgr checks m = case mgr of
     res <- lift $ runAccessPolicy ur checks
     case res of
       Allow     -> m
-      Deny err  -> lift $ throwError $ InternalServerError $ err
+      Deny err  -> lift $ throwError $ AccessPolicyError err
 

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

@@ -33,6 +33,7 @@ module Gargantext.Database.Query.Table.Node
   , getOrMkList
   , getParentId
   , getUserRootPublicNode
+  , getUserRootPrivateNode
   , selectNode
 
   -- * Queries that returns multiple nodes
@@ -418,13 +419,24 @@ getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 getUserRootPublicNode :: (HasNodeError err, HasDBid NodeType)
                       => UserId
                       -> DBCmd err (Node HyperdataFolder)
-getUserRootPublicNode userId = do
+getUserRootPublicNode = get_user_root_node_folder NodeFolderPublic
+
+getUserRootPrivateNode :: (HasNodeError err, HasDBid NodeType)
+                       => UserId
+                       -> DBCmd err (Node HyperdataFolder)
+getUserRootPrivateNode = get_user_root_node_folder NodeFolderPrivate
+
+get_user_root_node_folder :: (HasNodeError err, HasDBid NodeType)
+                          => NodeType
+                          -> UserId
+                          -> DBCmd err (Node HyperdataFolder)
+get_user_root_node_folder nty userId = do
   result <- runOpaQuery $ do
     n <- queryNodeTable
-    where_ $ (n ^. node_typename .== sqlInt4 (toDBid NodeFolderPublic)) .&&
+    where_ $ (n ^. node_typename .== sqlInt4 (toDBid nty)) .&&
              (n ^. node_user_id  .== sqlInt4 (_UserId userId))
     pure n
   case result of
-    []      -> nodeError $ NodeLookupFailed $ UserPublicFolderDoesNotExist userId
+    []      -> nodeError $ NodeLookupFailed $ UserFolderDoesNotExist userId
     [n]     -> pure n
     folders -> nodeError $ NodeLookupFailed $ UserHasTooManyRoots userId (map _node_id folders)

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

@@ -57,7 +57,7 @@ data NodeLookupError
   | UserDoesNotExist     UserId
   | UserNameDoesNotExist Username
   | UserHasTooManyRoots UserId [NodeId]
-  | UserPublicFolderDoesNotExist UserId
+  | UserFolderDoesNotExist UserId
   deriving (Show, Eq, Generic)
 
 instance ToJSON NodeLookupError
@@ -69,7 +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)
-  UserPublicFolderDoesNotExist uid -> "no public folder was found for user with id " <> T.pack (show uid)
+  UserFolderDoesNotExist uid -> "no requested folder was found for user with id " <> T.pack (show uid)
 
 ------------------------------------------------------------------------
 data NodeError = NoListFound ListId

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

@@ -31,6 +31,7 @@ module Gargantext.Database.Query.Table.NodeNode
   , selectDocs
   , selectDocsDates
   , selectPublicNodes
+  , publishedNodeIds
 
   -- * Destructive operations
   , deleteNodeNode
@@ -257,6 +258,15 @@ selectPublicNodes :: HasDBid NodeType => (Hyperdata a, DefaultFromField SqlJsonb
                   => DBCmd err [(Node a, Maybe Int)]
 selectPublicNodes = runOpaQuery (queryWithType NodeFolderPublic)
 
+publishedNodeIds :: DBCmd err [NodeId]
+publishedNodeIds = map (_nn_node1_id) <$> do_query
+  where
+    do_query :: DBCmd err [NodeNode]
+    do_query = runOpaQuery $ do
+      n <- queryNodeNodeTable
+      where_ $ (n ^. nn_category .== sqlInt4 (toDBid NNC_read_only_publish))
+      pure n
+
 -- | 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.
@@ -296,7 +306,7 @@ isNodeReadOnly targetNode = (== [Only True])
      , toDBid NodeFolderPublic
      , toDBid NNC_read_only_publish
      , targetNode
-     , toDBid NNC_read_only_publish
+     , toDBid NodeFolderPublic
      )
 
   where

src/Gargantext/Database/Query/Tree.hs

@@ -180,8 +180,8 @@ findShared :: HasTreeError err
            => RootId -> NodeType -> [NodeType] -> UpdateTree err
            -> DBCmd err [DbTreeNode]
 findShared r nt nts fun = do
-  foldersSharedId <- findNodesId r [nt]
-  trees           <- mapM (updateTree nts fun) foldersSharedId
+  foldersSharedId     <- findNodesId r [nt]
+  trees               <- mapM (updateTree nts fun) foldersSharedId
   pure $ concat trees
 
 -- | Find shared folders with "direct" access, i.e. when fetching only

test/Test/API.hs

@@ -13,7 +13,7 @@ import qualified Test.API.Private as Private
 import qualified Test.API.UpdateList as UpdateList
 
 tests :: NotificationsConfig -> D.Dispatcher -> Spec
-tests nc dispatcher = describe "API" $ do
+tests nc dispatcher = describe "Gargantext API" $ do
   Auth.tests
   Private.tests
   GraphQL.tests

test/Test/API/Prelude.hs

@@ -5,10 +5,13 @@ module Test.API.Prelude
   , newPrivateFolderForUser
   , newPublicFolderForUser
   , 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
@@ -17,6 +20,7 @@ import Gargantext.Core.Types (NodeType(..))
 import Gargantext.Database.Action.User
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Table.Node.User (getUserByName)
 import Gargantext.Database.Query.Tree.Root
 import Gargantext.Database.Schema.Node (_node_id)
 import Gargantext.Prelude hiding (get)
@@ -24,7 +28,6 @@ import Prelude (fail)
 import Servant.Client.Core
 import Test.Database.Types
 import Test.Tasty.HUnit (Assertion, (@?=))
-import qualified Data.Aeson as JSON
 
 checkEither :: (Show a, Monad m) => m (Either a b) -> m b
 checkEither = fmap (either (\x -> panicTrace $ "checkEither:" <> T.pack (show x)) identity)
@@ -57,6 +60,14 @@ 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."

test/Test/API/Private.hs

@@ -7,20 +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
 import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob, SpecContext (..))
 import Test.Hspec
 import Test.Hspec.Wai hiding (pendingWith)
@@ -28,19 +30,22 @@ import Test.Hspec.Wai.Internal (withApplication)
 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 $ do
+  describe "Prelude" $ do
     baseUrl <- runIO $ parseBaseUrl "http://localhost"
     manager <- runIO $ newManager defaultManagerSettings
     let unauthenticatedClientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port })
 
+    it "setup DB triggers" $ \SpecContext{..} -> do
+      setupEnvironment _sctx_env
+      -- Let's create the Alice user.
+      void $ createAliceAndBob _sctx_env
+
     describe "GET /api/v1.0/user" $ do
 
       -- FIXME(adn): unclear if this is useful at all. Doesn't do permission checking.
-      it "doesn't allow someone with an invalid token to show the results" $ \(SpecContext testEnv port _ _) -> do
-
-        void $ createAliceAndBob testEnv
+      it "doesn't allow someone with an invalid token to show the results" $ \(SpecContext _testEnv port _ _) -> do
 
         let gargAdminClient = (genericClient :: GargAdminAPI (AsClientT ClientM))
             admin_user_api_get = (getRootsEp . rootsEp $ gargAdminClient :: ClientM [Node HyperdataUser])
@@ -72,8 +77,10 @@ privateTests =
 
       it "forbids 'alice' to see others node private info" $ \(SpecContext _testEnv port app _) -> do
         withApplication app $ 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" $ \(SpecContext _testEnv port app _) -> do
@@ -88,16 +95,16 @@ privateTests =
 
       it "forbids 'alice' to see others node private info" $ \(SpecContext _testEnv port app _) -> do
         withApplication app $ 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 $ do
-    describe "Prelude" $ do
-      it "setup DB triggers" $ \SpecContext{..} -> setupEnvironment _sctx_env
-    privateTests
+  describe "Private API" $ do
+    nodeTests
   describe "Share API" $ do
     Share.tests
   describe "Table API" $ do

test/Test/API/Private/Move.hs

@@ -6,42 +6,21 @@ module Test.API.Private.Move (
     tests
   ) where
 
-import Control.Lens
 import Gargantext.API.Errors
-import Gargantext.API.Routes.Named
-import Gargantext.API.Routes.Named.Node (moveAPI, moveNodeEp)
-import Gargantext.API.Routes.Named.Private
 import Gargantext.Core.Types
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Query.Table.NodeNode (SourceId(..), TargetId(..))
 import Gargantext.Prelude
-import Servant.Auth.Client qualified as SC
 import Servant.Client
-import Test.API.Prelude (newCorpusForUser, getRootPublicFolderIdForUser, checkEither, shouldFailWith)
+import Test.API.Prelude
 import Test.API.Routes
 import Test.API.Setup
-import Test.Hspec
+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
 
-moveNodeFromTo :: SC.Token -> SourceId -> TargetId -> ClientM [NodeId]
-moveNodeFromTo token (SourceId sourceId) (TargetId targetId) = fmap (map UnsafeMkNodeId) $
-  clientRoutes & apiWithCustomErrorScheme
-               & ($ GES_new)
-               & backendAPI
-               & backendAPI'
-               & mkBackEndAPI
-               & gargAPIVersion
-               & gargPrivateAPI
-               & mkPrivateAPI
-               & ($ token)
-               & nodeEp
-               & nodeEndpointAPI
-               & ($ sourceId)
-               & moveAPI
-               & moveNodeEp
-               & ($ targetId)
-
 tests :: Spec
 tests = sequential $ aroundAll withTestDBAndPort $ do
   describe "Prelude" $ do
@@ -58,8 +37,8 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
             liftIO $ do
               cId <- newCorpusForUser testEnv "alice"
               bobPublicFolderId <- getRootPublicFolderIdForUser testEnv (UserName "bob")
-              res <- runClientM (moveNodeFromTo (toServantToken token) (SourceId bobPublicFolderId) (TargetId cId)) clientEnv
-              res `shouldFailWith` EC_500__internal_server_error
+              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
@@ -67,5 +46,39 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
             nodes <- liftIO $ do
               cId <- newCorpusForUser testEnv "alice"
               alicePublicFolderId <- getRootPublicFolderIdForUser testEnv (UserName "alice")
-              checkEither $ runClientM (moveNodeFromTo (toServantToken token) (SourceId alicePublicFolderId) (TargetId cId)) clientEnv
+              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
+
+containsNode :: NodeId -> Tree NodeTree -> Bool
+containsNode target (TreeN r c) = _nt_id r == target || any (containsNode target) c

test/Test/API/Routes.hs

-{-# LANGUAGE InstanceSigs    #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# 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
+  ) where
 
 import Data.Text.Encoding qualified as TE
 import Fmt (Builder, (+|), (|+))
@@ -13,16 +34,17 @@ import Gargantext.API.Errors
 import Gargantext.API.HashedResponse (HashedResponse)
 import Gargantext.API.Ngrams.Types ( NgramsTable, NgramsTablePatch, OrderBy, TabType, Versioned, VersionedWithCount )
 import Gargantext.API.Routes.Named
-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.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.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)
@@ -41,12 +63,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"
 
@@ -77,6 +98,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
@@ -198,3 +238,36 @@ 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)

test/Test/API/Setup.hs

@@ -6,6 +6,7 @@ module Test.API.Setup (
   , withTestDBAndPort
   , withTestDBAndNotifications
   , withBackendServerAndProxy
+  , testWithApplicationOnPort
   , setupEnvironment
   , createAliceAndBob
   ) where

test/Test/Instances.hs

@@ -266,9 +266,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_public_folder
+    Errors.EC_404__node_lookup_failed_user_no_folder
       -> do userId <- arbitrary
-            pure $ Errors.mkFrontendErr' txt (Errors.FE_node_lookup_failed_user_no_public_folder userId)
+            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)
@@ -300,6 +300,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