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