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