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' <- 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 <- liftIO newEmptyMVar
 181   _ <- forkIO <$> putMVar g <$> computeGraph cId nt repo
 182   g' <- liftIO $ 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   let graph  = 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 (liftIO . 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