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