A NodeTree now stores a publish policy

This allows the frontend to correctly display a different icon in case a
node has been published with edits enabled or not.

src/Gargantext/Core/Types/Main.hs

@@ -33,9 +33,10 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
 type CorpusName = Text
 ------------------------------------------------------------------------
-data NodeTree = NodeTree { _nt_name      :: Text
-                         , _nt_type      :: NodeType
-                         , _nt_id        :: NodeId
+data NodeTree = NodeTree { _nt_name           :: Text
+                         , _nt_type           :: NodeType
+                         , _nt_id             :: NodeId
+                         , _nt_publish_policy :: Maybe NodePublishPolicy
                          } deriving (Show, Read, Generic)
 
 instance Eq NodeTree where
@@ -138,20 +139,21 @@ gargNode = [userTree]
 
 -- | User Tree simplified
 userTree :: Tree NodeTree
-userTree = TreeN (NodeTree "user name" NodeUser 1) [annuaireTree, projectTree]
+userTree = TreeN (NodeTree "user name" NodeUser 1 Nothing) [annuaireTree, projectTree]
 
 -- | Project Tree
 projectTree :: Tree NodeTree
-projectTree = TreeN (NodeTree "Project CNRS/IMT" NodeFolder 2) [corpusTree 10 "A", corpusTree 20 "B"]
+projectTree = TreeN (NodeTree "Project CNRS/IMT" NodeFolder 2 Nothing) [corpusTree 10 "A", corpusTree 20 "B"]
 
 -- | Corpus Tree
 annuaireTree :: Tree NodeTree
-annuaireTree = (leafT $ NodeTree "Annuaire" NodeAnnuaire 41)
+annuaireTree = (leafT $ NodeTree "Annuaire" NodeAnnuaire 41 Nothing)
 
 corpusTree :: NodeId -> Text -> Tree NodeTree
-corpusTree nId t  = TreeN (NodeTree ("Corpus " <> t)  NodeCorpus nId) (  [ leafT $ NodeTree "Dashboard" NodeDashboard (nId +1)
-                                                                         , leafT $ NodeTree "Graph" NodeGraph (nId +2)
-                                                                         ]
+corpusTree nId t  = TreeN (NodeTree ("Corpus " <> t)  NodeCorpus nId Nothing)
+                          (  [ leafT $ NodeTree "Dashboard" NodeDashboard (nId +1) Nothing
+                             , leafT $ NodeTree "Graph" NodeGraph (nId +2) Nothing
+                             ]
 --                                                      <> [ leafT $ NodeTree "My lists"  Lists    5]
 --                          <> [ leafT (NodeTree "Metrics A" Metrics 6)  ]
 --                          <> [ leafT (NodeTree "Class A" Classification 7)]

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

@@ -18,6 +18,7 @@ Portability : POSIX
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- {-# LANGUAGE DuplicateRecordFields #-}
 
@@ -27,29 +28,31 @@ module Gargantext.Database.Admin.Types.Node
 import Codec.Serialise (Serialise())
 import Data.Aeson as JSON
 import Data.Aeson.Types
+import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
+import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
+import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
 import Data.Csv qualified as Csv
 import Data.Morpheus.Kind (SCALAR)
 import Data.Morpheus.Types ( DecodeScalar(..), EncodeScalar(..), GQLType(KIND) )
 import Data.Swagger
 import Data.Text (pack, unpack)
+import Data.Text qualified as T
 import Data.Time (UTCTime)
 import Data.TreeDiff
-import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
-import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
-import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
 import Fmt ( Buildable(..) )
+import Gargantext.Core (HasDBid(..))
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
 import Gargantext.Database.Schema.Context
 import Gargantext.Database.Schema.Node ( NodePoly(Node), NodePolySearch(NodeSearch) )
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Hash (Hash)
 import Opaleye (DefaultFromField, defaultFromField, SqlInt4, SqlText, Nullable, fromPGSFromField)
-import Opaleye.TextSearch (SqlTSVector)
 import Opaleye qualified as O
+import Opaleye.TextSearch (SqlTSVector)
 import Prelude qualified
 import Servant hiding (Context)
-import Test.QuickCheck (elements, Positive (getPositive))
 import Test.QuickCheck.Arbitrary ( Arbitrary(arbitrary), arbitraryBoundedEnum )
+import Test.QuickCheck (elements, Positive (getPositive))
 import Test.QuickCheck.Instances.Text ()
 import Test.QuickCheck.Instances.Time ()
 import Text.Read (read)
@@ -635,3 +638,39 @@ instance DefaultFromField SqlText (Maybe Hash)
 
 context2node :: Context a -> Node a
 context2node (Context ci ch ct cu cp cn cd chy) = Node ci ch ct cu cp cn cd chy
+
+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, Read, Generic, Eq, Ord, Enum, Bounded)
+
+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 ToSchema NodePublishPolicy where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "NPP_")
+
+instance ToJSON NodePublishPolicy where
+  toJSON = \case
+    NPP_publish_no_edits_allowed
+      -> toJSON @T.Text "publish_no_edits_allowed"
+    NPP_publish_edits_only_owner_or_super
+      -> toJSON @T.Text "publish_edits_only_owner_or_super"
+
+instance FromJSON NodePublishPolicy where
+  parseJSON = JSON.withText "NodePublishPolicy" $ \case
+    "publish_no_edits_allowed"
+      -> pure NPP_publish_no_edits_allowed
+    "publish_edits_only_owner_or_super"
+      -> pure NPP_publish_edits_only_owner_or_super
+    xs -> typeMismatch "NodePublishPolicy" (toJSON xs)

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

@@ -23,7 +23,7 @@ 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.Query.Table.NodeNode (isNodeReadOnly, SourceId (..), TargetId(..), publishNode, unpublishNode)
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
 

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

@@ -24,6 +24,7 @@ module Gargantext.Database.Query.Table.NodeNode
   , SourceId(..)
   , TargetId(..)
   , OwnerId(..)
+  , PublishedNodeInfo(..)
 
   -- * Queries
   , getNodeNode
@@ -33,7 +34,7 @@ module Gargantext.Database.Query.Table.NodeNode
   , selectDocs
   , selectDocsDates
   , selectPublicNodes
-  , publishedNodeIds
+  , selectPublishedNodes
 
   -- * Destructive operations
   , deleteNodeNode
@@ -67,6 +68,7 @@ import Gargantext.Database.Schema.NodeNode
 import Gargantext.Prelude
 import Opaleye
 import Opaleye qualified as O
+import qualified Control.Lens as L
 
 queryNodeNodeTable :: Select NodeNodeRead
 queryNodeNodeTable = selectTable nodeNodeTable
@@ -269,9 +271,24 @@ selectPublicNodes :: HasDBid NodeType => (Hyperdata a, DefaultFromField SqlJsonb
                   => 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 []
+data PublishedNodeInfo
+  = PublishedNodeInfo
+  { pni_source_id :: !SourceId
+  , pni_target_id :: !TargetId
+  , pni_owner_id  :: !OwnerId
+  , pni_policy    :: !NodePublishPolicy
+  } deriving (Show, Eq)
+
+selectPublishedNodes :: DBCmd err [PublishedNodeInfo]
+selectPublishedNodes =
+  mapMaybe mk_info <$> published_node_ids []
+  where
+    mk_info :: (NodeId, NodeNode) -> Maybe PublishedNodeInfo
+    mk_info (owner, nn) =
+      PublishedNodeInfo <$> (pure $ SourceId $ _nn_node2_id nn)
+                        <*> (pure $ TargetId $ _nn_node1_id nn)
+                        <*> (pure $ OwnerId  owner)
+                        <*> (nn L.^? (nn_category . L._Just . _NNC_publish))
 
 published_node_ids :: [ NodeNodeRead -> Field SqlBool ] -> DBCmd err [(NodeId, NodeNode)]
 published_node_ids extraPreds = runOpaQuery $ do
@@ -358,11 +375,11 @@ node_NodeNode = proc () -> do
     (\nn' -> (nn' ^. nn_node1_id) .== (n ^. node_id))
   returnA -< (n, view nn_node2_id <$> nn)
 
-newtype SourceId = SourceId NodeId
+newtype SourceId = SourceId { _SourceId :: NodeId }
   deriving (Show, Eq, Ord)
-newtype TargetId = TargetId NodeId
+newtype TargetId = TargetId { _TargetId :: NodeId }
   deriving (Show, Eq, Ord)
-newtype OwnerId = OwnerId NodeId
+newtype OwnerId = OwnerId { _OwnerId :: NodeId }
   deriving (Show, Eq, Ord)
 
 shareNode :: SourceId -> TargetId -> DBCmd err Int

src/Gargantext/Database/Query/Tree.hs

@@ -32,6 +32,7 @@ module Gargantext.Database.Query.Tree
   , dt_name
   , dt_nodeId
   , dt_typeId
+  , dt_publish_policy
   , findShared
   , findNodes
   , findNodesWithType
@@ -69,10 +70,11 @@ import Gargantext.Database.Schema.Node
 import Gargantext.Prelude hiding (to)
 
 ------------------------------------------------------------------------
-data DbTreeNode = DbTreeNode { _dt_nodeId   :: NodeId
-                             , _dt_typeId   :: Int
-                             , _dt_parentId :: Maybe NodeId
-                             , _dt_name     :: Text
+data DbTreeNode = DbTreeNode { _dt_nodeId         :: NodeId
+                             , _dt_typeId         :: Int
+                             , _dt_parentId       :: Maybe NodeId
+                             , _dt_name           :: Text
+                             , _dt_publish_policy :: Maybe NodePublishPolicy
                              } deriving (Show)
 
 makeLenses ''DbTreeNode
@@ -203,8 +205,10 @@ findPublished loggedInUserId _r nt = do
   loggedInUserPublicFolder <- getUserRootPublicNode loggedInUserId
   -- Get all the published nodes, but filter out those owned by the currently logged in user, because
   -- those will be listed /only for the owner/ as part of the 'Public' 'find_nodes' query.
-  allPublishedRootFolders  <- filter (notOwnedByMe loggedInUserPublicFolder) <$> publishedNodeIds
-  trees <- forM allPublishedRootFolders $ \(SourceId _sharedNodeId, TargetId publicFolderId, OwnerId publicFolderOwnerId) -> do
+  allPublishedRootFolders  <- filter (notOwnedByMe loggedInUserPublicFolder) <$> selectPublishedNodes
+  trees <- forM allPublishedRootFolders $ \PublishedNodeInfo{pni_target_id, pni_owner_id, pni_policy} -> do
+    let (TargetId publicFolderId) = pni_target_id
+    let (OwnerId  publicFolderOwnerId) = pni_owner_id
     publicNode     <- getNode publicFolderId
     let publicNodeId = publicNode ^. node_id
     -- Fetch the user node which is sharing this folder.
@@ -215,19 +219,24 @@ findPublished loggedInUserId _r nt = do
     -- the final tree as being owned by the logged-in user, but clearly showing as provenance
     -- the public folder id.
 
-    let sharerDbTreeNode = DbTreeNode {
-            _dt_nodeId   = publicNodeId
-          , _dt_typeId   = publicNode ^. node_typename
-          , _dt_parentId = Just (loggedInUserPublicFolder ^. node_id)
-          , _dt_name     = sharerUserNode ^. node_name
+    let sharerDbTreeNode       = DbTreeNode {
+            _dt_nodeId         = publicNodeId
+          , _dt_typeId         = publicNode ^. node_typename
+          , _dt_parentId       = Just (loggedInUserPublicFolder ^. node_id)
+          , _dt_name           = sharerUserNode ^. node_name
+          -- It's the published node, not this artificial root that has to display the
+          -- policy.
+          , _dt_publish_policy = Nothing
           }
 
-    let detachedTree = sharerDbTreeNode : (sharedSubTree & over L._head (\dt -> dt { _dt_parentId = Just publicNodeId }))
+    let detachedTree = sharerDbTreeNode : (sharedSubTree & over L._head (\dt -> dt { _dt_parentId = Just publicNodeId
+                                                                                   , _dt_publish_policy = Just pni_policy
+                                                                                   }))
     pure $ detachedTree
   pure $ mconcat trees
   where
-    notOwnedByMe :: Node a -> (SourceId, TargetId, OwnerId) -> Bool
-    notOwnedByMe myPublicFolder (_, TargetId folderId, _) = myPublicFolder ^. node_id /= folderId
+    notOwnedByMe :: Node a -> PublishedNodeInfo -> Bool
+    notOwnedByMe myPublicFolder PublishedNodeInfo{pni_target_id} = myPublicFolder ^. node_id /= (_TargetId pni_target_id)
 
 ------------------------------------------------------------------------
 -- | Collaborative Nodes in the Tree
@@ -322,8 +331,10 @@ toTree m =
             -- m' ^.. at (Just $ _dt_nodeId root) . _Just . each . to (toTree' m')
             toListOf (at (Just $ _nt_id root) . _Just . each . to (toTree' m')) m'
 
+-- FIXME(adn) We need to propagate the 'PublishPolicy' into a 'DbTreeNode' and a 'NodeTree'
+-- so that we can display them properly in the frontend.
 toNodeTree :: HasCallStack => DbTreeNode -> NodeTree
-toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromDBid tId) nId
+toNodeTree (DbTreeNode nId tId _ n pp) = NodeTree n (fromDBid tId) nId pp
 
 ------------------------------------------------------------------------
 toTreeParent :: [(Maybe ParentId, NodeTree)]
@@ -366,7 +377,7 @@ nullifyParent r (Just parent, t@(NodeTree{..}))
 dbTree :: RootId
        -> [NodeType]
        -> DBCmd err [DbTreeNode]
-dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
+dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n Nothing)
   <$> runPGSQuery [sql|
     WITH RECURSIVE
         tree (id, typename, parent_id, name) AS
@@ -466,7 +477,7 @@ isIn cId docId = ( == [Only True])
 recursiveParents :: NodeId
                  -> [NodeType]
                  -> DBCmd err [DbTreeNode]
-recursiveParents nodeId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
+recursiveParents nodeId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n Nothing)
   <$> runPGSQuery [sql|
     WITH RECURSIVE recursiveParents AS
     (

src/Gargantext/Database/Schema/NodeNode.hs

@@ -69,30 +69,12 @@ data NodeNodeCategory
     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
 

test/Test/Offline/JSON.hs

@@ -57,6 +57,7 @@ tests = testGroup "JSON" [
   , testProperty "FrontendError roundtrips" jsonFrontendErrorRoundtrip
   , testProperty "BackendErrorCode roundtrips" (jsonEnumRoundtrip (Dict @_ @BackendErrorCode))
   , testProperty "NodeType roundtrips"      (jsonEnumRoundtrip (Dict @_ @NodeType))
+  , testProperty "NodePublishPolicy roundtrips" (jsonEnumRoundtrip (Dict @_ @NodePublishPolicy))
   , testCase "WithQuery frontend compliance" testWithQueryFrontend
   , testGroup "Phylo" [
     testProperty "PeriodToNode"  (jsonRoundtrip @PeriodToNodeData)