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   -- TODO split diagonal
 151   myCooc <- Map.filter (>1)
 152          <$> getCoocByNgrams (Diagonal True)
 153          <$> groupNodesByNgrams ngs
 154          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 155
 156   graph <- liftBase $ cooc2graph d 0 myCooc
 157   let graph' = set graph_metadata (Just metadata) graph
 158   pure graph'
 159
 160 ------------------------------------------------------------
 161 type GraphAsyncAPI = Summary "Update graph"
 162                    :> "async"
 163                    :> AsyncJobsAPI JobLog () JobLog
 164
 165
 166 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 167 graphAsync u n =
 168   serveJobsAPI $
 169     JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
 170
 171
 172 graphAsync' :: UserId
 173            -> NodeId
 174            -> (JobLog -> GargNoServer ())
 175            -> GargNoServer JobLog
 176 graphAsync' u n logStatus = do
 177   logStatus JobLog { _scst_succeeded = Just 0
 178                           , _scst_failed    = Just 0
 179                           , _scst_remaining = Just 1
 180                           , _scst_events    = Just []
 181                           }
 182   _g <- trace (show u) $ recomputeGraph u n Conditional
 183   pure  JobLog { _scst_succeeded = Just 1
 184                       , _scst_failed    = Just 0
 185                       , _scst_remaining = Just 0
 186                       , _scst_events    = Just []
 187                       }
 188
 189 ------------------------------------------------------------
 190 type GraphVersionsAPI = Summary "Graph versions"
 191                         :> Get '[JSON] GraphVersions
 192                    :<|> Summary "Recompute graph version"
 193                         :> Post '[JSON] Graph
 194
 195 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 196 graphVersionsAPI u n =
 197            graphVersions u n
 198       :<|> recomputeVersions u n
 199
 200 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
 201 graphVersions _uId nId = do
 202   nodeGraph <- getNodeWith nId HyperdataGraph
 203   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 204   let listVersion = graph ^? _Just
 205                             . graph_metadata
 206                             . _Just
 207                             . gm_list
 208                             . lfg_version
 209
 210   repo <- getRepo
 211   let v = repo ^. r_version
 212
 213   pure $ GraphVersions { gv_graph = listVersion
 214                        , gv_repo = v }
 215
 216 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 217 recomputeVersions uId nId = recomputeGraph uId nId Conditional
 218
 219 ------------------------------------------------------------
 220 getGraphGexf :: UserId
 221              -> NodeId
 222              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 223 getGraphGexf uId nId = do
 224   graph <- getGraph uId nId
 225   pure $ addHeader "attachment; filename=graph.gexf" graph
 226
 227
 228