src/Gargantext/Viz/Graph/API.hs

   1 {-|
   2 Module      : Gargantext.Viz.Graph
   3 Description :
   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 OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  16 {-# LANGUAGE TypeOperators     #-}
  17
  18 module Gargantext.Viz.Graph.API
  19   where
  20
  21 import Control.Lens (set, (^.), _Just, (^?))
  22 import Data.Aeson
  23 import Data.Maybe (Maybe(..))
  24 import Data.Swagger
  25 import Data.Text
  26 import Debug.Trace (trace)
  27 import GHC.Generics (Generic)
  28 import Gargantext.API.Admin.Orchestrator.Types
  29 import Gargantext.API.Ngrams (NgramsRepo, r_version)
  30 import Gargantext.API.Ngrams.Tools
  31 import Gargantext.API.Prelude
  32 import Gargantext.Core.Types.Main
  33 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  34 import Gargantext.Database.Admin.Config
  35 import Gargantext.Database.Admin.Types.Node
  36 import Gargantext.Database.Prelude (Cmd)
  37 import Gargantext.Database.Query.Table.Node
  38 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  39 import Gargantext.Database.Query.Table.Node.Select
  40 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  41 import Gargantext.Database.Schema.Ngrams
  42 import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata)
  43 import Gargantext.Prelude
  44 import Gargantext.Viz.Graph
  45 import Gargantext.Viz.Graph.GEXF ()
  46 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
  47 import Servant
  48 import Servant.Job.Async
  49 import Servant.XML
  50 import qualified Data.Map as Map
  51
  52 ------------------------------------------------------------------------
  53 -- | There is no Delete specific API for Graph since it can be deleted
  54 -- as simple Node.
  55 type GraphAPI   =  Get  '[JSON] Graph
  56               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  57               :<|> GraphAsyncAPI
  58               :<|> "versions" :> GraphVersionsAPI
  59
  60 data GraphVersions =
  61   GraphVersions { gv_graph :: Maybe Int
  62                 , gv_repo :: Int }
  63    deriving (Show, Generic)
  64
  65 instance ToJSON GraphVersions
  66 instance ToSchema GraphVersions
  67
  68 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  69 graphAPI u n =  getGraph       u n
  70          :<|> getGraphGexf     u n
  71          :<|> graphAsync       u n
  72          :<|> graphVersionsAPI u n
  73
  74 ------------------------------------------------------------------------
  75 getGraph :: UserId -> NodeId -> GargNoServer Graph
  76 getGraph _uId nId = do
  77   nodeGraph <- getNodeWith nId HyperdataGraph
  78   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
  79   repo <- getRepo
  80
  81   let cId = maybe (panic "[G.V.G.API] Node has no parent")
  82                   identity
  83                   $ nodeGraph ^. node_parentId
  84
  85   case graph of
  86     Nothing     -> do
  87         graph' <- computeGraph cId NgramsTerms repo
  88         _      <- updateHyperdata nId (HyperdataGraph $ Just graph')
  89         pure $ trace "[G.V.G.API] Graph empty, computing" graph'
  90
  91     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" graph'
  92
  93
  94 recomputeGraph :: UserId -> NodeId -> GargNoServer Graph
  95 recomputeGraph _uId nId = do
  96   nodeGraph <- getNodeWith nId HyperdataGraph
  97   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
  98   let listVersion = graph ^? _Just
  99                             . graph_metadata
 100                             . _Just
 101                             . gm_list
 102                             . lfg_version
 103
 104   repo <- getRepo
 105   let v   = repo ^. r_version
 106   let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
 107                   identity
 108                   $ nodeGraph ^. node_parentId
 109
 110   case graph of
 111     Nothing     -> do
 112       graph' <- computeGraph cId NgramsTerms repo
 113       _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
 114       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph'
 115
 116     Just graph' -> if listVersion == Just v
 117                      then pure graph'
 118                      else do
 119                        graph'' <- computeGraph cId NgramsTerms repo
 120                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 121                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph''
 122
 123
 124 -- TODO use Database Monad only here ?
 125 computeGraph :: HasNodeError err
 126              => CorpusId
 127              -> NgramsType
 128              -> NgramsRepo
 129              -> Cmd err Graph
 130 computeGraph cId nt repo = do
 131   lId  <- defaultList cId
 132
 133   let metadata = GraphMetadata "Title" [cId]
 134                                      [ LegendField 1 "#FFF" "Cluster"
 135                                      , LegendField 2 "#FFF" "Cluster"
 136                                      ]
 137                                 (ListForGraph lId (repo ^. r_version))
 138                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 139
 140   lIds <- selectNodesWithUsername NodeList userMaster
 141   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 142
 143   myCooc <- Map.filter (>1)
 144          <$> getCoocByNgrams (Diagonal True)
 145          <$> groupNodesByNgrams ngs
 146          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 147
 148   graph <- liftBase $ cooc2graph 0 myCooc
 149   let graph' = set graph_metadata (Just metadata) graph
 150   pure graph'
 151
 152 ------------------------------------------------------------
 153 type GraphAsyncAPI = Summary "Update graph"
 154                    :> "async"
 155                    :> AsyncJobsAPI JobLog () JobLog
 156
 157
 158 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 159 graphAsync u n =
 160   serveJobsAPI $
 161     JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
 162
 163
 164 graphAsync' :: UserId
 165            -> NodeId
 166            -> (JobLog -> GargNoServer ())
 167            -> GargNoServer JobLog
 168 graphAsync' u n logStatus = do
 169   logStatus JobLog { _scst_succeeded = Just 0
 170                           , _scst_failed    = Just 0
 171                           , _scst_remaining = Just 1
 172                           , _scst_events    = Just []
 173                           }
 174   _g <- trace (show u) $ recomputeGraph u n
 175   pure  JobLog { _scst_succeeded = Just 1
 176                       , _scst_failed    = Just 0
 177                       , _scst_remaining = Just 0
 178                       , _scst_events    = Just []
 179                       }
 180
 181 ------------------------------------------------------------
 182 type GraphVersionsAPI = Summary "Graph versions"
 183                         :> Get '[JSON] GraphVersions
 184                    :<|> Summary "Recompute graph version"
 185                         :> Post '[JSON] Graph
 186
 187 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 188 graphVersionsAPI u n =
 189            graphVersions u n
 190       :<|> recomputeVersions u n
 191
 192 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
 193 graphVersions _uId nId = do
 194   nodeGraph <- getNodeWith nId HyperdataGraph
 195   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 196   let listVersion = graph ^? _Just
 197                             . graph_metadata
 198                             . _Just
 199                             . gm_list
 200                             . lfg_version
 201
 202   repo <- getRepo
 203   let v = repo ^. r_version
 204
 205   pure $ GraphVersions { gv_graph = listVersion
 206                        , gv_repo = v }
 207
 208 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 209 recomputeVersions = recomputeGraph
 210
 211 ------------------------------------------------------------
 212 getGraphGexf :: UserId
 213              -> NodeId
 214              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 215 getGraphGexf uId nId = do
 216   graph <- getGraph uId nId
 217   pure $ addHeader "attachment; filename=graph.gexf" graph
 218
 219
 220