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 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  14 {-# LANGUAGE TypeOperators     #-}
  15
  16 module Gargantext.Core.Viz.Graph.API
  17   where
  18
  19 import Control.Lens (set, (^.), _Just, (^?))
  20 import Data.Aeson
  21 import qualified Data.Map as Map
  22 import Data.Swagger
  23 import Data.Text
  24 import Debug.Trace (trace)
  25 import GHC.Generics (Generic)
  26 import Servant
  27 import Servant.Job.Async
  28 import Servant.XML
  29
  30 import Gargantext.API.Admin.Orchestrator.Types
  31 import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
  32 import Gargantext.API.Ngrams.Tools
  33 import Gargantext.API.Prelude
  34 import Gargantext.Core.Types.Main
  35 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  36 import Gargantext.Database.Action.Node (mkNodeWithParent)
  37 import Gargantext.Database.Admin.Config
  38 import Gargantext.Database.Admin.Types.Node
  39 import Gargantext.Database.Prelude (Cmd)
  40 import Gargantext.Database.Query.Table.Node
  41 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
  42 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  43 import Gargantext.Database.Query.Table.Node.Select
  44 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  45 import Gargantext.Database.Schema.Ngrams
  46 import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata, node_name, node_userId)
  47 import Gargantext.Prelude
  48 import Gargantext.Core.Viz.Graph
  49 import Gargantext.Core.Viz.Graph.GEXF ()
  50 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
  51 import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..))
  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] HyperdataGraphAPI
  57               :<|> "async" :> GraphAsyncAPI
  58               :<|> "clone"
  59                    :> ReqBody '[JSON] HyperdataGraphAPI
  60                    :> Post '[JSON] NodeId
  61               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  62               :<|> "versions" :> GraphVersionsAPI
  63
  64 data GraphVersions =
  65   GraphVersions { gv_graph :: Maybe Int
  66                 , gv_repo :: Int
  67                 }
  68    deriving (Show, Generic)
  69
  70 instance ToJSON GraphVersions
  71 instance ToSchema GraphVersions
  72
  73 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  74 graphAPI u n = getGraph         u n
  75           :<|> graphAsync       u n
  76           :<|> graphClone       u n
  77           :<|> getGraphGexf     u n
  78           :<|> graphVersionsAPI u n
  79
  80 ------------------------------------------------------------------------
  81 getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
  82 getGraph _uId nId = do
  83   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
  84   let graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
  85   let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  86
  87   repo <- getRepo
  88
  89   let cId = maybe (panic "[G.V.G.API] Node has no parent")
  90                   identity
  91                   $ nodeGraph ^. node_parentId
  92
  93   -- TODO Distance in Graph params
  94   case graph of
  95     Nothing     -> do
  96         graph' <- computeGraph cId Distributional NgramsTerms repo
  97         -- graph' <- computeGraph cId Conditional NgramsTerms repo
  98         mt     <- defaultGraphMetadata cId "Title" repo
  99         let graph'' = set graph_metadata (Just mt) graph'
 100         let hg = HyperdataGraphAPI graph'' camera
 101        -- _      <- updateHyperdata nId hg
 102         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 103         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 104
 105     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 106         HyperdataGraphAPI graph' camera
 107
 108
 109 recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
 110 recomputeGraph _uId nId d = do
 111   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 112   let graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
 113   let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 114   let graphMetadata = graph ^? _Just . graph_metadata . _Just
 115   let listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 116
 117   repo <- getRepo
 118   let v   = repo ^. r_version
 119   let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
 120                   identity
 121                   $ nodeGraph ^. node_parentId
 122
 123   case graph of
 124     Nothing     -> do
 125       graph' <- computeGraph cId d NgramsTerms repo
 126       mt     <- defaultGraphMetadata cId "Title" repo
 127       let graph'' = set graph_metadata (Just mt) graph'
 128       _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 129       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
 130
 131     Just graph' -> if listVersion == Just v
 132                      then pure graph'
 133                      else do
 134                        graph'' <- computeGraph cId d NgramsTerms repo
 135                        let graph''' = set graph_metadata graphMetadata graph''
 136                        _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
 137                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
 138
 139
 140 -- TODO use Database Monad only here ?
 141 computeGraph :: HasNodeError err
 142              => CorpusId
 143              -> Distance
 144              -> NgramsType
 145              -> NgramsRepo
 146              -> Cmd err Graph
 147 computeGraph cId d nt repo = do
 148   lId  <- defaultList cId
 149
 150   lIds <- selectNodesWithUsername NodeList userMaster
 151   let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
 152
 153   -- TODO split diagonal
 154   myCooc <- Map.filter (>1)
 155          <$> getCoocByNgrams (Diagonal True)
 156          <$> groupNodesByNgrams ngs
 157          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 158
 159   graph <- liftBase $ cooc2graph d 0 myCooc
 160
 161   pure graph
 162
 163
 164 defaultGraphMetadata :: HasNodeError err
 165                      => CorpusId
 166                      -> Text
 167                      -> NgramsRepo
 168                      -> Cmd err GraphMetadata
 169 defaultGraphMetadata cId t repo = do
 170   lId  <- defaultList cId
 171
 172   pure $ GraphMetadata {
 173       _gm_title = t
 174     , _gm_metric = Order1
 175     , _gm_corpusId = [cId]
 176     , _gm_legend = [
 177           LegendField 1 "#FFF" "Cluster1"
 178         , LegendField 2 "#FFF" "Cluster2"
 179         , LegendField 3 "#FFF" "Cluster3"
 180         , LegendField 4 "#FFF" "Cluster4"
 181         ]
 182       , _gm_list = (ListForGraph lId (repo ^. r_version))
 183       , _gm_startForceAtlas = True
 184     }
 185                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 186
 187
 188 ------------------------------------------------------------
 189 type GraphAsyncAPI = Summary "Recompute graph"
 190                      :> "recompute"
 191                      :> AsyncJobsAPI JobLog () JobLog
 192
 193
 194 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 195 graphAsync u n =
 196   serveJobsAPI $
 197     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 198
 199
 200 graphRecompute :: UserId
 201                -> NodeId
 202                -> (JobLog -> GargNoServer ())
 203                -> GargNoServer JobLog
 204 graphRecompute u n logStatus = do
 205   logStatus JobLog { _scst_succeeded = Just 0
 206                    , _scst_failed    = Just 0
 207                    , _scst_remaining = Just 1
 208                    , _scst_events    = Just []
 209                    }
 210   _g <- trace (show u) $ recomputeGraph u n Distributional -- Conditional
 211   pure  JobLog { _scst_succeeded = Just 1
 212                , _scst_failed    = Just 0
 213                , _scst_remaining = Just 0
 214                , _scst_events    = Just []
 215                }
 216
 217 ------------------------------------------------------------
 218 type GraphVersionsAPI = Summary "Graph versions"
 219                         :> Get '[JSON] GraphVersions
 220                    :<|> Summary "Recompute graph version"
 221                         :> Post '[JSON] Graph
 222
 223 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 224 graphVersionsAPI u n =
 225            graphVersions n
 226       :<|> recomputeVersions u n
 227
 228 graphVersions :: NodeId -> GargNoServer GraphVersions
 229 graphVersions nId = do
 230   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 231   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 232   let listVersion = graph ^? _Just
 233                             . graph_metadata
 234                             . _Just
 235                             . gm_list
 236                             . lfg_version
 237
 238   repo <- getRepo
 239   let v = repo ^. r_version
 240
 241   pure $ GraphVersions { gv_graph = listVersion
 242                        , gv_repo = v }
 243
 244 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 245 recomputeVersions uId nId = recomputeGraph uId nId Distributional -- Conditional
 246
 247 ------------------------------------------------------------
 248 graphClone :: UserId
 249            -> NodeId
 250            -> HyperdataGraphAPI
 251            -> GargNoServer NodeId
 252 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 253                                       , _hyperdataAPICamera = camera }) = do
 254   let nodeType = NodeGraph
 255   nodeUser <- getNodeUser (NodeId uId)
 256   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 257   let uId' = nodeUser ^. node_userId
 258   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 259   case nIds of
 260     [] -> pure pId
 261     (nId:_) -> do
 262       let graphP = graph
 263       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 264
 265       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 266
 267       pure nId
 268
 269 ------------------------------------------------------------
 270 getGraphGexf :: UserId
 271              -> NodeId
 272              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 273 getGraphGexf uId nId = do
 274   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 275   pure $ addHeader "attachment; filename=graph.gexf" graph