{-|
-Module : Gargantext.Viz.Phylo.Tools
-Description : Phylomemy Tools to build/manage it
+Module : Gargantext.Viz.Graph
+Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-} -- allows to write Text literals
{-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.Viz.Graph.API
where
-import Debug.Trace (trace)
import Control.Lens (set, (^.), _Just, (^?))
-import Control.Monad.IO.Class (liftIO)
+import Data.Aeson
import Data.Maybe (Maybe(..))
+import Data.Swagger
+import Data.Text
+import Debug.Trace (trace)
+import GHC.Generics (Generic)
+import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams (NgramsRepo, r_version)
import Gargantext.API.Ngrams.Tools
-import Gargantext.API.Types
+import Gargantext.API.Prelude
import Gargantext.Core.Types.Main
-import Gargantext.Database.Config
-import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
+import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
+import Gargantext.Database.Admin.Config
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude (Cmd)
+import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Query.Table.Node.Select
+import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Ngrams
-import Gargantext.Database.Node.Select
-import Gargantext.Database.Schema.Node (getNodeWith, defaultList, insertGraph, HasNodeError)
-import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
-import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
-import Gargantext.Database.Utils (Cmd)
+import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata)
import Gargantext.Prelude
import Gargantext.Viz.Graph
+import Gargantext.Viz.Graph.GEXF ()
import Gargantext.Viz.Graph.Tools -- (cooc2graph)
+import Gargantext.Viz.Graph.Distances (Distance(..), GraphMetric(..))
import Servant
+import Servant.Job.Async
+import Servant.XML
import qualified Data.Map as Map
------------------------------------------------------------------------
-
-- | There is no Delete specific API for Graph since it can be deleted
-- as simple Node.
type GraphAPI = Get '[JSON] Graph
- :<|> Post '[JSON] [GraphId]
- :<|> Put '[JSON] Int
+ :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
+ :<|> GraphAsyncAPI
+ :<|> "versions" :> GraphVersionsAPI
+data GraphVersions =
+ GraphVersions { gv_graph :: Maybe Int
+ , gv_repo :: Int
+ }
+ deriving (Show, Generic)
+
+instance ToJSON GraphVersions
+instance ToSchema GraphVersions
graphAPI :: UserId -> NodeId -> GargServer GraphAPI
-graphAPI u n = getGraph u n
- :<|> postGraph n
- :<|> putGraph n
+graphAPI u n = getGraph u n
+ :<|> getGraphGexf u n
+ :<|> graphAsync u n
+ :<|> graphVersionsAPI u n
------------------------------------------------------------------------
+getGraph :: UserId -> NodeId -> GargNoServer Graph
+getGraph _uId nId = do
+ nodeGraph <- getNodeWith nId HyperdataGraph
+ let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+
+ repo <- getRepo
+
+ let cId = maybe (panic "[G.V.G.API] Node has no parent")
+ identity
+ $ nodeGraph ^. node_parentId
+
+ -- TODO Distance in Graph params
+ case graph of
+ Nothing -> do
+ graph' <- computeGraph cId Conditional NgramsTerms repo
+ _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
+ pure $ trace "[G.V.G.API] Graph empty, computing" graph'
+
+ Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" graph'
-getGraph :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
-getGraph uId nId = do
+
+recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
+recomputeGraph _uId nId d = do
nodeGraph <- getNodeWith nId HyperdataGraph
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let listVersion = graph ^? _Just
. lfg_version
repo <- getRepo
- let v = repo ^. r_version
- nodeUser <- getNodeWith (NodeId uId) HyperdataUser
-
- let uId' = nodeUser ^. node_userId
-
- let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
+ let v = repo ^. r_version
+ let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
identity
$ nodeGraph ^. node_parentId
- g <- case graph of
+ case graph of
Nothing -> do
- graph' <- computeGraph cId NgramsTerms repo
- _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
- pure graph'
+ graph' <- computeGraph cId d NgramsTerms repo
+ _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
+ pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph'
Just graph' -> if listVersion == Just v
then pure graph'
else do
- graph'' <- computeGraph cId NgramsTerms repo
+ graph'' <- computeGraph cId d NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
- pure graph''
- pure $ trace ("salut" <> show g) $ g
+ pure $ trace "[G.V.G.API] Graph exists, recomputing" graph''
-- TODO use Database Monad only here ?
-computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
-computeGraph cId nt repo = do
+computeGraph :: HasNodeError err
+ => CorpusId
+ -> Distance
+ -> NgramsType
+ -> NgramsRepo
+ -> Cmd err Graph
+computeGraph cId d nt repo = do
lId <- defaultList cId
- let metadata = GraphMetadata "Title" [cId]
- [ LegendField 1 "#FFF" "Cluster"
- , LegendField 2 "#FFF" "Cluster"
- ]
- (ListForGraph lId (repo ^. r_version))
- -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
-
lIds <- selectNodesWithUsername NodeList userMaster
- let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
+ let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
+ -- TODO split diagonal
myCooc <- Map.filter (>1)
<$> getCoocByNgrams (Diagonal True)
<$> groupNodesByNgrams ngs
<$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
- graph <- liftIO $ cooc2graph 0 myCooc
- let graph' = set graph_metadata (Just metadata) graph
- pure graph'
+ graph <- liftBase $ cooc2graph d 0 myCooc
+
+
+ let metadata = GraphMetadata "Title"
+ Order1
+ [cId]
+ [ LegendField 1 "#FFF" "Cluster1"
+ , LegendField 2 "#FFF" "Cluster2"
+ , LegendField 3 "#FFF" "Cluster3"
+ , LegendField 4 "#FFF" "Cluster4"
+ ]
+ (ListForGraph lId (repo ^. r_version))
+ -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
+
+ pure $ set graph_metadata (Just metadata) graph
+
+
+------------------------------------------------------------
+type GraphAsyncAPI = Summary "Update graph"
+ :> "async"
+ :> AsyncJobsAPI JobLog () JobLog
+
+
+graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
+graphAsync u n =
+ serveJobsAPI $
+ JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
+
+
+graphAsync' :: UserId
+ -> NodeId
+ -> (JobLog -> GargNoServer ())
+ -> GargNoServer JobLog
+graphAsync' u n logStatus = do
+ logStatus JobLog { _scst_succeeded = Just 0
+ , _scst_failed = Just 0
+ , _scst_remaining = Just 1
+ , _scst_events = Just []
+ }
+ _g <- trace (show u) $ recomputeGraph u n Conditional
+ pure JobLog { _scst_succeeded = Just 1
+ , _scst_failed = Just 0
+ , _scst_remaining = Just 0
+ , _scst_events = Just []
+ }
+
+------------------------------------------------------------
+type GraphVersionsAPI = Summary "Graph versions"
+ :> Get '[JSON] GraphVersions
+ :<|> Summary "Recompute graph version"
+ :> Post '[JSON] Graph
+
+graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
+graphVersionsAPI u n =
+ graphVersions u n
+ :<|> recomputeVersions u n
+
+graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
+graphVersions _uId nId = do
+ nodeGraph <- getNodeWith nId HyperdataGraph
+ let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+ let listVersion = graph ^? _Just
+ . graph_metadata
+ . _Just
+ . gm_list
+ . lfg_version
+
+ repo <- getRepo
+ let v = repo ^. r_version
+
+ pure $ GraphVersions { gv_graph = listVersion
+ , gv_repo = v }
+recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
+recomputeVersions uId nId = recomputeGraph uId nId Conditional
+------------------------------------------------------------
+getGraphGexf :: UserId
+ -> NodeId
+ -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
+getGraphGexf uId nId = do
+ graph <- getGraph uId nId
+ pure $ addHeader "attachment; filename=graph.gexf" graph
-postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
-postGraph = undefined
-putGraph :: NodeId -> GargServer (Put '[JSON] Int)
-putGraph = undefined