]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Graph/API.hs
[DB] refactoring
[gargantext.git] / src / Gargantext / Viz / Graph / API.hs
1 {-|
2 Module : Gargantext.Viz.Phylo.Tools
3 Description : Phylomemy Tools to build/manage it
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 -}
11
12
13 {-# OPTIONS_GHC -fno-warn-orphans #-}
14
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 #-}
24
25 module Gargantext.Viz.Graph.API
26 where
27
28 import Control.Lens (set, (^.), _Just, (^?))
29 import Data.Aeson
30 import Debug.Trace (trace)
31 import qualified Data.HashMap.Lazy as HashMap
32 import qualified Data.Map as Map
33 import Data.Maybe (Maybe(..))
34 import Data.Swagger
35 import Data.Text
36 import GHC.Generics (Generic)
37 import Servant
38 import Servant.Job.Async
39 import Servant.XML
40 import qualified Xmlbf as Xmlbf
41
42 import Gargantext.API.Ngrams (NgramsRepo, r_version)
43 import Gargantext.API.Ngrams.Tools
44 import Gargantext.API.Admin.Orchestrator.Types
45 import Gargantext.API.Admin.Types
46 import Gargantext.Core.Types.Main
47 import Gargantext.Database.Admin.Config
48 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
49 import Gargantext.Database.Schema.Node (node_userId, node_parentId, node_hyperdata)
50 import Gargantext.Database.Schema.Ngrams
51 import Gargantext.Database.Action.Query.Node.Select
52 import Gargantext.Database.Action.Query.Node
53 import Gargantext.Database.Action.Query.Node.User
54 import Gargantext.Database.Admin.Types.Errors (HasNodeError)
55 import Gargantext.Database.Admin.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
56 import Gargantext.Database.Action.Query.Node.UpdateOpaleye (updateHyperdata)
57 import Gargantext.Database.Admin.Utils (Cmd)
58 import Gargantext.Prelude
59 import qualified Gargantext.Prelude as P
60 import Gargantext.Viz.Graph
61 import qualified Gargantext.Viz.Graph as G
62 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
63
64 -- Converts to GEXF format
65 -- See https://gephi.org/gexf/format/
66 instance Xmlbf.ToXml Graph where
67 toXml (Graph { _graph_nodes = graphNodes
68 , _graph_edges = graphEdges }) = root graphNodes graphEdges
69 where
70 root :: [G.Node] -> [G.Edge] -> [Xmlbf.Node]
71 root gn ge =
72 Xmlbf.element "gexf" params $ meta <> (graph gn ge)
73 where
74 params = HashMap.fromList [ ("xmlns", "http://www.gexf.net/1.2draft")
75 , ("version", "1.2") ]
76 meta = Xmlbf.element "meta" params $ creator <> desc
77 where
78 params = HashMap.fromList [ ("lastmodifieddate", "2020-03-13") ]
79 creator = Xmlbf.element "creator" HashMap.empty $ Xmlbf.text "Gargantext.org"
80 desc = Xmlbf.element "description" HashMap.empty $ Xmlbf.text "Gargantext gexf file"
81 graph :: [G.Node] -> [G.Edge] -> [Xmlbf.Node]
82 graph gn ge = Xmlbf.element "graph" params $ (nodes gn) <> (edges ge)
83 where
84 params = HashMap.fromList [ ("mode", "static")
85 , ("defaultedgetype", "directed") ]
86 nodes :: [G.Node] -> [Xmlbf.Node]
87 nodes gn = Xmlbf.element "nodes" HashMap.empty $ P.concatMap node' gn
88
89 node' :: G.Node -> [Xmlbf.Node]
90 node' (G.Node { node_id = nId, node_label = l }) =
91 Xmlbf.element "node" params []
92 where
93 params = HashMap.fromList [ ("id", nId)
94 , ("label", l) ]
95 edges :: [G.Edge] -> [Xmlbf.Node]
96 edges gn = Xmlbf.element "edges" HashMap.empty $ P.concatMap edge gn
97 edge :: G.Edge -> [Xmlbf.Node]
98 edge (G.Edge { edge_id = eId, edge_source = es, edge_target = et }) =
99 Xmlbf.element "edge" params []
100 where
101 params = HashMap.fromList [ ("id", eId)
102 , ("source", es)
103 , ("target", et) ]
104
105 ------------------------------------------------------------------------
106
107 -- | There is no Delete specific API for Graph since it can be deleted
108 -- as simple Node.
109 type GraphAPI = Get '[JSON] Graph
110 :<|> Post '[JSON] [GraphId]
111 :<|> Put '[JSON] Int
112 :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
113 :<|> GraphAsyncAPI
114 :<|> "versions" :> GraphVersionsAPI
115
116
117 data GraphVersions = GraphVersions { gv_graph :: Maybe Int
118 , gv_repo :: Int } deriving (Show, Generic)
119
120 instance ToJSON GraphVersions
121 instance ToSchema GraphVersions
122
123 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
124 graphAPI u n = getGraph u n
125 :<|> postGraph n
126 :<|> putGraph n
127 :<|> getGraphGexf u n
128 :<|> graphAsync u n
129 :<|> graphVersionsAPI u n
130
131 ------------------------------------------------------------------------
132
133 getGraph :: UserId -> NodeId -> GargNoServer Graph
134 getGraph uId nId = do
135 nodeGraph <- getNodeWith nId HyperdataGraph
136 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
137 -- let listVersion = graph ^? _Just
138 -- . graph_metadata
139 -- . _Just
140 -- . gm_list
141 -- . lfg_version
142
143 repo <- getRepo
144 -- let v = repo ^. r_version
145 nodeUser <- getNodeUser (NodeId uId)
146
147 let uId' = nodeUser ^. node_userId
148
149 let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
150 identity
151 $ nodeGraph ^. node_parentId
152
153 g <- case graph of
154 Nothing -> do
155 graph' <- computeGraph cId NgramsTerms repo
156 _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
157 pure $ trace "Graph empty, computing" $ graph'
158
159 Just graph' -> pure $ trace "Graph exists, returning" $ graph'
160
161 -- Just graph' -> if listVersion == Just v
162 -- then pure graph'
163 -- else do
164 -- graph'' <- computeGraph cId NgramsTerms repo
165 -- _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
166 -- pure graph''
167
168 pure g
169
170
171 recomputeGraph :: UserId -> NodeId -> GargNoServer Graph
172 recomputeGraph uId nId = do
173 nodeGraph <- getNodeWith nId HyperdataGraph
174 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
175 let listVersion = graph ^? _Just
176 . graph_metadata
177 . _Just
178 . gm_list
179 . lfg_version
180
181 repo <- getRepo
182 let v = repo ^. r_version
183 nodeUser <- getNodeUser (NodeId uId)
184
185 let uId' = nodeUser ^. node_userId
186
187 let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
188 identity
189 $ nodeGraph ^. node_parentId
190
191 g <- case graph of
192 Nothing -> do
193 graph' <- computeGraph cId NgramsTerms repo
194 _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
195 pure $ trace "[recomputeGraph] Graph empty, computing" $ graph'
196
197 Just graph' -> if listVersion == Just v
198 then pure graph'
199 else do
200 graph'' <- computeGraph cId NgramsTerms repo
201 _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
202 pure $ trace "[recomputeGraph] Graph exists, recomputing" $ graph''
203 pure g
204
205
206 -- TODO use Database Monad only here ?
207 computeGraph :: HasNodeError err
208 => CorpusId
209 -> NgramsType
210 -> NgramsRepo
211 -> Cmd err Graph
212 computeGraph cId nt repo = do
213 lId <- defaultList cId
214
215 let metadata = GraphMetadata "Title" [cId]
216 [ LegendField 1 "#FFF" "Cluster"
217 , LegendField 2 "#FFF" "Cluster"
218 ]
219 (ListForGraph lId (repo ^. r_version))
220 -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
221
222 lIds <- selectNodesWithUsername NodeList userMaster
223 let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
224
225 myCooc <- Map.filter (>1)
226 <$> getCoocByNgrams (Diagonal True)
227 <$> groupNodesByNgrams ngs
228 <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
229
230 graph <- liftBase $ cooc2graph 0 myCooc
231 let graph' = set graph_metadata (Just metadata) graph
232 pure graph'
233
234
235
236 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
237 postGraph = undefined
238
239 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
240 putGraph = undefined
241
242
243 ------------------------------------------------------------
244
245 getGraphGexf :: UserId -> NodeId -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
246 getGraphGexf uId nId = do
247 graph <- getGraph uId nId
248 pure $ addHeader (concat [ "attachment; filename=graph.gexf" ]) graph
249
250 ------------------------------------------------------------
251
252 type GraphAsyncAPI = Summary "Update graph"
253 :> "async"
254 :> AsyncJobsAPI ScraperStatus () ScraperStatus
255
256 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
257 graphAsync u n =
258 serveJobsAPI $
259 JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
260
261
262 graphAsync' :: UserId
263 -> NodeId
264 -> (ScraperStatus -> GargNoServer ())
265 -> GargNoServer ScraperStatus
266 graphAsync' u n logStatus = do
267 logStatus ScraperStatus { _scst_succeeded = Just 0
268 , _scst_failed = Just 0
269 , _scst_remaining = Just 1
270 , _scst_events = Just []
271 }
272 _g <- trace (show u) $ recomputeGraph u n
273 pure ScraperStatus { _scst_succeeded = Just 1
274 , _scst_failed = Just 0
275 , _scst_remaining = Just 0
276 , _scst_events = Just []
277 }
278
279 ------------------------------------------------------------
280
281 type GraphVersionsAPI = Summary "Graph versions"
282 :> Get '[JSON] GraphVersions
283 :<|> Summary "Recompute graph version"
284 :> Post '[JSON] Graph
285
286 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
287 graphVersionsAPI u n =
288 graphVersions u n
289 :<|> recomputeVersions u n
290
291 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
292 graphVersions _uId nId = do
293 nodeGraph <- getNodeWith nId HyperdataGraph
294 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
295 let listVersion = graph ^? _Just
296 . graph_metadata
297 . _Just
298 . gm_list
299 . lfg_version
300
301 repo <- getRepo
302 let v = repo ^. r_version
303
304 pure $ GraphVersions { gv_graph = listVersion
305 , gv_repo = v }
306
307 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
308 recomputeVersions uId nId = recomputeGraph uId nId