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