Add NodeReadOnly nodetype and Hyperdata

This commit adds a new `NodeType` called `NodeReadOnly`, to model nodes
which can be exported as read-only (frozen) snapshots. It also extends
the code to have a (provisional, in its shape) `HyperdataReadOnly`.

gargantext.cabal

@@ -426,6 +426,7 @@ library
       Gargantext.Database.Admin.Types.Hyperdata.Model
       Gargantext.Database.Admin.Types.Hyperdata.Phylo
       Gargantext.Database.Admin.Types.Hyperdata.Prelude
+      Gargantext.Database.Admin.Types.Hyperdata.ReadOnly
       Gargantext.Database.Admin.Types.Hyperdata.Texts
       Gargantext.Database.Admin.Types.Hyperdata.User
       Gargantext.Database.Admin.Types.Metrics
@@ -711,6 +712,7 @@ common testDependencies
     , aeson-pretty ^>= 0.8.9
     , aeson-qq
     , async ^>= 2.2.4
+    , bimap >= 0.5.0
     , boolexpr ^>= 0.3
     , bytestring ^>= 0.11.5.3
     , cache >= 0.1.3.0
@@ -826,6 +828,7 @@ test-suite garg-test-tasty
       Test.Ngrams.NLP
       Test.Ngrams.Query
       Test.Ngrams.Query.PaginationCorpus
+      Test.Offline.Database
       Test.Offline.Errors
       Test.Offline.JSON
       Test.Offline.Phylo

src/Gargantext/Database/Admin/Config.hs

@@ -75,3 +75,4 @@ nodeTypes = Bimap.fromList $ allNodeTypes <&> \n -> case n of
     Calc              -> (n, 992)
     NodeFrameNotebook -> (n, 993)
     NodeFrameVisio    -> (n, 994)
+    NodeReadOnly      -> (n, 995)

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

@@ -13,7 +13,8 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
 
 module Gargantext.Database.Admin.Types.Hyperdata
-  ( module Gargantext.Database.Admin.Types.Hyperdata.Any
+  ( module Gargantext.Core.Viz.Graph.Types
+  , module Gargantext.Database.Admin.Types.Hyperdata.Any
   , module Gargantext.Database.Admin.Types.Hyperdata.Contact
   , module Gargantext.Database.Admin.Types.Hyperdata.Corpus
   , module Gargantext.Database.Admin.Types.Hyperdata.Dashboard
@@ -23,14 +24,15 @@ module Gargantext.Database.Admin.Types.Hyperdata
   , module Gargantext.Database.Admin.Types.Hyperdata.Frame
   , module Gargantext.Database.Admin.Types.Hyperdata.List
   , module Gargantext.Database.Admin.Types.Hyperdata.Model
+  , module Gargantext.Database.Admin.Types.Hyperdata.Phylo
   , module Gargantext.Database.Admin.Types.Hyperdata.Prelude
+  , module Gargantext.Database.Admin.Types.Hyperdata.ReadOnly
   , module Gargantext.Database.Admin.Types.Hyperdata.Texts
-  , module Gargantext.Database.Admin.Types.Hyperdata.Phylo
   , module Gargantext.Database.Admin.Types.Hyperdata.User
-  , module Gargantext.Core.Viz.Graph.Types
   )
   where
 
+import Gargantext.Core.Viz.Graph.Types (HyperdataGraph(..), defaultHyperdataGraph)
 import Gargantext.Database.Admin.Types.Hyperdata.Any
 import Gargantext.Database.Admin.Types.Hyperdata.Contact
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
@@ -41,8 +43,8 @@ import Gargantext.Database.Admin.Types.Hyperdata.Folder
 import Gargantext.Database.Admin.Types.Hyperdata.Frame
 import Gargantext.Database.Admin.Types.Hyperdata.List
 import Gargantext.Database.Admin.Types.Hyperdata.Model
+import Gargantext.Database.Admin.Types.Hyperdata.Phylo
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude (Hyperdata, HyperdataC)
+import Gargantext.Database.Admin.Types.Hyperdata.ReadOnly
 import Gargantext.Database.Admin.Types.Hyperdata.Texts
-import Gargantext.Database.Admin.Types.Hyperdata.Phylo
 import Gargantext.Database.Admin.Types.Hyperdata.User
-import Gargantext.Core.Viz.Graph.Types (HyperdataGraph(..), defaultHyperdataGraph)

src/Gargantext/Database/Admin/Types/Hyperdata/Any.hs

@@ -19,7 +19,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Prelude
 
 ------------------------------------------------------------------------
 newtype HyperdataAny = HyperdataAny Object
-  deriving (Show, Generic, ToJSON, FromJSON)
+  deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
 ------------------------------------------------------------------------
 -- Instances

src/Gargantext/Database/Admin/Types/Hyperdata/Default.hs

@@ -49,6 +49,7 @@ data DefaultHyperdata =
   | DefaultFrameCode     HyperdataFrame
 
   | DefaultFile          HyperdataFile
+  | DefaultReadOnly      HyperdataReadOnly
 
 instance Hyperdata DefaultHyperdata
 
@@ -81,7 +82,8 @@ instance ToJSON DefaultHyperdata where
   toJSON (DefaultFrameVisio x) = toJSON x
   toJSON (DefaultFrameCode  x) = toJSON x
 
-  toJSON (DefaultFile x) = toJSON x
+  toJSON (DefaultFile x)     = toJSON x
+  toJSON (DefaultReadOnly x) = toJSON x
 
 
 defaultHyperdata :: NodeType -> DefaultHyperdata
@@ -114,3 +116,4 @@ defaultHyperdata NodeFrameVisio     = DefaultFrameVisio defaultHyperdataFrame
 defaultHyperdata NodeFrameNotebook      = DefaultFrameCalc  defaultHyperdataFrame
 
 defaultHyperdata NodeFile           = DefaultFile defaultHyperdataFile
+defaultHyperdata NodeReadOnly       = DefaultReadOnly defaultHyperdataReadOnly

src/Gargantext/Database/Admin/Types/Hyperdata/ReadOnly.hs

+{-# LANGUAGE TemplateHaskell #-}
+module Gargantext.Database.Admin.Types.Hyperdata.ReadOnly (
+    HyperdataReadOnly(..)
+  , defaultHyperdataReadOnly
+  ) where
+
+import Data.Aeson.TH
+
+import Prelude
+import GHC.Generics
+import Gargantext.Database.Admin.Types.Hyperdata.Any
+import Gargantext.Core.Utils.Prefix (unPrefix)
+import Test.QuickCheck
+
+data HyperdataReadOnly =
+  HyperdataReadOnly { _hro_wrapped :: Maybe HyperdataAny }
+    deriving (Generic, Show, Eq)
+
+defaultHyperdataReadOnly :: HyperdataReadOnly
+defaultHyperdataReadOnly =
+  HyperdataReadOnly
+    { _hro_wrapped = Nothing
+    }
+
+--
+-- Instances
+--
+
+$(deriveJSON (unPrefix "_hro_") ''HyperdataReadOnly)
+
+instance Arbitrary HyperdataReadOnly where
+    arbitrary = HyperdataReadOnly <$> arbitrary

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

@@ -433,6 +433,14 @@ data NodeType
   | NodeFrameVisio
   | NodeFrameNotebook
   | NodeFile
+  -- Nodes that controls access
+
+  -- | A read-only node is a node that is non modifiable after
+  -- creation, and this access control extends to all its children
+  -- (even recursively). This can be used to publish things like
+  -- corpus or graphs without giving the possibility for third-parties
+  -- to modify/tamper it.
+  | NodeReadOnly
   deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum)
 
 instance GQLType NodeType
@@ -489,6 +497,8 @@ instance ToJSON NodeType where
       -> "NodeFrameNotebook"
     NodeFile
       -> "NodeFile"
+    NodeReadOnly
+      -> "NodeReadOnly"
 
 instance FromJSON NodeType where
   parseJSON = withText "NodeType" $ \t -> case t of
@@ -538,6 +548,8 @@ instance FromJSON NodeType where
       -> pure NodeFrameNotebook
     "NodeFile"
       -> pure NodeFile
+    "NodeReadOnly"
+      -> pure NodeReadOnly
     unhandled
       -> typeMismatch "NodeType" (JSON.String unhandled)
 
@@ -591,6 +603,7 @@ defaultName NodeFrameVisio    = "Visio"
 defaultName NodeFrameNotebook = "Code"
 
 defaultName NodeFile          = "File"
+defaultName NodeReadOnly      = "Frozen"
 
 
 

test/Test/Offline/Database.hs

+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Test.Offline.Database (tests) where
+
+import Gargantext.Database.Admin.Config (nodeTypes)
+import Prelude
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import qualified Data.Bimap as Bimap
+import qualified Data.Set as Set
+
+tests :: TestTree
+tests = testGroup "Database" [
+    testProperty "NodeType -> NodeTypeId no clashes" nodeTypesNoClashing_prop
+  ]
+
+-- | Tests that the 'nodeTypes' bimap never yields clashing IDs, i.e.
+-- different keys yielding the same value.
+nodeTypesNoClashing_prop :: Property
+nodeTypesNoClashing_prop =
+  let e = Bimap.elems nodeTypes
+  in counterexample "Careful! the nodeTypes bimap has clashing values!" $
+       Set.toList (Set.fromList e) === e
+

test/Test/Offline/JSON.hs

@@ -6,14 +6,15 @@
 module Test.Offline.JSON (tests) where
 
 import Data.Aeson
-import Data.ByteString qualified as B
 import Data.ByteString.Lazy.Char8 qualified as C8
+import Data.ByteString qualified as B
 import Data.Either
 import Gargantext.API.Errors
 import Gargantext.API.Node.Corpus.Types
 import Gargantext.API.Node.Types
 import Gargantext.API.Viz.Types
 import Gargantext.Core.Types.Phylo
+import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node
 import Paths_gargantext
 import Prelude
@@ -63,6 +64,7 @@ tests = testGroup "JSON" [
   , testProperty "ObjectData"    (jsonRoundtrip @ObjectData)
   , testProperty "PhyloData"     (jsonRoundtrip @PhyloData)
   , testProperty "LayerData"     (jsonRoundtrip @LayerData)
+  , testProperty "HyperdataReadOnly" (jsonRoundtrip @HyperdataReadOnly)
   , testCase "can parse bpa_phylo_test.json" testParseBpaPhylo
   , testCase "can parse open_science.json" testOpenSciencePhylo
   ]

test/drivers/tasty/Main.hs

@@ -19,6 +19,7 @@ import qualified Test.Graph.Clustering           as Graph
 import qualified Test.Ngrams.NLP                 as NLP
 import qualified Test.Ngrams.Query               as NgramsQuery
 import qualified Test.Offline.JSON               as JSON
+import qualified Test.Offline.Database           as DBOffline
 import qualified Test.Offline.Errors             as Errors
 import qualified Test.Offline.Phylo              as Phylo
 import qualified Test.Offline.Stemming.Lancaster as Lancaster
@@ -54,6 +55,7 @@ main = do
     , TSVParser.tests
     , JSON.tests
     , Errors.tests
+    , DBOffline.tests
     , similaritySpec
     , Phylo.tests
     , testGroup "Stemming" [ Lancaster.tests ]