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