]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Graph/API.hs
[graph] graph versoin refresh endpoint
[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 Debug.Trace (trace)
29 import Control.Concurrent -- (forkIO)
30 import Control.Lens (set, (^.), _Just, (^?))
31 import Control.Monad.IO.Class (liftIO)
32 import Data.Aeson
33 import Data.Maybe (Maybe(..))
34 import Data.Swagger
35 import GHC.Generics (Generic)
36
37 import Gargantext.API.Ngrams (NgramsRepo, r_version)
38 import Gargantext.API.Ngrams.Tools
39 import Gargantext.API.Types
40 import Gargantext.Core.Types.Main
41 import Gargantext.Database.Config
42 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
43 import Gargantext.Database.Schema.Ngrams
44 import Gargantext.Database.Node.Select
45 import Gargantext.Database.Schema.Node (getNodeWith, getNodeUser, defaultList, insertGraph, HasNodeError)
46 import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
47 import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
48 import Gargantext.Database.Utils (Cmd)
49 import Gargantext.Prelude
50 import Gargantext.Viz.Graph
51 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
52 import Servant
53
54 import Gargantext.API.Orchestrator.Types
55 import Servant.Job.Types
56 import Servant.Job.Async
57 import qualified Data.Map as Map
58
59 ------------------------------------------------------------------------
60
61 -- | There is no Delete specific API for Graph since it can be deleted
62 -- as simple Node.
63 type GraphAPI = Get '[JSON] Graph
64 :<|> Post '[JSON] [GraphId]
65 :<|> Put '[JSON] Int
66 :<|> GraphAsyncAPI
67 :<|> "versions" :> GraphVersionsAPI
68
69
70 data GraphVersions = GraphVersions { gv_graph :: Maybe Int
71 , gv_repo :: Int } deriving (Show, Generic)
72
73 instance ToJSON GraphVersions
74 instance ToSchema GraphVersions
75
76 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
77 graphAPI u n = getGraph u n
78 :<|> postGraph n
79 :<|> putGraph n
80 :<|> graphAsync u n
81 :<|> graphVersionsAPI u n
82
83 ------------------------------------------------------------------------
84
85 {- Model to fork Graph Computation
86 -- This is not really optimized since it increases the need RAM
87 -- and freezes the whole system
88 -- This is mainly for documentation (see a better solution in the function below)
89 -- Each process has to be tailored
90 getGraph' :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
91 getGraph' u n = do
92 newGraph <- liftIO newEmptyMVar
93 g <- getGraph u n
94 _ <- liftIO $ forkIO $ putMVar newGraph g
95 g' <- liftIO $ takeMVar newGraph
96 pure g'
97 -}
98 getGraph :: UserId -> NodeId -> GargNoServer Graph
99 getGraph uId nId = 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 nodeUser <- getNodeUser (NodeId uId)
111
112 let uId' = nodeUser ^. node_userId
113
114 let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
115 identity
116 $ nodeGraph ^. node_parentId
117
118 g <- case graph of
119 Nothing -> do
120 graph' <- computeGraph cId NgramsTerms repo
121 _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
122 pure $ trace "Graph empty, computing" $ graph'
123
124 Just graph' -> pure $ trace "Graph exists, returning" $ graph'
125
126 -- Just graph' -> if listVersion == Just v
127 -- then pure graph'
128 -- else do
129 -- graph'' <- computeGraph cId NgramsTerms repo
130 -- _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
131 -- pure graph''
132
133 newGraph <- liftIO newEmptyMVar
134 _ <- liftIO $ forkIO $ putMVar newGraph g
135 g' <- liftIO $ takeMVar newGraph
136 pure {- $ trace (show g) $ -} g'
137
138
139 recomputeGraph :: UserId -> NodeId -> GargNoServer Graph
140 recomputeGraph uId nId = do
141 nodeGraph <- getNodeWith nId HyperdataGraph
142 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
143 let listVersion = graph ^? _Just
144 . graph_metadata
145 . _Just
146 . gm_list
147 . lfg_version
148
149 repo <- getRepo
150 let v = repo ^. r_version
151 nodeUser <- getNodeUser (NodeId uId)
152
153 let uId' = nodeUser ^. node_userId
154
155 let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
156 identity
157 $ nodeGraph ^. node_parentId
158
159 g <- case graph of
160 Nothing -> do
161 graph' <- computeGraph cId NgramsTerms repo
162 _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
163 pure $ trace "[recomputeGraph] Graph empty, computing" $ graph'
164
165 Just graph' -> if listVersion == Just v
166 then pure graph'
167 else do
168 graph'' <- computeGraph cId NgramsTerms repo
169 _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
170 pure $ trace "[recomputeGraph] Graph exists, recomputing" $ graph''
171
172 newGraph <- liftIO newEmptyMVar
173 _ <- liftIO $ forkIO $ putMVar newGraph g
174 g' <- liftIO $ takeMVar newGraph
175 pure g'
176
177
178 -- TODO use Database Monad only here ?
179 computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
180 computeGraph cId nt repo = do
181 lId <- defaultList cId
182
183 let metadata = GraphMetadata "Title" [cId]
184 [ LegendField 1 "#FFF" "Cluster"
185 , LegendField 2 "#FFF" "Cluster"
186 ]
187 (ListForGraph lId (repo ^. r_version))
188 -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
189
190 lIds <- selectNodesWithUsername NodeList userMaster
191 let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
192
193 myCooc <- inMVarIO $ Map.filter (>1)
194 <$> getCoocByNgrams (Diagonal False)
195 <$> groupNodesByNgrams ngs
196 <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
197
198 graph <- liftIO $ inMVar $ cooc2graph 0 myCooc
199 let graph' = set graph_metadata (Just metadata) graph
200 pure graph'
201
202
203
204 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
205 postGraph = undefined
206
207 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
208 putGraph = undefined
209
210 ------------------------------------------------------------
211
212 type GraphAsyncAPI = Summary "Update graph"
213 :> "async"
214 :> AsyncJobsAPI ScraperStatus () ScraperStatus
215
216 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
217 graphAsync u n =
218 serveJobsAPI $
219 JobFunction (\_ log' -> graphAsync' u n (liftIO . log'))
220
221
222 graphAsync' :: UserId
223 -> NodeId
224 -> (ScraperStatus -> GargNoServer ())
225 -> GargNoServer ScraperStatus
226 graphAsync' u n logStatus = do
227 logStatus ScraperStatus { _scst_succeeded = Just 0
228 , _scst_failed = Just 0
229 , _scst_remaining = Just 1
230 , _scst_events = Just []
231 }
232 _g <- trace (show u) $ recomputeGraph u n
233 pure ScraperStatus { _scst_succeeded = Just 1
234 , _scst_failed = Just 0
235 , _scst_remaining = Just 0
236 , _scst_events = Just []
237 }
238
239 ------------------------------------------------------------
240
241 type GraphVersionsAPI = Summary "Graph versions"
242 :> Get '[JSON] GraphVersions
243 :<|> Summary "Recompute graph version"
244 :> Post '[JSON] Graph
245
246 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
247 graphVersionsAPI u n =
248 graphVersions u n
249 :<|> recomputeVersions u n
250
251 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
252 graphVersions _uId nId = do
253 nodeGraph <- getNodeWith nId HyperdataGraph
254 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
255 let listVersion = graph ^? _Just
256 . graph_metadata
257 . _Just
258 . gm_list
259 . lfg_version
260
261 repo <- getRepo
262 let v = repo ^. r_version
263
264 pure $ GraphVersions { gv_graph = listVersion
265 , gv_repo = v }
266
267 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
268 recomputeVersions uId nId = recomputeGraph uId nId