import Gargantext.Core (Lang(..))
import Gargantext.Core.Types
import Gargantext.Core.Types.Individu (Username)
-import Gargantext.Core.Types.Main (UserId)
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Queries.Filter (limit', offset')
import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
------------------------------------------------------------------------
data NodeError = NoListFound
+ | NoRootFound
+ | NoCorpusFound
+ | NoUserFound
+ | MkNode
+ | UserNoParent
+ | HasParent
+ | ManyParents
+ | NegativeId
+ | NotImplYet
+ | ManyNodeUsers
deriving (Show)
class HasNodeError e where
where
fromField = fromField'
+instance FromField HyperdataListModel
+ where
+ fromField = fromField'
+
instance FromField HyperdataGraph
where
fromField = fromField'
instance FromField HyperdataAnnuaire
where
fromField = fromField'
+
+instance FromField (NodeId, Text)
+ where
+ fromField = fromField'
------------------------------------------------------------------------
instance QueryRunnerColumnDefault PGJsonb HyperdataAny
where
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
+instance QueryRunnerColumnDefault PGJsonb HyperdataListModel
+ where
+ queryRunnerColumnDefault = fieldQueryRunnerColumn
+
instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
-instance QueryRunnerColumnDefault PGInt4 (Maybe NodeParentId)
+instance QueryRunnerColumnDefault PGInt4 (Maybe NodeId)
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
+instance QueryRunnerColumnDefault PGInt4 NodeId
+ where
+ queryRunnerColumnDefault = fieldQueryRunnerColumn
+
+instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
+ where
+ queryRunnerColumnDefault = fieldQueryRunnerColumn
+
+
------------------------------------------------------------------------
-- WIP
-- TODO Classe HasDefault where
------------------------------------------------------------------------
$(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(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
restrict -< _node_id row .== id
returnA -< row
+
+
runGetNodes :: Query NodeRead -> Cmd err [NodeAny]
runGetNodes = runOpaQuery
selectNodesWith' parentId maybeNodeType = proc () -> do
node <- (proc () -> do
row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
- restrict -< parentId' .== (pgInt4 parentId)
+ restrict -< parentId' .== (pgNodeId parentId)
let typeId' = maybe 0 nodeTypeId maybeNodeType
returnA -< row ) -< ()
returnA -< node
-
-deleteNode :: Int -> Cmd err Int
+deleteNode :: NodeId -> Cmd err Int
deleteNode n = mkCmd $ \conn ->
fromIntegral <$> runDelete conn nodeTable
- (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
+ (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
-deleteNodes :: [Int] -> Cmd err Int
+deleteNodes :: [NodeId] -> Cmd err Int
deleteNodes ns = mkCmd $ \conn ->
fromIntegral <$> runDelete conn nodeTable
- (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
+ (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
-- TODO: NodeType should match with `a'
-getNodesWith :: JSONB a => Int -> proxy a -> Maybe NodeType
+getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
-> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
getNodesWith parentId _ nodeType maybeOffset maybeLimit =
runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
-- TODO: Why is the second parameter ignored?
-- TODO: Why not use getNodesWith?
-getNodesWithParentId :: Int -> Maybe Text -> Cmd err [NodeAny]
+getNodesWithParentId :: NodeId -> Maybe Text -> Cmd err [NodeAny]
getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
------------------------------------------------------------------------
-getDocumentsV3WithParentId :: Int -> Cmd err [Node HyperdataDocumentV3]
+getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
-getDocumentsWithParentId :: Int -> Cmd err [Node HyperdataDocument]
+getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
-getListsWithParentId :: Int -> Cmd err [Node HyperdataList]
+getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
-getCorporaWithParentId :: Int -> Cmd err [Node HyperdataCorpus]
+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)
------------------------------------------------------------------------
-selectNodesWithParentID :: Int -> Query NodeRead
+selectNodesWithParentID :: NodeId -> Query NodeRead
selectNodesWithParentID n = proc () -> do
row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
- restrict -< parent_id .== (pgInt4 n)
+ restrict -< parent_id .== (pgNodeId n)
returnA -< row
selectNodesWithType :: Column PGInt4 -> Query NodeRead
type JSONB = QueryRunnerColumnDefault PGJsonb
-getNode :: JSONB a => Int -> proxy a -> Cmd err (Node a)
-getNode id _ = do
- fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runOpaQuery (limit 1 $ selectNode (pgInt4 id))
+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))
getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
getNodesWithType = runOpaQuery . selectNodesWithType
where
name = maybe "Annuaire" identity maybeName
annuaire = maybe defaultAnnuaire identity maybeAnnuaire
- --------------------------
------------------------------------------------------------------------
arbitraryList :: HyperdataList
name = maybe "Listes" identity maybeName
list = maybe arbitraryList identity maybeList
+ --------------------
+
+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 "List Model" identity maybeName
+ list = maybe arbitraryListModel identity maybeListModel
+
------------------------------------------------------------------------
arbitraryGraph :: HyperdataGraph
arbitraryGraph = HyperdataGraph (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) (pgInt4 <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
+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
-insertNodesR :: [NodeWrite] -> Cmd err [Int]
+insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
insertNodesR ns = mkCmd $ \conn ->
- runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ __) -> i)) Nothing)
+ runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
-insertNodesWithParent pid ns = insertNodes (set node_parentId (pgInt4 <$> pid) <$> ns)
+insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
-insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [Int]
-insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgInt4 <$> pid) <$> ns)
+insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
+insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
------------------------------------------------------------------------
-- TODO Hierachy of Nodes
-- post and get same types Node' and update if changes
------------------------------------------------------------------------
-- TODO
--- currently this function remove the child relation
+-- currently this function removes the child relation
-- needs a Temporary type between Node' and NodeWriteT
node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
-node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4$ nodeTypeId nt) (pgInt4 uid) (fmap pgInt4 pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
+node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
mkNode :: [NodeWrite] -> Cmd err Int64
mkNode ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
-mkNodeR :: [NodeWrite] -> Cmd err [Int]
+mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
------------------------------------------------------------------------
-data NewNode = NewNode { _newNodeId :: Int
- , _newNodeChildren :: [Int] }
+data NewNode = NewNode { _newNodeId :: NodeId
+ , _newNodeChildren :: [NodeId] }
--- | postNode
-postNode :: UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
+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
- [pid] -> pure $ NewNode pid []
- _ -> panic "postNode: only one pid expected"
+ [pid'] -> pure $ NewNode pid' []
+ _ -> nodeError ManyParents
postNode uid pid (Node' NodeCorpus txt v ns) = do
NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
pure $ NewNode pid' pids
-postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implemented yet"
+postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
childWith :: UserId -> ParentId -> Node' -> NodeWrite
childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
+type Name = Text
-mk :: NodeType -> Maybe ParentId -> Text -> Cmd err [Int]
-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
+mkNodeWithParent NodeUser Nothing uId name =
+ insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
+ where
+ hd = HyperdataUser . Just . pack $ show EN
+mkNodeWithParent _ Nothing _ _ = nodeError HasParent
+mkNodeWithParent _ _ _ _ = nodeError NotImplYet
-mk' :: NodeType -> UserId -> Maybe ParentId -> Text -> Cmd err [Int]
-mk' nt uId pId name = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId]
+
+mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
+mkRoot uname uId = case uId > 0 of
+ False -> nodeError NegativeId
+ True -> mkNodeWithParent NodeUser Nothing uId uname
+
+-- |
+-- 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
- hd = HyperdataUser . Just . pack $ show EN
+ mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
-type Name = Text
+instance MkCorpus HyperdataCorpus
+ where
+ mk n h p u = insertNodesR [nodeCorpusW n h p u]
-mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [Int]
-mk'' NodeUser Nothing uId name = mk' NodeUser uId Nothing name
-mk'' NodeUser _ _ _ = panic "NodeUser do not have any parent"
-mk'' _ Nothing _ _ = panic "NodeType does have a parent"
-mk'' nt pId uId name = mk' nt uId pId name
-mkRoot :: Username -> UserId -> Cmd err [Int]
-mkRoot uname uId = case uId > 0 of
- False -> panic "UserId <= 0"
- True -> mk'' NodeUser Nothing uId uname
+instance MkCorpus HyperdataAnnuaire
+ where
+ mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
-mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd err [Int]
-mkCorpus n h p u = insertNodesR [nodeCorpusW n h p u]
-getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err Int
+getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
getOrMkList pId uId =
- defaultList pId
- `catchNodeError`
- (\NoListFound -> maybe (nodeError NoListFound) pure . headMay =<< mkList 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
+-- | 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 [Int]
+mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
-mkGraph :: ParentId -> UserId -> Cmd err [Int]
+mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
-mkDashboard :: ParentId -> UserId -> Cmd err [Int]
+mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
-mkAnnuaire :: ParentId -> UserId -> Cmd err [Int]
-mkAnnuaire p u = insertNodesR [nodeAnnuaireW Nothing Nothing p u]
-
-- | Default CorpusId Master and ListId Master
+pgNodeId :: NodeId -> Column PGInt4
+pgNodeId = pgInt4 . id2int