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.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.Error (HasNodeError)
  44 import Gargantext.Database.Query.Table.Node.Select
  45 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  46 import Gargantext.Database.Schema.Ngrams
  47 import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata)
  48 import Gargantext.Prelude
  49 import Gargantext.Core.Viz.Graph
  50 import Gargantext.Core.Viz.Graph.GEXF ()
  51 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
  52 import Gargantext.Core.Viz.Graph.Distances (Distance(..), GraphMetric(..))
  53
  54 ------------------------------------------------------------------------
  55 -- | There is no Delete specific API for Graph since it can be deleted
  56 -- as simple Node.
  57 type GraphAPI   =  Get  '[JSON] Graph
  58               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  59               :<|> GraphAsyncAPI
  60               :<|> "versions" :> GraphVersionsAPI
  61
  62 data GraphVersions =
  63   GraphVersions { gv_graph :: Maybe Int
  64                 , gv_repo :: Int
  65                 }
  66    deriving (Show, Generic)
  67
  68 instance ToJSON GraphVersions
  69 instance ToSchema GraphVersions
  70
  71 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  72 graphAPI u n =  getGraph       u n
  73          :<|> getGraphGexf     u n
  74          :<|> graphAsync       u n
  75          :<|> graphVersionsAPI u n
  76
  77 ------------------------------------------------------------------------
  78 getGraph :: UserId -> NodeId -> GargNoServer Graph
  79 getGraph _uId nId = do
  80   nodeGraph <- getNodeWith nId HyperdataGraph
  81   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
  82
  83   repo <- getRepo
  84
  85   let cId = maybe (panic "[G.V.G.API] Node has no parent")
  86                   identity
  87                   $ nodeGraph ^. node_parentId
  88
  89   -- TODO Distance in Graph params
  90   case graph of
  91     Nothing     -> do
  92         graph' <- computeGraph cId Conditional NgramsTerms repo
  93         _      <- updateHyperdata nId (HyperdataGraph $ Just graph')
  94         pure $ trace "[G.V.G.API] Graph empty, computing" graph'
  95
  96     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" graph'
  97
  98
  99 recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
 100 recomputeGraph _uId nId d = do
 101   nodeGraph <- getNodeWith nId HyperdataGraph
 102   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 103   let listVersion = graph ^? _Just
 104                             . graph_metadata
 105                             . _Just
 106                             . gm_list
 107                             . lfg_version
 108
 109   repo <- getRepo
 110   let v   = repo ^. r_version
 111   let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
 112                   identity
 113                   $ nodeGraph ^. node_parentId
 114
 115   case graph of
 116     Nothing     -> do
 117       graph' <- computeGraph cId d NgramsTerms repo
 118       _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
 119       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph'
 120
 121     Just graph' -> if listVersion == Just v
 122                      then pure graph'
 123                      else do
 124                        graph'' <- computeGraph cId d NgramsTerms repo
 125                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 126                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph''
 127
 128
 129 -- TODO use Database Monad only here ?
 130 computeGraph :: HasNodeError err
 131              => CorpusId
 132              -> Distance
 133              -> NgramsType
 134              -> NgramsRepo
 135              -> Cmd err Graph
 136 computeGraph cId d nt repo = do
 137   lId  <- defaultList cId
 138
 139   lIds <- selectNodesWithUsername NodeList userMaster
 140   let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
 141
 142   -- TODO split diagonal
 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 d 0 myCooc
 149
 150
 151   let metadata = GraphMetadata "Title"
 152                                Order1
 153                                [cId]
 154                                [ LegendField 1 "#FFF" "Cluster1"
 155                                , LegendField 2 "#FFF" "Cluster2"
 156                                , LegendField 3 "#FFF" "Cluster3"
 157                                , LegendField 4 "#FFF" "Cluster4"
 158                                ]
 159                                (ListForGraph lId (repo ^. r_version))
 160                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 161
 162   pure $ set graph_metadata (Just metadata) graph
 163
 164
 165 ------------------------------------------------------------
 166 type GraphAsyncAPI = Summary "Update graph"
 167                    :> "async"
 168                    :> AsyncJobsAPI JobLog () JobLog
 169
 170
 171 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 172 graphAsync u n =
 173   serveJobsAPI $
 174     JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
 175
 176
 177 graphAsync' :: UserId
 178            -> NodeId
 179            -> (JobLog -> GargNoServer ())
 180            -> GargNoServer JobLog
 181 graphAsync' u n logStatus = do
 182   logStatus JobLog { _scst_succeeded = Just 0
 183                           , _scst_failed    = Just 0
 184                           , _scst_remaining = Just 1
 185                           , _scst_events    = Just []
 186                           }
 187   _g <- trace (show u) $ recomputeGraph u n Conditional
 188   pure  JobLog { _scst_succeeded = Just 1
 189                       , _scst_failed    = Just 0
 190                       , _scst_remaining = Just 0
 191                       , _scst_events    = Just []
 192                       }
 193
 194 ------------------------------------------------------------
 195 type GraphVersionsAPI = Summary "Graph versions"
 196                         :> Get '[JSON] GraphVersions
 197                    :<|> Summary "Recompute graph version"
 198                         :> Post '[JSON] Graph
 199
 200 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 201 graphVersionsAPI u n =
 202            graphVersions u n
 203       :<|> recomputeVersions u n
 204
 205 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
 206 graphVersions _uId nId = do
 207   nodeGraph <- getNodeWith nId HyperdataGraph
 208   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 209   let listVersion = graph ^? _Just
 210                             . graph_metadata
 211                             . _Just
 212                             . gm_list
 213                             . lfg_version
 214
 215   repo <- getRepo
 216   let v = repo ^. r_version
 217
 218   pure $ GraphVersions { gv_graph = listVersion
 219                        , gv_repo = v }
 220
 221 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 222 recomputeVersions uId nId = recomputeGraph uId nId Conditional
 223
 224 ------------------------------------------------------------
 225 getGraphGexf :: UserId
 226              -> NodeId
 227              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 228 getGraphGexf uId nId = do
 229   graph <- getGraph uId nId
 230   pure $ addHeader "attachment; filename=graph.gexf" graph
 231
 232
 233