{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
module Gargantext.Database.Schema.Node where
import Data.Aeson
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
-import Data.Text (Text, pack)
+import Data.Text (Text)
import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import GHC.Int (Int64)
-import Gargantext.Core (Lang(..))
import Gargantext.Core.Types
import Gargantext.Core.Types.Individu (Username)
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Queries.Filter (limit', offset')
-import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
+import Gargantext.Database.Types.Node (NodeType(..), defaultCorpus, Hyperdata, HyperData(..))
+import Gargantext.Database.Node.User (HyperdataUser(..), fake_HyperdataUser)
+import Gargantext.Database.Node.Contact (HyperdataContact(..), arbitraryHyperdataContact)
import Gargantext.Database.Utils
import Gargantext.Prelude hiding (sum, head)
+import Gargantext.Viz.Graph (HyperdataGraph(..))
+
import Opaleye hiding (FromField)
import Opaleye.Internal.QueryArr (Query)
import Prelude hiding (null, id, map, sum)
where
fromField = fromField'
-instance FromField HyperdataUser
+instance FromField HyperData
where
fromField = fromField'
-instance FromField HyperdataList
+instance FromField HyperdataListModel
where
fromField = fromField'
where
fromField = fromField'
+instance FromField HyperdataPhylo
+ where
+ fromField = fromField'
+
instance FromField HyperdataAnnuaire
where
fromField = fromField'
+
+instance FromField HyperdataList
+ where
+ fromField = fromField'
+
+instance FromField (NodeId, Text)
+ where
+ fromField = fromField'
------------------------------------------------------------------------
instance QueryRunnerColumnDefault PGJsonb HyperdataAny
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
+instance QueryRunnerColumnDefault PGJsonb HyperdataList
+ where
+ queryRunnerColumnDefault = fieldQueryRunnerColumn
+
+instance QueryRunnerColumnDefault PGJsonb HyperData
+ where
+ queryRunnerColumnDefault = fieldQueryRunnerColumn
+
+
instance QueryRunnerColumnDefault PGJsonb HyperdataDocument
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
-instance QueryRunnerColumnDefault PGJsonb HyperdataUser
+instance QueryRunnerColumnDefault PGJsonb HyperdataListModel
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
-instance QueryRunnerColumnDefault PGJsonb HyperdataList
+instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
-instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
+instance QueryRunnerColumnDefault PGJsonb HyperdataPhylo
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
+instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
+ where
+ queryRunnerColumnDefault = fieldQueryRunnerColumn
+
-------------------------------------------------------------------------
--- WIP
--- TODO Classe HasDefault where
--- default NodeType = Hyperdata
------------------------------------------------------------------------
$(makeAdaptorAndInstance "pNode" ''NodePoly)
$(makeLensesWith abbreviatedFields ''NodePoly)
+
$(makeAdaptorAndInstance "pNodeSearch" ''NodePolySearch)
$(makeLensesWith abbreviatedFields ''NodePolySearch)
-type NodeWrite = NodePoly (Maybe (Column PGInt4 ))
- (Column PGInt4 )
- (Column PGInt4 )
- (Maybe (Column PGInt4 ))
- (Column PGText )
- (Maybe (Column PGTimestamptz))
- (Column PGJsonb )
-
-type NodeRead = NodePoly (Column PGInt4 )
- (Column PGInt4 )
- (Column PGInt4 )
- (Column PGInt4 )
- (Column PGText )
- (Column PGTimestamptz )
- (Column PGJsonb )
-
-type NodeReadNull = NodePoly (Column (Nullable PGInt4 ))
- (Column (Nullable PGInt4 ))
- (Column (Nullable PGInt4 ))
- (Column (Nullable PGInt4 ))
- (Column (Nullable PGText ))
- (Column (Nullable PGTimestamptz ))
- (Column (Nullable PGJsonb))
+type NodeWrite = NodePoly (Maybe (Column PGInt4) )
+ (Column PGInt4)
+ (Column PGInt4)
+ (Maybe (Column PGInt4) )
+ (Column PGText)
+ (Maybe (Column PGTimestamptz))
+ (Column PGJsonb)
+
+type NodeRead = NodePoly (Column PGInt4 )
+ (Column PGInt4 )
+ (Column PGInt4 )
+ (Column PGInt4 )
+ (Column PGText )
+ (Column PGTimestamptz )
+ (Column PGJsonb )
+
+type NodeReadNull = NodePoly (Column (Nullable PGInt4))
+ (Column (Nullable PGInt4))
+ (Column (Nullable PGInt4))
+ (Column (Nullable PGInt4))
+ (Column (Nullable PGText))
+ (Column (Nullable PGTimestamptz))
+ (Column (Nullable PGJsonb))
nodeTable :: Table NodeWrite NodeRead
nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
, _node_typename = required "typename"
, _node_userId = required "user_id"
-
+
, _node_parentId = optional "parent_id"
, _node_name = required "name"
, _node_date = optional "date"
-
+
, _node_hyperdata = required "hyperdata"
}
)
------------------------------------------------------------------------
-- | Node(Read|Write)Search is slower than Node(Write|Read) use it
-- for full text search only
-type NodeSearchWrite = NodePolySearch (Maybe (Column PGInt4 ))
- (Column PGInt4 )
- (Column PGInt4 )
- (Column (Nullable PGInt4 ))
- (Column (PGText ))
- (Maybe (Column PGTimestamptz))
- (Column PGJsonb )
- (Maybe (Column PGTSVector))
-
-type NodeSearchRead = NodePolySearch (Column PGInt4 )
- (Column PGInt4 )
- (Column PGInt4 )
- (Column (Nullable PGInt4 ))
- (Column (PGText ))
- (Column PGTimestamptz )
- (Column PGJsonb)
- (Column PGTSVector)
-
-type NodeSearchReadNull = NodePolySearch (Column (Nullable PGInt4 ))
- (Column (Nullable PGInt4 ))
- (Column (Nullable PGInt4 ))
- (Column (Nullable PGInt4 ))
- (Column (Nullable PGText ))
- (Column (Nullable PGTimestamptz ))
- (Column (Nullable PGJsonb))
- (Column (Nullable PGTSVector))
-
---{-
+type NodeSearchWrite =
+ NodePolySearch
+ (Maybe (Column PGInt4) )
+ (Column PGInt4 )
+ (Column PGInt4 )
+ (Column (Nullable PGInt4) )
+ (Column PGText )
+ (Maybe (Column PGTimestamptz))
+ (Column PGJsonb )
+ (Maybe (Column PGTSVector) )
+
+type NodeSearchRead =
+ NodePolySearch
+ (Column PGInt4 )
+ (Column PGInt4 )
+ (Column PGInt4 )
+ (Column (Nullable PGInt4 ))
+ (Column PGText )
+ (Column PGTimestamptz )
+ (Column PGJsonb )
+ (Column PGTSVector )
+
+type NodeSearchReadNull =
+ NodePolySearch
+ (Column (Nullable PGInt4) )
+ (Column (Nullable PGInt4) )
+ (Column (Nullable PGInt4) )
+ (Column (Nullable PGInt4) )
+ (Column (Nullable PGText) )
+ (Column (Nullable PGTimestamptz))
+ (Column (Nullable PGJsonb) )
+ (Column (Nullable PGTSVector) )
+
nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id = optional "id"
, _ns_typename = required "typename"
, _ns_userId = required "user_id"
-
+
, _ns_parentId = required "parent_id"
, _ns_name = required "name"
, _ns_date = optional "date"
-
+
, _ns_hyperdata = required "hyperdata"
, _ns_search = optional "search"
}
)
---}
+
queryNodeSearchTable :: Query NodeSearchRead
queryNodeSearchTable = queryTable nodeTableSearch
restrict -< _node_id row .== id
returnA -< row
-runGetNodes :: Query NodeRead -> Cmd err [NodeAny]
+
+
+runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
runGetNodes = runOpaQuery
------------------------------------------------------------------------
------------------------------------------------------------------------
-
-- | order by publication date
-- Favorites (Bool), node_ngrams
selectNodesWith :: ParentId -> Maybe NodeType
returnA -< row ) -< ()
returnA -< node
-
deleteNode :: NodeId -> Cmd err Int
deleteNode n = mkCmd $ \conn ->
fromIntegral <$> runDelete conn nodeTable
-- TODO: Why is the second parameter ignored?
-- TODO: Why not use getNodesWith?
-getNodesWithParentId :: NodeId -> Maybe Text -> Cmd err [NodeAny]
-getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
+getNodesWithParentId :: (Hyperdata a, QueryRunnerColumnDefault PGJsonb a)
+ => Maybe NodeId
+ -> Cmd err [Node a]
+getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
+ where
+ n' = case n of
+ Just n'' -> n''
+ Nothing -> 0
------------------------------------------------------------------------
getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
-getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
-getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
+getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
+getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
type JSONB = QueryRunnerColumnDefault PGJsonb
-getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
-getNode nId _ = do
- fromMaybe (error $ "Node does node exist: " <> show nId) . headMay <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
+
+getNode :: NodeId -> Cmd err (Node Value)
+getNode nId = fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
+ <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
+
+getNodeWith :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
+getNodeWith nId _ = do
+ fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
+ <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
+
+getNodeUser :: NodeId -> Cmd err (Node HyperdataUser)
+getNodeUser nId = do
+ fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
+ <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
+
+
+getNodePhylo :: NodeId -> Cmd err (Node HyperdataPhylo)
+getNodePhylo nId = do
+ fromMaybe (error $ "Node Phylo does not exist: " <> show nId) . headMay
+ <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
+
getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
getNodesWithType = runOpaQuery . selectNodesWithType
------------------------------------------------------------------------
-------------------------------------------------------------------------
-defaultUser :: HyperdataUser
-defaultUser = HyperdataUser (Just $ (pack . show) EN)
-
nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
where
name = maybe "User" identity maybeName
- user = maybe defaultUser identity maybeHyperdata
+ user = maybe fake_HyperdataUser identity maybeHyperdata
+
+nodeContactW :: Maybe Name -> Maybe HyperdataContact
+ -> AnnuaireId -> UserId -> NodeWrite
+nodeContactW maybeName maybeContact aId =
+ node NodeContact name contact (Just aId)
+ where
+ name = maybe "Contact" identity maybeName
+ contact = maybe arbitraryHyperdataContact identity maybeContact
------------------------------------------------------------------------
-defaultFolder :: HyperdataFolder
-defaultFolder = HyperdataFolder (Just "Markdown Description")
+defaultFolder :: HyperdataCorpus
+defaultFolder = defaultCorpus
-nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite
+nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
where
name = maybe "Folder" identity maybeName
where
name = maybe "Annuaire" identity maybeName
annuaire = maybe defaultAnnuaire identity maybeAnnuaire
- --------------------------
------------------------------------------------------------------------
-arbitraryList :: HyperdataList
-arbitraryList = HyperdataList (Just "Preferences")
-nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
-nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
+{-
+class IsNodeDb a where
+ data Node'' a :: *
+ data Hyper a :: *
+
+instance IsNodeDb NodeType where
+ data
+
+instance HasHyperdata NodeType where
+ data Hyper NodeType = HyperList HyperdataList
+ | HyperCorpus HyperdataCorpus
+
+ hasHyperdata nt = case nt of
+ NodeList -> HyperList $ HyperdataList (Just "list")
+
+ unHyper h = case h of
+ HyperList h' -> h'
+
+--}
+
+
+class HasDefault a where
+ hasDefaultData :: a -> HyperData
+ hasDefaultName :: a -> Text
+
+instance HasDefault NodeType where
+ hasDefaultData nt = case nt of
+ NodeTexts -> HyperdataTexts (Just "Preferences")
+ NodeList -> HyperdataList' (Just "Preferences")
+ NodeListCooc -> HyperdataList' (Just "Preferences")
+ _ -> undefined
+ --NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
+
+ hasDefaultName nt = case nt of
+ NodeTexts -> "Texts"
+ NodeList -> "Lists"
+ NodeListCooc -> "Cooc"
+ _ -> undefined
+
+------------------------------------------------------------------------
+
+nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
+nodeDefault nt parent = node nt name hyper (Just parent)
+ where
+ name = (hasDefaultName nt)
+ hyper = (hasDefaultData nt)
+
+------------------------------------------------------------------------
+arbitraryListModel :: HyperdataListModel
+arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
+
+mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
+mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
+
+nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
+nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
where
- name = maybe "Listes" identity maybeName
- list = maybe arbitraryList identity maybeList
+ name = maybe "List Model" identity maybeName
+ list = maybe arbitraryListModel identity maybeListModel
------------------------------------------------------------------------
arbitraryGraph :: HyperdataGraph
-arbitraryGraph = HyperdataGraph (Just "Preferences")
+arbitraryGraph = HyperdataGraph Nothing
nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
name = maybe "Graph" identity maybeName
graph = maybe arbitraryGraph identity maybeGraph
-------------------------------------------------------------------------
+mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
+mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
-arbitraryDashboard :: HyperdataDashboard
-arbitraryDashboard = HyperdataDashboard (Just "Preferences")
+insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
+insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
+
+------------------------------------------------------------------------
+arbitraryPhylo :: HyperdataPhylo
+arbitraryPhylo = HyperdataPhylo Nothing Nothing
-nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
-nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
+nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
+nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
where
- name = maybe "Dashboard" identity maybeName
- dashboard = maybe arbitraryDashboard identity maybeDashboard
+ name = maybe "Phylo" identity maybeName
+ graph = maybe arbitraryPhylo identity maybePhylo
+
------------------------------------------------------------------------
+arbitraryDashboard :: HyperdataDashboard
+arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
+------------------------------------------------------------------------
+
node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
-node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
- where
- typeId = nodeTypeId nodeType
+node nodeType name hyperData parentId userId =
+ Node Nothing
+ (pgInt4 typeId)
+ (pgInt4 userId)
+ (pgNodeId <$> parentId)
+ (pgStrictText name)
+ Nothing
+ (pgJSONB $ cs $ encode hyperData)
+ where
+ typeId = nodeTypeId nodeType
-------------------------------
insertNodes :: [NodeWrite] -> Cmd err Int64
-insertNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
+insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
insertNodesR ns = mkCmd $ \conn ->
, _n_children :: [Node']
} deriving (Show)
-mkNode :: [NodeWrite] -> Cmd err Int64
-mkNode ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
+mkNodes :: [NodeWrite] -> Cmd err Int64
+mkNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
-mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
+mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
------------------------------------------------------------------------
, _newNodeChildren :: [NodeId] }
postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
+
postNode uid pid (Node' nt txt v []) = do
pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
case pids of
NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
pure $ NewNode pid' pids
+
+postNode uid pid (Node' NodeDashboard txt v ns) = do
+ NewNode pid' _ <- postNode uid pid (Node' NodeDashboard txt v [])
+ pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
+ pure $ NewNode pid' pids
+
postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
--- | TODO Use right userId
-mk :: NodeType -> Maybe ParentId -> Text -> Cmd err [NodeId]
-mk nt pId name = mk' nt userId pId name
- where
- userId = 1
+-- =================================================================== --
+------------------------------------------------------------------------
+-- | TODO mk all others nodes
+mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
+mkNodeWithParent NodeUser (Just _) _ _ = nodeError UserNoParent
-mk' :: NodeType -> UserId -> Maybe ParentId -> Text -> Cmd err [NodeId]
-mk' nt uId pId name = insertNodesWithParentR pId [node nt name hd pId uId]
- where
- hd = HyperdataUser . Just . pack $ show EN
+------------------------------------------------------------------------
+mkNodeWithParent NodeUser Nothing uId name =
+ insertNodesWithParentR Nothing [node NodeUser name fake_HyperdataUser Nothing uId]
+
+mkNodeWithParent _ Nothing _ _ = nodeError HasParent
+------------------------------------------------------------------------
+mkNodeWithParent NodeFolder (Just i) uId name =
+ insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId]
+ where
+ hd = defaultFolder
+
+mkNodeWithParent NodeFolderPrivate (Just i) uId _ =
+ insertNodesWithParentR (Just i) [node NodeFolderPrivate "Private" hd Nothing uId]
+ where
+ hd = defaultFolder
+
+mkNodeWithParent NodeFolderShared (Just i) uId _ =
+ insertNodesWithParentR (Just i) [node NodeFolderShared "Shared" hd Nothing uId]
+ where
+ hd = defaultFolder
+
+mkNodeWithParent NodeFolderPublic (Just i) uId _ =
+ insertNodesWithParentR (Just i) [node NodeFolderPublic "Public" hd Nothing uId]
+ where
+ hd = defaultFolder
+
+mkNodeWithParent NodeTeam (Just i) uId _ =
+ insertNodesWithParentR (Just i) [node NodeTeam "Team" hd Nothing uId]
+ where
+ hd = defaultFolder
+------------------------------------------------------------------------
+mkNodeWithParent NodeCorpus (Just i) uId name =
+ insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId]
+ where
+ hd = defaultCorpus
+
+mkNodeWithParent NodeAnnuaire (Just i) uId name =
+ insertNodesWithParentR (Just i) [node NodeAnnuaire name hd Nothing uId]
+ where
+ hd = defaultAnnuaire
+
+mkNodeWithParent _ _ _ _ = nodeError NotImplYet
+------------------------------------------------------------------------
+-- =================================================================== --
-type Name = Text
-mk'' :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
-mk'' NodeUser Nothing uId name = mk' NodeUser uId Nothing name
-mk'' NodeUser _ _ _ = nodeError UserNoParent
-mk'' _ Nothing _ _ = nodeError HasParent
-mk'' nt pId uId name = mk' nt uId pId name
mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
mkRoot uname uId = case uId > 0 of
False -> nodeError NegativeId
- True -> mk'' NodeUser Nothing uId uname
+ True -> do
+ rs <- mkNodeWithParent NodeUser Nothing uId uname
+ _ <- case rs of
+ [r] -> do
+ _ <- mkNodeWithParent NodeFolderPrivate (Just r) uId uname
+ _ <- mkNodeWithParent NodeFolderShared (Just r) uId uname
+ _ <- mkNodeWithParent NodeFolderPublic (Just r) uId uname
+ pure rs
+ _ -> pure rs
+ pure rs
+
+-- |
+-- CorpusDocument is a corpus made from a set of documents
+-- CorpusContact is a corpus made from a set of contacts (syn of Annuaire)
+data CorpusType = CorpusDocument | CorpusContact
+
+class MkCorpus a
+ where
+ mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
+
+instance MkCorpus HyperdataCorpus
+ where
+ mk n h p u = insertNodesR [nodeCorpusW n h p u]
-mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd err [CorpusId]
-mkCorpus n h p u = insertNodesR [nodeCorpusW n h p u]
-getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err NodeId
+instance MkCorpus HyperdataAnnuaire
+ where
+ mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
+
+
+getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
getOrMkList pId uId =
maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
where
- mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkList pId uId
+ mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode 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
-mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
-mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
-
-mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
-mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
+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
+
-mkAnnuaire :: ParentId -> UserId -> Cmd err [NodeId]
-mkAnnuaire p u = insertNodesR [nodeAnnuaireW Nothing Nothing p u]
+mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
+mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
-- | Default CorpusId Master and ListId Master
pgNodeId :: NodeId -> Column PGInt4
pgNodeId = pgInt4 . id2int
+
+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
+
+