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.Swagger
  25 import Data.Text
  26 import Debug.Trace (trace)
  27 import GHC.Generics (Generic)
  28 import Servant
  29 import Servant.Job.Async
  30 import Servant.XML
  31
  32 import Gargantext.API.Admin.Orchestrator.Types
  33 import Gargantext.API.Ngrams (NgramsRepo, r_version)
  34 import Gargantext.API.Ngrams.Tools
  35 import Gargantext.API.Prelude
  36 import Gargantext.Core.Types.Main
  37 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  38 import Gargantext.Database.Action.Node (mkNodeWithParent)
  39 import Gargantext.Database.Admin.Config
  40 import Gargantext.Database.Admin.Types.Node
  41 import Gargantext.Database.Prelude (Cmd)
  42 import Gargantext.Database.Query.Table.Node
  43 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
  44 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  45 import Gargantext.Database.Query.Table.Node.Select
  46 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  47 import Gargantext.Database.Schema.Ngrams
  48 import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata, node_name, node_userId)
  49 import Gargantext.Prelude
  50 import Gargantext.Core.Viz.Graph
  51 import Gargantext.Core.Viz.Graph.GEXF ()
  52 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
  53 import Gargantext.Core.Viz.Graph.Distances (Distance(..), GraphMetric(..))
  54
  55 ------------------------------------------------------------------------
  56 -- | There is no Delete specific API for Graph since it can be deleted
  57 -- as simple Node.
  58 type GraphAPI   =  Get  '[JSON] HyperdataGraphAPI
  59               :<|> "async" :> GraphAsyncAPI
  60               :<|> "clone"
  61                    :> ReqBody '[JSON] HyperdataGraphAPI
  62                    :> Post '[JSON] NodeId
  63               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  64               :<|> "versions" :> GraphVersionsAPI
  65
  66 data GraphVersions =
  67   GraphVersions { gv_graph :: Maybe Int
  68                 , gv_repo :: Int
  69                 }
  70    deriving (Show, Generic)
  71
  72 instance ToJSON GraphVersions
  73 instance ToSchema GraphVersions
  74
  75 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  76 graphAPI u n = getGraph         u n
  77           :<|> graphAsync       u n
  78           :<|> graphClone       u n
  79           :<|> getGraphGexf     u n
  80           :<|> graphVersionsAPI u n
  81
  82 ------------------------------------------------------------------------
  83 getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
  84 getGraph _uId nId = do
  85   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
  86   let graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
  87   let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  88
  89   repo <- getRepo
  90
  91   let cId = maybe (panic "[G.V.G.API] Node has no parent")
  92                   identity
  93                   $ nodeGraph ^. node_parentId
  94
  95   -- TODO Distance in Graph params
  96   case graph of
  97     Nothing     -> do
  98         graph' <- computeGraph cId Conditional NgramsTerms repo
  99         mt     <- defaultGraphMetadata cId "Title" repo
 100         let graph'' = set graph_metadata (Just mt) graph'
 101         let hg = HyperdataGraphAPI graph'' camera
 102        -- _      <- updateHyperdata nId hg
 103         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 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 n
 227       :<|> recomputeVersions u n
 228
 229 graphVersions :: NodeId -> GargNoServer GraphVersions
 230 graphVersions 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