src/Gargantext/Viz/Graph/API.hs

   1 {-|
   2 Module      : Gargantext.Viz.Phylo.Tools
   3 Description : Phylomemy Tools to build/manage it
   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 Debug.Trace (trace)
  29 import Control.Concurrent -- (forkIO)
  30 import Control.Lens (set, (^.), _Just, (^?))
  31 import Control.Monad.IO.Class (liftIO)
  32 import Data.Aeson
  33 import Data.Maybe (Maybe(..))
  34 import Data.Swagger
  35 import GHC.Generics (Generic)
  36
  37 import Gargantext.API.Ngrams (NgramsRepo, r_version)
  38 import Gargantext.API.Ngrams.Tools
  39 import Gargantext.API.Types
  40 import Gargantext.Core.Types.Main
  41 import Gargantext.Database.Config
  42 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  43 import Gargantext.Database.Schema.Ngrams
  44 import Gargantext.Database.Node.Select
  45 import Gargantext.Database.Schema.Node (getNodeWith, getNodeUser, defaultList, insertGraph, HasNodeError)
  46 import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
  47 import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
  48 import Gargantext.Database.Utils (Cmd)
  49 import Gargantext.Prelude
  50 import Gargantext.Viz.Graph
  51 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
  52 import Servant
  53
  54 import Gargantext.API.Orchestrator.Types
  55 import Servant.Job.Types
  56 import Servant.Job.Async
  57 import qualified Data.Map as Map
  58
  59 ------------------------------------------------------------------------
  60
  61 -- | There is no Delete specific API for Graph since it can be deleted
  62 -- as simple Node.
  63 type GraphAPI   =  Get  '[JSON] Graph
  64               :<|> Post '[JSON] [GraphId]
  65               :<|> Put  '[JSON] Int
  66               :<|> GraphAsyncAPI
  67               :<|> "versions" :> GraphVersionsAPI
  68
  69
  70 data GraphVersions = GraphVersions { gv_graph :: Maybe Int
  71                                    , gv_repo :: Int } deriving (Show, Generic)
  72
  73 instance ToJSON GraphVersions
  74 instance ToSchema GraphVersions
  75
  76 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  77 graphAPI u n =  getGraph  u n
  78          :<|> postGraph n
  79          :<|> putGraph  n
  80          :<|> graphAsync u n
  81          :<|> graphVersionsAPI u n
  82
  83 ------------------------------------------------------------------------
  84
  85 {- Model to fork Graph Computation
  86 -- This is not really optimized since it increases the need RAM
  87 -- and freezes the whole system
  88 -- This is mainly for documentation (see a better solution in the function below)
  89 -- Each process has to be tailored
  90 getGraph' :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
  91 getGraph' u n = do
  92   newGraph  <- liftIO newEmptyMVar
  93   g  <- getGraph u n
  94   _  <- liftIO $ forkIO $ putMVar newGraph g
  95   g' <- liftIO $ takeMVar newGraph
  96   pure g'
  97 -}
  98 getGraph :: UserId -> NodeId -> GargNoServer Graph
  99 getGraph uId nId = do
 100   nodeGraph <- getNodeWith nId HyperdataGraph
 101   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 102   -- let listVersion = graph ^? _Just
 103   --                           . graph_metadata
 104   --                           . _Just
 105   --                           . gm_list
 106   --                           . lfg_version
 107
 108   repo <- getRepo
 109   -- let v = repo ^. r_version
 110   nodeUser <- getNodeUser (NodeId uId)
 111
 112   let uId' = nodeUser ^. node_userId
 113
 114   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
 115                   identity
 116                   $ nodeGraph ^. node_parentId
 117
 118   g <- case graph of
 119     Nothing     -> do
 120         graph' <- computeGraph cId NgramsTerms repo
 121         _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
 122         pure $ trace "Graph empty, computing" $ graph'
 123
 124     Just graph' -> pure $ trace "Graph exists, returning" $ graph'
 125
 126     -- Just graph' -> if listVersion == Just v
 127     --                  then pure graph'
 128     --                  else do
 129     --                    graph'' <- computeGraph cId NgramsTerms repo
 130     --                    _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 131     --                    pure graph''
 132
 133   newGraph  <- liftIO newEmptyMVar
 134   _  <- liftIO $ forkIO $ putMVar newGraph g
 135   g' <- liftIO $ takeMVar newGraph
 136   pure {- $ trace (show g) $ -} g'
 137
 138
 139 recomputeGraph :: UserId -> NodeId -> GargNoServer Graph
 140 recomputeGraph uId nId = do
 141   nodeGraph <- getNodeWith nId HyperdataGraph
 142   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 143   let listVersion = graph ^? _Just
 144                             . graph_metadata
 145                             . _Just
 146                             . gm_list
 147                             . lfg_version
 148
 149   repo <- getRepo
 150   let v = repo ^. r_version
 151   nodeUser <- getNodeUser (NodeId uId)
 152
 153   let uId' = nodeUser ^. node_userId
 154
 155   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
 156                   identity
 157                   $ nodeGraph ^. node_parentId
 158
 159   g <- case graph of
 160     Nothing     -> do
 161       graph' <- computeGraph cId NgramsTerms repo
 162       _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
 163       pure $ trace "[recomputeGraph] Graph empty, computing" $ graph'
 164
 165     Just graph' -> if listVersion == Just v
 166                      then pure graph'
 167                      else do
 168                        graph'' <- computeGraph cId NgramsTerms repo
 169                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 170                        pure $ trace "[recomputeGraph] Graph exists, recomputing" $ graph''
 171
 172   newGraph  <- liftIO newEmptyMVar
 173   _  <- liftIO $ forkIO $ putMVar newGraph g
 174   g' <- liftIO $ takeMVar newGraph
 175   pure g'
 176
 177
 178 -- TODO use Database Monad only here ?
 179 computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
 180 computeGraph cId nt repo = do
 181   lId  <- defaultList cId
 182
 183   let metadata = GraphMetadata "Title" [cId]
 184                                      [ LegendField 1 "#FFF" "Cluster"
 185                                      , LegendField 2 "#FFF" "Cluster"
 186                                      ]
 187                                 (ListForGraph lId (repo ^. r_version))
 188                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 189
 190   lIds <- selectNodesWithUsername NodeList userMaster
 191   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 192
 193   myCooc <- inMVarIO $ Map.filter (>1)
 194          <$> getCoocByNgrams (Diagonal False)
 195          <$> groupNodesByNgrams ngs
 196          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 197
 198   graph <- liftIO $ inMVar $ cooc2graph 0 myCooc
 199   let graph' = set graph_metadata (Just metadata) graph
 200   pure graph'
 201
 202
 203
 204 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
 205 postGraph = undefined
 206
 207 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 208 putGraph = undefined
 209
 210 ------------------------------------------------------------
 211
 212 type GraphAsyncAPI = Summary "Update graph"
 213                    :> "async"
 214                    :> AsyncJobsAPI ScraperStatus () ScraperStatus
 215
 216 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 217 graphAsync u n =
 218   serveJobsAPI $
 219     JobFunction (\_ log' -> graphAsync' u n (liftIO . log'))
 220
 221
 222 graphAsync' :: UserId
 223            -> NodeId
 224            -> (ScraperStatus -> GargNoServer ())
 225            -> GargNoServer ScraperStatus
 226 graphAsync' u n logStatus = do
 227   logStatus ScraperStatus { _scst_succeeded = Just 0
 228                           , _scst_failed    = Just 0
 229                           , _scst_remaining = Just 1
 230                           , _scst_events    = Just []
 231                           }
 232   _g <- trace (show u) $ recomputeGraph u n
 233   pure  ScraperStatus { _scst_succeeded = Just 1
 234                       , _scst_failed    = Just 0
 235                       , _scst_remaining = Just 0
 236                       , _scst_events    = Just []
 237                       }
 238
 239 ------------------------------------------------------------
 240
 241 type GraphVersionsAPI = Summary "Graph versions"
 242                         :> Get '[JSON] GraphVersions
 243                    :<|> Summary "Recompute graph version"
 244                         :> Post '[JSON] Graph
 245
 246 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 247 graphVersionsAPI u n =
 248            graphVersions u n
 249       :<|> recomputeVersions u n
 250
 251 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
 252 graphVersions _uId nId = do
 253   nodeGraph <- getNodeWith nId HyperdataGraph
 254   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 255   let listVersion = graph ^? _Just
 256                             . graph_metadata
 257                             . _Just
 258                             . gm_list
 259                             . lfg_version
 260
 261   repo <- getRepo
 262   let v = repo ^. r_version
 263
 264   pure $ GraphVersions { gv_graph = listVersion
 265                        , gv_repo = v }
 266
 267 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 268 recomputeVersions uId nId = recomputeGraph uId nId