Skip to content

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

[Graph] missing files and default graph.

parent 3c69e15f
Hide whitespace changes
Inline Side-by-side
Showing with 127 additions and 60 deletions
src/Gargantext/API/Auth.hs
View file @ c2bfe19e
......@@ -34,7 +34,7 @@ import Data.Text (Text, reverse)
import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Node (getRootUsername)
import Gargantext.Database.Root (getRoot)
import Gargantext.Database.Types.Node (NodePoly(_node_id))
import Gargantext.Prelude hiding (reverse)
import Test.QuickCheck (elements, oneof)
......@@ -86,7 +86,7 @@ checkAuthRequest u p c
| not (u `elem` arbitraryUsername) = pure InvalidUser
| u /= reverse p = pure InvalidPassword
| otherwise = do
muId <- getRootUsername u c
muId <- getRoot u c
pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
auth' :: Connection -> AuthRequest -> IO AuthResponse
......
src/Gargantext/API/Node.hs
View file @ c2bfe19e
......@@ -61,12 +61,12 @@ import Gargantext.Database.Facet (FacetDoc , runViewDocuments', OrderBy(..)
import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
import Gargantext.Database.NodeNode (nodesToFavorite, nodesToTrash)
-- Graph
import Gargantext.Text.Flow
import Gargantext.Viz.Graph (Graph)
import Gargantext.Core (Lang(..))
--import Gargantext.Text.Flow
import Gargantext.Viz.Graph (Graph,readGraphFromJson,defaultGraph)
-- import Gargantext.Core (Lang(..))
import Gargantext.Core.Types (Offset, Limit)
import Gargantext.Core.Types.Main (Tree, NodeTree, ListId)
import Gargantext.Text.Terms (TermType(..))
-- import Gargantext.Text.Terms (TermType(..))
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
......@@ -238,7 +238,10 @@ type ChartApi = Summary " Chart API"
------------------------------------------------------------------------
type GraphAPI = Get '[JSON] Graph
graphAPI :: Connection -> NodeId -> Server GraphAPI
graphAPI _ _ = liftIO $ textFlow (Mono EN) (Contexts contextText)
graphAPI _ _ = do
liftIO $ maybe defaultGraph identity <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
-- t <- textFlow (Mono EN) (Contexts contextText)
-- liftIO $ liftIO $ pure $ maybe t identity maybeGraph
-- TODO what do we get about the node? to replace contextText
-- TODO(orphan): There should be a proper APIError data type with a case TreeError.
......
src/Gargantext/Core/Types/Individu.hs 0 → 100644
View file @ c2bfe19e
{-|
Module : Gargantext.Core.Types.Individu
Description : Short description
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Individu defintions
-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Gargantext.Core.Types.Individu
where
import Data.Text (Text)
type Username = Text
src/Gargantext/Database/Flow.hs
View file @ c2bfe19e
......@@ -28,7 +28,8 @@ import Gargantext.Core.Types (NodePoly(..), ListType(..), listTypeId)
import Gargantext.Database.Bashql (runCmd') -- , del)
import Gargantext.Database.Config (userMaster, userArbitrary, corpusMasterName)
import Gargantext.Database.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT, ngramsTypeId, NgramsType(..), text2ngrams)
import Gargantext.Database.Node (getRoot, mkRoot, mkCorpus, Cmd(..), mkList, mkGraph, mkDashboard, mkAnnuaire)
import Gargantext.Database.Node (mkRoot, mkCorpus, Cmd(..), mkList, mkGraph, mkDashboard, mkAnnuaire)
import Gargantext.Database.Root (getRootCmd)
import Gargantext.Database.Types.Node (NodeType(..))
import Gargantext.Database.Node.Document.Add (add)
import Gargantext.Database.Node.Document.Insert (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
......@@ -36,7 +37,8 @@ import Gargantext.Database.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
import Gargantext.Database.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
import Gargantext.Database.Types.Node (HyperdataDocument(..))
--import Gargantext.Database.Node.Contact (HyperdataContact(..))
import Gargantext.Database.User (getUser, UserLight(..), Username)
import Gargantext.Database.User (getUser, UserLight(..))
import Gargantext.Core.Types.Individu (Username)
import Gargantext.Ext.IMT (toSchoolName)
import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
import Gargantext.Prelude
......@@ -149,7 +151,7 @@ subFlowCorpus username cName = do
-- mk NodeUser gargantua_id "Node Gargantua"
Just user -> userLight_id user
rootId' <- map _node_id <$> runCmd' (getRoot userId)
rootId' <- map _node_id <$> runCmd' (getRootCmd username)
rootId'' <- case rootId' of
[] -> runCmd' (mkRoot username userId)
......@@ -175,7 +177,7 @@ subFlowAnnuaire username _cName = do
-- mk NodeUser gargantua_id "Node Gargantua"
Just user -> userLight_id user
rootId' <- map _node_id <$> runCmd' (getRoot userId)
rootId' <- map _node_id <$> runCmd' (getRootCmd username)
rootId'' <- case rootId' of
[] -> runCmd' (mkRoot username userId)
......
src/Gargantext/Database/Ngrams.hs
View file @ c2bfe19e
......@@ -40,7 +40,8 @@ import GHC.Generics (Generic)
import Gargantext.Core.Types -- (fromListTypeId, ListType, NodePoly(Node))
import Gargantext.Database.Config (nodeTypeId,userMaster)
import Gargantext.Database.Types.Node (NodeType)
import Gargantext.Database.Node (mkCmd, Cmd(..),getRootUsername)
import Gargantext.Database.Node (mkCmd, Cmd(..))
import Gargantext.Database.Root (getRoot)
import Gargantext.Database.Tree (dbTree, toNodeTree)
import Gargantext.Core.Types.Main (NodeTree(..))
import Gargantext.Prelude
......@@ -192,7 +193,7 @@ getNgramsTableDb :: DPS.Connection
-> IO ([NgramsTableData], MapToParent, MapToChildren)
getNgramsTableDb c nt ngrt ntp@(NgramsTableParam listIdUser _) = do
let lieu = "Garg.Db.Ngrams.getTableNgrams: "
maybeRoot <- head <$> getRootUsername userMaster c
maybeRoot <- head <$> getRoot userMaster c
let masterRootId = maybe (panic $ lieu <> "no userMaster Tree") (view node_id) maybeRoot
tree <- map toNodeTree <$> dbTree c masterRootId
let maybeCorpus = head $ filter (\n -> _nt_type n == NodeCorpus) tree
......
src/Gargantext/Database/Node.hs
View file @ c2bfe19e
......@@ -35,6 +35,7 @@ import Prelude hiding (null, id, map, sum)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types
import Gargantext.Core.Types.Individu (Username)
import Gargantext.Database.Utils (fromField')
import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
import Gargantext.Database.Queries
......@@ -205,26 +206,6 @@ runGetNodes :: Query NodeRead -> Cmd [NodeAny]
runGetNodes q = mkCmd $ \conn -> runQuery conn q
------------------------------------------------------------------------
selectRootUsername :: Username -> Query NodeRead
selectRootUsername username = proc () -> do
row <- queryNodeTable -< ()
restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
restrict -< _node_name row .== (pgStrictText username)
returnA -< row
getRootUsername :: Username -> Connection -> IO [Node HyperdataUser]
getRootUsername uname conn = runQuery conn (selectRootUsername uname)
------------------------------------------------------------------------
selectRootUser :: UserId -> Query NodeRead
selectRootUser userId = proc () -> do
row <- queryNodeTable -< ()
restrict -< _node_userId row .== (pgInt4 userId)
restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
returnA -< row
getRoot :: UserId -> Cmd [Node HyperdataUser]
getRoot userId = mkCmd $ \conn -> runQuery conn (selectRootUser userId)
------------------------------------------------------------------------
-- | order by publication date
......@@ -537,7 +518,6 @@ mk'' NodeUser _ _ _ = panic "NodeUser do not have any parent"
mk'' _ Nothing _ _ = panic "NodeType does have a parent"
mk'' nt pId uId name = mkCmd $ \c -> mk' c nt uId pId name
type Username = Text
mkRoot :: Username -> UserId -> Cmd [Int]
mkRoot uname uId = case uId > 0 of
......
src/Gargantext/Database/Root.hs 0 → 100644
View file @ c2bfe19e
{-|
Module : Gargantext.Database.Root
Description : Main requests to get root of users
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Root where
import Database.PostgreSQL.Simple (Connection)
import Opaleye (restrict, (.==), Query, runQuery)
import Opaleye.PGTypes (pgStrictText, pgInt4)
import Control.Arrow (returnA)
import Gargantext.Prelude
import Gargantext.Database.Types.Node (Node, NodePoly(..), NodeType(NodeUser), HyperdataUser)
import Gargantext.Database.Queries (NodeRead)
import Gargantext.Database.Node (queryNodeTable)
import Gargantext.Database.User (queryUserTable, UserPoly(..))
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Core.Types.Individu (Username)
import Gargantext.Database.Node (Cmd(..), mkCmd)
getRootCmd :: Username -> Cmd [Node HyperdataUser]
getRootCmd u = mkCmd $ \c -> getRoot u c
getRoot :: Username -> Connection -> IO [Node HyperdataUser]
getRoot uname conn = runQuery conn (selectRoot uname)
selectRoot :: Username -> Query NodeRead
selectRoot username = proc () -> do
row <- queryNodeTable -< ()
users <- queryUserTable -< ()
restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
restrict -< user_username users .== (pgStrictText username)
restrict -< _node_userId row .== (user_id users)
returnA -< row
src/Gargantext/Database/User.hs
View file @ c2bfe19e
......@@ -32,6 +32,7 @@ import Data.Text (Text)
import Data.Time (UTCTime)
import GHC.Show(Show(..))
import Gargantext.Database.Node (Cmd(..), mkCmd, runCmd)
import Gargantext.Core.Types.Individu (Username)
import Gargantext.Prelude
import Opaleye
......@@ -139,7 +140,6 @@ users = mkCmd $ \conn -> runQuery conn queryUserTable
usersLight :: Cmd [UserLight]
usersLight = mkCmd $ \conn -> map toUserLight <$> runQuery conn queryUserTable
type Username = Text
getUser :: Username -> Cmd (Maybe UserLight)
getUser u = mkCmd $ \c -> userLightWithUsername u <$> runCmd c usersLight
......
src/Gargantext/Viz/Graph.hs
View file @ c2bfe19e
......@@ -83,39 +83,42 @@ instance ToSchema Attributes
instance ToSchema Edge
instance ToSchema Graph
defaultGraph :: Graph
defaultGraph = Graph {graph_nodes = [Node {node_size = 4, node_type = Terms, node_id = pack "0", node_label = pack "animal", node_attributes = Attributes {clust_default = 0}},Node {node_size = 3, node_type = Terms, node_id = pack "1", node_label = pack "bird", node_attributes = Attributes {clust_default = 0}},Node {node_size = 2, node_type = Terms, node_id = pack "2", node_label = pack "boy", node_attributes = Attributes {clust_default = 1}},Node {node_size = 2, node_type = Terms, node_id = pack "3", node_label = pack "dog", node_attributes = Attributes {clust_default = 0}},Node {node_size = 2, node_type = Terms, node_id = pack "4", node_label = pack "girl", node_attributes = Attributes {clust_default = 1}},Node {node_size = 4, node_type = Terms, node_id = pack "5", node_label = pack "human body", node_attributes = Attributes {clust_default = 1}},Node {node_size = 3, node_type = Terms, node_id = pack "6", node_label = pack "object", node_attributes = Attributes {clust_default = 2}},Node {node_size = 2, node_type = Terms, node_id = pack "7", node_label = pack "pen", node_attributes = Attributes {clust_default = 2}},Node {node_size = 2, node_type = Terms, node_id = pack "8", node_label = pack "table", node_attributes = Attributes {clust_default = 2}}], graph_edges = [Edge {edge_source = pack "0", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "0"},Edge {edge_source = pack "1", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "1"},Edge {edge_source = pack "1", edge_target = pack "1", edge_weight = 1.0, edge_id = pack "2"},Edge {edge_source = pack "2", edge_target = pack "2", edge_weight = 1.0, edge_id = pack "3"},Edge {edge_source = pack "2", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "4"},Edge {edge_source = pack "3", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "5"},Edge {edge_source = pack "3", edge_target = pack "1", edge_weight = 1.0, edge_id = pack "6"},Edge {edge_source = pack "3", edge_target = pack "3", edge_weight = 1.0, edge_id = pack "7"},Edge {edge_source = pack "4", edge_target = pack "4", edge_weight = 1.0, edge_id = pack "8"},Edge {edge_source = pack "4", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "9"},Edge {edge_source = pack "5", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "10"},Edge {edge_source = pack "6", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "11"},Edge {edge_source = pack "7", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "12"},Edge {edge_source = pack "7", edge_target = pack "7", edge_weight = 1.0, edge_id = pack "13"},Edge {edge_source = pack "8", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "14"},Edge {edge_source = pack "8", edge_target = pack "7", edge_weight = 1.0, edge_id = pack "15"},Edge {edge_source = pack "8", edge_target = pack "8", edge_weight = 1.0, edge_id = pack "16"}]}
-- | Intances for the mack
instance Arbitrary Graph where
arbitrary = elements $ [Graph {graph_nodes = [Node {node_size = 4, node_type = Terms, node_id = pack "0", node_label = pack "animal", node_attributes = Attributes {clust_default = 0}},Node {node_size = 3, node_type = Terms, node_id = pack "1", node_label = pack "bird", node_attributes = Attributes {clust_default = 0}},Node {node_size = 2, node_type = Terms, node_id = pack "2", node_label = pack "boy", node_attributes = Attributes {clust_default = 1}},Node {node_size = 2, node_type = Terms, node_id = pack "3", node_label = pack "dog", node_attributes = Attributes {clust_default = 0}},Node {node_size = 2, node_type = Terms, node_id = pack "4", node_label = pack "girl", node_attributes = Attributes {clust_default = 1}},Node {node_size = 4, node_type = Terms, node_id = pack "5", node_label = pack "human body", node_attributes = Attributes {clust_default = 1}},Node {node_size = 3, node_type = Terms, node_id = pack "6", node_label = pack "object", node_attributes = Attributes {clust_default = 2}},Node {node_size = 2, node_type = Terms, node_id = pack "7", node_label = pack "pen", node_attributes = Attributes {clust_default = 2}},Node {node_size = 2, node_type = Terms, node_id = pack "8", node_label = pack "table", node_attributes = Attributes {clust_default = 2}}], graph_edges = [Edge {edge_source = pack "0", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "0"},Edge {edge_source = pack "1", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "1"},Edge {edge_source = pack "1", edge_target = pack "1", edge_weight = 1.0, edge_id = pack "2"},Edge {edge_source = pack "2", edge_target = pack "2", edge_weight = 1.0, edge_id = pack "3"},Edge {edge_source = pack "2", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "4"},Edge {edge_source = pack "3", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "5"},Edge {edge_source = pack "3", edge_target = pack "1", edge_weight = 1.0, edge_id = pack "6"},Edge {edge_source = pack "3", edge_target = pack "3", edge_weight = 1.0, edge_id = pack "7"},Edge {edge_source = pack "4", edge_target = pack "4", edge_weight = 1.0, edge_id = pack "8"},Edge {edge_source = pack "4", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "9"},Edge {edge_source = pack "5", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "10"},Edge {edge_source = pack "6", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "11"},Edge {edge_source = pack "7", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "12"},Edge {edge_source = pack "7", edge_target = pack "7", edge_weight = 1.0, edge_id = pack "13"},Edge {edge_source = pack "8", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "14"},Edge {edge_source = pack "8", edge_target = pack "7", edge_weight = 1.0, edge_id = pack "15"},Edge {edge_source = pack "8", edge_target = pack "8", edge_weight = 1.0, edge_id = pack "16"}]}]
arbitrary = elements $ [defaultGraph]
-----------------------------------------------------------
-- Old Gargantext Version
-- V3 Gargantext Version
data AttributesOld = AttributesOld { cl :: Int }
data AttributesV3 = AttributesV3 { cl :: Int }
deriving (Show, Generic)
$(deriveJSON (unPrefix "") ''AttributesOld)
$(deriveJSON (unPrefix "") ''AttributesV3)
data NodeOld = NodeOld { no_id :: Int
, no_at :: AttributesOld
data NodeV3 = NodeV3 { no_id :: Int
, no_at :: AttributesV3
, no_s :: Int
, no_lb :: Text
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "no_") ''NodeOld)
$(deriveJSON (unPrefix "no_") ''NodeV3)
data EdgeOld = EdgeOld { eo_s :: Int
data EdgeV3 = EdgeV3 { eo_s :: Int
, eo_t :: Int
, eo_w :: Text
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "eo_") ''EdgeOld)
$(deriveJSON (unPrefix "eo_") ''EdgeV3)
data GraphOld = GraphOld {
go_links :: [EdgeOld]
, go_nodes :: [NodeOld]
data GraphV3 = GraphV3 {
go_links :: [EdgeV3]
, go_nodes :: [NodeV3]
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "go_") ''GraphOld)
$(deriveJSON (unPrefix "go_") ''GraphV3)
----------------------------------------------------------
-- | From data to Graph
......@@ -143,25 +146,28 @@ data2graph labels coocs distance partitions = Graph nodes edges
-----------------------------------------------------------
-----------------------------------------------------------
graphOld2graph :: GraphOld -> Graph
graphOld2graph (GraphOld links nodes) = Graph (map nodeOld2node nodes) (zipWith linkOld2edge [1..] links)
graphV3ToGraph :: GraphV3 -> Graph
graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links)
where
nodeOld2node :: NodeOld -> Node
nodeOld2node (NodeOld no_id' (AttributesOld cl') no_s' no_lb')
nodeV32node :: NodeV3 -> Node
nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
= Node no_s' Terms (cs $ show no_id') no_lb' (Attributes cl')
linkOld2edge :: Int -> EdgeOld -> Edge
linkOld2edge n (EdgeOld eo_s' eo_t' eo_w') = Edge (cs $ show eo_s') (cs $ show eo_t') ((T.read $ T.unpack eo_w') :: Double) (cs $ show n)
linkV32edge :: Int -> EdgeV3 -> Edge
linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') = Edge (cs $ show eo_s') (cs $ show eo_t') ((T.read $ T.unpack eo_w') :: Double) (cs $ show n)
graphOld2graphWithFiles :: FilePath -> FilePath -> IO ()
graphOld2graphWithFiles g1 g2 = do
-- GraphOld <- IO Fichier
graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
graphV3ToGraphWithFiles g1 g2 = do
-- GraphV3 <- IO Fichier
graph <- DBL.readFile g1
let newGraph = case DA.decode graph :: Maybe GraphOld of
let newGraph = case DA.decode graph :: Maybe GraphV3 of
Nothing -> panic (T.pack "no graph")
Just new -> new
DBL.writeFile g2 (DA.encode $ graphOld2graph newGraph)
DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
readGraphFromJson :: FilePath -> IO (Maybe Graph)
readGraphFromJson fp = do
graph <- DBL.readFile fp
pure $ DA.decode graph
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