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