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