[MERGE] fix conflicts

src/Gargantext/API/GraphQL/Node.hs

@@ -22,6 +22,7 @@ import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Auth.PolicyCheck
 import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
 import Gargantext.API.GraphQL.Types
+import Gargantext.Core
 import Gargantext.Database.Admin.Types.Node (NodeType)
 import Gargantext.Database.Admin.Types.Node qualified as NN
 import Gargantext.Database.Prelude (CmdCommon)  -- , JSONB)
@@ -43,6 +44,7 @@ data Node = Node
   , name         :: Text
   , parent_id    :: Maybe Int
   , type_id      :: Int
+  , node_type    :: Maybe NodeType
   } deriving (Show, Generic, GQLType)
 
 data CorpusArgs
@@ -113,10 +115,14 @@ dbParentNodes node_id parent_type = do
           pure [toNode node]
 
 toNode :: NN.Node json -> Node
-toNode N.Node { .. } = Node { id = NN.unNodeId _node_id
+toNode N.Node { .. } = Node { id = nid
                             , name = _node_name
                             , parent_id = NN.unNodeId <$> _node_parent_id
-                            , type_id = _node_typename }
+                            , type_id = _node_typename
+                            , node_type = lookupDBid _node_typename
+                            }
+  where
+    nid = NN.unNodeId _node_id
 
 toCorpus :: NN.Node Value -> Corpus
 toCorpus N.Node { .. } = Corpus { id = NN.unNodeId _node_id

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

@@ -11,12 +11,13 @@ Portability : POSIX
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-{-# LANGUAGE BangPatterns       #-}
-{-# LANGUAGE DeriveAnyClass     #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DerivingVia        #-}
-{-# LANGUAGE TemplateHaskell    #-}
-{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DerivingStrategies  #-}
+{-# LANGUAGE DerivingVia         #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeFamilies        #-}
 
 -- {-# LANGUAGE DuplicateRecordFields #-}
 
@@ -24,12 +25,13 @@ module Gargantext.Database.Admin.Types.Node
   where
 
 import Codec.Serialise (Serialise())
-import Data.Aeson (FromJSONKey, ToJSONKey)
+import Data.Aeson as JSON
+import Data.Aeson.Types
 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 (unpack, pack)
+import Data.Text (pack, unpack)
 import Data.Time (UTCTime)
 import Data.TreeDiff
 import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
@@ -46,7 +48,7 @@ import Opaleye qualified as O
 import Prelude qualified
 import Servant hiding (Context)
 import Test.QuickCheck (elements, Positive (getPositive))
-import Test.QuickCheck.Arbitrary ( Arbitrary(arbitrary) )
+import Test.QuickCheck.Arbitrary ( Arbitrary(arbitrary), arbitraryBoundedEnum)
 import Test.QuickCheck.Instances.Text ()
 import Test.QuickCheck.Instances.Time ()
 import Text.Read (read)
@@ -405,37 +407,142 @@ instance ToSchema Resource where
 
 ------------------------------------------------------------------------
 -- | Then a Node can be either a Folder or a Corpus or a Document
-data NodeType = NodeUser
-              | NodeFolderPrivate
-              | NodeFolderShared | NodeTeam
-              | NodeFolderPublic
-              | NodeFolder
-
-              -- | NodeAnalysis | NodeCommunity
-
-              | NodeCorpus     | NodeCorpusV3 | NodeTexts | NodeDocument
-              | NodeAnnuaire   | NodeContact
-              | NodeGraph      | NodePhylo
-              | NodeDashboard  -- | NodeChart    | NodeNoteBook
-              | NodeList       | NodeModel
-              | NodeListCooc
-
-{-
-              -- | Metrics
-              -- | NodeOccurrences
-              -- | Classification
--}
-
-              -- Optional Nodes
-              | Notes | Calc | NodeFrameVisio | NodeFrameNotebook
-              | NodeFile
-
+data NodeType
+  = NodeUser
+  | NodeFolderPrivate
+  | NodeFolderShared
+  | NodeTeam
+  | NodeFolderPublic
+  | NodeFolder
+  | NodeCorpus
+  | NodeCorpusV3
+  | NodeTexts
+  | NodeDocument
+  | NodeAnnuaire
+  | NodeContact
+  | NodeGraph
+  | NodePhylo
+  | NodeDashboard
+  | NodeList
+  | NodeModel
+  | NodeListCooc
+  -- Optional Nodes
+  | Notes
+  | Calc
+  | NodeFrameVisio
+  | NodeFrameNotebook
+  | NodeFile
   deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum)
 
-
 instance GQLType NodeType
-instance FromJSON NodeType
-instance ToJSON NodeType
+
+-- /NOTE/ (adn) For backward-compatibility reasons, we keep the format for ToJSON/FromJSON similar
+-- to what 'Show/Read' would generate, but we otherwise generate \"by hand\" the mapping between a
+-- NodeType and its JSON representation, because this way we reduce the odds of /breaking the frontend/
+-- in case we change the Show/Read instances in the future.
+instance ToJSON NodeType where
+  toJSON = JSON.String . \case
+    NodeUser
+      -> "NodeUser"
+    NodeFolderPrivate
+      -> "NodeFolderPrivate"
+    NodeFolderShared
+      -> "NodeFolderShared"
+    NodeTeam
+      -> "NodeTeam"
+    NodeFolderPublic
+      -> "NodeFolderPublic"
+    NodeFolder
+      -> "NodeFolder"
+    NodeCorpus
+      -> "NodeCorpus"
+    NodeCorpusV3
+      -> "NodeCorpusV3"
+    NodeTexts
+      -> "NodeTexts"
+    NodeDocument
+      -> "NodeDocument"
+    NodeAnnuaire
+      -> "NodeAnnuaire"
+    NodeContact
+      -> "NodeContact"
+    NodeGraph
+      -> "NodeGraph"
+    NodePhylo
+      -> "NodePhylo"
+    NodeDashboard
+      -> "NodeDashboard"
+    NodeList
+      -> "NodeList"
+    NodeModel
+      -> "NodeModel"
+    NodeListCooc
+      -> "NodeListCooc"
+    Notes
+      -> "Notes"
+    Calc
+      -> "Calc"
+    NodeFrameVisio
+      -> "NodeFrameVisio"
+    NodeFrameNotebook
+      -> "NodeFrameNotebook"
+    NodeFile
+      -> "NodeFile"
+
+instance FromJSON NodeType where
+  parseJSON = withText "NodeType" $ \t -> case t of
+    "NodeUser"
+      -> pure NodeUser
+    "NodeFolderPrivate"
+      -> pure NodeFolderPrivate
+    "NodeFolderShared"
+      -> pure NodeFolderShared
+    "NodeTeam"
+      -> pure NodeTeam
+    "NodeFolderPublic"
+      -> pure NodeFolderPublic
+    "NodeFolder"
+      -> pure NodeFolder
+    "NodeCorpus"
+      -> pure NodeCorpus
+    "NodeCorpusV3"
+      -> pure NodeCorpusV3
+    "NodeTexts"
+      -> pure NodeTexts
+    "NodeDocument"
+      -> pure NodeDocument
+    "NodeAnnuaire"
+      -> pure NodeAnnuaire
+    "NodeContact"
+      -> pure NodeContact
+    "NodeGraph"
+      -> pure NodeGraph
+    "NodePhylo"
+      -> pure NodePhylo
+    "NodeDashboard"
+      -> pure NodeDashboard
+    "NodeList"
+      -> pure NodeList
+    "NodeModel"
+      -> pure NodeModel
+    "NodeListCooc"
+      -> pure NodeListCooc
+    "Notes"
+      -> pure Notes
+    "Calc"
+      -> pure Calc
+    "NodeFrameVisio"
+      -> pure NodeFrameVisio
+    "NodeFrameNotebook"
+      -> pure NodeFrameNotebook
+    "NodeFile"
+      -> pure NodeFile
+    unhandled
+      -> typeMismatch "NodeType" (JSON.String unhandled)
+
+-- | FIXME(adn) these instances could reuse the fromJSON/toJSON instances,
+-- but for some reason this broke the frontend:
+-- https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/277#note_10388
 instance FromHttpApiData NodeType where
   parseUrlPiece = Right . read . unpack
 instance ToHttpApiData NodeType where
@@ -443,7 +550,7 @@ instance ToHttpApiData NodeType where
 instance ToParamSchema NodeType
 instance ToSchema      NodeType
 instance Arbitrary NodeType where
-  arbitrary = elements allNodeTypes
+  arbitrary = arbitraryBoundedEnum
 instance FromField NodeType where
   fromField = fromJSONField
 instance ToField NodeType where

test/Test/API/GraphQL.hs

@@ -19,10 +19,9 @@ import Text.RawString.QQ (r)
 
 tests :: Spec
 tests = sequential $ aroundAll withTestDBAndPort $ do
-  describe "Prelude" $ do
-    it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
   describe "GraphQL" $ do
-
+    describe "Prelude" $ do
+      it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
 
     describe "get_user_infos" $ do
       it "allows 'alice' to see her own info" $ \((testEnv, port), app) -> do
@@ -34,6 +33,13 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
             let expected = [json| {"data":{"user_infos":[{"ui_id":2,"ui_email":"alice@gargan.text"}]}} |]
             protected token "POST" "/gql" query `shouldRespondWithFragment` expected
 
+    describe "nodes" $ do
+      it "returns node_type" $ \((_testEnv, port), app) -> do
+        withApplication app $ do
+          withValidLogin port "gargantua" (GargPassword "secret_key") $ \token -> do
+            let query = [r| { "query": "{ nodes(node_id: 2) { node_type } }" } |]
+            let expected = [json| {"data":{"nodes":[{"node_type":"NodeFolderPrivate"}]}} |]
+            protected token "POST" "/gql" query `shouldRespondWithFragment` expected
 
     describe "check error format" $ do
       it "returns the new error if header X-Garg-Error-Scheme: new is passed" $ \((_testEnv, port), app) -> do

test/Test/Offline/JSON.hs

@@ -30,6 +30,7 @@ jsonRoundtrip a =
 
 class (Show a, FromJSON a, ToJSON a, Eq a, Enum a, Bounded a) => EnumBoundedJSON a
 instance EnumBoundedJSON BackendErrorCode
+instance EnumBoundedJSON NodeType
 
 jsonEnumRoundtrip :: forall a. Dict EnumBoundedJSON a -> Property
 jsonEnumRoundtrip d = case d of
@@ -54,6 +55,7 @@ tests = testGroup "JSON" [
   , testProperty "WithQuery roundtrips"     (jsonRoundtrip @WithQuery)
   , testProperty "FrontendError roundtrips" jsonFrontendErrorRoundtrip
   , testProperty "BackendErrorCode roundtrips" (jsonEnumRoundtrip (Dict @_ @BackendErrorCode))
+  , testProperty "NodeType roundtrips"      (jsonEnumRoundtrip (Dict @_ @NodeType))
   , testCase "WithQuery frontend compliance" testWithQueryFrontend
   , testGroup "Phylo" [
     testProperty "PeriodToNode"  (jsonRoundtrip @PeriodToNodeData)