2 Module : Gargantext.Viz.Graph
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
13 {-# OPTIONS_GHC -fno-warn-orphans #-}
15 {-# LANGUAGE DataKinds #-}
16 {-# LANGUAGE DeriveGeneric #-}
17 {-# LANGUAGE FlexibleContexts #-}
18 {-# LANGUAGE FlexibleInstances #-}
19 {-# LANGUAGE NoImplicitPrelude #-}
20 {-# LANGUAGE OverloadedStrings #-} -- allows to write Text literals
21 {-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
22 {-# LANGUAGE RankNTypes #-}
23 {-# LANGUAGE TypeOperators #-}
25 module Gargantext.Viz.Graph.API
28 import Control.Lens (set, (^.), _Just, (^?))
30 import Data.Maybe (Maybe(..))
33 import Debug.Trace (trace)
34 import GHC.Generics (Generic)
35 import Gargantext.API.Admin.Orchestrator.Types
36 import Gargantext.API.Ngrams (NgramsRepo, r_version)
37 import Gargantext.API.Ngrams.Tools
38 import Gargantext.API.Prelude
39 import Gargantext.Core.Types.Main
40 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
41 import Gargantext.Database.Admin.Config
42 import Gargantext.Database.Admin.Types.Node
43 import Gargantext.Database.Prelude (Cmd)
44 import Gargantext.Database.Query.Table.Node
45 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
46 import Gargantext.Database.Query.Table.Node.Select
47 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
48 import Gargantext.Database.Schema.Ngrams
49 import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata)
50 import Gargantext.Prelude
51 import Gargantext.Viz.Graph
52 import Gargantext.Viz.Graph.GEXF ()
53 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
55 import Servant.Job.Async
57 import qualified Data.Map as Map
59 ------------------------------------------------------------------------
60 -- | There is no Delete specific API for Graph since it can be deleted
62 type GraphAPI = Get '[JSON] Graph
63 :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
65 :<|> "versions" :> GraphVersionsAPI
68 GraphVersions { gv_graph :: Maybe Int
70 deriving (Show, Generic)
72 instance ToJSON GraphVersions
73 instance ToSchema GraphVersions
75 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
76 graphAPI u n = getGraph u n
79 :<|> graphVersionsAPI u n
81 ------------------------------------------------------------------------
82 getGraph :: UserId -> NodeId -> GargNoServer Graph
83 getGraph _uId nId = do
84 nodeGraph <- getNodeWith nId HyperdataGraph
85 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
88 let cId = maybe (panic "[G.V.G.API] Node has no parent")
90 $ nodeGraph ^. node_parentId
94 graph' <- computeGraph cId NgramsTerms repo
95 _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
96 pure $ trace "[G.V.G.API] Graph empty, computing" $ graph'
98 Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $ graph'
103 recomputeGraph :: UserId -> NodeId -> GargNoServer Graph
104 recomputeGraph _uId nId = do
105 nodeGraph <- getNodeWith nId HyperdataGraph
106 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
107 let listVersion = graph ^? _Just
114 let v = repo ^. r_version
115 let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
117 $ nodeGraph ^. node_parentId
121 graph' <- computeGraph cId NgramsTerms repo
122 _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
123 pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" $ graph'
125 Just graph' -> if listVersion == Just v
128 graph'' <- computeGraph cId NgramsTerms repo
129 _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
130 pure $ trace "[G.V.G.API] Graph exists, recomputing" $ graph''
134 -- TODO use Database Monad only here ?
135 computeGraph :: HasNodeError err
140 computeGraph cId nt repo = do
141 lId <- defaultList cId
143 let metadata = GraphMetadata "Title" [cId]
144 [ LegendField 1 "#FFF" "Cluster"
145 , LegendField 2 "#FFF" "Cluster"
147 (ListForGraph lId (repo ^. r_version))
148 -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
150 lIds <- selectNodesWithUsername NodeList userMaster
151 let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
153 myCooc <- Map.filter (>1)
154 <$> getCoocByNgrams (Diagonal True)
155 <$> groupNodesByNgrams ngs
156 <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
158 graph <- liftBase $ cooc2graph 0 myCooc
159 let graph' = set graph_metadata (Just metadata) graph
162 ------------------------------------------------------------
163 type GraphAsyncAPI = Summary "Update graph"
165 :> AsyncJobsAPI ScraperStatus () ScraperStatus
168 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
171 JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
174 graphAsync' :: UserId
176 -> (ScraperStatus -> GargNoServer ())
177 -> GargNoServer ScraperStatus
178 graphAsync' u n logStatus = do
179 logStatus ScraperStatus { _scst_succeeded = Just 0
180 , _scst_failed = Just 0
181 , _scst_remaining = Just 1
182 , _scst_events = Just []
184 _g <- trace (show u) $ recomputeGraph u n
185 pure ScraperStatus { _scst_succeeded = Just 1
186 , _scst_failed = Just 0
187 , _scst_remaining = Just 0
188 , _scst_events = Just []
191 ------------------------------------------------------------
192 type GraphVersionsAPI = Summary "Graph versions"
193 :> Get '[JSON] GraphVersions
194 :<|> Summary "Recompute graph version"
195 :> Post '[JSON] Graph
197 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
198 graphVersionsAPI u n =
200 :<|> recomputeVersions u n
202 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
203 graphVersions _uId nId = do
204 nodeGraph <- getNodeWith nId HyperdataGraph
205 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
206 let listVersion = graph ^? _Just
213 let v = repo ^. r_version
215 pure $ GraphVersions { gv_graph = listVersion
218 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
219 recomputeVersions uId nId = recomputeGraph uId nId
221 ------------------------------------------------------------
222 getGraphGexf :: UserId
224 -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
225 getGraphGexf uId nId = do
226 graph <- getGraph uId nId
227 pure $ addHeader (concat [ "attachment; filename=graph.gexf" ]) graph