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 DataKinds         #-}
  16 {-# LANGUAGE DeriveGeneric     #-}
  17 {-# LANGUAGE FlexibleContexts  #-}
  18 {-# LANGUAGE FlexibleInstances #-}
  19 {-# LANGUAGE NoImplicitPrelude #-}
  20 {-# LANGUAGE OverloadedStrings #-}   -- allows to write Text literals
  21 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  22 {-# LANGUAGE RankNTypes        #-}
  23 {-# LANGUAGE TypeOperators     #-}
  24
  25 module Gargantext.Viz.Graph.API
  26   where
  27
  28 import Control.Lens (set, (^.), _Just, (^?))
  29 import Data.Aeson
  30 import Data.Maybe (Maybe(..))
  31 import Data.Swagger
  32 import Data.Text
  33 import Debug.Trace (trace)
  34 import GHC.Generics (Generic)
  35 import Gargantext.API.Admin.Orchestrator.Types
  36 import Gargantext.API.Ngrams (NgramsRepo, r_version)
  37 import Gargantext.API.Ngrams.Tools
  38 import Gargantext.API.Prelude
  39 import Gargantext.Core.Types.Main
  40 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  41 import Gargantext.Database.Admin.Config
  42 import Gargantext.Database.Admin.Types.Node
  43 import Gargantext.Database.Prelude (Cmd)
  44 import Gargantext.Database.Query.Table.Node
  45 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  46 import Gargantext.Database.Query.Table.Node.Select
  47 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  48 import Gargantext.Database.Schema.Ngrams
  49 import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata)
  50 import Gargantext.Prelude
  51 import Gargantext.Viz.Graph
  52 import Gargantext.Viz.Graph.GEXF ()
  53 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
  54 import Servant
  55 import Servant.Job.Async
  56 import Servant.XML
  57 import qualified Data.Map as Map
  58
  59 ------------------------------------------------------------------------
  60 -- | There is no Delete specific API for Graph since it can be deleted
  61 -- as simple Node.
  62 type GraphAPI   =  Get  '[JSON] Graph
  63               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  64               :<|> GraphAsyncAPI
  65               :<|> "versions" :> GraphVersionsAPI
  66
  67 data GraphVersions =
  68   GraphVersions { gv_graph :: Maybe Int
  69                 , gv_repo :: Int }
  70    deriving (Show, Generic)
  71
  72 instance ToJSON GraphVersions
  73 instance ToSchema GraphVersions
  74
  75 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  76 graphAPI u n =  getGraph       u n
  77          :<|> getGraphGexf     u n
  78          :<|> graphAsync       u n
  79          :<|> graphVersionsAPI u n
  80
  81 ------------------------------------------------------------------------
  82 getGraph :: UserId -> NodeId -> GargNoServer Graph
  83 getGraph _uId nId = do
  84   nodeGraph <- getNodeWith nId HyperdataGraph
  85   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
  86   repo <- getRepo
  87
  88   let cId = maybe (panic "[G.V.G.API] Node has no parent")
  89                   identity
  90                   $ nodeGraph ^. node_parentId
  91
  92   g <- case graph of
  93     Nothing     -> do
  94         graph' <- computeGraph cId NgramsTerms repo
  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   pure g
 101
 102
 103 recomputeGraph :: UserId -> NodeId -> GargNoServer Graph
 104 recomputeGraph _uId nId = do
 105   nodeGraph <- getNodeWith nId HyperdataGraph
 106   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 107   let listVersion = graph ^? _Just
 108                             . graph_metadata
 109                             . _Just
 110                             . gm_list
 111                             . lfg_version
 112
 113   repo <- getRepo
 114   let v   = repo ^. r_version
 115   let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
 116                   identity
 117                   $ nodeGraph ^. node_parentId
 118
 119   g <- case graph of
 120     Nothing     -> do
 121       graph' <- computeGraph cId NgramsTerms repo
 122       _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
 123       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" $ graph'
 124
 125     Just graph' -> if listVersion == Just v
 126                      then pure graph'
 127                      else do
 128                        graph'' <- computeGraph cId NgramsTerms repo
 129                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 130                        pure $ trace "[G.V.G.API] Graph exists, recomputing" $ graph''
 131   pure g
 132
 133
 134 -- TODO use Database Monad only here ?
 135 computeGraph :: HasNodeError err
 136              => CorpusId
 137              -> NgramsType
 138              -> NgramsRepo
 139              -> Cmd err Graph
 140 computeGraph cId nt repo = do
 141   lId  <- defaultList cId
 142
 143   let metadata = GraphMetadata "Title" [cId]
 144                                      [ LegendField 1 "#FFF" "Cluster"
 145                                      , LegendField 2 "#FFF" "Cluster"
 146                                      ]
 147                                 (ListForGraph lId (repo ^. r_version))
 148                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 149
 150   lIds <- selectNodesWithUsername NodeList userMaster
 151   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 152
 153   myCooc <- Map.filter (>1)
 154          <$> getCoocByNgrams (Diagonal True)
 155          <$> groupNodesByNgrams ngs
 156          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 157
 158   graph <- liftBase $ cooc2graph 0 myCooc
 159   let graph' = set graph_metadata (Just metadata) graph
 160   pure graph'
 161
 162 ------------------------------------------------------------
 163 type GraphAsyncAPI = Summary "Update graph"
 164                    :> "async"
 165                    :> AsyncJobsAPI ScraperStatus () ScraperStatus
 166
 167
 168 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 169 graphAsync u n =
 170   serveJobsAPI $
 171     JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
 172
 173
 174 graphAsync' :: UserId
 175            -> NodeId
 176            -> (ScraperStatus -> GargNoServer ())
 177            -> GargNoServer ScraperStatus
 178 graphAsync' u n logStatus = do
 179   logStatus ScraperStatus { _scst_succeeded = Just 0
 180                           , _scst_failed    = Just 0
 181                           , _scst_remaining = Just 1
 182                           , _scst_events    = Just []
 183                           }
 184   _g <- trace (show u) $ recomputeGraph u n
 185   pure  ScraperStatus { _scst_succeeded = Just 1
 186                       , _scst_failed    = Just 0
 187                       , _scst_remaining = Just 0
 188                       , _scst_events    = Just []
 189                       }
 190
 191 ------------------------------------------------------------
 192 type GraphVersionsAPI = Summary "Graph versions"
 193                         :> Get '[JSON] GraphVersions
 194                    :<|> Summary "Recompute graph version"
 195                         :> Post '[JSON] Graph
 196
 197 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 198 graphVersionsAPI u n =
 199            graphVersions u n
 200       :<|> recomputeVersions u n
 201
 202 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
 203 graphVersions _uId nId = do
 204   nodeGraph <- getNodeWith nId HyperdataGraph
 205   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 206   let listVersion = graph ^? _Just
 207                             . graph_metadata
 208                             . _Just
 209                             . gm_list
 210                             . lfg_version
 211
 212   repo <- getRepo
 213   let v = repo ^. r_version
 214
 215   pure $ GraphVersions { gv_graph = listVersion
 216                        , gv_repo = v }
 217
 218 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 219 recomputeVersions uId nId = recomputeGraph uId nId
 220
 221 ------------------------------------------------------------
 222 getGraphGexf :: UserId
 223              -> NodeId
 224              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 225 getGraphGexf uId nId = do
 226   graph <- getGraph uId nId
 227   pure $ addHeader (concat [ "attachment; filename=graph.gexf" ]) graph
 228
 229
 230