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 Control.Lens (set, (^.), _Just, (^?))
  29 import Data.Aeson
  30 import Debug.Trace (trace)
  31 import qualified Data.HashMap.Lazy as HashMap
  32 import qualified Data.Map as Map
  33 import Data.Maybe (Maybe(..))
  34 import Data.Swagger
  35 import Data.Text
  36 import GHC.Generics (Generic)
  37 import Servant
  38 import Servant.Job.Async
  39 import Servant.XML
  40 import qualified Xmlbf as Xmlbf
  41
  42 import Gargantext.API.Ngrams (NgramsRepo, r_version)
  43 import Gargantext.API.Ngrams.Tools
  44 import Gargantext.API.Admin.Orchestrator.Types
  45 import Gargantext.API.Admin.Types
  46 import Gargantext.Core.Types.Main
  47 import Gargantext.Database.Admin.Config
  48 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  49 import Gargantext.Database.Schema.Node (node_userId, node_parentId, node_hyperdata)
  50 import Gargantext.Database.Schema.Ngrams
  51 import Gargantext.Database.Query.Table.Node.Select
  52 import Gargantext.Database.Query.Table.Node
  53 import Gargantext.Database.Query.Table.Node.User
  54 import Gargantext.Database.Admin.Types.Errors (HasNodeError)
  55 import Gargantext.Database.Admin.Types.Node
  56 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  57 import Gargantext.Database.Admin.Utils (Cmd)
  58 import Gargantext.Prelude
  59 import qualified Gargantext.Prelude as P
  60 import Gargantext.Viz.Graph
  61 import qualified Gargantext.Viz.Graph as G
  62 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
  63
  64 -- Converts to GEXF format
  65 -- See https://gephi.org/gexf/format/
  66 instance Xmlbf.ToXml Graph where
  67   toXml (Graph { _graph_nodes = graphNodes
  68                 , _graph_edges = graphEdges }) = root graphNodes graphEdges
  69     where
  70       root :: [G.Node] -> [G.Edge] -> [Xmlbf.Node]
  71       root gn ge =
  72         Xmlbf.element "gexf" params $ meta <> (graph gn ge)
  73         where
  74           params = HashMap.fromList [ ("xmlns", "http://www.gexf.net/1.2draft")
  75                                     , ("version", "1.2") ]
  76       meta = Xmlbf.element "meta" params $ creator <> desc
  77         where
  78           params = HashMap.fromList [ ("lastmodifieddate", "2020-03-13") ]
  79       creator = Xmlbf.element "creator" HashMap.empty $ Xmlbf.text "Gargantext.org"
  80       desc = Xmlbf.element "description" HashMap.empty $ Xmlbf.text "Gargantext gexf file"
  81       graph :: [G.Node] -> [G.Edge] -> [Xmlbf.Node]
  82       graph gn ge = Xmlbf.element "graph" params $ (nodes gn) <> (edges ge)
  83         where
  84           params = HashMap.fromList [ ("mode", "static")
  85                                     , ("defaultedgetype", "directed") ]
  86       nodes :: [G.Node] -> [Xmlbf.Node]
  87       nodes gn = Xmlbf.element "nodes" HashMap.empty $ P.concatMap node' gn
  88
  89       node' :: G.Node -> [Xmlbf.Node]
  90       node' (G.Node { node_id = nId, node_label = l }) =
  91         Xmlbf.element "node" params []
  92         where
  93           params = HashMap.fromList [ ("id", nId)
  94                                     , ("label", l) ]
  95       edges :: [G.Edge] -> [Xmlbf.Node]
  96       edges gn = Xmlbf.element "edges" HashMap.empty $ P.concatMap edge gn
  97       edge :: G.Edge -> [Xmlbf.Node]
  98       edge (G.Edge { edge_id = eId, edge_source = es, edge_target = et }) =
  99         Xmlbf.element "edge" params []
 100         where
 101           params = HashMap.fromList [ ("id", eId)
 102                                     , ("source", es)
 103                                     , ("target", et) ]
 104
 105 ------------------------------------------------------------------------
 106
 107 -- | There is no Delete specific API for Graph since it can be deleted
 108 -- as simple Node.
 109 type GraphAPI   =  Get  '[JSON] Graph
 110               :<|> Post '[JSON] [GraphId]
 111               :<|> Put  '[JSON] Int
 112               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 113               :<|> GraphAsyncAPI
 114               :<|> "versions" :> GraphVersionsAPI
 115
 116
 117 data GraphVersions = GraphVersions { gv_graph :: Maybe Int
 118                                    , gv_repo :: Int } deriving (Show, Generic)
 119
 120 instance ToJSON GraphVersions
 121 instance ToSchema GraphVersions
 122
 123 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
 124 graphAPI u n =  getGraph  u n
 125          :<|> postGraph n
 126          :<|> putGraph  n
 127          :<|> getGraphGexf u n
 128          :<|> graphAsync u n
 129          :<|> graphVersionsAPI u n
 130
 131 ------------------------------------------------------------------------
 132
 133 getGraph :: UserId -> NodeId -> GargNoServer Graph
 134 getGraph uId nId = do
 135   nodeGraph <- getNodeWith nId HyperdataGraph
 136   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 137   -- let listVersion = graph ^? _Just
 138   --                           . graph_metadata
 139   --                           . _Just
 140   --                           . gm_list
 141   --                           . lfg_version
 142
 143   repo <- getRepo
 144   -- let v = repo ^. r_version
 145   nodeUser <- getNodeUser (NodeId uId)
 146
 147   let uId' = nodeUser ^. node_userId
 148
 149   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
 150                   identity
 151                   $ nodeGraph ^. node_parentId
 152
 153   g <- case graph of
 154     Nothing     -> do
 155         graph' <- computeGraph cId NgramsTerms repo
 156         _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
 157         pure $ trace "Graph empty, computing" $ graph'
 158
 159     Just graph' -> pure $ trace "Graph exists, returning" $ graph'
 160
 161     -- Just graph' -> if listVersion == Just v
 162     --                  then pure graph'
 163     --                  else do
 164     --                    graph'' <- computeGraph cId NgramsTerms repo
 165     --                    _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 166     --                    pure graph''
 167
 168   pure g
 169
 170
 171 recomputeGraph :: UserId -> NodeId -> GargNoServer Graph
 172 recomputeGraph uId nId = do
 173   nodeGraph <- getNodeWith nId HyperdataGraph
 174   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 175   let listVersion = graph ^? _Just
 176                             . graph_metadata
 177                             . _Just
 178                             . gm_list
 179                             . lfg_version
 180
 181   repo <- getRepo
 182   let v = repo ^. r_version
 183   nodeUser <- getNodeUser (NodeId uId)
 184
 185   let uId' = nodeUser ^. node_userId
 186
 187   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
 188                   identity
 189                   $ nodeGraph ^. node_parentId
 190
 191   g <- case graph of
 192     Nothing     -> do
 193       graph' <- computeGraph cId NgramsTerms repo
 194       _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
 195       pure $ trace "[recomputeGraph] Graph empty, computing" $ graph'
 196
 197     Just graph' -> if listVersion == Just v
 198                      then pure graph'
 199                      else do
 200                        graph'' <- computeGraph cId NgramsTerms repo
 201                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 202                        pure $ trace "[recomputeGraph] Graph exists, recomputing" $ graph''
 203   pure g
 204
 205
 206 -- TODO use Database Monad only here ?
 207 computeGraph :: HasNodeError err
 208              => CorpusId
 209              -> NgramsType
 210              -> NgramsRepo
 211              -> Cmd err Graph
 212 computeGraph cId nt repo = do
 213   lId  <- defaultList cId
 214
 215   let metadata = GraphMetadata "Title" [cId]
 216                                      [ LegendField 1 "#FFF" "Cluster"
 217                                      , LegendField 2 "#FFF" "Cluster"
 218                                      ]
 219                                 (ListForGraph lId (repo ^. r_version))
 220                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 221
 222   lIds <- selectNodesWithUsername NodeList userMaster
 223   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 224
 225   myCooc <- Map.filter (>1)
 226          <$> getCoocByNgrams (Diagonal True)
 227          <$> groupNodesByNgrams ngs
 228          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 229
 230   graph <- liftBase $ cooc2graph 0 myCooc
 231   let graph' = set graph_metadata (Just metadata) graph
 232   pure graph'
 233
 234
 235
 236 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
 237 postGraph = undefined
 238
 239 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 240 putGraph = undefined
 241
 242
 243 ------------------------------------------------------------
 244
 245 getGraphGexf :: UserId -> NodeId -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 246 getGraphGexf uId nId = do
 247   graph <- getGraph uId nId
 248   pure $ addHeader (concat [ "attachment; filename=graph.gexf" ]) graph
 249
 250 ------------------------------------------------------------
 251
 252 type GraphAsyncAPI = Summary "Update graph"
 253                    :> "async"
 254                    :> AsyncJobsAPI ScraperStatus () ScraperStatus
 255
 256 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 257 graphAsync u n =
 258   serveJobsAPI $
 259     JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
 260
 261
 262 graphAsync' :: UserId
 263            -> NodeId
 264            -> (ScraperStatus -> GargNoServer ())
 265            -> GargNoServer ScraperStatus
 266 graphAsync' u n logStatus = do
 267   logStatus ScraperStatus { _scst_succeeded = Just 0
 268                           , _scst_failed    = Just 0
 269                           , _scst_remaining = Just 1
 270                           , _scst_events    = Just []
 271                           }
 272   _g <- trace (show u) $ recomputeGraph u n
 273   pure  ScraperStatus { _scst_succeeded = Just 1
 274                       , _scst_failed    = Just 0
 275                       , _scst_remaining = Just 0
 276                       , _scst_events    = Just []
 277                       }
 278
 279 ------------------------------------------------------------
 280
 281 type GraphVersionsAPI = Summary "Graph versions"
 282                         :> Get '[JSON] GraphVersions
 283                    :<|> Summary "Recompute graph version"
 284                         :> Post '[JSON] Graph
 285
 286 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 287 graphVersionsAPI u n =
 288            graphVersions u n
 289       :<|> recomputeVersions u n
 290
 291 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
 292 graphVersions _uId nId = do
 293   nodeGraph <- getNodeWith nId HyperdataGraph
 294   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 295   let listVersion = graph ^? _Just
 296                             . graph_metadata
 297                             . _Just
 298                             . gm_list
 299                             . lfg_version
 300
 301   repo <- getRepo
 302   let v = repo ^. r_version
 303
 304   pure $ GraphVersions { gv_graph = listVersion
 305                        , gv_repo = v }
 306
 307 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 308 recomputeVersions uId nId = recomputeGraph uId nId