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