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