Skip to content

haskell-gargantext
haskell-gargantext
Commit ed24e95d authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[DB-FLOW] functions to create nodeTypes.

parent 8438f4b7
Hide whitespace changes
Inline Side-by-side
Showing with 115 additions and 95 deletions
src/Gargantext/API/Node.hs
View file @ ed24e95d
......@@ -205,7 +205,7 @@ getNodesWith' conn id nodeType offset limit = liftIO (getNodesWith conn id node
getFacet :: Connection -> NodeId -> Maybe Int -> Maybe Int
-> Handler [FacetDoc]
getFacet conn id offset limit = liftIO (putStrLn ( "/facet" :: Text)) >> liftIO (getDocFacet conn NodeCorpus id (Just Document) offset limit)
getFacet conn id offset limit = liftIO (putStrLn ( "/facet" :: Text)) >> liftIO (getDocFacet conn NodeCorpus id (Just NodeDocument) offset limit)
getChart :: Connection -> NodeId -> Maybe UTCTime -> Maybe UTCTime
-> Handler [FacetChart]
......
src/Gargantext/Core/Types/Main.hs
View file @ ed24e95d
......@@ -60,25 +60,21 @@ userTree = TreeN (NodeTree "user name" NodeUser 1) [annuaireTree, projectTree]
-- | Project Tree
projectTree :: Tree NodeTree
projectTree = TreeN (NodeTree "Project CNRS/IMT" Folder 2) [corpusTree 10 "A", corpusTree 20 "B"]
type Individu = Document
projectTree = TreeN (NodeTree "Project CNRS/IMT" NodeFolder 2) [corpusTree 10 "A", corpusTree 20 "B"]
-- | Corpus Tree
annuaireTree :: Tree NodeTree
annuaireTree = (leafT $ NodeTree "Annuaire" Annuaire 41)
annuaireTree = (leafT $ NodeTree "Annuaire" NodeAnnuaire 41)
corpusTree :: NodeId -> Text -> Tree NodeTree
corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT $ NodeTree "Dashboard" Dashboard (nId +1)
, leafT $ NodeTree "Graph" Graph (nId +2)
corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT $ NodeTree "Dashboard" NodeDashboard (nId +1)
, leafT $ NodeTree "Graph" NodeGraph (nId +2)
]
-- <> [ leafT $ NodeTree "My lists" Lists 5]
-- <> [ leafT (NodeTree "Metrics A" Metrics 6) ]
-- <> [ leafT (NodeTree "Class A" Classification 7)]
)
data Parent = NodeType NodeId
--data Classification = Favorites | MyClassifcation
......
src/Gargantext/Database/Bashql.hs
View file @ ed24e95d
......@@ -125,7 +125,7 @@ tree p = do
post :: PWD -> [NodeWrite'] -> Cmd Int64
post [] _ = pure 0
post _ [] = pure 0
post pth ns = Cmd . ReaderT $ mkNode (Just $ last pth) ns
post pth ns = Cmd . ReaderT $ insertNode (Just $ last pth) ns
--postR :: PWD -> [NodeWrite'] -> Cmd [Int]
--postR [] _ _ = pure [0]
......
src/Gargantext/Database/Config.hs
View file @ ed24e95d
......@@ -31,14 +31,13 @@ import Gargantext.Prelude
nodeTypeId :: NodeType -> NodeTypeId
nodeTypeId n =
case n of
NodeUser -> 1
Folder -> 2
--NodeCorpus -> 3
NodeCorpusV3 -> 3
NodeCorpus -> 30
Annuaire -> 31
Document -> 4
UserPage -> 41
NodeUser -> 1
NodeFolder -> 2
NodeCorpusV3 -> 3
NodeCorpus -> 30
NodeAnnuaire -> 31
NodeDocument -> 4
NodeContact -> 41
--NodeSwap -> 19
---- Lists
......@@ -48,10 +47,10 @@ nodeTypeId n =
-- MapList -> 8
---- Scores
Occurrences -> 10
Graph -> 9
Dashboard -> 5
Chart -> 51
NodeOccurrences -> 10
NodeGraph -> 9
NodeDashboard -> 5
NodeChart -> 51
-- Cooccurrences -> 9
--
......@@ -65,14 +64,9 @@ nodeTypeId n =
-- TirankLocal -> 16
-- TirankGlobal -> 17
---- Node management
Favorites -> 15
-- Node management
-- NodeFavorites -> 15
-- Project -> TODO
-- Individu -> TODO
-- Classification -> TODO
-- Lists -> TODO
-- Metrics -> TODO
--
-- | Nodes are typed in the database according to a specific ID
......
src/Gargantext/Database/Facet.hs
View file @ ed24e95d
......@@ -221,13 +221,13 @@ selectDocFacet' :: NodeType -> ParentId -> Maybe NodeType -> Query FacetDocRead
selectDocFacet' _ pId _ = proc () -> do
(n1,(nn,n2)) <- leftJoin3''' -< ()
restrict -< (.&&) (node_parentId n1 .== (toNullable $ pgInt4 pId))
(node_typename n1 .== (pgInt4 $ nodeTypeId Document))
(node_typename n1 .== (pgInt4 $ nodeTypeId NodeDocument))
restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
(isNull $ node_typename n2)
restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
(isNull $ node_parentId n2)
-- restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
-- (isNull $ node_typename n2)
--
-- restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
-- (isNull $ node_parentId n2)
let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
......
src/Gargantext/Database/Flow.hs
View file @ ed24e95d
......@@ -45,7 +45,7 @@ flow = do
masterUser <- runCmd' (getUser "gargantua")
let masterUserId = case masterUser of
Nothing -> panic "no user"
Nothing -> panic "Error: User does not exist (yet)" -- mk NodeUser gargantua_id "Node Gargantua"
Just user -> userLight_id user
root <- map node_id <$> runCmd' (getRoot masterUserId)
......@@ -60,7 +60,6 @@ flow = do
pure ()
{-
rootId <- mk NodeUser gargantua_id "Node Gargantua"
--folderId <- mk Folder parentId (Name "Data") (Descr "All corpora DATA here")
folderId <- mk Folder rootId "Data"
......
src/Gargantext/Database/Node.hs
View file @ ed24e95d
......@@ -89,7 +89,6 @@ type CorpusId = Int
type UserId = NodeId
type TypeId = Int
------------------------------------------------------------------------
instance FromField HyperdataCorpus where
fromField = fromField'
......@@ -99,13 +98,9 @@ instance FromField HyperdataDocument where
instance FromField HyperdataDocumentV3 where
fromField = fromField'
instance FromField HyperdataProject where
fromField = fromField'
instance FromField HyperdataUser where
fromField = fromField'
------------------------------------------------------------------------
instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
queryRunnerColumnDefault = fieldQueryRunnerColumn
......@@ -115,13 +110,9 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3 where
instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataProject where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataUser where
queryRunnerColumnDefault = fieldQueryRunnerColumn
------------------------------------------------------------------------
fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
fromField' field mb = do
......@@ -261,10 +252,10 @@ getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
------------------------------------------------------------------------
getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just Document)
getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just Document)
getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
------------------------------------------------------------------------
......@@ -298,15 +289,58 @@ getNodesWithType conn type_id = do
------------------------------------------------------------------------
-- Quick and dirty
-- WIP
------------------------------------------------------------------------
type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
------------------------------------------------------------------------
defaultUser :: HyperdataUser
defaultUser = HyperdataUser (Just $ (pack . show) EN)
node :: ToJSON a => UserId -> Maybe ParentId -> NodeType -> Text -> Hyperdata a -> NodeWrite'
node userId parentId nodeType name nodeData = Node Nothing typeId userId parentId name Nothing byteData
nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite'
nodeUserW maybeName maybeHyperdata = node NodeUser name (Hyperdata user) Nothing
where
name = maybe "User" identity maybeName
user = maybe defaultUser identity maybeHyperdata
------------------------------------------------------------------------
defaultFolder :: HyperdataFolder
defaultFolder = HyperdataFolder (Just "Markdown Description")
nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite'
nodeFolderW maybeName maybeFolder pid = node NodeFolder name (Hyperdata folder) (Just pid)
where
name = maybe "Folder" identity maybeName
folder = maybe defaultFolder identity maybeFolder
------------------------------------------------------------------------
defaultCorpus :: HyperdataCorpus
defaultCorpus = (HyperdataCorpus (Just "Title") (Just "Descr") (Just "Bool query") (Just "Authors") Nothing)
nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite'
nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name (Hyperdata corpus) (Just pId)
where
name = maybe "Corpus" identity maybeName
corpus = maybe defaultCorpus identity maybeCorpus
------------------------------------------------------------------------
defaultDocument :: HyperdataDocument
defaultDocument = hyperdataDocument
nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite'
nodeDocumentW maybeName maybeDocument cId = node NodeDocument name (Hyperdata doc) (Just cId)
where
name = maybe "Document" identity maybeName
doc = maybe defaultDocument identity maybeDocument
------------------------------------------------------------------------
--defaultAnnuaire :: HyperdataAnnuaire
--defaultAnnuaire = HyperdataAnnuaire
--nodeAnnuaireW
--nodeContactW
------------------------------------------------------------------------
node :: ToJSON a => NodeType -> Name -> Hyperdata a -> Maybe ParentId -> UserId -> NodeWrite'
node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
where
typeId = nodeTypeId nodeType
byteData = DB.pack $ DBL.unpack $ encode $ unHyperdata nodeData
byteData = DB.pack $ DBL.unpack $ encode $ unHyperdata hyperData
node2write :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
......@@ -315,30 +349,27 @@ node2write :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
maybe1 (Column PGInt4), Column PGText, maybe3 (Column PGTimestamptz),
Column PGJsonb)
node2write pid (Node id tn ud _ nm dt hp) = ((pgInt4 <$> id)
,(pgInt4 tn)
,(pgInt4 tn)
,(pgInt4 ud)
,(pgInt4 <$> pid)
,(pgStrictText nm)
,(pgUTCTime <$> dt)
,(pgStrictJSONB hp)
)
------------------------------------------------------------------------
insertNode :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
insertNode pid ns conn = runInsertMany conn nodeTable' $ map (node2write pid) ns
mkNode :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
mkNode pid ns conn = runInsertMany conn nodeTable' $ map (node2write pid) ns
mkNodeR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
mkNodeR pid ns conn = runInsertManyReturning conn nodeTable' (map (node2write pid) ns) (\(i,_,_,_,_,_,_) -> i)
insertNodeR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
insertNodeR pid ns conn = runInsertManyReturning conn nodeTable' (map (node2write pid) ns) (\(i,_,_,_,_,_,_) -> i)
------------------------------------------------------------------------
-- TODO Hierachy of Nodes
-- post and get same types Node' and update if changes
{- TODO semantic to achieve
post c uid pid [ Node' Corpus "name" "{}" []
, Node' Folder "name" "{}" [Node' Corpus "test 2" "" [ Node' Document "title" "metaData" []
, Node' Document "title" "jsonData" []
post c uid pid [ Node' NodeCorpus "name" "{}" []
, Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
, Node' NodeDocument "title" "jsonData" []
]
]
]
......@@ -377,6 +408,9 @@ mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
mkNodeR' :: [NodeWriteT] -> Cmd [Int]
mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
------------------------------------------------------------------------
data NewNode = NewNode { _newNodeId :: Int
, _newNodeChildren :: [Int] }
......@@ -393,26 +427,28 @@ postNode uid pid (Node' NodeCorpus txt v ns) = do
pids <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
pure $ NewNode pid' pids
postNode uid pid (Node' Annuaire txt v ns) = do
NewNode pid' _ <- postNode uid pid (Node' Annuaire txt v [])
postNode uid pid (Node' NodeAnnuaire txt v ns) = do
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"
childWith :: UserId -> ParentId -> Node' -> NodeWriteT
childWith uId pId (Node' Document txt v []) = node2table uId (Just pId) (Node' Document txt v [])
childWith uId pId (Node' UserPage txt v []) = node2table uId (Just pId) (Node' UserPage txt v [])
childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
-- TODO: remove hardcoded userId (with Reader)
-- TODO: user Reader in the API and adapt this function
userId = 1
mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
mk c nt pId name = mk' c nt 1 pId name
mk c nt pId name = mk' c nt userId pId name
mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
mk' c nt uId pId name = map fromIntegral <$> mkNodeR pId [node uId pId nt name hd] c
mk' c nt uId pId name = map fromIntegral <$> insertNodeR pId [node nt name hd pId uId] c
where
hd = Hyperdata (HyperdataUser (Just $ (pack . show) EN))
......
src/Gargantext/Database/Node/Document/Import.hs
View file @ ed24e95d
......@@ -149,7 +149,7 @@ queryInsert = [sql|
prepare :: UserId -> ParentId -> [HyperdataDocument] -> [InputData]
prepare uId pId = map (\h -> InputData tId uId pId (DT.pack "Doc") (toJSON $ addUniqId h))
where
tId = nodeTypeId Document
tId = nodeTypeId NodeDocument
------------------------------------------------------------------------
-- * Main Types used
......
src/Gargantext/Database/Types/Node.hs
View file @ ed24e95d
......@@ -191,10 +191,14 @@ instance Arbitrary Resource where
------------------------------------------------------------------------
data Hyperdata a = Hyperdata { unHyperdata :: a}
data Hyperdata a = Hyperdata { unHyperdata :: a}
$(deriveJSON (unPrefix "") ''Hyperdata)
data HyperdataCorpus = HyperdataCorpus { hyperdataCorpus_resources :: [Resource]
data HyperdataCorpus = HyperdataCorpus { hyperdataCorpus_title :: Maybe Text
, hyperdataCorpus_descr :: Maybe Text
, hyperdataCorpus_query :: Maybe Text
, hyperdataCorpus_authors :: Maybe Text
, hyperdataCorpus_resources :: Maybe [Resource]
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataCorpus_") ''HyperdataCorpus)
......@@ -205,17 +209,11 @@ $(deriveJSON (unPrefix "hyperdataUser_") ''HyperdataUser)
-- Preferences ?
data HyperdataFolder = HyperdataFolder { hyperdataFolder_preferences :: Maybe Text
data HyperdataFolder = HyperdataFolder { hyperdataFolder_descr :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataFolder_") ''HyperdataFolder)
data HyperdataProject = HyperdataProject { hyperdataProject_preferences :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataProject_") ''HyperdataProject)
data HyperdataList = HyperdataList { hyperdataList_preferences :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataList_") ''HyperdataList)
......@@ -225,7 +223,6 @@ data HyperdataScore = HyperdataScore { hyperdataScore_preferences :: Maybe Tex
$(deriveJSON (unPrefix "hyperdataScore_") ''HyperdataScore)
data HyperdataFavorites = HyperdataFavorites { hyperdataFavorites_preferences :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataFavorites_") ''HyperdataFavorites)
......@@ -268,25 +265,23 @@ type NodeName = Text
--type NodeUser = Node HyperdataUser
-- | Then a Node can be either a Folder or a Corpus or a Document
type NodeUser = Node HyperdataUser
type Folder = Node HyperdataFolder
type Project = Node HyperdataProject
type NodeCorpus = Node HyperdataCorpus
type NodeUser = Node HyperdataUser
type NodeFolder = Node HyperdataFolder
type NodeCorpus = Node HyperdataCorpus
type NodeCorpusV3 = Node HyperdataCorpus
type Document = Node HyperdataDocument
type NodeDocument = Node HyperdataDocument
------------------------------------------------------------------------
data NodeType = NodeUser
-- | Project
| Folder
| NodeCorpus | NodeCorpusV3 | Annuaire
| Document -- | Individu
| UserPage | Favorites
| Graph | Dashboard | Chart
| NodeFolder
| NodeCorpus | NodeCorpusV3 | NodeDocument
| NodeAnnuaire | NodeContact
| NodeOccurrences
| NodeGraph
| NodeDashboard | NodeChart
-- | Classification
-- | Lists
-- | Metrics
| Occurrences
deriving (Show, Read, Eq, Generic, Bounded, Enum)
allNodeTypes :: [NodeType]
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment