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
 133   newGraph  <- liftBase newEmptyMVar
 134   _  <- liftBase $ forkIO $ putMVar newGraph g
 135   g' <- liftBase $ 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' <- computeGraphAsync 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'' <- computeGraphAsync cId NgramsTerms repo
 169                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 170                        pure $ trace "[recomputeGraph] Graph exists, recomputing" $ graph''
 171
 172   pure g
 173
 174 computeGraphAsync :: HasNodeError err
 175              => CorpusId
 176              -> NgramsType
 177              -> NgramsRepo
 178              -> Cmd err Graph
 179 computeGraphAsync cId nt repo = do
 180   g <- liftBase newEmptyMVar
 181   _ <- forkIO <$> putMVar g <$> computeGraph cId nt repo
 182   g' <- liftBase $ takeMVar g
 183   pure g'
 184
 185
 186 -- TODO use Database Monad only here ?
 187 computeGraph :: HasNodeError err
 188              => CorpusId
 189              -> NgramsType
 190              -> NgramsRepo
 191              -> Cmd err Graph
 192 computeGraph cId nt repo = do
 193   lId  <- defaultList cId
 194
 195   let metadata = GraphMetadata "Title" [cId]
 196                                      [ LegendField 1 "#FFF" "Cluster"
 197                                      , LegendField 2 "#FFF" "Cluster"
 198                                      ]
 199                                 (ListForGraph lId (repo ^. r_version))
 200                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 201
 202   lIds <- selectNodesWithUsername NodeList userMaster
 203   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 204
 205   myCooc <- Map.filter (>1)
 206          <$> getCoocByNgrams (Diagonal False)
 207          <$> groupNodesByNgrams ngs
 208          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 209
 210   graph <- liftBase $ cooc2graph 0 myCooc
 211   let graph' = set graph_metadata (Just metadata) graph
 212   pure graph'
 213
 214
 215
 216 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
 217 postGraph = undefined
 218
 219 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 220 putGraph = undefined
 221
 222 ------------------------------------------------------------
 223
 224 type GraphAsyncAPI = Summary "Update graph"
 225                    :> "async"
 226                    :> AsyncJobsAPI ScraperStatus () ScraperStatus
 227
 228 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 229 graphAsync u n =
 230   serveJobsAPI $
 231     JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
 232
 233
 234 graphAsync' :: UserId
 235            -> NodeId
 236            -> (ScraperStatus -> GargNoServer ())
 237            -> GargNoServer ScraperStatus
 238 graphAsync' u n logStatus = do
 239   logStatus ScraperStatus { _scst_succeeded = Just 0
 240                           , _scst_failed    = Just 0
 241                           , _scst_remaining = Just 1
 242                           , _scst_events    = Just []
 243                           }
 244   _g <- trace (show u) $ recomputeGraph u n
 245   pure  ScraperStatus { _scst_succeeded = Just 1
 246                       , _scst_failed    = Just 0
 247                       , _scst_remaining = Just 0
 248                       , _scst_events    = Just []
 249                       }
 250
 251 ------------------------------------------------------------
 252
 253 type GraphVersionsAPI = Summary "Graph versions"
 254                         :> Get '[JSON] GraphVersions
 255                    :<|> Summary "Recompute graph version"
 256                         :> Post '[JSON] Graph
 257
 258 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 259 graphVersionsAPI u n =
 260            graphVersions u n
 261       :<|> recomputeVersions u n
 262
 263 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
 264 graphVersions _uId nId = do
 265   nodeGraph <- getNodeWith nId HyperdataGraph
 266   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 267   let listVersion = graph ^? _Just
 268                             . graph_metadata
 269                             . _Just
 270                             . gm_list
 271                             . lfg_version
 272
 273   repo <- getRepo
 274   let v = repo ^. r_version
 275
 276   pure $ GraphVersions { gv_graph = listVersion
 277                        , gv_repo = v }
 278
 279 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 280 recomputeVersions uId nId = recomputeGraph uId nId