src/Gargantext/Core/Viz/Graph/API.hs

   1 {-|
   2 Module      : Gargantext.Core.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.Core.Viz.Graph.API
  19   where
  20
  21 import Control.Lens (set, (^.), _Just, (^?))
  22 import Data.Aeson
  23 import qualified Data.Map as Map
  24 import Data.Maybe (Maybe(..))
  25 import Data.Swagger
  26 import Data.Text
  27 import Debug.Trace (trace)
  28 import GHC.Generics (Generic)
  29 import Servant
  30 import Servant.Job.Async
  31 import Servant.XML
  32
  33 import Gargantext.API.Admin.Orchestrator.Types
  34 import Gargantext.API.Ngrams (NgramsRepo, r_version)
  35 import Gargantext.API.Ngrams.Tools
  36 import Gargantext.API.Prelude
  37 import Gargantext.Core.Types.Main
  38 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  39 import Gargantext.Database.Action.Node (mkNodeWithParent)
  40 import Gargantext.Database.Admin.Config
  41 import Gargantext.Database.Admin.Types.Node
  42 import Gargantext.Database.Prelude (Cmd)
  43 import Gargantext.Database.Query.Table.Node
  44 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
  45 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  46 import Gargantext.Database.Query.Table.Node.Select
  47 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  48 import Gargantext.Database.Schema.Ngrams
  49 import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata, node_name, node_userId)
  50 import Gargantext.Prelude
  51 import Gargantext.Core.Viz.Graph
  52 import Gargantext.Core.Viz.Graph.GEXF ()
  53 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
  54 import Gargantext.Core.Viz.Graph.Distances (Distance(..), GraphMetric(..))
  55
  56 ------------------------------------------------------------------------
  57 -- | There is no Delete specific API for Graph since it can be deleted
  58 -- as simple Node.
  59 type GraphAPI   =  Get  '[JSON] HyperdataGraphAPI
  60               :<|> "async" :> GraphAsyncAPI
  61               :<|> "clone"
  62                    :> ReqBody '[JSON] HyperdataGraphAPI
  63                    :> Post '[JSON] NodeId
  64               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  65               :<|> "versions" :> GraphVersionsAPI
  66
  67 data GraphVersions =
  68   GraphVersions { gv_graph :: Maybe Int
  69                 , gv_repo :: Int
  70                 }
  71    deriving (Show, Generic)
  72
  73 instance ToJSON GraphVersions
  74 instance ToSchema GraphVersions
  75
  76 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  77 graphAPI u n = getGraph         u n
  78           :<|> graphAsync       u n
  79           :<|> graphClone       u n
  80           :<|> getGraphGexf     u n
  81           :<|> graphVersionsAPI u n
  82
  83 ------------------------------------------------------------------------
  84 getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
  85 getGraph _uId nId = do
  86   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
  87   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
  88   let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  89
  90   repo <- getRepo
  91
  92   let cId = maybe (panic "[G.V.G.API] Node has no parent")
  93                   identity
  94                   $ nodeGraph ^. node_parentId
  95
  96   -- TODO Distance in Graph params
  97   case graph of
  98     Nothing     -> do
  99         graph' <- computeGraph cId Conditional NgramsTerms repo
 100         mt     <- defaultGraphMetadata cId "Title" repo
 101         let graph'' = set graph_metadata (Just mt) graph'
 102         let hg = HyperdataGraphAPI graph'' camera
 103         _      <- updateHyperdata nId hg
 104         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 105
 106     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 107         HyperdataGraphAPI graph' camera
 108
 109
 110 recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
 111 recomputeGraph _uId nId d = do
 112   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 113   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 114   let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 115   let graphMetadata = graph ^? _Just . graph_metadata . _Just
 116   let listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 117
 118   repo <- getRepo
 119   let v   = repo ^. r_version
 120   let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
 121                   identity
 122                   $ nodeGraph ^. node_parentId
 123
 124   case graph of
 125     Nothing     -> do
 126       graph' <- computeGraph cId d NgramsTerms repo
 127       mt     <- defaultGraphMetadata cId "Title" repo
 128       let graph'' = set graph_metadata (Just mt) graph'
 129       _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 130       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
 131
 132     Just graph' -> if listVersion == Just v
 133                      then pure graph'
 134                      else do
 135                        graph'' <- computeGraph cId d NgramsTerms repo
 136                        let graph''' = set graph_metadata graphMetadata graph''
 137                        _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
 138                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
 139
 140
 141 -- TODO use Database Monad only here ?
 142 computeGraph :: HasNodeError err
 143              => CorpusId
 144              -> Distance
 145              -> NgramsType
 146              -> NgramsRepo
 147              -> Cmd err Graph
 148 computeGraph cId d nt repo = do
 149   lId  <- defaultList cId
 150
 151   lIds <- selectNodesWithUsername NodeList userMaster
 152   let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
 153
 154   -- TODO split diagonal
 155   myCooc <- Map.filter (>1)
 156          <$> getCoocByNgrams (Diagonal True)
 157          <$> groupNodesByNgrams ngs
 158          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 159
 160   graph <- liftBase $ cooc2graph d 0 myCooc
 161
 162   pure graph
 163
 164
 165 defaultGraphMetadata :: HasNodeError err
 166                      => CorpusId
 167                      -> Text
 168                      -> NgramsRepo
 169                      -> Cmd err GraphMetadata
 170 defaultGraphMetadata cId t repo = do
 171   lId  <- defaultList cId
 172
 173   pure $ GraphMetadata {
 174       _gm_title = t
 175     , _gm_metric = Order1
 176     , _gm_corpusId = [cId]
 177     , _gm_legend = [
 178           LegendField 1 "#FFF" "Cluster1"
 179         , LegendField 2 "#FFF" "Cluster2"
 180         , LegendField 3 "#FFF" "Cluster3"
 181         , LegendField 4 "#FFF" "Cluster4"
 182         ]
 183       , _gm_list = (ListForGraph lId (repo ^. r_version))
 184       , _gm_startForceAtlas = True
 185     }
 186                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 187
 188
 189 ------------------------------------------------------------
 190 type GraphAsyncAPI = Summary "Recompute graph"
 191                      :> "recompute"
 192                      :> AsyncJobsAPI JobLog () JobLog
 193
 194
 195 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 196 graphAsync u n =
 197   serveJobsAPI $
 198     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 199
 200
 201 graphRecompute :: UserId
 202                -> NodeId
 203                -> (JobLog -> GargNoServer ())
 204                -> GargNoServer JobLog
 205 graphRecompute u n logStatus = do
 206   logStatus JobLog { _scst_succeeded = Just 0
 207                    , _scst_failed    = Just 0
 208                    , _scst_remaining = Just 1
 209                    , _scst_events    = Just []
 210                    }
 211   _g <- trace (show u) $ recomputeGraph u n Conditional
 212   pure  JobLog { _scst_succeeded = Just 1
 213                , _scst_failed    = Just 0
 214                , _scst_remaining = Just 0
 215                , _scst_events    = Just []
 216                }
 217
 218 ------------------------------------------------------------
 219 type GraphVersionsAPI = Summary "Graph versions"
 220                         :> Get '[JSON] GraphVersions
 221                    :<|> Summary "Recompute graph version"
 222                         :> Post '[JSON] Graph
 223
 224 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 225 graphVersionsAPI u n =
 226            graphVersions u n
 227       :<|> recomputeVersions u n
 228
 229 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
 230 graphVersions _uId nId = do
 231   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 232   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 233   let listVersion = graph ^? _Just
 234                             . graph_metadata
 235                             . _Just
 236                             . gm_list
 237                             . lfg_version
 238
 239   repo <- getRepo
 240   let v = repo ^. r_version
 241
 242   pure $ GraphVersions { gv_graph = listVersion
 243                        , gv_repo = v }
 244
 245 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 246 recomputeVersions uId nId = recomputeGraph uId nId Conditional
 247
 248 ------------------------------------------------------------
 249 graphClone :: UserId
 250            -> NodeId
 251            -> HyperdataGraphAPI
 252            -> GargNoServer NodeId
 253 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 254                                       , _hyperdataAPICamera = camera }) = do
 255   let nodeType = NodeGraph
 256   nodeUser <- getNodeUser (NodeId uId)
 257   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 258   let uId' = nodeUser ^. node_userId
 259   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 260   case nIds of
 261     [] -> pure pId
 262     (nId:_) -> do
 263       let graphP = graph
 264       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 265
 266       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 267
 268       pure nId
 269
 270 ------------------------------------------------------------
 271 getGraphGexf :: UserId
 272              -> NodeId
 273              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 274 getGraphGexf uId nId = do
 275   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 276   pure $ addHeader "attachment; filename=graph.gexf" graph