]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Graph/API.hs
[FIX] Node size back
[gargantext.git] / src / Gargantext / Viz / Graph / API.hs
1 {-|
2 Module : Gargantext.Viz.Graph
3 Description :
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 OverloadedLists #-} -- allows to write Map and HashMap as lists
16 {-# LANGUAGE TypeOperators #-}
17
18 module Gargantext.Viz.Graph.API
19 where
20
21 import Control.Lens (set, (^.), _Just, (^?))
22 import Data.Aeson
23 import Data.Maybe (Maybe(..))
24 import Data.Swagger
25 import Data.Text
26 import Debug.Trace (trace)
27 import GHC.Generics (Generic)
28 import Gargantext.API.Admin.Orchestrator.Types
29 import Gargantext.API.Ngrams (NgramsRepo, r_version)
30 import Gargantext.API.Ngrams.Tools
31 import Gargantext.API.Prelude
32 import Gargantext.Core.Types.Main
33 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
34 import Gargantext.Database.Admin.Config
35 import Gargantext.Database.Admin.Types.Node
36 import Gargantext.Database.Prelude (Cmd)
37 import Gargantext.Database.Query.Table.Node
38 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
39 import Gargantext.Database.Query.Table.Node.Select
40 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
41 import Gargantext.Database.Schema.Ngrams
42 import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata)
43 import Gargantext.Prelude
44 import Gargantext.Viz.Graph
45 import Gargantext.Viz.Graph.GEXF ()
46 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
47 import Gargantext.Viz.Graph.Distances (Distance(..), GraphMetric(..))
48 import Servant
49 import Servant.Job.Async
50 import Servant.XML
51 import qualified Data.Map as Map
52
53 ------------------------------------------------------------------------
54 -- | There is no Delete specific API for Graph since it can be deleted
55 -- as simple Node.
56 type GraphAPI = Get '[JSON] Graph
57 :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
58 :<|> GraphAsyncAPI
59 :<|> "versions" :> GraphVersionsAPI
60
61 data GraphVersions =
62 GraphVersions { gv_graph :: Maybe Int
63 , gv_repo :: Int
64 }
65 deriving (Show, Generic)
66
67 instance ToJSON GraphVersions
68 instance ToSchema GraphVersions
69
70 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
71 graphAPI u n = getGraph u n
72 :<|> getGraphGexf u n
73 :<|> graphAsync u n
74 :<|> graphVersionsAPI u n
75
76 ------------------------------------------------------------------------
77 getGraph :: UserId -> NodeId -> GargNoServer Graph
78 getGraph _uId nId = do
79 nodeGraph <- getNodeWith nId HyperdataGraph
80 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
81
82 repo <- getRepo
83
84 let cId = maybe (panic "[G.V.G.API] Node has no parent")
85 identity
86 $ nodeGraph ^. node_parentId
87
88 -- TODO Distance in Graph params
89 case graph of
90 Nothing -> do
91 graph' <- computeGraph cId Conditional NgramsTerms repo
92 _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
93 pure $ trace "[G.V.G.API] Graph empty, computing" graph'
94
95 Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" graph'
96
97
98 recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
99 recomputeGraph _uId nId d = do
100 nodeGraph <- getNodeWith nId HyperdataGraph
101 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
102 let listVersion = graph ^? _Just
103 . graph_metadata
104 . _Just
105 . gm_list
106 . lfg_version
107
108 repo <- getRepo
109 let v = repo ^. r_version
110 let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
111 identity
112 $ nodeGraph ^. node_parentId
113
114 case graph of
115 Nothing -> do
116 graph' <- computeGraph cId d NgramsTerms repo
117 _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
118 pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph'
119
120 Just graph' -> if listVersion == Just v
121 then pure graph'
122 else do
123 graph'' <- computeGraph cId d NgramsTerms repo
124 _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
125 pure $ trace "[G.V.G.API] Graph exists, recomputing" graph''
126
127
128 -- TODO use Database Monad only here ?
129 computeGraph :: HasNodeError err
130 => CorpusId
131 -> Distance
132 -> NgramsType
133 -> NgramsRepo
134 -> Cmd err Graph
135 computeGraph cId d nt repo = do
136 lId <- defaultList cId
137
138 let metadata = GraphMetadata "Title"
139 Order1
140 [cId]
141 [ LegendField 1 "#FFF" "Cluster"
142 , LegendField 2 "#FFF" "Cluster"
143 ]
144 (ListForGraph lId (repo ^. r_version))
145 -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
146
147 lIds <- selectNodesWithUsername NodeList userMaster
148 let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
149
150 -- TODO split diagonal
151 myCooc <- Map.filter (>1)
152 <$> getCoocByNgrams (Diagonal True)
153 <$> groupNodesByNgrams ngs
154 <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
155
156 graph <- liftBase $ cooc2graph d 0 myCooc
157 let graph' = set graph_metadata (Just metadata) graph
158 pure graph'
159
160 ------------------------------------------------------------
161 type GraphAsyncAPI = Summary "Update graph"
162 :> "async"
163 :> AsyncJobsAPI JobLog () JobLog
164
165
166 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
167 graphAsync u n =
168 serveJobsAPI $
169 JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
170
171
172 graphAsync' :: UserId
173 -> NodeId
174 -> (JobLog -> GargNoServer ())
175 -> GargNoServer JobLog
176 graphAsync' u n logStatus = do
177 logStatus JobLog { _scst_succeeded = Just 0
178 , _scst_failed = Just 0
179 , _scst_remaining = Just 1
180 , _scst_events = Just []
181 }
182 _g <- trace (show u) $ recomputeGraph u n Conditional
183 pure JobLog { _scst_succeeded = Just 1
184 , _scst_failed = Just 0
185 , _scst_remaining = Just 0
186 , _scst_events = Just []
187 }
188
189 ------------------------------------------------------------
190 type GraphVersionsAPI = Summary "Graph versions"
191 :> Get '[JSON] GraphVersions
192 :<|> Summary "Recompute graph version"
193 :> Post '[JSON] Graph
194
195 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
196 graphVersionsAPI u n =
197 graphVersions u n
198 :<|> recomputeVersions u n
199
200 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
201 graphVersions _uId nId = do
202 nodeGraph <- getNodeWith nId HyperdataGraph
203 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
204 let listVersion = graph ^? _Just
205 . graph_metadata
206 . _Just
207 . gm_list
208 . lfg_version
209
210 repo <- getRepo
211 let v = repo ^. r_version
212
213 pure $ GraphVersions { gv_graph = listVersion
214 , gv_repo = v }
215
216 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
217 recomputeVersions uId nId = recomputeGraph uId nId Conditional
218
219 ------------------------------------------------------------
220 getGraphGexf :: UserId
221 -> NodeId
222 -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
223 getGraphGexf uId nId = do
224 graph <- getGraph uId nId
225 pure $ addHeader "attachment; filename=graph.gexf" graph
226
227
228