[REFACT] Hyperdatas easy polymorphic insert (WIP)

src/Gargantext/Database/Action/Flow.hs

@@ -202,11 +202,11 @@ flowCorpusUser l user corpusName ctype ids = do
   -- User Flow
   (userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus user corpusName ctype
   listId <- getOrMkList userCorpusId userId
-  _cooc  <- mkNode NodeListCooc listId userId
+  _cooc  <- insertDefaultNode NodeListCooc listId userId
   -- TODO: check if present already, ignore
   _ <- Doc.add userCorpusId ids
 
-  _tId <- mkNode NodeTexts userCorpusId userId
+  _tId <- insertDefaultNode NodeTexts userCorpusId userId
   -- printDebug "Node Text Id" tId
 
   -- User List Flow
@@ -217,8 +217,8 @@ flowCorpusUser l user corpusName ctype ids = do
   -- _ <- insertOccsUpdates userCorpusId mastListId
   -- printDebug "userListId" userListId
   -- User Graph Flow
-  _ <- mkDashboard userCorpusId userId
-  _ <- mkGraph  userCorpusId userId
+  _ <- insertDefaultNode NodeDashboard userCorpusId userId
+  _ <- insertDefaultNode NodeGraph     userCorpusId userId
   --_ <- mkPhylo  userCorpusId userId
 
   -- Annuaire Flow
@@ -272,7 +272,7 @@ insertMasterDocs c lang hs  =  do
                        ]
 
   _ <- Doc.add masterCorpusId ids'
-  _cooc <- mkNode NodeListCooc lId masterUserId
+  _cooc <- insertDefaultNode NodeListCooc lId masterUserId
   -- to be removed
   _   <- insertDocNgrams lId indexedNgrams
 

src/Gargantext/Database/Action/Node.hs

@@ -133,14 +133,18 @@ mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err)
                                     -> Name
                                     -> Cmd err [NodeId]
 mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
-  maybeNodeId <- insertNodesWithParentR (Just i) [node nt name defaultFolder Nothing uId]
+  maybeNodeId <- case nt of
+     NodeFrameWrite -> insertNode NodeFrameWrite (Just name) Nothing i uId
+     NodeFrameCalc  -> insertNode NodeFrameCalc  (Just name) Nothing i uId
+     _              -> nodeError NeedsConfiguration
+
   case maybeNodeId of
     []  -> nodeError (DoesNotExist i)
     [n] -> do
       config <- view hasConfig
       u <- case nt of
             NodeFrameWrite -> pure $ _gc_frame_write_url config
-            NodeFrameCalc  -> pure $ _gc_frame_calc_url config
+            NodeFrameCalc  -> pure $ _gc_frame_calc_url  config
             _              -> nodeError NeedsConfiguration
       let
         s = _gc_secretkey config

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

+{-|
+Module      : Gargantext.Database.Admin.Types.Hyperdata.Default
+Description :
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE TemplateHaskell            #-}
+
+module Gargantext.Database.Admin.Types.Hyperdata.Default
+  where
+
+import Gargantext.Database.Admin.Types.Node (NodeType(..))
+import Gargantext.Database.Admin.Types.Hyperdata
+import Gargantext.Database.Admin.Types.Hyperdata.Prelude
+
+
+data DefaultHyperdata =
+    DefaultUser    HyperdataUser 
+  | DefaultContact HyperdataContact
+
+  | DefaultCorpus    HyperdataCorpus
+  | DefaultCorpusV3  HyperdataCorpus
+  | DefaultAnnuaire  HyperdataAnnuaire
+
+  | DefaultDocument  HyperdataDocument
+  | DefaultTexts     HyperdataTexts
+  | DefaultList      HyperdataList
+  | DefaultListCooc  HyperdataListCooc
+  | DefaultModel     HyperdataModel
+
+  | DefaultFolder        HyperdataFolder
+  | DefaultFolderPrivate HyperdataFolderPrivate
+  | DefaultFolderShared  HyperdataFolderShared
+  | DefaultTeam          HyperdataFolder
+  | DefaultFolderPublic  HyperdataFolderPublic
+
+  | DefaultGraph         HyperdataGraph
+  | DefaultPhylo         HyperdataPhylo
+  | DefaultDashboard     HyperdataDashboard
+
+  | DefaultFrameWrite    HyperdataFrame
+  | DefaultFrameCalc     HyperdataFrame
+
+instance Hyperdata DefaultHyperdata
+
+instance ToJSON DefaultHyperdata where
+  toJSON (DefaultUser    x) = toJSON x
+  toJSON (DefaultContact x) = toJSON x
+
+  toJSON (DefaultCorpus   x) = toJSON x
+  toJSON (DefaultCorpusV3 x) = toJSON x
+  toJSON (DefaultAnnuaire x) = toJSON x
+
+  toJSON (DefaultDocument x) = toJSON x
+  toJSON (DefaultTexts    x) = toJSON x
+  toJSON (DefaultList     x) = toJSON x
+  toJSON (DefaultListCooc x) = toJSON x
+  toJSON (DefaultModel    x) = toJSON x
+
+  toJSON (DefaultFolder        x) = toJSON x
+  toJSON (DefaultFolderPrivate x) = toJSON x
+  toJSON (DefaultFolderShared  x) = toJSON x
+  toJSON (DefaultTeam          x) = toJSON x
+  toJSON (DefaultFolderPublic  x) = toJSON x
+
+  toJSON (DefaultGraph     x) = toJSON x
+  toJSON (DefaultPhylo     x) = toJSON x
+  toJSON (DefaultDashboard x) = toJSON x
+
+  toJSON (DefaultFrameWrite x) = toJSON x
+  toJSON (DefaultFrameCalc  x) = toJSON x
+
+
+defaultHyperdata :: NodeType -> DefaultHyperdata
+defaultHyperdata NodeUser           = DefaultUser    defaultHyperdataUser
+defaultHyperdata NodeContact        = DefaultContact defaultHyperdataContact
+
+defaultHyperdata NodeCorpus         = DefaultCorpus   defaultHyperdataCorpus
+defaultHyperdata NodeCorpusV3       = DefaultCorpusV3 defaultHyperdataCorpus
+defaultHyperdata NodeAnnuaire       = DefaultAnnuaire defaultHyperdataAnnuaire
+
+defaultHyperdata NodeDocument       = DefaultDocument defaultHyperdataDocument
+defaultHyperdata NodeTexts          = DefaultTexts    defaultHyperdataTexts
+defaultHyperdata NodeList           = DefaultList     defaultHyperdataList
+defaultHyperdata NodeListCooc       = DefaultListCooc defaultHyperdataListCooc
+defaultHyperdata NodeModel          = DefaultModel    defaultHyperdataModel
+
+defaultHyperdata NodeFolder         = DefaultFolder        defaultHyperdataFolder
+defaultHyperdata NodeFolderPrivate  = DefaultFolderPrivate defaultHyperdataFolderPrivate
+defaultHyperdata NodeFolderShared   = DefaultFolderShared  defaultHyperdataFolderShared
+defaultHyperdata NodeTeam           = DefaultTeam          defaultHyperdataFolder
+defaultHyperdata NodeFolderPublic   = DefaultFolderPublic  defaultHyperdataFolderPublic
+
+defaultHyperdata NodeGraph          = DefaultGraph     defaultHyperdataGraph
+defaultHyperdata NodePhylo          = DefaultPhylo     defaultHyperdataPhylo
+defaultHyperdata NodeDashboard      = DefaultDashboard defaultHyperdataDashboard
+
+defaultHyperdata NodeFrameWrite     = DefaultFrameWrite defaultHyperdataFrame
+defaultHyperdata NodeFrameCalc      = DefaultFrameCalc  defaultHyperdataFrame
+
+
+

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

@@ -263,6 +263,34 @@ data NodeType = NodeUser
 allNodeTypes :: [NodeType]
 allNodeTypes = [minBound ..]
 
+defaultName :: NodeType -> Text
+defaultName NodeUser       = "User"
+defaultName NodeContact    = "Contact"
+
+defaultName NodeCorpus     = "Corpus"
+defaultName NodeCorpusV3   = "Corpus"
+defaultName NodeAnnuaire   = "Annuaire"
+
+defaultName NodeDocument   = "Doc"
+defaultName NodeTexts      = "Texts"
+defaultName NodeList       = "List"
+defaultName NodeListCooc   = "List"
+defaultName NodeModel      = "Model"
+
+defaultName NodeFolder     = "Folder"
+defaultName NodeFolderPrivate = "Private Folder"
+defaultName NodeFolderShared  = "Shared Folder"
+defaultName NodeTeam          = "Folder"
+defaultName NodeFolderPublic  = "Public Folder"
+
+defaultName NodeGraph         = "Graph"
+defaultName NodePhylo         = "Phylo"
+defaultName NodeDashboard     = "Dashboard"
+
+defaultName NodeFrameWrite    = "Frame Write"
+defaultName NodeFrameCalc     = "Frame Calc"
+
+
 instance FromJSON NodeType
 instance ToJSON NodeType
 

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

@@ -24,19 +24,19 @@ module Gargantext.Database.Query.Table.Node
 import Control.Arrow (returnA)
 import Control.Lens (set, view)
 import Data.Aeson
-import Data.Maybe (Maybe(..))
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
 import Data.Text (Text)
 import GHC.Int (Int64)
 import Gargantext.Core.Types
 import Gargantext.Database.Admin.Config (nodeTypeId)
 import Gargantext.Database.Admin.Types.Hyperdata
-import Gargantext.Database.Admin.Types.Node (NodeType(..))
+import Gargantext.Database.Admin.Types.Hyperdata.Default
+import Gargantext.Database.Admin.Types.Node (NodeType(..), defaultName)
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Filter (limit', offset')
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude hiding (sum, head)
-import Gargantext.Viz.Graph (HyperdataGraph(..), defaultHyperdataGraph)
 import Opaleye hiding (FromField)
 import Opaleye.Internal.QueryArr (Query)
 import Prelude hiding (null, id, map, sum)
@@ -162,16 +162,6 @@ nodeContactW maybeName maybeContact aId =
       name    = maybe "Contact" identity maybeName
       contact = maybe arbitraryHyperdataContact identity maybeContact
 ------------------------------------------------------------------------
-defaultFolder :: HyperdataFolder
-defaultFolder = defaultHyperdataFolder
-
-
-nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
-nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
-  where
-    name   = maybe "Folder" identity maybeName
-    folder = maybe defaultFolder identity maybeFolder
-------------------------------------------------------------------------
 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
   where
@@ -185,65 +175,19 @@ nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId
     name = maybe "Document" identity maybeName
     doc  = maybe defaultHyperdataDocument identity maybeDocument
 ------------------------------------------------------------------------
-nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
-nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
-  where
-    name     = maybe "Annuaire" identity maybeName
-    annuaire = maybe defaultHyperdataAnnuaire identity maybeAnnuaire
+-- | Sugar to insert Node with NodeType in Database
+insertDefaultNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
+insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 
-------------------------------------------------------------------------
-mkModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
-mkModelNode p u = insertNodesR [nodeModelW Nothing Nothing p u]
+insertNode :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
+insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 
-nodeModelW :: Maybe Name -> Maybe HyperdataModel -> ParentId -> UserId -> NodeWrite
-nodeModelW maybeName maybeModel pId = node NodeModel name list (Just pId)
+nodeW :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
+nodeW nt n h p u = node nt n' h' (Just p) u
   where
-    name = maybe "List Model" identity maybeName
-    list = maybe defaultHyperdataModel identity maybeModel
-
-------------------------------------------------------------------------
-nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
-nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
-  where
-    name = maybe "Graph" identity maybeName
-    graph = maybe defaultHyperdataGraph identity maybeGraph
-
-mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
-mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
-
-insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
-insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
+    n' = fromMaybe (defaultName nt) n
+    h' = maybe     (defaultHyperdata nt) identity h
 
-------------------------------------------------------------------------
-nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
-nodeDefault NodeUser      parentId = node NodeUser     "User"   defaultHyperdataUser     (Just parentId)
-nodeDefault NodeContact   parentId = node NodeContact  "Contact" defaultHyperdataContact   (Just parentId)
-
-nodeDefault NodeCorpus    parentId = node NodeCorpus   "Corpus" defaultHyperdataCorpus   (Just parentId)
-nodeDefault NodeCorpusV3  parentId = node NodeCorpus   "Corpus" defaultHyperdataCorpus   (Just parentId)
-nodeDefault NodeAnnuaire  parentId = node NodeAnnuaire "Annuaire" defaultHyperdataAnnuaire   (Just parentId)
-
-nodeDefault NodeDocument  parentId = node NodeDocument "Doc"    defaultHyperdataDocument (Just parentId)
-nodeDefault NodeTexts     parentId = node NodeTexts    "Texts"  defaultHyperdataTexts    (Just parentId)
-nodeDefault NodeList      parentId = node NodeList     "List"   defaultHyperdataList     (Just parentId)
-nodeDefault NodeListCooc  parentId = node NodeListCooc "List"   defaultHyperdataListCooc (Just parentId)
-nodeDefault NodeModel     parentId = node NodeModel    "Model"  defaultHyperdataModel    (Just parentId)
-
-nodeDefault NodeFolder    parentId = node NodeFolder   "Folder" defaultHyperdataFolder   (Just parentId)
-nodeDefault NodeFolderPrivate parentId = node NodeFolderPrivate  "Private Folder" defaultHyperdataFolderPrivate   (Just parentId)
-nodeDefault NodeFolderShared  parentId = node NodeFolderShared   "Shared Folder"  defaultHyperdataFolderShared   (Just parentId)
-nodeDefault NodeTeam          parentId = node NodeFolder  "Folder" defaultHyperdataFolder  (Just parentId)
-nodeDefault NodeFolderPublic  parentId = node NodeFolderPublic   "Public Folder"  defaultHyperdataFolderPublic   (Just parentId)
-
-nodeDefault NodeGraph         parentId = node NodeGraph   "Graph"  defaultHyperdataGraph   (Just parentId)
-nodeDefault NodePhylo         parentId = node NodePhylo   "Phylo"  defaultHyperdataPhylo   (Just parentId)
-nodeDefault NodeDashboard     parentId = node NodeDashboard   "Dashboard"  defaultHyperdataDashboard   (Just parentId)
-
-nodeDefault NodeFrameWrite   parentId = node NodeFrameWrite "Frame Write"  defaultHyperdataFrame   (Just parentId)
-nodeDefault NodeFrameCalc    parentId = node NodeFrameCalc "Frame Calc"  defaultHyperdataFrame   (Just parentId)
--- nodeDefault nt _ = panic $ "G.D.Q.T.Node.nodeDefault " <> (cs $ show nt)
-
-------------------------------------------------------------------------
 ------------------------------------------------------------------------
 node :: (ToJSON a, Hyperdata a)
      => NodeType
@@ -318,12 +262,14 @@ class MkCorpus a
 
 instance MkCorpus HyperdataCorpus
   where
-    mk n h p u = insertNodesR [nodeCorpusW n h p u]
+    mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
+    mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 
 
 instance MkCorpus HyperdataAnnuaire
   where
-    mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
+    mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
+    mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 
 
 getOrMkList :: HasNodeError err
@@ -333,38 +279,14 @@ getOrMkList :: HasNodeError err
 getOrMkList pId uId =
   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
     where
-      mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
-
-mkList :: HasNodeError err
-            => ParentId
-            -> UserId
-            -> Cmd err [ListId]
-mkList pId uId = mkNode NodeList pId uId
+      mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId uId
 
 -- | TODO remove defaultList
 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 defaultList cId =
   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 
-mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
-mkNode nt p u = insertNodesR [nodeDefault nt p u]
-
-mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
-mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
-  where
-    nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
-    nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
-      where
-        name = maybe "Board" identity maybeName
-        dashboard = maybe arbitraryDashboard identity maybeDashboard
-        arbitraryDashboard :: HyperdataDashboard 
-        arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
-
 
 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 
--- import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
--- updateNodeUser_fake :: NodeId -> Cmd err Int64
--- updateNodeUser_fake n = updateHyperdata n fake_HyperdataUser
-

src/Gargantext/Database/Query/Tree/Root.hs

@@ -89,7 +89,7 @@ getOrMk_RootWithCorpus user cName c = do
                     c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
                     _tId <- case head c' of
                               Nothing -> pure [0]
-                              Just c'' -> mkNode NodeTexts c'' userId
+                              Just c'' -> insertDefaultNode NodeTexts c'' userId
                     pure c'
 
   corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')