diff --git a/src/Gargantext/Database/Admin/Types/Node.hs b/src/Gargantext/Database/Admin/Types/Node.hs index 975cac994cb6559af9d8620e2d70b0c9a8e55aef..9b5f2dd796dc528e75f41ff4d2d1806132c9fed0 100644 --- a/src/Gargantext/Database/Admin/Types/Node.hs +++ b/src/Gargantext/Database/Admin/Types/Node.hs @@ -16,6 +16,7 @@ Portability : POSIX {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} -- {-# LANGUAGE DuplicateRecordFields #-} @@ -23,14 +24,17 @@ module Gargantext.Database.Admin.Types.Node where import Codec.Serialise (Serialise()) -import Data.Aeson +import Data.Aeson as JSON +import Data.Aeson.Types import Data.Aeson.TH (deriveJSON) +import Data.Bifunctor +import Data.ByteString.Lazy qualified as BL import Data.Csv qualified as Csv -import Data.Either import Data.Morpheus.Kind (SCALAR) import Data.Morpheus.Types import Data.Swagger -import Data.Text (unpack, pack) +import Data.Text (pack) +import Data.Text.Encoding qualified as TE import Data.Time (UTCTime) import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField) import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField) @@ -400,45 +404,147 @@ 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) + instance FromHttpApiData NodeType where - parseUrlPiece = Right . read . unpack + parseUrlPiece = first pack . eitherDecode . BL.fromStrict . TE.encodeUtf8 instance ToHttpApiData NodeType where - toUrlPiece = pack . show + toUrlPiece = TE.decodeUtf8 . BL.toStrict . JSON.encode 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 diff --git a/test/Test/Offline/JSON.hs b/test/Test/Offline/JSON.hs index 0bcb24c6cd09e3cc4d77d2e661bdd179a19f36f1..384e56da8015b1bfb7643d3ab1b386f7bf672fe6 100644 --- a/test/Test/Offline/JSON.hs +++ b/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)