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