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 FlexibleContexts  #-}
  16 {-# LANGUAGE FlexibleInstances #-}
  17 {-# LANGUAGE RankNTypes        #-}
  18 {-# LANGUAGE NoImplicitPrelude #-}
  19 {-# LANGUAGE OverloadedStrings #-}   -- allows to write Text literals
  20 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  21 {-# LANGUAGE DataKinds         #-}
  22 {-# LANGUAGE TypeOperators     #-}
  23
  24 module Gargantext.Viz.Graph.API
  25   where
  26
  27 -- import Debug.Trace (trace)
  28 import Control.Concurrent -- (forkIO)
  29 import Control.Lens (set, (^.), _Just, (^?))
  30 import Control.Monad.IO.Class (liftIO)
  31 import qualified Data.HashMap.Lazy as HashMap
  32 import qualified Data.Map as Map
  33 import Data.Maybe (Maybe(..))
  34 import Servant
  35 import Servant.XML
  36 import qualified Xmlbf as Xmlbf
  37
  38 import Gargantext.API.Ngrams (NgramsRepo, r_version)
  39 import Gargantext.API.Ngrams.Tools
  40 import Gargantext.API.Types
  41 import Gargantext.Core.Types.Main
  42 import Gargantext.Database.Config
  43 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  44 import Gargantext.Database.Schema.Ngrams
  45 import Gargantext.Database.Node.Select
  46 import Gargantext.Database.Schema.Node (getNodeWith, getNodeUser, defaultList, insertGraph, HasNodeError)
  47 import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
  48 import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
  49 import Gargantext.Database.Utils (Cmd)
  50 import Gargantext.Prelude
  51 import qualified Gargantext.Prelude as P
  52 import Gargantext.Viz.Graph
  53 import qualified Gargantext.Viz.Graph as G
  54 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
  55
  56 instance Xmlbf.ToXml Graph where
  57   toXml (Graph { _graph_nodes = graphNodes
  58                 , _graph_edges = graphEdges }) = root graphNodes graphEdges
  59     where
  60       root :: [G.Node] -> [G.Edge] -> [Xmlbf.Node]
  61       root gn ge =
  62         Xmlbf.element "gexf" params $ meta <> (graph gn ge)
  63         where
  64           params = HashMap.fromList [ ("xmlns", "http://www.gexf.net/1.2draft")
  65                                     , ("version", "1.2") ]
  66       meta = Xmlbf.element "meta" params $ creator <> description
  67         where
  68           params = HashMap.fromList [ ("lastmodifieddate", "2020-03-13") ]
  69       creator = Xmlbf.element "Gargantext.org" HashMap.empty []
  70       description = Xmlbf.element "Gargantext gexf file" HashMap.empty []
  71       graph :: [G.Node] -> [G.Edge] -> [Xmlbf.Node]
  72       graph gn ge = Xmlbf.element "graph" params $ (nodes gn) <> (edges ge)
  73         where
  74           params = HashMap.fromList [ ("mode", "static")
  75                                     , ("defaultedgetype", "directed") ]
  76       nodes :: [G.Node] -> [Xmlbf.Node]
  77       nodes gn = Xmlbf.element "nodes" HashMap.empty $ P.concatMap node gn
  78       node :: G.Node -> [Xmlbf.Node]
  79       node (G.Node { node_id = nId, node_label = l }) =
  80         Xmlbf.element "node" params []
  81         where
  82           params = HashMap.fromList [ ("id", nId)
  83                                     , ("label", l) ]
  84       edges :: [G.Edge] -> [Xmlbf.Node]
  85       edges gn = Xmlbf.element "edges" HashMap.empty $ P.concatMap edge gn
  86       edge :: G.Edge -> [Xmlbf.Node]
  87       edge (G.Edge { edge_id = eId, edge_source = es, edge_target = et }) =
  88         Xmlbf.element "edge" params []
  89         where
  90           params = HashMap.fromList [ ("id", eId)
  91                                     , ("source", es)
  92                                     , ("target", et) ]
  93
  94 ------------------------------------------------------------------------
  95
  96 -- | There is no Delete specific API for Graph since it can be deleted
  97 -- as simple Node.
  98 type GraphAPI   =  Get  '[JSON] Graph
  99               :<|> Post '[JSON] [GraphId]
 100               :<|> Put  '[JSON] Int
 101               :<|> "gexf" :> Get '[XML] Graph
 102
 103
 104 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
 105 graphAPI u n =  getGraph  u n
 106          :<|> postGraph n
 107          :<|> putGraph  n
 108          :<|> getGraphGexf u n
 109
 110 ------------------------------------------------------------------------
 111
 112 {- Model to fork Graph Computation
 113 -- This is not really optimized since it increases the need RAM
 114 -- and freezes the whole system
 115 -- This is mainly for documentation (see a better solution in the function below)
 116 -- Each process has to be tailored
 117 getGraph' :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
 118 getGraph' u n = do
 119   newGraph  <- liftIO newEmptyMVar
 120   g  <- getGraph u n
 121   _  <- liftIO $ forkIO $ putMVar newGraph g
 122   g' <- liftIO $ takeMVar newGraph
 123   pure g'
 124 -}
 125 getGraph :: UserId -> NodeId -> GargNoServer Graph
 126 getGraph uId nId = do
 127   nodeGraph <- getNodeWith nId HyperdataGraph
 128   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 129   let listVersion = graph ^? _Just
 130                             . graph_metadata
 131                             . _Just
 132                             . gm_list
 133                             . lfg_version
 134
 135   repo <- getRepo
 136   let v = repo ^. r_version
 137   nodeUser <- getNodeUser (NodeId uId)
 138
 139   let uId' = nodeUser ^. node_userId
 140
 141   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
 142                   identity
 143                   $ nodeGraph ^. node_parentId
 144
 145   newGraph  <- liftIO newEmptyMVar
 146   g <- case graph of
 147     Nothing     -> do
 148       graph' <- computeGraph cId NgramsTerms repo
 149       _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
 150       pure graph'
 151
 152     Just graph' -> if listVersion == Just v
 153                      then pure graph'
 154                      else do
 155                        graph'' <- computeGraph cId NgramsTerms repo
 156                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 157                        pure graph''
 158   _  <- liftIO $ forkIO $ putMVar newGraph g
 159   g' <- liftIO $ takeMVar newGraph
 160   pure {- $ trace (show g) $ -} g'
 161
 162
 163 -- TODO use Database Monad only here ?
 164 computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
 165 computeGraph cId nt repo = do
 166   lId  <- defaultList cId
 167
 168   let metadata = GraphMetadata "Title" [cId]
 169                                      [ LegendField 1 "#FFF" "Cluster"
 170                                      , LegendField 2 "#FFF" "Cluster"
 171                                      ]
 172                                 (ListForGraph lId (repo ^. r_version))
 173                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 174
 175   lIds <- selectNodesWithUsername NodeList userMaster
 176   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 177
 178   myCooc <- Map.filter (>1)
 179          <$> getCoocByNgrams (Diagonal True)
 180          <$> groupNodesByNgrams ngs
 181          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 182
 183   graph <- liftIO $ cooc2graph 0 myCooc
 184   let graph' = set graph_metadata (Just metadata) graph
 185   pure graph'
 186
 187
 188
 189 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
 190 postGraph = undefined
 191
 192 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 193 putGraph = undefined
 194
 195
 196 getGraphGexf :: UserId -> NodeId -> GargNoServer Graph
 197 getGraphGexf uId nId = do
 198   graph <- getGraph uId nId
 199   pure graph