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 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.Viz.Graph
  50 import Gargantext.Viz.Graph.GEXF ()
  51 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
  52 import Gargantext.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               :<|> "async" :> GraphAsyncAPI
  59               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  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           :<|> graphAsync       u n
  74           :<|> getGraphGexf     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         mt     <- defaultGraphMetadata cId "Title" repo
  94         let graph'' = set graph_metadata (Just mt) graph'
  95         _      <- updateHyperdata nId (HyperdataGraph $ Just graph'')
  96         pure $ trace "[G.V.G.API] Graph empty, computing" graph''
  97
  98     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" graph'
  99
 100
 101 recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
 102 recomputeGraph _uId nId d = do
 103   nodeGraph <- getNodeWith nId HyperdataGraph
 104   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 105   let graphMetadata = graph ^? _Just . graph_metadata . _Just
 106   let listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . 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       mt     <- defaultGraphMetadata cId "Title" repo
 118       let graph'' = set graph_metadata (Just mt) graph'
 119       _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 120       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
 121
 122     Just graph' -> if listVersion == Just v
 123                      then pure graph'
 124                      else do
 125                        graph'' <- computeGraph cId d NgramsTerms repo
 126                        let graph''' = set graph_metadata graphMetadata graph''
 127                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph''')
 128                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
 129
 130
 131 -- TODO use Database Monad only here ?
 132 computeGraph :: HasNodeError err
 133              => CorpusId
 134              -> Distance
 135              -> NgramsType
 136              -> NgramsRepo
 137              -> Cmd err Graph
 138 computeGraph cId d nt repo = do
 139   lId  <- defaultList cId
 140
 141   lIds <- selectNodesWithUsername NodeList userMaster
 142   let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
 143
 144   -- TODO split diagonal
 145   myCooc <- Map.filter (>1)
 146          <$> getCoocByNgrams (Diagonal True)
 147          <$> groupNodesByNgrams ngs
 148          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 149
 150   graph <- liftBase $ cooc2graph d 0 myCooc
 151
 152   pure graph
 153
 154
 155 defaultGraphMetadata :: HasNodeError err
 156                      => CorpusId
 157                      -> Text
 158                      -> NgramsRepo
 159                      -> Cmd err GraphMetadata
 160 defaultGraphMetadata cId t repo = do
 161   lId  <- defaultList cId
 162
 163   pure $ GraphMetadata {
 164       _gm_title = t
 165     , _gm_metric = Order1
 166     , _gm_corpusId = [cId]
 167     , _gm_legend = [
 168           LegendField 1 "#FFF" "Cluster1"
 169         , LegendField 2 "#FFF" "Cluster2"
 170         , LegendField 3 "#FFF" "Cluster3"
 171         , LegendField 4 "#FFF" "Cluster4"
 172         ]
 173       , _gm_list = (ListForGraph lId (repo ^. r_version))
 174       , _gm_startForceAtlas = True
 175     }
 176                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 177
 178
 179 ------------------------------------------------------------
 180 type GraphAsyncAPI = Summary "Recompute graph"
 181                      :> "recompute"
 182                      :> AsyncJobsAPI JobLog () JobLog
 183
 184
 185 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 186 graphAsync u n =
 187   serveJobsAPI $
 188     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 189
 190
 191 graphRecompute :: UserId
 192                -> NodeId
 193                -> (JobLog -> GargNoServer ())
 194                -> GargNoServer JobLog
 195 graphRecompute u n logStatus = do
 196   logStatus JobLog { _scst_succeeded = Just 0
 197                    , _scst_failed    = Just 0
 198                    , _scst_remaining = Just 1
 199                    , _scst_events    = Just []
 200                    }
 201   _g <- trace (show u) $ recomputeGraph u n Conditional
 202   pure  JobLog { _scst_succeeded = Just 1
 203                , _scst_failed    = Just 0
 204                , _scst_remaining = Just 0
 205                , _scst_events    = Just []
 206                }
 207
 208 ------------------------------------------------------------
 209 type GraphVersionsAPI = Summary "Graph versions"
 210                         :> Get '[JSON] GraphVersions
 211                    :<|> Summary "Recompute graph version"
 212                         :> Post '[JSON] Graph
 213
 214 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 215 graphVersionsAPI u n =
 216            graphVersions u n
 217       :<|> recomputeVersions u n
 218
 219 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
 220 graphVersions _uId nId = do
 221   nodeGraph <- getNodeWith nId HyperdataGraph
 222   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 223   let listVersion = graph ^? _Just
 224                             . graph_metadata
 225                             . _Just
 226                             . gm_list
 227                             . lfg_version
 228
 229   repo <- getRepo
 230   let v = repo ^. r_version
 231
 232   pure $ GraphVersions { gv_graph = listVersion
 233                        , gv_repo = v }
 234
 235 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 236 recomputeVersions uId nId = recomputeGraph uId nId Conditional
 237
 238 ------------------------------------------------------------
 239 getGraphGexf :: UserId
 240              -> NodeId
 241              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 242 getGraphGexf uId nId = do
 243   graph <- getGraph uId nId
 244   pure $ addHeader "attachment; filename=graph.gexf" graph
 245
 246
 247