{-| Module : Gargantext.Viz.Graph Description : Copyright : (c) CNRS, 2017-Present License : AGPL + CECILL v3 Maintainer : team@gargantext.org Stability : experimental Portability : POSIX -} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- allows to write Text literals {-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} module Gargantext.Viz.Graph.API where import Control.Lens (set, (^.), _Just, (^?)) import Data.Aeson import Data.Maybe (Maybe(..)) import Data.Swagger import Data.Text import Debug.Trace (trace) import GHC.Generics (Generic) import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Ngrams (NgramsRepo, r_version) import Gargantext.API.Ngrams.Tools import Gargantext.API.Prelude import Gargantext.Core.Types.Main import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser) import Gargantext.Database.Admin.Config import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Prelude (Cmd) import Gargantext.Database.Query.Table.Node import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Select import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Schema.Ngrams import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata) import Gargantext.Prelude import Gargantext.Viz.Graph import Gargantext.Viz.Graph.GEXF () import Gargantext.Viz.Graph.Tools -- (cooc2graph) import Servant import Servant.Job.Async import Servant.XML import qualified Data.Map as Map ------------------------------------------------------------------------ -- | There is no Delete specific API for Graph since it can be deleted -- as simple Node. type GraphAPI = Get '[JSON] Graph :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph) :<|> GraphAsyncAPI :<|> "versions" :> GraphVersionsAPI data GraphVersions = GraphVersions { gv_graph :: Maybe Int , gv_repo :: Int } deriving (Show, Generic) instance ToJSON GraphVersions instance ToSchema GraphVersions graphAPI :: UserId -> NodeId -> GargServer GraphAPI graphAPI u n = getGraph u n :<|> getGraphGexf u n :<|> graphAsync u n :<|> graphVersionsAPI u n ------------------------------------------------------------------------ getGraph :: UserId -> NodeId -> GargNoServer Graph getGraph _uId nId = do nodeGraph <- getNodeWith nId HyperdataGraph let graph = nodeGraph ^. node_hyperdata . hyperdataGraph -- let listVersion = graph ^? _Just -- . graph_metadata -- . _Just -- . gm_list -- . lfg_version repo <- getRepo -- let v = repo ^. r_version -- nodeUser <- getNodeUser (NodeId uId) -- let uId' = nodeUser ^. node_userId let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent") identity $ nodeGraph ^. node_parentId g <- case graph of Nothing -> do graph' <- computeGraph cId NgramsTerms repo _ <- updateHyperdata nId (HyperdataGraph $ Just graph') pure $ trace "Graph empty, computing" $ graph' Just graph' -> pure $ trace "Graph exists, returning" $ graph' -- Just graph' -> if listVersion == Just v -- then pure graph' -- else do -- graph'' <- computeGraph cId NgramsTerms repo -- _ <- updateHyperdata nId (HyperdataGraph $ Just graph'') -- pure graph'' pure g recomputeGraph :: UserId -> NodeId -> GargNoServer Graph recomputeGraph _uId nId = do nodeGraph <- getNodeWith nId HyperdataGraph let graph = nodeGraph ^. node_hyperdata . hyperdataGraph let listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version repo <- getRepo let v = repo ^. r_version -- nodeUser <- getNodeUser (NodeId uId) -- let uId' = nodeUser ^. node_userId let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent") identity $ nodeGraph ^. node_parentId g <- case graph of Nothing -> do graph' <- computeGraph cId NgramsTerms repo _ <- updateHyperdata nId (HyperdataGraph $ Just graph') pure $ trace "[recomputeGraph] Graph empty, computed" $ graph' Just graph' -> if listVersion == Just v then pure graph' else do graph'' <- computeGraph cId NgramsTerms repo _ <- updateHyperdata nId (HyperdataGraph $ Just graph'') pure $ trace "[recomputeGraph] Graph exists, recomputing" $ graph'' pure g -- TODO use Database Monad only here ? computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph computeGraph cId nt repo = do lId <- defaultList cId let metadata = GraphMetadata "Title" [cId] [ LegendField 1 "#FFF" "Cluster" , LegendField 2 "#FFF" "Cluster" ] (ListForGraph lId (repo ^. r_version)) -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10]) lIds <- selectNodesWithUsername NodeList userMaster let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal True) <$> groupNodesByNgrams ngs <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs) graph <- liftBase $ cooc2graph 0 myCooc let graph' = set graph_metadata (Just metadata) graph pure graph' ------------------------------------------------------------ getGraphGexf :: UserId -> NodeId -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph) getGraphGexf uId nId = do graph <- getGraph uId nId pure $ addHeader (concat [ "attachment; filename=graph.gexf" ]) graph ------------------------------------------------------------ type GraphAsyncAPI = Summary "Update graph" :> "async" :> AsyncJobsAPI ScraperStatus () ScraperStatus graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI graphAsync u n = serveJobsAPI $ JobFunction (\_ log' -> graphAsync' u n (liftBase . log')) graphAsync' :: UserId -> NodeId -> (ScraperStatus -> GargNoServer ()) -> GargNoServer ScraperStatus graphAsync' u n logStatus = do logStatus ScraperStatus { _scst_succeeded = Just 0 , _scst_failed = Just 0 , _scst_remaining = Just 1 , _scst_events = Just [] } _g <- trace (show u) $ recomputeGraph u n pure ScraperStatus { _scst_succeeded = Just 1 , _scst_failed = Just 0 , _scst_remaining = Just 0 , _scst_events = Just [] } ------------------------------------------------------------ type GraphVersionsAPI = Summary "Graph versions" :> Get '[JSON] GraphVersions :<|> Summary "Recompute graph version" :> Post '[JSON] Graph graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI graphVersionsAPI u n = graphVersions u n :<|> recomputeVersions u n graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions graphVersions _uId nId = do nodeGraph <- getNodeWith nId HyperdataGraph let graph = nodeGraph ^. node_hyperdata . hyperdataGraph let listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version repo <- getRepo let v = repo ^. r_version pure $ GraphVersions { gv_graph = listVersion , gv_repo = v } recomputeVersions :: UserId -> NodeId -> GargNoServer Graph recomputeVersions uId nId = recomputeGraph uId nId